diff --git a/CMakeLists.txt b/CMakeLists.txt index 4da6a195e7..e5e5b846e5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -10,6 +10,15 @@ cmake_minimum_required(VERSION 3.24) # include our cmake snippets set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} ${CMAKE_CURRENT_SOURCE_DIR}/cmake) +# Require out-of-source builds +file(TO_CMAKE_PATH "${CMAKE_BINARY_DIR}/CMakeLists.txt" LOC_PATH) +if(EXISTS "${LOC_PATH}") + message( + FATAL_ERROR + "You cannot build in a source directory (or any directory with a CMakeLists.txt file). " + "Please make a build subdirectory.") +endif() + # ================================================================================================= # PROJECT AND VERSION include(CMakeDependentOption) @@ -26,20 +35,11 @@ project( cp2k DESCRIPTION "CP2K" HOMEPAGE_URL "https://www.cp2k.org" - VERSION "2026.1" + VERSION "2026.2" LANGUAGES Fortran C CXX) list(APPEND CMAKE_MODULE_PATH "${PROJECT_SOURCE_DIR}/cmake/modules") -# Require out-of-source builds -file(TO_CMAKE_PATH "${PROJECT_BINARY_DIR}/CMakeLists.txt" LOC_PATH) -if(EXISTS "${LOC_PATH}") - message( - FATAL_ERROR - "You cannot build in a source directory (or any directory with a CMakeLists.txt file). Please make a build subdirectory." - ) -endif() - # set language and standard. # # cmake does not provide any mechanism to set the fortran standard. Adding the @@ -226,18 +226,18 @@ cmake_dependent_option( CP2K_USE_CUSOLVER_MP "Enable cuSOLVERMp. Only active when CUDA is ON" OFF "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF) -cmake_dependent_option(CP2K_USE_NVHPC OFF "Enable Nvidia NVHPC kit" - "(NOT CP2K_USE_ACCEL MATCHES \"CUDA\")" OFF) +cmake_dependent_option(CP2K_USE_NVHPC "Enable Nvidia NVHPC kit" OFF + "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF) cmake_dependent_option( - CP2K_USE_SPLA_GEMM_OFFLOADING ON - "Enable SpLA dgemm offloading (only valid with GPU support on)" - "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_SPLA)" OFF) + CP2K_USE_SPLA_GEMM_OFFLOADING + "Enable SpLA dgemm offloading (only valid with GPU support on)" ON + "CP2K_USE_ACCEL MATCHES \"HIP|CUDA\" AND CP2K_USE_SPLA" OFF) cmake_dependent_option( - CP2K_USE_CRAY_PM_ACCEL_ENERGY ON - "Enable CRAY power management framework with gpu support" - "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_CRAY_PM_ENERGY)" OFF) + CP2K_USE_CRAY_PM_ACCEL_ENERGY + "Enable CRAY power management framework with gpu support" ON + "CP2K_USE_ACCEL MATCHES \"OPENCL|HIP|CUDA\" AND CP2K_USE_CRAY_PM_ENERGY" OFF) cmake_dependent_option( CP2K_USE_LIBGINT "Enable LibGint support" ${CP2K_USE_EVERYTHING} diff --git a/data/MACE/MACE_scratch_run-3.model-cp2k.pth b/data/MACE/MACE_scratch_run-3.model-cp2k.pth new file mode 100644 index 0000000000..f0ff697cb9 Binary files /dev/null and b/data/MACE/MACE_scratch_run-3.model-cp2k.pth differ diff --git a/docs/changelog.md b/docs/changelog.md index 7c52cfc20c..ead18e18fa 100644 --- a/docs/changelog.md +++ b/docs/changelog.md @@ -1,6 +1,6 @@ # Changelog -## 2026.2 (Draft) +## 2026.2 (July 15, 2026) ### New Features @@ -41,7 +41,6 @@ - Per-thermal-region function for rescaling temperatures in MD (independent of thermostats) ([#5002](https://github.com/cp2k/cp2k/pull/5002)) - Cell optimization with fixed volume ([#5086](https://github.com/cp2k/cp2k/pull/5086)) -- **TODO** ### New Libraries @@ -53,7 +52,6 @@ - Reintegrate with LIBXS, LIBXSTREAM, and LIBXSMM ([#5343](https://github.com/cp2k/cp2k/pull/5343)) - Add libGint for Hartree–Fock exchange with CUDA acceleration ([#5446](https://github.com/cp2k/cp2k/pull/5446)) -- **TODO** ### Breaking Changes @@ -67,14 +65,12 @@ - An implementation of the FFTW3 interface may be turned into a hard dependency in a later release. Please consider compiling and CP2K with FFTW3, MKL, AOCL or any other library implementing this interface if you have not used it until now. ([#5454](https://github.com/cp2k/cp2k/pull/5454)) -- **TODO** ### Fixes - Fix issues in the native DFT-D4 implementation. ([#5030](https://github.com/cp2k/cp2k/pull/5030)) - Analytical periodic-subspace stress for 2D systems with ANALYTIC/MT ([#5282](https://github.com/cp2k/cp2k/pull/5282)) -- **TODO** ______________________________________________________________________ diff --git a/docs/generate_input_reference.py b/docs/generate_input_reference.py index 9a51f77e42..7db6276aa0 100755 --- a/docs/generate_input_reference.py +++ b/docs/generate_input_reference.py @@ -342,20 +342,28 @@ def render_keyword( output += [f":module: {section_xref}"] else: output += [":noindex:"] - output += [f":type: '{data_type}{n_var_brackets}'"] - if default_value or default_unit: - default_unit_bracketed = f"[{default_unit}]" if default_unit else "" - output += [f":value: '{default_value} {default_unit_bracketed}'"] output += [""] + + # Render keyword properties as compact, unbulleted lines instead of placing the + # type and default value in the object signature. + metadata = [f"**Type:** {escape_markdown(data_type + n_var_brackets)}"] + if default_value or default_unit: + default = default_value + if default_unit: + default += f" [{default_unit}]" + metadata += [f"**Default:** {escape_markdown(default.strip())}"] if repeats: - output += ["**Keyword can be repeated.**", ""] + metadata += ["**Repeatable:** yes"] if len(keyword_names) > 1: - aliases = " ,".join(keyword_names[1:]) - output += [f"**Aliases:** {escape_markdown(aliases)}", ""] + aliases = ", ".join(keyword_names[1:]) + metadata += [f"**Aliases:** {escape_markdown(aliases)}"] if lone_keyword_value: - output += [f"**Lone keyword:** `{escape_markdown(lone_keyword_value)}`", ""] + metadata += [f"**Lone keyword:** {escape_markdown(lone_keyword_value)}"] if usage: - output += [f"**Usage:** _{escape_markdown(usage)}_", ""] + metadata += [f"**Usage:** _{escape_markdown(usage)}_"] + output += [" \n".join(metadata), ""] + if description: + output += [f"**Description:** {escape_markdown(description)}", ""] if data_type == "enum": output += ["**Valid values:**"] for item in keyword.findall("DATA_TYPE/ENUMERATION/ITEM"): @@ -369,7 +377,6 @@ def render_keyword( if mentions: mentions_list = ", ".join([f"⭐[](project:{m})" for m in mentions]) output += [f"**Mentions:** {mentions_list}", ""] - output += [escape_markdown(description)] if github: output += [github_link(location)] output += ["", "```", ""] # Close py:data directive. diff --git a/docs/methods/machine_learning/index.md b/docs/methods/machine_learning/index.md index 004f3c7a6e..f3ae029b1e 100644 --- a/docs/methods/machine_learning/index.md +++ b/docs/methods/machine_learning/index.md @@ -6,6 +6,7 @@ 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 new file mode 100644 index 0000000000..7e3bf66da5 --- /dev/null +++ b/docs/methods/machine_learning/mace.md @@ -0,0 +1,60 @@ +# MACE + +MACE is a framework for building interatomic potentials using higher-order equivariant +message-passing neural networks. The methodology is described in detail in the literature by Batatia +et al. (2022). + +**Note:** Running MACE requires a CP2K build with LibTorch support + +Like the [NequIP/Allegro](https://manual.cp2k.org/trunk/methods/machine_learning/nequip.html) +interface, CP2K runs MACE models through the generic LibTorch interface: a trained MACE model is +exported once to a self-contained TorchScript file (`.pth`), which CP2K then loads and evaluates at +runtime. No Python interpreter is involved during the simulation. + +## Exporting a MACE model for CP2K + +Wraps a trained MACE model (`.model`) and compiles it to CP2K-loadable TorchScrip file with the +helper script `cp2k/tools/mace/create_cp2k_model.py`: + +```shell +python create_cp2k_model.py my_mace.model --dtype float64 +# -> writes my_mace.model-cp2k.pth +``` + +This conversion only needs to be performed once on a machine with both `torch` and `mace` installed. +The resulting `*.pth` file uses the same tensor and metadata format as the NequIP interface (inputs +`pos`, `edge_index`, `edge_cell_shift`, `cell`, `atom_types`; outputs `atomic_energy`, `forces`, +`virial`) and embeds the metadata (`num_types`, `r_max`, `type_names`, `model_dtype`) that CP2K +reads to build the neighbour graph. The `torch` version used for export must be compatible with the +LibTorch version linked into CP2K. + +## Input Section + +Inference is configured through the [MACE](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE) +section within the `&NONBONDED` forcefield parameters: + +```text +&FORCEFIELD + &NONBONDED + &MACE + ATOMS Cu + POT_FILE_NAME MACE/my_mace.model-cp2k.pth + &END MACE + &END NONBONDED +&END FORCEFIELD +``` + +- [ATOMS](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE.ATOMS): a list of elements/kinds; the + mapping to the model type list must be consistent with the coordinates in `&COORDS`/`&TOPOLOGY`. +- [POT_FILE_NAME](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE.POT_FILE_NAME): path to the + exported MACE model. + +MACE is a message-passing model with a non-local receptive field. As with NequIP, the interface +evaluates the full system on every MPI rank and divides the energy, forces, and virial by the number +of ranks. + +## Further Resources + +- **MACE:** Paper [](#Batatia2022) and source code at + [github.com/ACEsuit/mace](https://github.com/ACEsuit/mace). +- **e3nn:** For an introduction to Euclidean neural networks, visit [e3nn.org](https://e3nn.org). diff --git a/docs/technologies/libraries.md b/docs/technologies/libraries.md index 2e5bf4ebbf..86a2cb3451 100644 --- a/docs/technologies/libraries.md +++ b/docs/technologies/libraries.md @@ -220,8 +220,8 @@ of each atom. ## Torch (PyTorch C++ library) -LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP interface and for GauXC -Skala models. +LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP and MACE interfaces and for +GauXC Skala models. - LibTorch can be downloaded from the [PyTorch installation page](https://pytorch.org/get-started/locally/). diff --git a/docs/versions.md b/docs/versions.md index 48f5f78b15..923bdbb73d 100644 --- a/docs/versions.md +++ b/docs/versions.md @@ -5,6 +5,7 @@ maxdepth: 1 titlesonly: --- +2026.2 2026.1 2025.2 2025.1 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 21439a11e8..a016d826a6 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -329,6 +329,7 @@ list( kpoint_k_r_trafo_simple.F kpoint_methods.F kpoint_mo_dump.F + kpoint_mo_symmetry_methods.F kpoint_transitional.F kpoint_types.F kpsym.F @@ -354,7 +355,7 @@ list( manybody_deepmd.F manybody_gal21.F manybody_gal.F - manybody_nequip.F + manybody_e3nn.F manybody_potential.F manybody_siepmann.F manybody_tersoff.F @@ -1378,6 +1379,7 @@ list( xc/xc.F xc/xc_functionals_utilities.F xc/xc_fxc_kernel.F + xc/xc_gauxc_cache.F xc/xc_gauxc_functional.F xc/xc_gauxc_interface.F xc/xc_hcth.F diff --git a/src/accint_weights_forces.F b/src/accint_weights_forces.F index b5d9376e9b..f56be20318 100644 --- a/src/accint_weights_forces.F +++ b/src/accint_weights_forces.F @@ -412,7 +412,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_g_base, rho_r, rho_g) - ELSEIF (ASSOCIATED(rho_r_base)) THEN + ELSE IF (ASSOCIATED(rho_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho_r_base, rho_r, rho_g) ELSE CPABORT("Fine Grid in xc_density requires rho_r or rho_g") @@ -420,7 +420,7 @@ CONTAINS IF (rho_tau_valid) THEN IF (rho_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau_g_base, tau_r, tau_g) - ELSEIF (ASSOCIATED(tau_r_base)) THEN + ELSE IF (ASSOCIATED(tau_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau_r_base, tau_r, tau_g) ELSE CPABORT("Fine Grid in xc_density requires tau_r or tau_g") @@ -482,7 +482,7 @@ CONTAINS NULLIFY (rho1_r, rho1_g, tau1_r, tau1_g) IF (rho1_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho1_g_base, rho1_r, rho1_g) - ELSEIF (ASSOCIATED(rho1_r_base)) THEN + ELSE IF (ASSOCIATED(rho1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho1_r_base, rho1_r, rho1_g) ELSE CPABORT("Fine Grid in xc_density requires rho1_r or rho1_g") @@ -490,7 +490,7 @@ CONTAINS IF (rho1_tau_valid) THEN IF (rho1_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau1_g_base, tau1_r, tau1_g) - ELSEIF (ASSOCIATED(tau1_r_base)) THEN + ELSE IF (ASSOCIATED(tau1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau1_r_base, tau1_r, tau1_g) ELSE CPABORT("Fine Grid in xc_density requires tau1_r or tau1_g") @@ -518,7 +518,7 @@ CONTAINS NULLIFY (rho1_r, rho1_g, tau1_r, tau1_g) IF (rho1_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho1_g_base, rho1_r, rho1_g) - ELSEIF (ASSOCIATED(rho1_r_base)) THEN + ELSE IF (ASSOCIATED(rho1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho1_r_base, rho1_r, rho1_g) ELSE CPABORT("Fine Grid in xc_density requires rho1_r or rho1_g") @@ -526,7 +526,7 @@ CONTAINS IF (rho1_tau_valid) THEN IF (rho1_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau1_g_base, tau1_r, tau1_g) - ELSEIF (ASSOCIATED(tau1_r_base)) THEN + ELSE IF (ASSOCIATED(tau1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau1_r_base, tau1_r, tau1_g) ELSE CPABORT("Fine Grid in xc_density requires tau1_r or tau1_g") @@ -574,8 +574,9 @@ CONTAINS DEALLOCATE (vxc_rho) END IF IF (ASSOCIATED(vxc_tau)) THEN - IF (.NOT. ASSOCIATED(tau1_r)) & + IF (.NOT. ASSOCIATED(tau1_r)) THEN CPABORT("Tau response density required for mGGA xc_density") + END IF DO ispin = 1, nspins CALL pw_multiply_with(vxc_tau(ispin), tau1_r(ispin)) CALL pw_axpy(vxc_tau(ispin), exc, 1.0_dp) diff --git a/src/admm_dm_methods.F b/src/admm_dm_methods.F index 7d046cdca3..a2c56f3155 100644 --- a/src/admm_dm_methods.F +++ b/src/admm_dm_methods.F @@ -76,8 +76,9 @@ CONTAINS CPABORT("admm_dm_calc_rho_aux: unknown method") END SELECT - IF (admm_dm%purify) & + IF (admm_dm%purify) THEN CALL purify_mcweeny(qs_env) + END IF CALL update_rho_aux(qs_env) @@ -120,8 +121,9 @@ CONTAINS CPABORT("admm_dm_merge_ks_matrix: unknown method") END SELECT - IF (admm_dm%purify) & + IF (admm_dm%purify) THEN CALL dbcsr_deallocate_matrix_set(matrix_ks_merge) + END IF CALL timestop(handle) @@ -217,8 +219,9 @@ CONTAINS IF (admm_dm%block_map(iatom, jatom) == 1) THEN CALL dbcsr_get_block_p(rho_ao_aux(ispin)%matrix, & row=iatom, col=jatom, BLOCK=sparse_block_aux, found=found) - IF (found) & + IF (found) THEN sparse_block_aux = sparse_block + END IF END IF END DO CALL dbcsr_iterator_stop(iter) @@ -333,8 +336,9 @@ CONTAINS CALL dbcsr_iterator_start(iter, matrix_ks_merge(ispin)%matrix) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, iatom, jatom, sparse_block) - IF (admm_dm%block_map(iatom, jatom) == 0) & + IF (admm_dm%block_map(iatom, jatom) == 0) THEN sparse_block = 0.0_dp + END IF END DO CALL dbcsr_iterator_stop(iter) CALL dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_merge(ispin)%matrix, 1.0_dp, 1.0_dp) diff --git a/src/admm_dm_types.F b/src/admm_dm_types.F index 2ca1e1d4d7..90183cb8a4 100644 --- a/src/admm_dm_types.F +++ b/src/admm_dm_types.F @@ -105,8 +105,9 @@ CONTAINS DEALLOCATE (admm_dm%matrix_a) END IF - IF (ASSOCIATED(admm_dm%block_map)) & + IF (ASSOCIATED(admm_dm%block_map)) THEN DEALLOCATE (admm_dm%block_map) + END IF DEALLOCATE (admm_dm%mcweeny_history) DEALLOCATE (admm_dm) diff --git a/src/admm_methods.F b/src/admm_methods.F index 42d3850230..9715ce9516 100644 --- a/src/admm_methods.F +++ b/src/admm_methods.F @@ -226,12 +226,13 @@ CONTAINS END IF - IF (admm_env%purification_method == do_admm_purify_cauchy) & + IF (admm_env%purification_method == do_admm_purify_cauchy) THEN CALL purify_dm_cauchy(admm_env, & mo_set=mos_aux_fit(ispin), & density_matrix=rho_ao_aux(ispin)%matrix, & ispin=ispin, & blocked=admm_env%block_dm) + END IF !GPW is the default, PW density is computed using the AUX_FIT basis and task_list !If GAPW, the we use the AUX_FIT_SOFT basis and task list @@ -2180,13 +2181,15 @@ CONTAINS IF (my_kpgrp) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux, work_aux_aux, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, work_aux_aux2, & para_env, info(indx, 2)) + END IF ELSE CALL cp_fm_start_copy_general(admm_env%work_aux_aux, fmdummy, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, fmdummy, para_env, info(indx, 2)) + END IF END IF END DO END DO @@ -2984,12 +2987,14 @@ CONTAINS IF (my_kpgrp) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux, work_aux_aux, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, work_aux_aux2, para_env, info(indx, 2)) + END IF ELSE CALL cp_fm_start_copy_general(admm_env%work_aux_aux, fmdummy, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) & + IF (.NOT. use_real_wfn) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, fmdummy, para_env, info(indx, 2)) + END IF END IF END DO END DO diff --git a/src/admm_types.F b/src/admm_types.F index 3aefcb365e..e02e1ba93f 100644 --- a/src/admm_types.F +++ b/src/admm_types.F @@ -382,12 +382,15 @@ CONTAINS admm_env%aux_x_param(:) = admm_control%aux_x_param(:) !ADMMP, ADMMQ, ADMMS - IF ((.NOT. admm_env%charge_constrain) .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & + IF ((.NOT. admm_env%charge_constrain) .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) THEN admm_env%do_admmp = .TRUE. - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) & + END IF + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) THEN admm_env%do_admmq = .TRUE. - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & + END IF + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) THEN admm_env%do_admms = .TRUE. + END IF IF ((admm_control%method == do_admm_blocking_purify_full) .OR. & (admm_control%method == do_admm_blocked_projection)) THEN @@ -483,13 +486,16 @@ CONTAINS DEALLOCATE (admm_env%eigvals_lambda) DEALLOCATE (admm_env%eigvals_P_to_be_purified) - IF (ASSOCIATED(admm_env%block_map)) & + IF (ASSOCIATED(admm_env%block_map)) THEN DEALLOCATE (admm_env%block_map) + END IF - IF (ASSOCIATED(admm_env%xc_section_primary)) & + IF (ASSOCIATED(admm_env%xc_section_primary)) THEN CALL section_vals_release(admm_env%xc_section_primary) - IF (ASSOCIATED(admm_env%xc_section_aux)) & + END IF + IF (ASSOCIATED(admm_env%xc_section_aux)) THEN CALL section_vals_release(admm_env%xc_section_aux) + END IF IF (ASSOCIATED(admm_env%admm_gapw_env)) CALL admm_gapw_env_release(admm_env%admm_gapw_env) IF (ASSOCIATED(admm_env%admm_dm)) CALL admm_dm_release(admm_env%admm_dm) diff --git a/src/almo_scf.F b/src/almo_scf.F index b005bb02e6..c01f6f1a07 100644 --- a/src/almo_scf.F +++ b/src/almo_scf.F @@ -1400,7 +1400,6 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_delocalization' INTEGER :: handle, ispin, unit_nr - LOGICAL :: almo_experimental TYPE(cp_logger_type), POINTER :: logger TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: no_quench TYPE(optimizer_options_type) :: arbitrary_optimizer @@ -1462,25 +1461,6 @@ CONTAINS !!!! are commented out at the moment because some of their !!!! routines have not been thoroughly tested. - !!!! if we have virtuals pre-optimize and truncate them - !!!IF (almo_scf_env%need_virtuals) THEN - !!! SELECT CASE (almo_scf_env%deloc_truncate_virt) - !!! CASE (virt_full) - !!! ! simply copy virtual orbitals from matrix_v_full_blk to matrix_v_blk - !!! DO ispin=1,almo_scf_env%nspins - !!! CALL dbcsr_copy(almo_scf_env%matrix_v_blk(ispin),& - !!! almo_scf_env%matrix_v_full_blk(ispin)) - !!! ENDDO - !!! CASE (virt_number,virt_occ_size) - !!! CALL split_v_blk(almo_scf_env) - !!! !CALL truncate_subspace_v_blk(qs_env,almo_scf_env) - !!! CASE DEFAULT - !!! CPErrorMessage(cp_failure_level,routineP,"illegal method for virtual space truncation") - !!! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !!! END SELECT - !!!ENDIF - !!!CALL harris_foulkes_correction(qs_env,almo_scf_env) - IF (almo_scf_env%xalmo_update_algorithm == almo_scf_pcg) THEN CALL almo_scf_xalmo_pcg(qs_env=qs_env, & @@ -1585,18 +1565,6 @@ CONTAINS perturbation_only=.FALSE., & special_case=xalmo_case_normal) - ! RZK-warning THIS IS A HACK TO GET ORBITAL ENERGIES - almo_experimental = .FALSE. - IF (almo_experimental) THEN - almo_scf_env%perturbative_delocalization = .TRUE. - !DO ispin=1,almo_scf_env%nspins - ! CALL dbcsr_copy(almo_scf_env%matrix_t(ispin),& - ! almo_scf_env%matrix_t_blk(ispin)) - !ENDDO - CALL almo_scf_xalmo_eigensolver(qs_env, almo_scf_env, & - arbitrary_optimizer) - END IF ! experimental - ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CALL almo_scf_xalmo_trustr(qs_env=qs_env, & @@ -2622,8 +2590,9 @@ CONTAINS ALLOCATE (almo_scf_env%matrix_p_blk(nspins)) ALLOCATE (almo_scf_env%matrix_ks(nspins)) ALLOCATE (almo_scf_env%matrix_ks_blk(nspins)) - IF (almo_scf_env%need_previous_ks) & + IF (almo_scf_env%need_previous_ks) THEN ALLOCATE (almo_scf_env%matrix_ks_0deloc(nspins)) + END IF DO ispin = 1, nspins ! RZK-warning copy with symmery but remember that this might cause problems CALL dbcsr_create(almo_scf_env%matrix_p(ispin), & diff --git a/src/almo_scf_diis_types.F b/src/almo_scf_diis_types.F index d776ff9d8b..75341d7de5 100644 --- a/src/almo_scf_diis_types.F +++ b/src/almo_scf_diis_types.F @@ -258,8 +258,9 @@ CONTAINS ! update the buffer length old_buffer_length = diis_env%buffer_length diis_env%buffer_length = diis_env%buffer_length + 1 - IF (diis_env%buffer_length > diis_env%max_buffer_length) & + IF (diis_env%buffer_length > diis_env%max_buffer_length) THEN diis_env%buffer_length = diis_env%max_buffer_length + END IF !!!! resize B matrix !!!IF (old_buffer_length.lt.diis_env%buffer_length) THEN @@ -402,24 +403,12 @@ CONTAINS ! use the eigensystem to invert (implicitly) B matrix ! and compute the extrapolation coefficients - !! ALLOCATE(tmp1(diis_env%buffer_length+1,1)) - !! ALLOCATE(coeff(diis_env%buffer_length+1,1)) - !! tmp1(:,1)=-1.0_dp*m_b_copy(1,:)/eigenvalues(:) - !! coeff=MATMUL(m_b_copy,tmp1) - !! DEALLOCATE(tmp1) ALLOCATE (tmp1(diis_env%buffer_length + 1)) ALLOCATE (coeff(diis_env%buffer_length + 1)) tmp1(:) = -1.0_dp*m_b_copy(1, :)/eigenvalues(:) coeff(:) = MATMUL(m_b_copy, tmp1) DEALLOCATE (tmp1) - !IF (unit_nr.gt.0) THEN - ! DO im=1,diis_env%buffer_length+1 - ! WRITE(unit_nr,*) diis_env%m_b(idomain)%mdata(im,:) - ! ENDDO - ! WRITE (unit_nr,*) coeff(:,1) - !ENDIF - ! extrapolate the variable checksum = 0.0_dp IF (diis_env%diis_env_type == diis_env_dbcsr) THEN @@ -441,7 +430,6 @@ CONTAINS checksum = checksum + coeff(im + 1) END DO END IF - !WRITE(*,*) checksum DEALLOCATE (coeff) diff --git a/src/almo_scf_env_methods.F b/src/almo_scf_env_methods.F index 06a3d9f70f..adb25ed0f3 100644 --- a/src/almo_scf_env_methods.F +++ b/src/almo_scf_env_methods.F @@ -364,108 +364,6 @@ CONTAINS almo_scf_env%activate = 0 END IF - !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_AOS",& - ! i_val=almo_scf_env%domain_layout_aos) - !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_MOS",& - ! i_val=almo_scf_env%domain_layout_mos) - !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_AOS",& - ! i_val=almo_scf_env%mat_distr_aos) - !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_MOS",& - ! i_val=almo_scf_env%mat_distr_mos) - !CALL section_vals_val_get(almo_scf_section,"CONSTRAINT_TYPE",& - ! i_val=almo_scf_env%constraint_type) - !CALL section_vals_val_get(almo_scf_section,"MU",& - ! r_val=almo_scf_env%mu) - !CALL section_vals_val_get(almo_scf_section,"FIXED_MU",& - ! l_val=almo_scf_env%fixed_mu) - !CALL section_vals_val_get(almo_scf_section,"EPS_USE_PREV_AS_GUESS",& - ! r_val=almo_scf_env%eps_prev_guess) - !CALL section_vals_val_get(almo_scf_section,"MIXING_FRACTION",& - ! r_val=almo_scf_env%mixing_fraction) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_TENSOR_TYPE",& - ! i_val=almo_scf_env%deloc_cayley_tensor_type) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_CONJUGATOR",& - ! i_val=almo_scf_env%deloc_cayley_conjugator) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_MAX_ITER",& - ! i_val=almo_scf_env%deloc_cayley_max_iter) - !CALL section_vals_val_get(almo_scf_section,"DELOC_USE_OCC_ORBS",& - ! l_val=almo_scf_env%deloc_use_occ_orbs) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_USE_VIRT_ORBS",& - ! l_val=almo_scf_env%deloc_cayley_use_virt_orbs) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_LINEAR",& - ! l_val=almo_scf_env%deloc_cayley_linear) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_EPS_CONVERGENCE",& - ! r_val=almo_scf_env%deloc_cayley_eps_convergence) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_OCC_PRECOND",& - ! l_val=almo_scf_env%deloc_cayley_occ_precond) - !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_VIR_PRECOND",& - ! l_val=almo_scf_env%deloc_cayley_vir_precond) - !CALL section_vals_val_get(almo_scf_section,"ALMO_UPDATE_ALGORITHM_BD",& - ! i_val=almo_scf_env%almo_update_algorithm) - !CALL section_vals_val_get(almo_scf_section,"DELOC_TRUNCATE_VIRTUALS",& - ! i_val=almo_scf_env%deloc_truncate_virt) - !CALL section_vals_val_get(almo_scf_section,"DELOC_VIRT_PER_DOMAIN",& - ! i_val=almo_scf_env%deloc_virt_per_domain) - ! - !CALL section_vals_val_get(almo_scf_section,"OPT_K_EPS_CONVERGENCE",& - ! r_val=almo_scf_env%opt_k_eps_convergence) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_MAX_ITER",& - ! i_val=almo_scf_env%opt_k_max_iter) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_OUTER_MAX_ITER",& - ! i_val=almo_scf_env%opt_k_outer_max_iter) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE",& - ! r_val=almo_scf_env%opt_k_trial_step_size) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJUGATOR",& - ! i_val=almo_scf_env%opt_k_conjugator) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE_MULTIPLIER",& - ! r_val=almo_scf_env%opt_k_trial_step_size_multiplier) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_START",& - ! i_val=almo_scf_env%opt_k_conj_iter_start) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_START",& - ! i_val=almo_scf_env%opt_k_prec_iter_start) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_FREQ_RESET",& - ! i_val=almo_scf_env%opt_k_conj_iter_freq) - !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_FREQ_UPDATE",& - ! i_val=almo_scf_env%opt_k_prec_iter_freq) - ! - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_RADIUS_TYPE",& - ! i_val=almo_scf_env%quencher_radius_type) - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_FACTOR",& - ! r_val=almo_scf_env%quencher_r0_factor) - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_FACTOR",& - ! r_val=almo_scf_env%quencher_r1_factor) - !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_SHIFT",& - !! r_val=almo_scf_env%quencher_r0_shift) - !! - !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_SHIFT",& - !! r_val=almo_scf_env%quencher_r1_shift) - !! - !!almo_scf_env%quencher_r0_shift = cp_unit_to_cp2k(& - !! almo_scf_env%quencher_r0_shift,"angstrom") - !!almo_scf_env%quencher_r1_shift = cp_unit_to_cp2k(& - !! almo_scf_env%quencher_r1_shift,"angstrom") - ! - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_0",& - ! r_val=almo_scf_env%quencher_s0) - !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_1",& - ! r_val=almo_scf_env%quencher_s1) - - !CALL section_vals_val_get(almo_scf_section,"ENVELOPE_AMPLITUDE",& - ! r_val=almo_scf_env%envelope_amplitude) - - !! how to read lists - !CALL section_vals_val_get(almo_scf_section,"INT_LIST01", & - ! n_rep_val=n_rep) - !counter_i = 0 - !DO k = 1,n_rep - ! CALL section_vals_val_get(almo_scf_section,"INT_LIST01",& - ! i_rep_val=k,i_vals=tmplist) - ! DO jj = 1,SIZE(tmplist) - ! counter_i=counter_i+1 - ! almo_scf_env%charge_of_domain(counter_i)=tmplist(jj) - ! ENDDO - !ENDDO - almo_scf_env%domain_layout_aos = almo_domain_layout_molecular almo_scf_env%domain_layout_mos = almo_domain_layout_molecular almo_scf_env%mat_distr_aos = almo_mat_distr_molecular diff --git a/src/almo_scf_methods.F b/src/almo_scf_methods.F index fdcc864590..67c4a367cf 100644 --- a/src/almo_scf_methods.F +++ b/src/almo_scf_methods.F @@ -1620,8 +1620,9 @@ CONTAINS my_algorithm = 0 IF (PRESENT(algorithm)) my_algorithm = algorithm - IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) & + IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) THEN CPABORT("PARA and BLACS env are necessary for cholesky algorithm") + END IF use_sigma_inv_guess = .FALSE. IF (PRESENT(use_guess)) THEN @@ -2092,7 +2093,6 @@ CONTAINS ALLOCATE (subm_in(ndomains)) ALLOCATE (subm_temp(ndomains)) ALLOCATE (subm_out(ndomains)) - !!!TRIM ALLOCATE(subm_trimmer(ndomains)) CALL init_submatrices(subm_in) CALL init_submatrices(subm_temp) CALL init_submatrices(subm_out) @@ -2100,11 +2100,6 @@ CONTAINS CALL construct_submatrices(matrix_in, subm_in, & dpattern, map, node_of_domain, select_row) - !!!TRIM IF (matrix_trimmer_required) THEN - !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& - !!!TRIM dpattern,map,node_of_domain,select_row) - !!!TRIM ENDIF - IF (my_action == 0) THEN ! for example, apply preconditioner CALL multiply_submatrices('N', 'N', 1.0_dp, operator1, & @@ -2257,16 +2252,10 @@ CONTAINS ALLOCATE (subm_main(ndomains)) CALL init_submatrices(subm_main) - !!!TRIM ALLOCATE(subm_trimmer(ndomains)) CALL construct_submatrices(matrix_main, subm_main, & dpattern, map, node_of_domain, select_row_col) - !!!TRIM IF (matrix_trimmer_required) THEN - !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& - !!!TRIM dpattern,map,node_of_domain,select_row) - !!!TRIM ENDIF - IF (my_action == -1) THEN ! project out the local occupied space !tmp=MATMUL(subm_r(idomain)%mdata,Minv) @@ -2315,38 +2304,9 @@ CONTAINS END DO naos = subm_main(idomain)%nrows - !WRITE(*,*) "Domain, mo_self_and_neig, ao_domain: ", idomain, n_domain_mos, naos ALLOCATE (Minv(naos, naos)) - !!!TRIM IF (my_use_trimmer) THEN - !!!TRIM ! THIS IS SUPER EXPENSIVE (ELIMINATE) - !!!TRIM ! trim the main matrix before inverting - !!!TRIM ! assume that the trimmer columns are different (i.e. the main matrix is different for each MO) - !!!TRIM allocate(tmp(naos,nmos(idomain))) - !!!TRIM DO ii=1, nmos(idomain) - !!!TRIM ! transform the main matrix using the trimmer for the current MO - !!!TRIM DO jj=1, naos - !!!TRIM DO kk=1, naos - !!!TRIM Mstore(jj,kk)=sumb_main(idomain)%mdata(jj,kk)*& - !!!TRIM subm_trimmer(idomain)%mdata(jj,ii)*& - !!!TRIM subm_trimmer(idomain)%mdata(kk,ii) - !!!TRIM ENDDO - !!!TRIM ENDDO - !!!TRIM ! invert the main matrix (exclude some eigenvalues, shift some) - !!!TRIM CALL pseudo_invert_matrix(A=Mstore,Ainv=Minv,N=naos,method=1,& - !!!TRIM !range1_thr=1.0E-9_dp,range2_thr=1.0E-9_dp,& - !!!TRIM shift=1.0E-5_dp,& - !!!TRIM range1=nmos(idomain),range2=nmos(idomain),& - !!!TRIM - !!!TRIM ! apply the inverted matrix - !!!TRIM ! RZK-warning this is only possible when the preconditioner is applied - !!!TRIM tmp(:,ii)=MATMUL(Minv,subm_in(idomain)%mdata(:,ii)) - !!!TRIM ENDDO - !!!TRIM subm_out=MATMUL(tmp,sigma) - !!!TRIM deallocate(tmp) - !!!TRIM ELSE - IF (PRESENT(bad_modes_projector_down)) THEN ALLOCATE (proj_array(naos, naos)) CALL pseudo_invert_matrix(A=subm_main(idomain)%mdata, Ainv=Minv, N=naos, method=1, & @@ -2360,7 +2320,6 @@ CONTAINS CALL pseudo_invert_matrix(A=subm_main(idomain)%mdata, Ainv=Minv, N=naos, method=1, & range1=nmos(idomain), range2=n_domain_mos) END IF - !!!TRIM ENDIF CALL copy_submatrices(subm_main(idomain), preconditioner(idomain), .FALSE.) CALL copy_submatrix_data(Minv, preconditioner(idomain)) @@ -2635,24 +2594,6 @@ CONTAINS unit_nr = -1 END IF - !CALL dpotrf('L', N, Ainv, N, INFO ) - !IF( INFO/=0 ) THEN - ! CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed") - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !END IF - !CALL dpotri('L', N, Ainv, N, INFO ) - !IF( INFO/=0 ) THEN - ! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed") - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !END IF - !! complete the matrix - !DO ii=1,N - ! DO jj=ii+1,N - ! Ainv(ii,jj)=Ainv(jj,ii) - ! ENDDO - ! !WRITE(*,'(100F13.9)') Ainv(ii,:) - !ENDDO - ! diagonalize first ALLOCATE (eigenvalues(N)) ! Query the optimal workspace for dsyev @@ -2689,21 +2630,6 @@ CONTAINS DEALLOCATE (eigenvalues) -!!! ! compute the error -!!! allocate(test(N,N)) -!!! test=MATMUL(Ainv,A) -!!! DO ii=1,N -!!! test(ii,ii)=test(ii,ii)-1.0_dp -!!! ENDDO -!!! test_error=0.0_dp -!!! DO ii=1,N -!!! DO jj=1,N -!!! test_error=test_error+test(jj,ii)*test(jj,ii) -!!! ENDDO -!!! ENDDO -!!! WRITE(*,*) "Inversion error: ", SQRT(test_error) -!!! deallocate(test) - CALL timestop(handle) END SUBROUTINE matrix_sqrt @@ -2916,21 +2842,6 @@ CONTAINS END SELECT - !! compute the inversion error - !allocate(temp1(N,N)) - !temp1=MATMUL(Ainv,A) - !DO ii=1,N - ! temp1(ii,ii)=temp1(ii,ii)-1.0_dp - !ENDDO - !temp1_error=0.0_dp - !DO ii=1,N - ! DO jj=1,N - ! temp1_error=temp1_error+temp1(jj,ii)*temp1(jj,ii) - ! ENDDO - !ENDDO - !WRITE(*,*) "Inversion error: ", SQRT(temp1_error) - !deallocate(temp1) - CALL timestop(handle) END SUBROUTINE pseudo_invert_matrix diff --git a/src/almo_scf_optimizer.F b/src/almo_scf_optimizer.F index b516dcac0c..8325511ab0 100644 --- a/src/almo_scf_optimizer.F +++ b/src/almo_scf_optimizer.F @@ -72,8 +72,7 @@ MODULE almo_scf_optimizer ct_step_env_init,& ct_step_env_set,& ct_step_env_type - USE domain_submatrix_methods, ONLY: add_submatrices,& - construct_submatrices,& + USE domain_submatrix_methods, ONLY: construct_submatrices,& copy_submatrices,& init_submatrices,& maxnorm_submatrices,& @@ -226,11 +225,11 @@ CONTAINS ! get error_norm: choose the largest of the two spins prev_error_norm = error_norm DO ispin = 1, nspin - !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm_ispin = dbcsr_maxabs(almo_scf_env%matrix_err_blk(ispin)) IF (ispin == 1) error_norm = error_norm_ispin - IF (ispin > 1 .AND. error_norm_ispin > error_norm) & + IF (ispin > 1 .AND. error_norm_ispin > error_norm) THEN error_norm = error_norm_ispin + END IF END DO IF (error_norm < almo_scf_env%eps_prev_guess) THEN @@ -253,8 +252,9 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) & + IF (optimizer%early_stopping_on .AND. iscf == 1) THEN prepare_to_exit = .FALSE. + END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix @@ -294,21 +294,7 @@ CONTAINS local_nocc_of_domain(:) = almo_scf_env%nocc_of_domain(:, ispin) local_mu(:) = almo_scf_env%mu_of_domain(:, ispin) - ! RZK UPDATE! the update algorithm is removed because - ! RZK UPDATE! it requires updating core LS_SCF routines - ! RZK UPDATE! (the code exists in the CVS version) CPABORT("Density_matrix_sign has not been tested yet") - ! RZK UPDATE! CALL density_matrix_sign(almo_scf_env%matrix_p_blk(ispin),& - ! RZK UPDATE! local_mu,& - ! RZK UPDATE! almo_scf_env%fixed_mu,& - ! RZK UPDATE! almo_scf_env%matrix_ks_blk(ispin),& - ! RZK UPDATE! !matrix_mixing_old_blk(ispin),& - ! RZK UPDATE! almo_scf_env%matrix_s_blk(1), & - ! RZK UPDATE! almo_scf_env%matrix_s_blk_inv(1), & - ! RZK UPDATE! local_nocc_of_domain,& - ! RZK UPDATE! almo_scf_env%eps_filter,& - ! RZK UPDATE! almo_scf_env%domain_index_of_ao) - ! RZK UPDATE! almo_scf_env%mu_of_domain(:, ispin) = local_mu(:) END DO @@ -497,13 +483,6 @@ CONTAINS dpattern=almo_scf_env%quench_t(ispin), & map=almo_scf_env%domain_map(ispin), & node_of_domain=almo_scf_env%cpu_of_domain) - ! TRY: construct s_inv - !CALL construct_domain_s_inv(& - ! matrix_s=almo_scf_env%matrix_s(1),& - ! subm_s_inv=almo_scf_env%domain_s_inv(:,ispin),& - ! dpattern=almo_scf_env%quench_t(ispin),& - ! map=almo_scf_env%domain_map(ispin),& - ! node_of_domain=almo_scf_env%cpu_of_domain) ! construct the domain template for the occupied orbitals DO ispin = 1, nspin @@ -524,27 +503,6 @@ CONTAINS CALL init_submatrices(submatrix_mixing_old_blk) ALLOCATE (almo_diis(nspin)) - ! TRY: construct block-projector - !ALLOCATE(submatrix_tmp(almo_scf_env%ndomains)) - !DO ispin=1,nspin - ! CALL init_submatrices(submatrix_tmp) - ! CALL construct_domain_r_down(& - ! matrix_t=almo_scf_env%matrix_t_blk(ispin),& - ! matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& - ! matrix_s=almo_scf_env%matrix_s(1),& - ! subm_r_down=submatrix_tmp(:),& - ! dpattern=almo_scf_env%quench_t(ispin),& - ! map=almo_scf_env%domain_map(ispin),& - ! node_of_domain=almo_scf_env%cpu_of_domain,& - ! filter_eps=almo_scf_env%eps_filter) - ! CALL multiply_submatrices('N','N',1.0_dp,& - ! submatrix_tmp(:),& - ! almo_scf_env%domain_s_inv(:,1),0.0_dp,& - ! almo_scf_env%domain_r_down_up(:,ispin)) - ! CALL release_submatrices(submatrix_tmp) - !ENDDO - !DEALLOCATE(submatrix_tmp) - DO ispin = 1, nspin ! use s_sqrt since they are already properly constructed ! and have the same distributions as domain_err and domain_ks_xx @@ -578,7 +536,6 @@ CONTAINS ! check convergence converged = .TRUE. DO ispin = 1, nspin - !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm = dbcsr_maxabs(almo_scf_env%matrix_err_xx(ispin)) CALL maxnorm_submatrices(almo_scf_env%domain_err(:, ispin), & norm=error_norm_0) @@ -596,28 +553,18 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) & + IF (optimizer%early_stopping_on .AND. iscf == 1) THEN prepare_to_exit = .FALSE. + END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix ! perform mixing of KS matrices IF (iscf /= 1) THEN - IF (.FALSE.) THEN ! use diis instead of mixing - DO ispin = 1, nspin - CALL add_submatrices( & - almo_scf_env%mixing_fraction, & - almo_scf_env%domain_ks_xx(:, ispin), & - 1.0_dp - almo_scf_env%mixing_fraction, & - submatrix_mixing_old_blk(:, ispin), & - 'N') - END DO - ELSE - DO ispin = 1, nspin - CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & - d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) - END DO - END IF + DO ispin = 1, nspin + CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & + d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) + END DO END IF ! save the new matrix for the future mixing DO ispin = 1, nspin @@ -694,64 +641,6 @@ CONTAINS denergy_tot = denergy_tot + denergy_spin(ispin) - ! RZK-warning Energy correction can be evaluated using matrix_x - ! as shown in the attempt below and in the PCG procedure. - ! Using matrix_x allows immediate decomposition of the energy - ! lowering into 2-body components for EDA. However, it does not - ! work here because the diagonalization routine does not necessarily - ! produce orbitals with the same sign as the block-diagonal ALMOs - ! Any fixes?! - - !CALL dbcsr_init(matrix_x) - !CALL dbcsr_create(matrix_x,& - ! template=almo_scf_env%matrix_t(ispin)) - ! - !CALL dbcsr_init(matrix_tmp_no) - !CALL dbcsr_create(matrix_tmp_no,& - ! template=almo_scf_env%matrix_t(ispin)) - ! - !CALL dbcsr_copy(matrix_x,& - ! almo_scf_env%matrix_t_blk(ispin)) - !CALL dbcsr_add(matrix_x,almo_scf_env%matrix_t(ispin),& - ! -1.0_dp,1.0_dp) - - !CALL dbcsr_dot(matrix_x, almo_scf_env%matrix_err_xx(ispin),denergy) - - !denergy=denergy*spin_factor - - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "_ENERGY-0: ", almo_scf_env%almo_scf_energy - ! WRITE(unit_nr,*) "_ENERGY-D: ", denergy - ! WRITE(unit_nr,*) "_ENERGY-F: ", almo_scf_env%almo_scf_energy+denergy - !ENDIF - !! RZK-warning update will not work since the energy is overwritten almost immediately - !!CALL almo_scf_update_ks_energy(qs_env,& - !! almo_scf_env%almo_scf_energy+denergy) - !! - - !! print out the results of the decomposition analysis - !CALL dbcsr_hadamard_product(matrix_x,& - ! almo_scf_env%matrix_err_xx(ispin),& - ! matrix_tmp_no) - !CALL dbcsr_scale(matrix_tmp_no,spin_factor) - !CALL dbcsr_filter(matrix_tmp_no,almo_scf_env%eps_filter) - ! - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) - ! WRITE(unit_nr,'(T2,A)') "DECOMPOSITION OF THE DELOCALIZATION ENERGY" - !ENDIF - - !mynode=dbcsr_mp_mynode(dbcsr_distribution_mp(& - ! dbcsr_distribution(matrix_tmp_no))) - !WRITE(mynodestr,'(I6.6)') mynode - !mylogfile='EDA.'//TRIM(ADJUSTL(mynodestr)) - !OPEN (iunit,file=mylogfile,status='REPLACE') - !CALL print_block_sum(matrix_tmp_no,iunit) - !CLOSE(iunit) - ! - !CALL dbcsr_release(matrix_tmp_no) - !CALL dbcsr_release(matrix_x) - END IF ! iscf.eq.1 END DO @@ -955,13 +844,11 @@ CONTAINS eps_skip_gradients = almo_scf_env%real01 ! penalty amplitude adjusts the strength of volume conservation - energy_coeff = 1.0_dp !optimizer%opt_penalty%energy_coeff - localiz_coeff = 0.0_dp !optimizer%opt_penalty%occ_loc_coeff - penalty_amplitude = 0.0_dp !optimizer%opt_penalty%occ_vol_coeff - penalty_occ_vol = .FALSE. !( optimizer%opt_penalty%occ_vol_method & - !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) - penalty_occ_local = .FALSE. !( optimizer%opt_penalty%occ_loc_method & - !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) + energy_coeff = 1.0_dp + localiz_coeff = 0.0_dp + penalty_amplitude = 0.0_dp + penalty_occ_vol = .FALSE. + penalty_occ_local = .FALSE. normalize_orbitals = penalty_occ_vol .OR. penalty_occ_local ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) ALLOCATE (penalty_occ_vol_h_prefactor(nspins)) @@ -1322,9 +1209,6 @@ CONTAINS DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im - !CALL matrix_qs_to_almo(op_sm_set_qs(reim, idim0)%matrix, - ! op_sm_set_almo(reim, idim0)%matrix, & - ! almo_scf_env%mat_distr_aos) CALL dbcsr_multiply("N", "N", 1.0_dp, & op_sm_set_almo(reim, idim0)%matrix, & matrix_t_out(ispin), & @@ -1379,8 +1263,9 @@ CONTAINS ! save the previous gradient to compute beta ! do it only if the previous grad was computed ! for .NOT.line_search - IF (line_search_iteration == 0 .AND. iteration /= 0) & + IF (line_search_iteration == 0 .AND. iteration /= 0) THEN CALL dbcsr_copy(prev_grad(ispin), grad(ispin)) + END IF END DO ! ispin @@ -1494,11 +1379,13 @@ CONTAINS prepare_to_exit = .TRUE. END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. just_started) & + IF (optimizer%early_stopping_on .AND. just_started) THEN prepare_to_exit = .FALSE. + END IF - IF (grad_norm < almo_scf_env%eps_prev_guess) & + IF (grad_norm < almo_scf_env%eps_prev_guess) THEN use_guess = .TRUE. + END IF ! it is not time to exit just yet IF (.NOT. prepare_to_exit) THEN @@ -1580,10 +1467,6 @@ CONTAINS ! update the step direction IF (.NOT. line_search) THEN - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....updating step direction...." - !ENDIF - cg_iteration = cg_iteration + 1 ! save the previous step @@ -1663,10 +1546,6 @@ CONTAINS END DO ! ispin END IF ! compute_prec - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....applying precomputed preconditioner...." - !ENDIF - IF (my_special_case == xalmo_case_block_diag .OR. & my_special_case == xalmo_case_fully_deloc) THEN @@ -1700,16 +1579,6 @@ CONTAINS filter_eps=almo_scf_env%eps_filter) CALL dbcsr_scale(step(ispin), -1.0_dp) - !CALL dbcsr_copy(m_tmp_no_3,& - ! quench_t(ispin)) - !CALL inverse_of_elements(m_tmp_no_3) - !CALL dbcsr_copy(m_tmp_no_2,step) - !CALL dbcsr_hadamard_product(& - ! m_tmp_no_2,& - ! m_tmp_no_3,& - ! step) - !CALL dbcsr_copy(m_tmp_no_3,quench_t(ispin)) - END DO ! ispin END IF ! special case @@ -1762,10 +1631,6 @@ CONTAINS CALL dbcsr_copy(prev_minus_prec_grad(ispin), step(ispin)) - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....final beta....", beta - !ENDIF - ! conjugate the step direction CALL dbcsr_add(step(ispin), prev_step(ispin), 1.0_dp, beta) @@ -1794,10 +1659,6 @@ CONTAINS step_size = next_step_size_guess*1.05_dp END IF END IF - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,3F12.5)') & - ! "EG", e0, g0, step_size - !ENDIF next_step_size_guess = step_size ELSE IF (fixed_line_search_niter == 0) THEN @@ -1810,10 +1671,6 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,7F12.5)') & - ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der - !ENDIF step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -1824,11 +1681,6 @@ CONTAINS e1 = energy_new appr_sec_der = 2.0*((e1 - e0)/step_size - g0)/step_size g1 = appr_sec_der*step_size + g0 - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,7F12.5)') & - ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der - !ENDIF - !appr_sec_der=(g1-g0)/step_size step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -2144,7 +1996,7 @@ CONTAINS ALLOCATE (m_B0(1, dim_op, nspins)) !m_B0 first dim is 1 now! DO idim0 = 1, dim_op - DO reim = 1, 1 !SIZE(op_sm_set_qs, 1) + DO reim = 1, 1 DO ispin = 1, nspins CALL dbcsr_create(m_B0(reim, idim0, ispin), & template=m_theta(ispin), & @@ -2158,8 +2010,6 @@ CONTAINS ! penalty amplitude adjusts the strenght of volume conservation penalty_amplitude = optimizer%opt_penalty%penalty_strength - !penalty_occ_vol = ( optimizer%opt_penalty%occ_vol_method /= penalty_type_none ) - !penalty_local = ( optimizer%opt_penalty%occ_loc_method /= penalty_type_none ) ! preconditioner control prec_type = optimizer%preconditioner @@ -2453,7 +2303,6 @@ CONTAINS DO ispin = 1, nspins CALL compute_obj_nlmos( & - !obj_function_ispin=obj_function_ispin, & localization_obj_function_ispin=localization_obj_function_ispin, & penalty_func_ispin=penalty_func_ispin, & overlap_determinant=overlap_determinant, & @@ -2630,30 +2479,6 @@ CONTAINS ! TODO: write preconditioner code later ! For now, create matrix filled with 1.0 here CALL fill_matrix_with_ones(approx_inv_hessian(ispin)) - !CALL compute_preconditioner(& - ! m_prec_out=approx_hessian(ispin),& - ! m_ks=almo_scf_env%matrix_ks(ispin),& - ! m_s=matrix_s,& - ! m_siginv=almo_scf_env%template_matrix_sigma(ispin),& - ! m_quench_t=quench_t(ispin),& - ! m_FTsiginv=FTsiginv(ispin),& - ! m_siginvTFTsiginv=siginvTFTsiginv(ispin),& - ! m_ST=ST(ispin),& - ! para_env=almo_scf_env%para_env,& - ! blacs_env=almo_scf_env%blacs_env,& - ! nocc_of_domain=almo_scf_env%nocc_of_domain(:,ispin),& - ! domain_s_inv=almo_scf_env%domain_s_inv(:,ispin),& - ! domain_r_down=domain_r_down(:,ispin),& - ! cpu_of_domain=almo_scf_env%cpu_of_domain,& - ! domain_map=almo_scf_env%domain_map(ispin),& - ! assume_t0_q0x=assume_t0_q0x,& - ! penalty_occ_vol=penalty_occ_vol,& - ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin),& - ! eps_filter=eps_filter,& - ! neg_thr=0.5_dp,& - ! spin_factor=spin_factor,& - ! special_case=my_special_case) - !CALL invert hessian END DO ! ispin END IF @@ -2812,18 +2637,14 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size - !IF (unit_nr > 0) THEN - ! WRITE (unit_nr, '(A2,7F12.5)') & - ! "DT", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der - !ENDIF step_size = -g1/appr_sec_der ELSE IF (linear_search_type == 2) THEN ! alternative method for finding step size ! do not use quadratic approximation, only gradient signs IF (g1sign /= g0sign) THEN - step_size = -step_size/2.0; + step_size = -step_size/2.0 ELSE - step_size = step_size*1.5; + step_size = step_size*1.5 END IF END IF ! end alternative LS types @@ -3426,7 +3247,6 @@ CONTAINS proj_in_template=almo_scf_env%matrix_ov(ispin), & eps_filter=almo_scf_env%eps_filter, & sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin)) - !sig_inv_template=almo_scf_env%matrix_sigma_inv(ispin),& ! save initial retained virtuals CALL dbcsr_create(vr_fixed, & @@ -3459,17 +3279,6 @@ CONTAINS ! project retained virtuals out of discarded block-by-block ! (1-Q^VR_ALMO)|ALMO_vd> ! this is probably not necessary, do it just to be safe - !CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin),& - ! psi_out=almo_scf_env%matrix_v_disc(ispin),& - ! psi_projector=almo_scf_env%matrix_v_blk(ispin),& - ! metric=almo_scf_env%matrix_s_blk(1),& - ! project_out=.TRUE.,& - ! psi_projector_orthogonal=.FALSE.,& - ! proj_in_template=almo_scf_env%matrix_k_tr(ispin),& - ! eps_filter=almo_scf_env%eps_filter,& - ! sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin)) - !CALL dbcsr_copy(almo_scf_env%matrix_v_disc_blk(ispin),& - ! almo_scf_env%matrix_v_disc(ispin)) ! construct discarded virtuals (1-R)|ALMO_vd> CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin), & @@ -3492,57 +3301,11 @@ CONTAINS CALL dbcsr_create(k_vr_index_down, & template=almo_scf_env%matrix_sigma_vv_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_copy(k_vr_index_down,& - ! almo_scf_env%matrix_sigma_vv_blk(ispin)) - - !CALL get_overlap(bra=almo_scf_env%matrix_v_blk(ispin),& - ! ket=almo_scf_env%matrix_v_blk(ispin),& - ! overlap=k_vr_index_down,& - ! metric=almo_scf_env%matrix_s_blk(1),& - ! retain_overlap_sparsity=.FALSE.,& - ! eps_filter=almo_scf_env%eps_filter) !! create the up metric in the discarded k-subspace CALL dbcsr_create(k_vd_index_down, & template=almo_scf_env%matrix_vv_disc_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_init(k_vd_index_up) - !CALL dbcsr_create(k_vd_index_up,& - ! template=almo_scf_env%matrix_vv_disc_blk(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_copy(k_vd_index_down,& - ! almo_scf_env%matrix_vv_disc_blk(ispin)) - - !CALL get_overlap(bra=almo_scf_env%matrix_v_disc_blk(ispin),& - ! ket=almo_scf_env%matrix_v_disc_blk(ispin),& - ! overlap=k_vd_index_down,& - ! metric=almo_scf_env%matrix_s_blk(1),& - ! retain_overlap_sparsity=.FALSE.,& - ! eps_filter=almo_scf_env%eps_filter) - - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "Inverting blocked overlap matrix of discarded virtuals" - !ENDIF - !CALL invert_Hotelling(k_vd_index_up,& - ! k_vd_index_down,& - ! almo_scf_env%eps_filter) - !IF (safe_mode) THEN - ! CALL dbcsr_init(matrix_tmp1) - ! CALL dbcsr_create(matrix_tmp1,template=k_vd_index_down,& - ! matrix_type=dbcsr_type_no_symmetry) - ! CALL dbcsr_multiply("N","N",1.0_dp,k_vd_index_up,& - ! k_vd_index_down,& - ! 0.0_dp, matrix_tmp1,& - ! filter_eps=almo_scf_env%eps_filter) - ! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp1) - ! CALL dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) - ! frob_matrix=dbcsr_frobenius_norm(matrix_tmp1) - ! IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "Error for (inv(SIG)*SIG-I)",& - ! frob_matrix/frob_matrix_base - ! ENDIF - ! CALL dbcsr_release(matrix_tmp1) - !ENDIF ! init matrices necessary for optimization of truncated virts ! init blocked gradient before setting K to zero @@ -3606,15 +3369,6 @@ CONTAINS template=almo_scf_env%matrix_k_blk(ispin)) CALL dbcsr_set(prev_grad, 0.0_dp) - !CALL dbcsr_init(sigma_oo_guess) - !CALL dbcsr_create(sigma_oo_guess,& - ! template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_set(sigma_oo_guess,0.0_dp) - !CALL dbcsr_add_on_diag(sigma_oo_guess,1.0_dp) - !CALL dbcsr_filter(sigma_oo_guess,almo_scf_env%eps_filter) - !CALL dbcsr_print(sigma_oo_guess) - END IF ! done constructing discarded virtuals ! init variables @@ -3652,9 +3406,6 @@ CONTAINS END IF ! decompose the overlap matrix of the current retained orbitals - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "decompose the active VV overlap matrix" - !ENDIF CALL get_overlap(bra=almo_scf_env%matrix_v(ispin), & ket=almo_scf_env%matrix_v(ispin), & overlap=almo_scf_env%matrix_sigma_vv(ispin), & @@ -3727,8 +3478,6 @@ CONTAINS CALL matrix_sqrt_Newton_Schulz(sigma_vv_sqrt, & sigma_vv_sqrt_inv, & almo_scf_env%matrix_sigma_vv(ispin), & - !matrix_sqrt_inv_guess=sigma_vv_sqrt_inv_guess,& - !matrix_sqrt_guess=sigma_vv_sqrt_guess,& threshold=almo_scf_env%eps_filter, & order=almo_scf_env%order_lanczos, & eps_lanczos=almo_scf_env%eps_lanczos, & @@ -3828,9 +3577,6 @@ CONTAINS +1.0_dp, +1.0_dp) ! calculate current occupied overlap - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "Inverting current occ overlap matrix" - !ENDIF CALL get_overlap(bra=t_curr, & ket=t_curr, & overlap=sigma_oo_curr, & @@ -3847,7 +3593,6 @@ CONTAINS sigma_oo_curr, & threshold=almo_scf_env%eps_filter, & use_inv_as_guess=.TRUE.) - !CALL dbcsr_copy(sigma_oo_guess,sigma_oo_curr_inv) END IF IF (safe_mode) THEN CALL dbcsr_create(matrix_tmp1, template=sigma_oo_curr, & @@ -3859,8 +3604,6 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) - !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) - !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (SIG*inv(SIG)-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3877,8 +3620,6 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) - !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) - !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (inv(SIG)*SIG-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3941,7 +3682,6 @@ CONTAINS tmp1_n_vr, & 0.0_dp, grad, & retain_sparsity=.TRUE.) - !filter_eps=almo_scf_env%eps_filter,& ! keep tmp2_n_o for the next step ! keep tmp4_o_vr for the preconditioner @@ -3991,21 +3731,6 @@ CONTAINS IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Computing preconditioner" END IF - !CALL opt_k_create_preconditioner(prec,& - ! almo_scf_env%matrix_v_disc(ispin),& - ! almo_scf_env%matrix_ks_0deloc(ispin),& - ! almo_scf_env%matrix_x(ispin),& - ! tmp4_o_vr,& - ! almo_scf_env%matrix_s(1),& - ! grad,& - ! !almo_scf_env%matrix_v_disc_blk(ispin),& - ! vd_fixed,& - ! t_curr,& - ! k_vd_index_up,& - ! k_vr_index_down,& - ! tmp1_n_vr,& - ! spin_factor,& - ! almo_scf_env%eps_filter) CALL opt_k_create_preconditioner_blk(almo_scf_env, & almo_scf_env%matrix_v_disc(ispin), & tmp4_o_vr, & @@ -4021,7 +3746,6 @@ CONTAINS ! compute the new step CALL opt_k_apply_preconditioner_blk(almo_scf_env, & step, grad, ispin) - !CALL dbcsr_hadamard_product(prec,grad,step) CALL dbcsr_scale(step, -1.0_dp) ! check whether we need to reset conjugate directions @@ -4036,9 +3760,6 @@ CONTAINS ELSE ! check for the errors in the cg algorithm - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) CALL dbcsr_dot(grad, prev_minus_prec_grad, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) conjugacy_error = numer/denom @@ -4076,63 +3797,32 @@ CONTAINS CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_fletcher_reeves) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) - !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) beta = numer/denom CASE (cg_polak_ribiere) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_fletcher) - !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !CALL dbcsr_dot(prev_grad,prev_step,denom) - !beta=-1.0_dp*numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_step, denom) beta = numer/denom CASE (cg_liu_storey) CALL dbcsr_dot(prev_grad, prev_step, denom) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_dai_yuan) - !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) - !CALL dbcsr_dot(grad,tmp_k_blk,numer) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_dot(prev_grad,prev_step,denom) - !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_hager_zhang) - !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) - !CALL dbcsr_dot(prev_grad,prev_step,denom) - !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) - !CALL dbcsr_dot(tmp_k_blk,prev_grad,numer) - !kappa=2.0_dp*numer/denom - !CALL dbcsr_dot(tmp_k_blk,grad,numer) - !tau=numer/denom - !CALL dbcsr_dot(prev_step,grad,numer) - !beta=tau-kappa*numer/denom CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) @@ -4164,7 +3854,6 @@ CONTAINS IF (reset_conjugator) THEN beta = 0.0_dp - !reset_step_size=.TRUE. IF (unit_nr > 0) THEN WRITE (unit_nr, *) "(Re)-setting conjugator to zero" @@ -4390,13 +4079,11 @@ CONTAINS "K iter CG", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun0, line_search_error, beta, conjugacy_error, t2a - t1a - !(flop1+flop2)/(1.0E6_dp*(t2-t1)) ELSE WRITE (unit_nr, '(T6,A,1X,I3,1X,E12.3,F16.10,F16.10,E12.3,E12.3,E12.3,F8.3,F8.3,F10.3)') & "K iter LS", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun1, line_search_error, beta, conjugacy_error, t2a - t1a - !(flop1+flop2)/(1.0E6_dp*(t2-t1)) END IF END IF CALL m_flush(unit_nr) @@ -4553,7 +4240,6 @@ CONTAINS IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN CALL dbcsr_release(k_vr_index_down) CALL dbcsr_release(k_vd_index_down) - !CALL dbcsr_release(k_vd_index_up) CALL dbcsr_release(matrix_k_central) CALL dbcsr_release(vr_fixed) CALL dbcsr_release(vd_fixed) @@ -4678,8 +4364,6 @@ CONTAINS ! just get the energy correction CALL ct_step_env_get(ct_step_env, & energy_correction=energy_correction(ispin)) - !copy_da_energy_matrix=matrix_eda(ispin),& - !copy_da_charge_matrix=matrix_cta(ispin),& CALL ct_step_env_clean(ct_step_env) @@ -4700,18 +4384,6 @@ CONTAINS END IF energy_correction_final = energy_correction_final + energy_correction(ispin) - !!! print out the results of decomposition analysis - !!IF (unit_nr>0) THEN - !! WRITE(unit_nr,*) - !! WRITE(unit_nr,'(T2,A)') "ENERGY DECOMPOSITION" - !!ENDIF - !!CALL print_block_sum(eda_matrix(ispin), unit_nr=6) - !!IF (unit_nr>0) THEN - !! WRITE(unit_nr,*) - !! WRITE(unit_nr,'(T2,A)') "CHARGE DECOMPOSITION" - !!ENDIF - !!CALL print_block_sum(cta_matrix(ispin), unit_nr=6) - ! obtain density matrix from updated MOs ! RZK-later sigma and sigma_inv are lost here CALL almo_scf_t_to_proj(t=almo_scf_env%matrix_t(ispin), & @@ -4731,9 +4403,10 @@ CONTAINS para_env=almo_scf_env%para_env, & blacs_env=almo_scf_env%blacs_env) - IF (almo_scf_env%nspins == 1) & + IF (almo_scf_env%nspins == 1) THEN CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) + END IF END DO @@ -4779,17 +4452,6 @@ CONTAINS END IF - DO ispin = 1, nspin - ! RZK-warning the preconditioner is very important - ! IF (.FALSE.) THEN - ! CALL apply_matrix_preconditioner(almo_scf_env%matrix_ks(ispin),& - ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& - ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) - ! ENDIF - !CALL dbcsr_filter(almo_scf_env%matrix_ks(ispin),& - ! almo_scf_env%eps_filter) - END DO - ALLOCATE (matrix_p_almo_scf_converged(nspin)) DO ispin = 1, nspin CALL dbcsr_create(matrix_p_almo_scf_converged(ispin), & @@ -4802,50 +4464,19 @@ CONTAINS DO ispin = 1, nspin nelectron_spin_real(1) = almo_scf_env%nelectrons_spin(ispin) - IF (almo_scf_env%nspins == 1) & + IF (almo_scf_env%nspins == 1) THEN nelectron_spin_real(1) = nelectron_spin_real(1)/2 + END IF local_mu(1) = SUM(almo_scf_env%mu_of_domain(:, ispin))/almo_scf_env%ndomains fake(1) = 123523 - ! RZK UPDATE! the update algorithm is removed because - ! RZK UPDATE! it requires updating core LS_SCF routines - ! RZK UPDATE! (the code exists in the CVS version) CPABORT("CVS only: density_matrix_sign has not been updated in SVN") - ! RZK UPDATE!CALL density_matrix_sign(almo_scf_env%matrix_p(ispin),& - ! RZK UPDATE! local_mu,& - ! RZK UPDATE! almo_scf_env%fixed_mu,& - ! RZK UPDATE! almo_scf_env%matrix_ks_0deloc(ispin),& - ! RZK UPDATE! almo_scf_env%matrix_s(1), & - ! RZK UPDATE! almo_scf_env%matrix_s_inv(1), & - ! RZK UPDATE! nelectron_spin_real,& - ! RZK UPDATE! almo_scf_env%eps_filter,& - ! RZK UPDATE! fake) - ! RZK UPDATE! - almo_scf_env%mu = local_mu(1) - !IF (almo_scf_env%has_s_preconditioner) THEN - ! CALL apply_matrix_preconditioner(& - ! almo_scf_env%matrix_p_blk(ispin),& - ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& - ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) - !ENDIF - !CALL dbcsr_filter(almo_scf_env%matrix_p(ispin),& - ! almo_scf_env%eps_filter) - - IF (almo_scf_env%nspins == 1) & + IF (almo_scf_env%nspins == 1) THEN CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) - - !CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin),& - ! almo_scf_env%matrix_p(ispin),& - ! energy_correction(ispin)) - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) - ! WRITE(unit_nr,'(T2,A,I6,F20.9)') "EFAKE",ispin,& - ! energy_correction(ispin) - ! WRITE(unit_nr,*) - !ENDIF + END IF CALL dbcsr_add(matrix_p_almo_scf_converged(ispin), & almo_scf_env%matrix_p(ispin), -1.0_dp, 1.0_dp) CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin), & @@ -4958,13 +4589,6 @@ CONTAINS tmp1_n_vr, tmp2_n_vr, tmp_n_vd, & tmp_vd_vd_blk, tmp_vr_vr_blk -! init diag blocks outside -! init diag blocks otside -!INTEGER :: iblock_row, iblock_col,& -! nblkrows_tot, nblkcols_tot -!REAL(KIND=dp), DIMENSION(:, :), POINTER :: p_new_block -!INTEGER :: mynode, hold, row, col - CALL timeset(routineN, handle) ! initialize a matrix to 1.0 @@ -5362,562 +4986,6 @@ CONTAINS END SUBROUTINE opt_k_apply_preconditioner_blk -!! ************************************************************************************************** -!!> \brief Reduce the number of virtual orbitals by rotating them within -!!> a domain. The rotation is such that minimizes the frobenius norm of -!!> the Fov domain-blocks of the discarded virtuals -!!> \par History -!!> 2011.08 created [Rustam Z Khaliullin] -!!> \author Rustam Z Khaliullin -!! ************************************************************************************************** -! SUBROUTINE truncate_subspace_v_blk(qs_env,almo_scf_env) -! -! TYPE(qs_environment_type), POINTER :: qs_env -! TYPE(almo_scf_env_type) :: almo_scf_env -! -! CHARACTER(len=*), PARAMETER :: routineN = 'truncate_subspace_v_blk', & -! routineP = moduleN//':'//routineN -! -! INTEGER :: handle, ispin, iblock_row, & -! iblock_col, iblock_row_size, & -! iblock_col_size, retained_v, & -! iteration, line_search_step, & -! unit_nr, line_search_step_last -! REAL(KIND=dp) :: t1, obj_function, grad_norm,& -! c0, b0, a0, obj_function_new,& -! t2, alpha, ff1, ff2, step1,& -! step2,& -! frob_matrix_base,& -! frob_matrix -! LOGICAL :: safe_mode, converged, & -! prepare_to_exit, failure -! TYPE(cp_logger_type), POINTER :: logger -! TYPE(dbcsr_type) :: Fon, Fov, Fov_filtered, & -! temp1_oo, temp2_oo, Fov_original, & -! temp0_ov, U_blk_tot, U_blk, & -! grad_blk, step_blk, matrix_filter, & -! v_full_new,v_full_tmp,& -! matrix_sigma_vv_full,& -! matrix_sigma_vv_full_sqrt,& -! matrix_sigma_vv_full_sqrt_inv,& -! matrix_tmp1,& -! matrix_tmp2 -! -! REAL(kind=dp), DIMENSION(:, :), POINTER :: data_p, p_new_block -! TYPE(dbcsr_iterator_type) :: iter -! -! -!REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: eigenvalues, WORK -!REAL(kind=dp), DIMENSION(:,:), ALLOCATABLE :: data_copy, left_vectors, right_vectors -!INTEGER :: LWORK, INFO -!TYPE(dbcsr_type) :: temp_u_v_full_blk -! -! CALL timeset(routineN,handle) -! -! safe_mode=.TRUE. -! -! ! get a useful output_unit -! logger => cp_get_default_logger() -! IF (logger%para_env%is_source()) THEN -! unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) -! ELSE -! unit_nr=-1 -! ENDIF -! -! DO ispin=1,almo_scf_env%nspins -! -! t1 = m_walltime() -! -! !!!!!!!!!!!!!!!!! -! ! 0. Orthogonalize virtuals -! ! Unfortunately, we have to do it in the FULL V subspace :( -! -! CALL dbcsr_init(v_full_new) -! CALL dbcsr_create(v_full_new,& -! template=almo_scf_env%matrix_v_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! project the occupied subspace out -! CALL almo_scf_p_out_from_v(almo_scf_env%matrix_v_full_blk(ispin),& -! v_full_new,almo_scf_env%matrix_ov_full(ispin),& -! ispin,almo_scf_env) -! -! ! init overlap and its functions -! CALL dbcsr_init(matrix_sigma_vv_full) -! CALL dbcsr_init(matrix_sigma_vv_full_sqrt) -! CALL dbcsr_init(matrix_sigma_vv_full_sqrt_inv) -! CALL dbcsr_create(matrix_sigma_vv_full,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_create(matrix_sigma_vv_full_sqrt,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_create(matrix_sigma_vv_full_sqrt_inv,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! construct VV overlap -! CALL almo_scf_mo_to_sigma(v_full_new,& -! matrix_sigma_vv_full,& -! almo_scf_env%matrix_s(1),& -! almo_scf_env%eps_filter) -! -! IF (unit_nr>0) THEN -! WRITE(unit_nr,*) "sqrt and inv(sqrt) of the FULL virtual MO overlap" -! ENDIF -! -! ! construct orthogonalization matrices -! CALL matrix_sqrt_Newton_Schulz(matrix_sigma_vv_full_sqrt,& -! matrix_sigma_vv_full_sqrt_inv,& -! matrix_sigma_vv_full,& -! threshold=almo_scf_env%eps_filter,& -! order=almo_scf_env%order_lanczos,& -! eps_lanczos=almo_scf_env%eps_lanczos,& -! max_iter_lanczos=almo_scf_env%max_iter_lanczos) -! IF (safe_mode) THEN -! CALL dbcsr_init(matrix_tmp1) -! CALL dbcsr_create(matrix_tmp1,template=matrix_sigma_vv_full,& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_init(matrix_tmp2) -! CALL dbcsr_create(matrix_tmp2,template=matrix_sigma_vv_full,& -! matrix_type=dbcsr_type_no_symmetry) -! -! CALL dbcsr_multiply("N","N",1.0_dp,matrix_sigma_vv_full_sqrt_inv,& -! matrix_sigma_vv_full,& -! 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& -! matrix_sigma_vv_full_sqrt_inv,& -! 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) -! -! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp2) -! CALL dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) -! frob_matrix=dbcsr_frobenius_norm(matrix_tmp2) -! IF (unit_nr>0) THEN -! WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",frob_matrix/frob_matrix_base -! ENDIF -! -! CALL dbcsr_release(matrix_tmp1) -! CALL dbcsr_release(matrix_tmp2) -! ENDIF -! -! ! discard unnecessary overlap functions -! CALL dbcsr_release(matrix_sigma_vv_full) -! CALL dbcsr_release(matrix_sigma_vv_full_sqrt) -! -!! this can be re-written because we have (1-P)|v> -! -! !!!!!!!!!!!!!!!!!!! -! ! 1. Compute F_ov -! CALL dbcsr_init(Fon) -! CALL dbcsr_create(Fon,& -! template=almo_scf_env%matrix_v_full_blk(ispin)) -! CALL dbcsr_init(Fov) -! CALL dbcsr_create(Fov,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! CALL dbcsr_init(Fov_filtered) -! CALL dbcsr_create(Fov_filtered,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! CALL dbcsr_init(temp1_oo) -! CALL dbcsr_create(temp1_oo,& -! template=almo_scf_env%matrix_sigma(ispin),& -! !matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_init(temp2_oo) -! CALL dbcsr_create(temp2_oo,& -! template=almo_scf_env%matrix_sigma(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& -! almo_scf_env%matrix_ks_0deloc(ispin),& -! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& -! almo_scf_env%matrix_v_full_blk(ispin),& -! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& -! almo_scf_env%matrix_t_blk(ispin),& -! 0.0_dp,temp1_oo,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,temp1_oo,& -! almo_scf_env%matrix_sigma_inv(ispin),& -! 0.0_dp,temp2_oo,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_release(temp1_oo) -! -! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& -! almo_scf_env%matrix_s(1),& -! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& -! almo_scf_env%matrix_v_full_blk(ispin),& -! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_release(Fon) -! -! CALL dbcsr_multiply("N","N",-1.0_dp,temp2_oo,& -! Fov_filtered,& -! 1.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_release(temp2_oo) -! -! CALL dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_sigma_inv(ispin),& -! Fov,0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_multiply("N","N",1.0_dp,Fov_filtered,& -! matrix_sigma_vv_full_sqrt_inv,& -! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) -! !CALL dbcsr_copy(Fov,Fov_filtered) -!CALL dbcsr_print(Fov) -! -! IF (safe_mode) THEN -! CALL dbcsr_init(Fov_original) -! CALL dbcsr_create(Fov_original,template=Fov) -! CALL dbcsr_copy(Fov_original,Fov) -! ENDIF -! -!!! remove diagonal blocks -!!CALL dbcsr_iterator_start(iter,Fov) -!!DO WHILE (dbcsr_iterator_blocks_left(iter)) -!! -!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -!! row_size=iblock_row_size,col_size=iblock_col_size) -!! -!! IF (iblock_row.eq.iblock_col) data_p(:,:)=0.0_dp -!! -!!ENDDO -!!CALL dbcsr_iterator_stop(iter) -!!CALL dbcsr_finalize(Fov) -! -!!! perform svd of blocks -!!!!! THIS ROUTINE WORKS ONLY ON ONE CPU AND ONLY FOR 2 MOLECULES !!! -!!CALL dbcsr_init(temp_u_v_full_blk) -!!CALL dbcsr_create(temp_u_v_full_blk,& -!! template=almo_scf_env%matrix_vv_full_blk(ispin),& -!! matrix_type=dbcsr_type_no_symmetry) -!! -!!CALL dbcsr_work_create(temp_u_v_full_blk,& -!! work_mutable=.TRUE.) -!!CALL dbcsr_iterator_start(iter,Fov) -!!DO WHILE (dbcsr_iterator_blocks_left(iter)) -!! -!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -!! row_size=iblock_row_size,col_size=iblock_col_size) -!! -!! IF (iblock_row.ne.iblock_col) THEN -!! -!! ! Prepare data -!! allocate(eigenvalues(min(iblock_row_size,iblock_col_size))) -!! allocate(data_copy(iblock_row_size,iblock_col_size)) -!! allocate(left_vectors(iblock_row_size,iblock_row_size)) -!! allocate(right_vectors(iblock_col_size,iblock_col_size)) -!! data_copy(:,:)=data_p(:,:) -!! -!! ! Query the optimal workspace for dgesvd -!! LWORK = -1 -!! allocate(WORK(MAX(1,LWORK))) -!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& -!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& -!! right_vectors,iblock_col_size,WORK,LWORK,INFO) -!! LWORK = INT(WORK( 1 )) -!! deallocate(WORK) -!! -!! ! Allocate the workspace and perform svd -!! allocate(WORK(MAX(1,LWORK))) -!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& -!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& -!! right_vectors,iblock_col_size,WORK,LWORK,INFO) -!! deallocate(WORK) -!! IF( INFO/=0 ) THEN -!! CPABORT("DGESVD failed") -!! END IF -!! -!! ! copy right singular vectors into a unitary matrix -!! CALL dbcsr_put_block(temp_u_v_full_blk,iblock_col,iblock_col,right_vectors) -!! -!! deallocate(eigenvalues) -!! deallocate(data_copy) -!! deallocate(left_vectors) -!! deallocate(right_vectors) -!! -!! ENDIF -!!ENDDO -!!CALL dbcsr_iterator_stop(iter) -!!CALL dbcsr_finalize(temp_u_v_full_blk) -!!!CALL dbcsr_print(temp_u_v_full_blk) -!!CALL dbcsr_multiply("N","T",1.0_dp,Fov,temp_u_v_full_blk,& -!! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) -!! -!!CALL dbcsr_copy(Fov,Fov_filtered) -!!CALL dbcsr_print(Fov) -! -! !!!!!!!!!!!!!!!!!!! -! ! 2. Initialize variables -! -! ! temp space -! CALL dbcsr_init(temp0_ov) -! CALL dbcsr_create(temp0_ov,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! -! ! current unitary matrix -! CALL dbcsr_init(U_blk) -! CALL dbcsr_create(U_blk,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! unitary matrix accumulator -! CALL dbcsr_init(U_blk_tot) -! CALL dbcsr_create(U_blk_tot,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_add_on_diag(U_blk_tot,1.0_dp) -! -!!CALL dbcsr_add_on_diag(U_blk,1.0_dp) -!!CALL dbcsr_multiply("N","T",1.0_dp,U_blk,temp_u_v_full_blk,& -!! 0.0_dp,U_blk_tot,filter_eps=almo_scf_env%eps_filter) -!! -!!CALL dbcsr_release(temp_u_v_full_blk) -! -! ! init gradient -! CALL dbcsr_init(grad_blk) -! CALL dbcsr_create(grad_blk,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! init step matrix -! CALL dbcsr_init(step_blk) -! CALL dbcsr_create(step_blk,& -! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! -! ! "retain discarded" filter (0.0 - retain, 1.0 - discard) -! CALL dbcsr_init(matrix_filter) -! CALL dbcsr_create(matrix_filter,& -! template=almo_scf_env%matrix_ov_full(ispin)) -! ! copy Fov into the filter matrix temporarily -! ! so we know which blocks contain significant elements -! CALL dbcsr_copy(matrix_filter,Fov) -! -! ! fill out filter elements block-by-block -! CALL dbcsr_iterator_start(iter,matrix_filter) -! DO WHILE (dbcsr_iterator_blocks_left(iter)) -! -! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -! row_size=iblock_row_size,col_size=iblock_col_size) -! -! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) -! -! data_p(:,1:retained_v)=0.0_dp -! data_p(:,(retained_v+1):iblock_col_size)=1.0_dp -! -! ENDDO -! CALL dbcsr_iterator_stop(iter) -! CALL dbcsr_finalize(matrix_filter) -! -! ! apply the filter -! CALL dbcsr_hadamard_product(Fov,matrix_filter,Fov_filtered) -! -! !!!!!!!!!!!!!!!!!!!!! -! ! 3. start iterative minimization of the elements to be discarded -! iteration=0 -! converged=.FALSE. -! prepare_to_exit=.FALSE. -! DO -! -! iteration=iteration+1 -! -! !!!!!!!!!!!!!!!!!!!!!!!!! -! ! 4. compute the gradient -! CALL dbcsr_set(grad_blk,0.0_dp) -! ! create the diagonal blocks only -! CALL dbcsr_add_on_diag(grad_blk,1.0_dp) -! -! CALL dbcsr_multiply("T","N",2.0_dp,Fov_filtered,Fov,& -! 0.0_dp,grad_blk,retain_sparsity=.TRUE.,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_multiply("T","N",-2.0_dp,Fov,Fov_filtered,& -! 1.0_dp,grad_blk,retain_sparsity=.TRUE.,& -! filter_eps=almo_scf_env%eps_filter) -! -! !!!!!!!!!!!!!!!!!!!!!!! -! ! 5. check convergence -! obj_function = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 -! grad_norm = dbcsr_frobenius_norm(grad_blk) -! converged=(grad_norm.lt.almo_scf_env%truncate_v_eps_convergence) -! IF (converged.OR.(iteration.ge.almo_scf_env%truncate_v_max_iter)) THEN -! prepare_to_exit=.TRUE. -! ENDIF -! -! IF (.NOT.prepare_to_exit) THEN -! -! !!!!!!!!!!!!!!!!!!!!!!! -! ! 6. perform steps in the direction of the gradient -! ! a. first, perform a trial step to "see" the parameters -! ! of the parabola along the gradient: -! ! a0 * x^2 + b0 * x + c0 -! ! b. then perform the step to the bottom of the parabola -! -! ! get c0 -! c0 = obj_function -! ! get b0 <= d_f/d_alpha along grad -! !!!CALL dbcsr_multiply("N","N",4.0_dp,Fov,grad_blk,& -! !!! 0.0_dp,temp0_ov,& -! !!! filter_eps=almo_scf_env%eps_filter) -! !!!CALL dbcsr_dot(Fov_filtered,temp0_ov,b0) -! -! alpha=almo_scf_env%truncate_v_trial_step_size -! -! line_search_step_last=3 -! DO line_search_step=1,line_search_step_last -! CALL dbcsr_copy(step_blk,grad_blk) -! CALL dbcsr_scale(step_blk,-1.0_dp*alpha) -! CALL generator_to_unitary(step_blk,U_blk,& -! almo_scf_env%eps_filter) -! CALL dbcsr_multiply("N","N",1.0_dp,Fov,U_blk,0.0_dp,temp0_ov,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& -! Fov_filtered) -! -! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 -! IF (line_search_step.eq.1) THEN -! ff1 = obj_function_new -! step1 = alpha -! ELSE IF (line_search_step.eq.2) THEN -! ff2 = obj_function_new -! step2 = alpha -! ENDIF -! -! IF (unit_nr>0.AND.(line_search_step.ne.line_search_step_last)) THEN -! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3)') & -! "JOINT_SVD_lin",& -! iteration,& -! alpha,& -! obj_function,& -! obj_function_new,& -! obj_function_new-obj_function -! ENDIF -! -! IF (line_search_step.eq.1) THEN -! alpha=2.0_dp*alpha -! ENDIF -! IF (line_search_step.eq.2) THEN -! a0 = ((ff1-c0)/step1 - (ff2-c0)/step2) / (step1 - step2) -! b0 = (ff1-c0)/step1 - a0*step1 -! ! step size in to the bottom of "the parabola" -! alpha=-b0/(2.0_dp*a0) -! ! update the default step size -! almo_scf_env%truncate_v_trial_step_size=alpha -! ENDIF -! !!!IF (line_search_step.eq.1) THEN -! !!! a0 = (obj_function_new - b0 * alpha - c0) / (alpha*alpha) -! !!! ! step size in to the bottom of "the parabola" -! !!! alpha=-b0/(2.0_dp*a0) -! !!! !IF (alpha.gt.10.0_dp) alpha=10.0_dp -! !!!ENDIF -! -! ENDDO -! -! ! update Fov and U_blk_tot (use grad_blk as tmp storage) -! CALL dbcsr_copy(Fov,temp0_ov) -! CALL dbcsr_multiply("N","N",1.0_dp,U_blk_tot,U_blk,& -! 0.0_dp,grad_blk,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_copy(U_blk_tot,grad_blk) -! -! ENDIF -! -! t2 = m_walltime() -! -! IF (unit_nr>0) THEN -! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3,E12.3,F10.3)') & -! "JOINT_SVD_itr",& -! iteration,& -! alpha,& -! obj_function,& -! obj_function_new,& -! obj_function_new-obj_function,& -! grad_norm,& -! t2-t1 -! !(flop1+flop2)/(1.0E6_dp*(t2-t1)) -! CALL m_flush(unit_nr) -! ENDIF -! -! t1 = m_walltime() -! -! IF (prepare_to_exit) EXIT -! -! ENDDO ! stop iterations -! -! IF (safe_mode) THEN -! CALL dbcsr_multiply("N","N",1.0_dp,Fov_original,& -! U_blk_tot,0.0_dp,temp0_ov,& -! filter_eps=almo_scf_env%eps_filter) -!CALL dbcsr_print(temp0_ov) -! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& -! Fov_filtered) -! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 -! -! IF (unit_nr>0) THEN -! WRITE(unit_nr,'(T6,A,1X,E12.3)') & -! "SANITY CHECK:",& -! obj_function_new -! CALL m_flush(unit_nr) -! ENDIF -! -! CALL dbcsr_release(Fov_original) -! ENDIF -! -! CALL dbcsr_release(temp0_ov) -! CALL dbcsr_release(U_blk) -! CALL dbcsr_release(grad_blk) -! CALL dbcsr_release(step_blk) -! CALL dbcsr_release(matrix_filter) -! CALL dbcsr_release(Fov) -! CALL dbcsr_release(Fov_filtered) -! -! ! compute rotated virtual orbitals -! CALL dbcsr_init(v_full_tmp) -! CALL dbcsr_create(v_full_tmp,& -! template=almo_scf_env%matrix_v_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! v_full_new,& -! matrix_sigma_vv_full_sqrt_inv,0.0_dp,v_full_tmp,& -! filter_eps=almo_scf_env%eps_filter) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! v_full_tmp,& -! U_blk_tot,0.0_dp,v_full_new,& -! filter_eps=almo_scf_env%eps_filter) -! -! CALL dbcsr_release(matrix_sigma_vv_full_sqrt_inv) -! CALL dbcsr_release(v_full_tmp) -! CALL dbcsr_release(U_blk_tot) -! -!!!!! orthogonalized virtuals are not blocked -! ! copy new virtuals into the truncated matrix -! !CALL dbcsr_work_create(almo_scf_env%matrix_v_blk(ispin),& -! CALL dbcsr_work_create(almo_scf_env%matrix_v(ispin),& -! work_mutable=.TRUE.) -! CALL dbcsr_iterator_start(iter,v_full_new) -! DO WHILE (dbcsr_iterator_blocks_left(iter)) -! -! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& -! row_size=iblock_row_size,col_size=iblock_col_size) -! -! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) -! -! CALL dbcsr_put_block(almo_scf_env%matrix_v(ispin), iblock_row,iblock_col,data_p(:,1:retained_v)) -! CPASSERT(retained_v.gt.0) -! -! ENDDO ! iterator -! CALL dbcsr_iterator_stop(iter) -! !!CALL dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin)) -! CALL dbcsr_finalize(almo_scf_env%matrix_v(ispin)) -! -! CALL dbcsr_release(v_full_new) -! -! ENDDO ! ispin -! -! CALL timestop(handle) -! -! END SUBROUTINE truncate_subspace_v_blk - ! ************************************************************************************************** !> \brief Compute the gradient wrt the main variable (e.g. Theta, X) !> \param m_grad_out ... @@ -6049,44 +5117,9 @@ CONTAINS template=m_t, & matrix_type=dbcsr_type_no_symmetry) - ! do d_E/d_T first - !IF (.NOT.PRESENT(m_FTsiginv)) THEN - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_ks,& - ! m_t,& - ! 0.0_dp,m_tmp_no_1,& - ! filter_eps=eps_filter) - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_tmp_no_1,& - ! m_siginv,& - ! 0.0_dp,m_FTsiginv,& - ! filter_eps=eps_filter) - !ENDIF - CALL dbcsr_copy(m_tmp_no_2, m_quench_t) CALL dbcsr_copy(m_tmp_no_2, m_FTsiginv, keep_sparsity=.TRUE.) - !IF (.NOT.PRESENT(m_siginvTFTsiginv)) THEN - ! CALL dbcsr_multiply("T","N",1.0_dp,& - ! m_t,& - ! m_FTsiginv,& - ! 0.0_dp,m_tmp_oo_1,& - ! filter_eps=eps_filter) - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_siginv,& - ! m_tmp_oo_1,& - ! 0.0_dp,m_siginvTFTsiginv,& - ! filter_eps=eps_filter) - !ENDIF - - !IF (.NOT.PRESENT(m_ST)) THEN - ! CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_s,& - ! m_t,& - ! 0.0_dp,m_ST,& - ! filter_eps=eps_filter) - !ENDIF - CALL dbcsr_multiply("N", "N", -1.0_dp, & m_ST, & m_siginvTFTsiginv, & @@ -6134,15 +5167,12 @@ CONTAINS SELECT CASE (2) ! allows for selection of different spread functionals CASE (1) ! functional = -W_I * log( |z_I|^2 ) CPABORT("Localization function is not implemented") - !coeff = -(weights(idim0)/z2(ielem)) CASE (2) ! functional = W_I * ( 1 - |z_I|^2 ) coeff = -weights(idim0) CASE (3) ! functional = W_I * ( 1 - |z_I| ) CPABORT("Localization function is not implemented") - !coeff = -(weights(idim0)/(2.0_dp*z2(ielem))) END SELECT CALL dbcsr_add(temp2, temp1, 1.0_dp, coeff) - !CALL dbcsr_add(grad_loc, temp1, 1.0_dp, 1.0_dp) END DO ! end loop over idim0 CALL dbcsr_add(m_tmp_no_2, temp2, my_energy_coeff, my_localiz_coeff*4.0_dp) @@ -6150,13 +5180,6 @@ CONTAINS ! add penalty on the occupied volume: det(sigma) IF (penalty_occ_vol) THEN - !RZK-warning CALL dbcsr_multiply("N","N",& - !RZK-warning penalty_occ_vol_prefactor,& - !RZK-warning m_ST,& - !RZK-warning m_siginv,& - !RZK-warning 1.0_dp,m_tmp_no_2,& - !RZK-warning retain_sparsity=.TRUE.,& - !RZK-warning ) CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", & penalty_occ_vol_prefactor, & @@ -6167,7 +5190,6 @@ CONTAINS ! this norm does not contain the normalization factors penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) energy_g_norm = dbcsr_maxabs(m_tmp_no_2) - !WRITE (*, "(A30,2F20.10)") "Energy/penalty g norms (no norm): ", energy_g_norm, penalty_occ_vol_g_norm CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, 1.0_dp) END IF @@ -6181,17 +5203,6 @@ CONTAINS ! This is because tr(T).G_Energy = 0 and ! tr(T).G_Penalty = c0*I - !! faster way to take the norm into account (tested for vol penalty olny) - !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) - !!CALL dbcsr_copy(m_tmp_no_1, m_ST, keep_sparsity=.TRUE.) - !!CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, -penalty_occ_vol_prefactor) - !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) - !!CALL dbcsr_multiply("N", "N", 1.0_dp, & - !! m_tmp_no_2, & - !! m_sig_sqrti_ii, & - !! 0.0_dp, m_tmp_no_1, & - !! retain_sparsity=.TRUE.) - ! slower way of taking the norm into account CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -6266,34 +5277,6 @@ CONTAINS CALL dbcsr_copy(m_tmp_no_1, m_grad_out) END IF - !! check whether the gradient lies entirely in R or Q - !CALL dbcsr_multiply("T","N",1.0_dp,& - ! m_t,& - ! m_tmp_no_1,& - ! 0.0_dp,m_tmp_oo_1,& - ! filter_eps=eps_filter,& - ! ) - !CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_siginv,& - ! m_tmp_oo_1,& - ! 0.0_dp,m_tmp_oo_2,& - ! filter_eps=eps_filter,& - ! ) - !CALL dbcsr_copy(m_tmp_no_2,m_tmp_no_1) - !CALL dbcsr_multiply("N","N",-1.0_dp,& - ! m_ST,& - ! m_tmp_oo_2,& - ! 1.0_dp,m_tmp_no_2,& - ! retain_sparsity=.TRUE.,& - ! ) - !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) - !WRITE(*,"(A50,2F20.10)") "Virtual-space projection of the gradient", penalty_occ_vol_g_norm - !CALL dbcsr_add(m_tmp_no_2,m_tmp_no_1,1.0_dp,-1.0_dp) - !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) - !WRITE(*,"(A50,2F20.10)") "Occupied-space projection of the gradient", penalty_occ_vol_g_norm - !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) - !WRITE(*,"(A50,2F20.10)") "Full gradient", penalty_occ_vol_g_norm - ! transform d_E/d_T to d_E/d_theta IF (optimize_theta) THEN CALL dbcsr_copy(m_tmp_no_2, m_theta) @@ -6651,7 +5634,6 @@ CONTAINS CALL dbcsr_get_diag(m_temp_oo_4, tg_diagonal) CALL dbcsr_set(m_temp_oo_4, 0.0_dp) CALL dbcsr_set_diag(m_temp_oo_4, tg_diagonal) - !CALL para_group%sum(tg_diagonal) z2(:) = z2(:) + tg_diagonal(:)*tg_diagonal(:) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -7052,15 +6034,6 @@ CONTAINS CALL dbcsr_copy(m_f_vv_out, m_prec_out) END IF -#if 0 -!penalty_only=.TRUE. - WRITE (unit_nr, *) "prefactor0:", penalty_occ_vol_prefactor - !IF (penalty_occ_vol) THEN - CALL dbcsr_desymmetrize(m_s, & - m_prec_out) - !CALL dbcsr_scale(m_prec_out,-penalty_occ_vol_prefactor) - !ENDIF -#else ! sum up the F_vv and S_vv terms CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, 1.0_dp) @@ -7072,7 +6045,6 @@ CONTAINS CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, penalty_occ_vol_prefactor) END IF -#endif CALL dbcsr_copy(m_tmp_nn_1, m_prec_out) @@ -7168,67 +6140,6 @@ CONTAINS END IF ! special_case - ! invert using cholesky (works with S matrix, will not work with S-SRS matrix) - !!!CALL cp_dbcsr_cholesky_decompose(prec_vv,& - !!! para_env=almo_scf_env%para_env,& - !!! blacs_env=almo_scf_env%blacs_env) - !!!CALL cp_dbcsr_cholesky_invert(prec_vv,& - !!! para_env=almo_scf_env%para_env,& - !!! blacs_env=almo_scf_env%blacs_env,& - !!! uplo_to_full=.TRUE.) - !!!CALL dbcsr_filter(prec_vv,& - !!! almo_scf_env%eps_filter) - !!! - - ! re-create the matrix because desymmetrize is buggy - - ! it will create multiple copies of blocks - !!!DESYM!CALL dbcsr_create(prec_vv,& - !!!DESYM! template=almo_scf_env%matrix_s(1),& - !!!DESYM! matrix_type=dbcsr_type_no_symmetry) - !!!DESYM!CALL dbcsr_desymmetrize(almo_scf_env%matrix_s(1),& - !!!DESYM! prec_vv) - !CALL dbcsr_multiply("N","N",1.0_dp,& - ! almo_scf_env%matrix_s(1),& - ! matrix_t_out(ispin),& - ! 0.0_dp,m_tmp_no_1,& - ! filter_eps=almo_scf_env%eps_filter) - !CALL dbcsr_multiply("N","N",1.0_dp,& - ! m_tmp_no_1,& - ! almo_scf_env%matrix_sigma_inv(ispin),& - ! 0.0_dp,m_tmp_no_3,& - ! filter_eps=almo_scf_env%eps_filter) - !CALL dbcsr_multiply("N","T",-1.0_dp,& - ! m_tmp_no_3,& - ! m_tmp_no_1,& - ! 1.0_dp,prec_vv,& - ! filter_eps=almo_scf_env%eps_filter) - !CALL dbcsr_add_on_diag(prec_vv,& - ! prec_sf_mixing_s) - - !CALL dbcsr_create(prec_oo,& - ! template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& - ! prec_oo) - !CALL dbcsr_filter(prec_oo,& - ! almo_scf_env%eps_filter) - - !! invert using cholesky - !CALL dbcsr_create(prec_oo_inv,& - ! template=prec_oo,& - ! matrix_type=dbcsr_type_no_symmetry) - !CALL dbcsr_desymmetrize(prec_oo,& - ! prec_oo_inv) - !CALL cp_dbcsr_cholesky_decompose(prec_oo_inv,& - ! para_env=almo_scf_env%para_env,& - ! blacs_env=almo_scf_env%blacs_env) - !CALL cp_dbcsr_cholesky_invert(prec_oo_inv,& - ! para_env=almo_scf_env%para_env,& - ! blacs_env=almo_scf_env%blacs_env,& - ! uplo_to_full=.TRUE.) - CALL dbcsr_release(m_tmp_nn_1) CALL dbcsr_release(m_tmp_no_3) @@ -7574,10 +6485,6 @@ CONTAINS filter_eps=eps_filter) ! RZK-warning -! compute preconditioner even if we do not use it -! this is for debugging because compute_preconditioner includes -! computing F_vv and S_vv necessary for -! IF ( use_preconditioner ) THEN ! domain_s_inv and domain_r_down are never used with assume_t0_q0x=FALSE CALL compute_preconditioner( & @@ -7610,8 +6517,6 @@ CONTAINS skip_inversion=.FALSE. & ) -! ENDIF ! use_preconditioner - ! initial guess CALL dbcsr_copy(m_delta(ispin), m_quench_t(ispin)) ! in order to use dbcsr_set matrix blocks must exist @@ -7647,10 +6552,7 @@ CONTAINS penalty_occ_vol_pf2=penalty_occ_vol_pf2(ispin), & m_s=m_s(1), & para_env=para_env, & - blacs_env=blacs_env & - ) - ! correct solution by the spin factor - !CALL dbcsr_scale(m_zet(ispin),1.0_dp/(2.0_dp*spin_factor)) + blacs_env=blacs_env) ELSE ! use PCG to solve H.D=-G @@ -7675,10 +6577,7 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter & - !matrix_trimmer=,& - !use_trimmer=.FALSE.,& - ) + filter_eps=eps_filter) END IF ! special_case @@ -7732,8 +6631,7 @@ CONTAINS normalize_orbitals=normalize_orbitals, & penalty_occ_vol_prefactor=penalty_occ_vol_prefactor, & eps_filter=eps_filter, & - path_num=hessian_path_reuse & - ) + path_num=hessian_path_reuse) ! alpha is computed outside the spin loop numer = 0.0_dp @@ -7778,10 +6676,6 @@ CONTAINS ! compute the new step (apply preconditioner if available) IF (use_preconditioner) THEN - !IF (unit_nr>0) THEN - ! WRITE(unit_nr,*) "....applying preconditioner...." - !ENDIF - IF (special_case == xalmo_case_block_diag .OR. & special_case == xalmo_case_fully_deloc) THEN @@ -7801,10 +6695,7 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter & - !matrix_trimmer=,& - !use_trimmer=.FALSE.,& - ) + filter_eps=eps_filter) END IF ! special case @@ -7837,7 +6728,6 @@ CONTAINS t2 = m_walltime() IF (unit_nr > 0) THEN - !iter_type=TRIM("ALMO SCF "//iter_type) iter_type = TRIM("NR STEP") WRITE (unit_nr, '(T6,A9,I6,F14.5,F14.5,F15.10,F9.2)') & iter_type, iteration, & @@ -7860,26 +6750,6 @@ CONTAINS END DO ! outer loop -! is not necessary if penalty_occ_vol_pf2=0.0 -#if 0 - - IF (penalty_occ_vol) THEN - - DO ispin = 1, nspins - - CALL dbcsr_copy(m_zet(ispin), m_grad(ispin)) - CALL dbcsr_dot(m_delta(ispin), m_zet(ispin), alpha) - WRITE (unit_nr, *) "trace(grad.delta): ", alpha - alpha = -1.0_dp/(penalty_occ_vol_pf2(ispin)*alpha - 1.0_dp) - WRITE (unit_nr, *) "correction alpha: ", alpha - CALL dbcsr_scale(m_delta(ispin), alpha) - - END DO - - END IF - -#endif - DO ispin = 1, nspins ! check whether the step lies entirely in R or Q @@ -8086,44 +6956,6 @@ CONTAINS ! apply pre-computed F_vv and S_vv to X -#if 0 -! RZK-warning: negative sign at penalty_prefactor_local is that -! magical fix for the negative definite problem -! (since penalty_prefactor_local<0 the coeff before S_vv must -! be multiplied by -1 to take the step in the right direction) -!CALL dbcsr_multiply("N","N",-4.0_dp*penalty_prefactor_local,& -! m_s_vv(ispin),& -! m_tmp_x_in,& -! 0.0_dp,m_tmp_no_1,& -! filter_eps=eps_filter) -!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) -!CALL dbcsr_multiply("N","N",1.0_dp,& -! m_tmp_no_1,& -! m_siginv(ispin),& -! 0.0_dp,m_x_out(ispin),& -! retain_sparsity=.TRUE.) - - CALL dbcsr_multiply("N", "N", 1.0_dp, & - m_s(1), & - m_tmp_x_in, & - 0.0_dp, m_tmp_no_1, & - filter_eps=eps_filter) - CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) - CALL dbcsr_multiply("N", "N", 1.0_dp, & - m_tmp_no_1, & - m_siginv(ispin), & - 0.0_dp, m_x_out(ispin), & - retain_sparsity=.TRUE.) - -!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) -!CALL dbcsr_multiply("N","N",1.0_dp,& -! m_s(1),& -! m_tmp_x_in,& -! 0.0_dp,m_x_out(ispin),& -! retain_sparsity=.TRUE.) - -#else - ! debugging: only vv matrices, oo matrices are kronecker CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -8140,75 +6972,6 @@ CONTAINS retain_sparsity=.TRUE.) CALL dbcsr_add(m_x_out(ispin), m_tmp_no_2, & 1.0_dp, -4.0_dp*penalty_prefactor_local + 1.0_dp) -#endif - -! ! F_vv.X.S_oo -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_ks_vv(ispin),& -! m_tmp_x_in,& -! 0.0_dp,m_tmp_no_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_tmp_no_1,& -! m_siginv(ispin),& -! 0.0_dp,m_x_out(ispin),& -! retain_sparsity=.TRUE.,& -! ) -! -! ! S_vv.X.F_oo -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_s_vv(ispin),& -! m_tmp_x_in,& -! 0.0_dp,m_tmp_no_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_tmp_no_1,& -! m_siginvTFTsiginv(ispin),& -! 0.0_dp,m_tmp_no_2,& -! retain_sparsity=.TRUE.,& -! ) -! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& -! 1.0_dp,-1.0_dp) -!! we have to add occ voll penalty here (the Svv termi (i.e. both Svv.D.Soo) -!! and STsiginv terms) -! -! ! S_vo.X^t.F_vo -! CALL dbcsr_multiply("T","N",1.0_dp,& -! m_tmp_x_in,& -! m_g_full(ispin),& -! 0.0_dp,m_tmp_oo_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_STsiginv(ispin),& -! m_tmp_oo_1,& -! 0.0_dp,m_tmp_no_2,& -! retain_sparsity=.TRUE.,& -! ) -! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& -! 1.0_dp,-1.0_dp) -! -! ! S_vo.X^t.F_vo -! CALL dbcsr_multiply("T","N",1.0_dp,& -! m_tmp_x_in,& -! m_STsiginv(ispin),& -! 0.0_dp,m_tmp_oo_1,& -! filter_eps=eps_filter,& -! ) -! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) -! CALL dbcsr_multiply("N","N",1.0_dp,& -! m_g_full(ispin),& -! m_tmp_oo_1,& -! 0.0_dp,m_tmp_no_2,& -! retain_sparsity=.TRUE.,& -! ) -! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& -! 1.0_dp,-1.0_dp) ELSE IF (path_num == hessian_path_assemble) THEN @@ -8400,12 +7163,6 @@ CONTAINS WRITE (unit_nr, *) "penalty_prefactor_local: ", penalty_prefactor_local WRITE (unit_nr, *) "penalty_prefactor_2: ", penalty_occ_vol_pf2 - !CALL dbcsr_print(matrix_grad) - !CALL dbcsr_print(matrix_F_ao_sym) - !CALL dbcsr_print(matrix_S_ao_sym) - !CALL dbcsr_print(matrix_F_mo_sym) - !CALL dbcsr_print(matrix_S_mo_sym) - ! loop over domains to find the size of the Hessian H_size = 0 DO col = 1, nblkcols_tot @@ -8505,23 +7262,6 @@ CONTAINS S_mo_block(1:mo_block_sizes(row), 1:mo_block_sizes(col)) = block_p(:, :) END IF - !WRITE(*,*) "F_AO_BLOCK", row, col, ao_domain_sizes(row), ao_domain_sizes(col) - !DO ii=1,ao_domain_sizes(row) - ! WRITE(*,'(100F13.9)') F_ao_block(ii,:) - !ENDDO - !WRITE(*,*) "S_AO_BLOCK", row, col - !DO ii=1,ao_domain_sizes(row) - ! WRITE(*,'(100F13.9)') S_ao_block(ii,:) - !ENDDO - !WRITE(*,*) "F_MO_BLOCK", row, col - !DO ii=1,mo_block_sizes(row) - ! WRITE(*,'(100F13.9)') F_mo_block(ii,:) - !ENDDO - !WRITE(*,*) "S_MO_BLOCK", row, col, mo_block_sizes(row), mo_block_sizes(col) - !DO ii=1,mo_block_sizes(row) - ! WRITE(*,'(100F13.9)') S_mo_block(ii,:) - !ENDDO - ! construct tensor products for the current row-column fragment pair lev2_vert_offset = 0 DO orb_j = 1, mo_block_sizes(row) @@ -8531,16 +7271,8 @@ CONTAINS IF (orb_i == orb_j .AND. row == col) THEN H(lev1_vert_offset + lev2_vert_offset + 1:lev1_vert_offset + lev2_vert_offset + ao_domain_sizes(row), & lev1_hori_offset + lev2_hori_offset + 1:lev1_hori_offset + lev2_hori_offset + ao_domain_sizes(col)) & - != -penalty_prefactor_local*S_ao_block(:,:) = F_ao_block(:, :) + S_ao_block(:, :) -!=S_ao_block(:,:) -!RZK-warning =F_ao_block(:,:)+( 1.0_dp + penalty_prefactor_local )*S_ao_block(:,:) -! =S_mo_block(orb_j,orb_i)*F_ao_block(:,:)& -! -F_mo_block(orb_j,orb_i)*S_ao_block(:,:)& -! +penalty_prefactor_local*S_mo_block(orb_j,orb_i)*S_ao_block(:,:) END IF - !WRITE(*,*) row, col, orb_j, orb_i, lev1_vert_offset+lev2_vert_offset+1, ao_domain_sizes(row),& - ! lev1_hori_offset+lev2_hori_offset+1, ao_domain_sizes(col), S_mo_block(orb_j,orb_i) lev2_hori_offset = lev2_hori_offset + ao_domain_sizes(col) @@ -8568,180 +7300,6 @@ CONTAINS CALL dbcsr_release(matrix_S_mo_sym) CALL dbcsr_release(matrix_F_mo_sym) -!! ! Two more terms of the Hessian: S_vo.D.F_vo and F_vo.D.S_vo -!! ! It seems that these terms break positive definite property of the Hessian -!! ALLOCATE(H1(H_size,H_size)) -!! ALLOCATE(H2(H_size,H_size)) -!! H1=0.0_dp -!! H2=0.0_dp -!! DO row = 1, nblkcols_tot -!! -!! lev1_hori_offset=0 -!! DO col = 1, nblkcols_tot -!! -!! CALL dbcsr_get_block_p(matrix_F_vo,& -!! row, col, block_p, found) -!! CALL dbcsr_get_block_p(matrix_S_vo,& -!! row, col, block_p2, found2) -!! -!! lev1_vert_offset=0 -!! DO block_col = 1, nblkcols_tot -!! -!! CALL dbcsr_get_block_p(quench_t,& -!! row, block_col, p_new_block, found_row) -!! -!! IF (found_row) THEN -!! -!! ! determine offset in this short loop -!! lev2_vert_offset=0 -!! DO block_row=1,row-1 -!! CALL dbcsr_get_block_p(quench_t,& -!! block_row, block_col, p_new_block, found_col) -!! IF (found_col) lev2_vert_offset=lev2_vert_offset+ao_block_sizes(block_row) -!! ENDDO -!! !!!!!!!! short loop -!! -!! ! over all electrons of the block -!! DO orb_i=1, mo_block_sizes(col) -!! -!! ! into all possible locations -!! DO orb_j=1, mo_block_sizes(block_col) -!! -!! ! column is copied several times -!! DO copy=1, ao_domain_sizes(col) -!! -!! IF (found) THEN -!! -!! !WRITE(*,*) row, col, block_col, orb_i, orb_j, copy,& -!! ! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1,& -!! ! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy -!! -!! H1( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& -!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& -!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& -!! =block_p(:,orb_i) -!! -!! ENDIF ! found block in the data matrix -!! -!! IF (found2) THEN -!! -!! H2( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& -!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& -!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& -!! =block_p2(:,orb_i) -!! -!! ENDIF ! found block in the data matrix -!! -!! ENDDO -!! -!! ENDDO -!! -!! ENDDO -!! -!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) -!! -!! ENDIF ! found block in the quench matrix -!! -!! lev1_vert_offset=lev1_vert_offset+& -!! ao_domain_sizes(block_col)*mo_block_sizes(block_col) -!! -!! ENDDO -!! -!! lev1_hori_offset=lev1_hori_offset+& -!! ao_domain_sizes(col)*mo_block_sizes(col) -!! -!! ENDDO -!! -!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) -!! -!! ENDDO -!! H1(:,:)=H1(:,:)*2.0_dp*spin_factor -!! !!!WRITE(*,*) "F_vo" -!! !!!DO ii=1,H_size -!! !!! WRITE(*,'(100F13.9)') H1(ii,:) -!! !!!ENDDO -!! !!!WRITE(*,*) "S_vo" -!! !!!DO ii=1,H_size -!! !!! WRITE(*,'(100F13.9)') H2(ii,:) -!! !!!ENDDO -!! !!!!! add terms to the hessian -!! DO ii=1,H_size -!! DO jj=1,H_size -!!! add penalty_occ_vol term -!! H(ii,jj)=H(ii,jj)-H1(ii,jj)*H2(jj,ii)-H1(jj,ii)*H2(ii,jj) -!! ENDDO -!! ENDDO -!! DEALLOCATE(H1) -!! DEALLOCATE(H2) - -!! ! S_vo.S_vo diagonal component due to determiant constraint -!! ! use grad vector temporarily -!! IF (penalty_occ_vol) THEN -!! ALLOCATE(Grad_vec(H_size)) -!! Grad_vec(:)=0.0_dp -!! lev1_vert_offset=0 -!! ! loop over all electron blocks -!! DO col = 1, nblkcols_tot -!! -!! ! loop over AO-rows of the dbcsr matrix -!! lev2_vert_offset=0 -!! DO row = 1, nblkrows_tot -!! -!! CALL dbcsr_get_block_p(quench_t,& -!! row, col, block_p, found_row) -!! IF (found_row) THEN -!! -!! CALL dbcsr_get_block_p(matrix_S_vo,& -!! row, col, block_p, found) -!! IF (found) THEN -!! ! copy the data into the vector, column by column -!! DO orb_i=1, mo_block_sizes(col) -!! Grad_vec(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& -!! lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& -!! =block_p(:,orb_i) -!! ENDDO -!! -!! ENDIF -!! -!! lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) -!! -!! ENDIF -!! -!! ENDDO -!! -!! lev1_vert_offset=lev1_vert_offset+ao_domain_sizes(col)*mo_block_sizes(col) -!! -!! ENDDO ! loop over electron blocks -!! ! update H now -!! DO ii=1,H_size -!! DO jj=1,H_size -!! H(ii,jj)=H(ii,jj)+penalty_occ_vol_prefactor*& -!! penalty_occ_vol_pf2*Grad_vec(ii)*Grad_vec(jj) -!! ENDDO -!! ENDDO -!! DEALLOCATE(Grad_vec) -!! ENDIF ! penalty_occ_vol - -!S-1.G ! invert S using cholesky -!S-1.G CALL dbcsr_create(m_prec_out,& -!S-1.G template=m_s,& -!S-1.G matrix_type=dbcsr_type_no_symmetry) -!S-1.G CALL dbcsr_copy(m_prec_out,m_s) -!S-1.G CALL dbcsr_cholesky_decompose(m_prec_out,& -!S-1.G para_env=para_env,& -!S-1.G blacs_env=blacs_env) -!S-1.G CALL dbcsr_cholesky_invert(m_prec_out,& -!S-1.G para_env=para_env,& -!S-1.G blacs_env=blacs_env,& -!S-1.G uplo_to_full=.TRUE.) -!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& -!S-1.G m_prec_out,& -!S-1.G matrix_grad,& -!S-1.G 0.0_dp,matrix_step,& -!S-1.G filter_eps=1.0E-10_dp) -!S-1.G !CALL dbcsr_release(m_prec_out) -!S-1.G ALLOCATE(test3(H_size)) - ! convert gradient from the dbcsr matrix to the vector form ALLOCATE (Grad_vec(H_size)) Grad_vec(:) = 0.0_dp @@ -8765,22 +7323,10 @@ CONTAINS Grad_vec(lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + 1: & lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + ao_block_sizes(row)) & = block_p(:, orb_i) -!WRITE(*,*) "GRAD: ", row, col, orb_i, lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1, ao_block_sizes(row) END DO END IF -!S-1.G CALL dbcsr_get_block_p(matrix_step,& -!S-1.G row, col, block_p, found) -!S-1.G IF (found) THEN -!S-1.G ! copy the data into the vector, column by column -!S-1.G DO orb_i=1, mo_block_sizes(col) -!S-1.G test3(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& -!S-1.G lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& -!S-1.G =block_p(:,orb_i) -!S-1.G ENDDO -!S-1.G ENDIF - lev2_vert_offset = lev2_vert_offset + ao_block_sizes(row) END IF @@ -8791,12 +7337,6 @@ CONTAINS END DO ! loop over electron blocks - !WRITE(*,*) "HESSIAN" - !DO ii=1,H_size - ! WRITE(*,*) ii - ! WRITE(*,'(20F14.10)') H(ii,:) - !ENDDO - ! invert the Hessian INFO = 0 ALLOCATE (Hinv(H_size, H_size)) @@ -8824,21 +7364,6 @@ CONTAINS ! Step_vec contains Grad_vec here Step_vec(:) = MATMUL(TRANSPOSE(Hinv), Grad_vec) - ! compute U.tr(U)-1 = error - !ALLOCATE(test(H_size,H_size)) - !test(:,:)=MATMUL(TRANSPOSE(Hinv),Hinv) - !DO ii=1,H_size - ! test(ii,ii)=test(ii,ii)-1.0_dp - !ENDDO - !test_error=0.0_dp - !DO ii=1,H_size - ! DO jj=1,H_size - ! test_error=test_error+test(jj,ii)*test(jj,ii) - ! ENDDO - !ENDDO - !WRITE(*,*) "U.tr(U)-1 error: ", SQRT(test_error) - !DEALLOCATE(test) - ! invert eigenvalues and use eigenvectors to compute the Hessian inverse ! project out zero-eigenvalue directions ALLOCATE (test(H_size, H_size)) @@ -8860,46 +7385,8 @@ CONTAINS Hinv(:, :) = test2(:, :) DEALLOCATE (test, test2) - !! shift to kill singularity - !shift=0.0_dp - !IF (eigenvalues(1).lt.0.0_dp) THEN - ! CPABORT("Negative eigenvalue(s)") - ! shift=abs(eigenvalues(1)) - ! WRITE(*,*) "Lowest eigenvalue: ", eigenvalues(1) - !ENDIF - !DO ii=1, H_size - ! IF (eigenvalues(ii).gt.eps_zero) THEN - ! shift=shift+min(1.0_dp,eigenvalues(ii))*1.0E-4_dp - ! EXIT - ! ENDIF - !ENDDO - !WRITE(*,*) "Hessian shift: ", shift - !DO ii=1, H_size - ! H(ii,ii)=H(ii,ii)+shift - !ENDDO - !! end shift - DEALLOCATE (eigenvalues) -!!!! Hinv=H -!!!! INFO=0 -!!!! CALL dpotrf('L', H_size, Hinv, H_size, INFO ) -!!!! IF( INFO/=0 ) THEN -!!!! WRITE(*,*) 'DPOTRF ERROR MESSAGE: ', INFO -!!!! CPABORT("DPOTRF failed") -!!!! END IF -!!!! CALL dpotri('L', H_size, Hinv, H_size, INFO ) -!!!! IF( INFO/=0 ) THEN -!!!! WRITE(*,*) 'DPOTRI ERROR MESSAGE: ', INFO -!!!! CPABORT("DPOTRI failed") -!!!! END IF -!!!! ! complete the matrix -!!!! DO ii=1,H_size -!!!! DO jj=ii+1,H_size -!!!! Hinv(ii,jj)=Hinv(jj,ii) -!!!! ENDDO -!!!! ENDDO - ! compute the inversion error ALLOCATE (test(H_size, H_size)) test(:, :) = MATMUL(Hinv, H) @@ -8919,7 +7406,6 @@ CONTAINS ALLOCATE (Step_vec(H_size)) ALLOCATE (tmp(H_size)) tmp(:) = MATMUL(Hinv, Grad_vec) - !tmp(:)=MATMUL(Hinv,test3) Step_vec(:) = -1.0_dp*tmp(:) ALLOCATE (tmpr(H_size)) @@ -8977,19 +7463,6 @@ CONTAINS CALL dbcsr_finalize(matrix_step) -!S-1.G CALL dbcsr_create(m_tmp_no_1,& -!S-1.G template=matrix_step,& -!S-1.G matrix_type=dbcsr_type_no_symmetry) -!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& -!S-1.G m_prec_out,& -!S-1.G matrix_step,& -!S-1.G 0.0_dp,m_tmp_no_1,& -!S-1.G filter_eps=1.0E-10_dp,& -!S-1.G ) -!S-1.G CALL dbcsr_copy(matrix_step,m_tmp_no_1) -!S-1.G CALL dbcsr_release(m_tmp_no_1) -!S-1.G CALL dbcsr_release(m_prec_out) - DEALLOCATE (mo_block_sizes, ao_block_sizes) DEALLOCATE (ao_domain_sizes) @@ -9135,8 +7608,6 @@ CONTAINS ! penalty amplitude adjusts the strength of volume conservation penalty_occ_vol = .FALSE. - !(almo_scf_env%penalty%occ_vol_method /= almo_occ_vol_penalty_none .AND. & - ! my_special_case == xalmo_case_fully_deloc) normalize_orbitals = penalty_occ_vol penalty_amplitude = 0.0_dp !almo_scf_env%penalty%occ_vol_coeff ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) @@ -9406,8 +7877,6 @@ CONTAINS ! check convergence and other exit criteria DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(grad(ispin)) - !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & - ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin grad_norm_ref = MAXVAL(grad_norm_spin) @@ -9429,8 +7898,9 @@ CONTAINS scf_converged = .TRUE. border_reached = .FALSE. expected_reduction = 0.0_dp - IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) & + IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) THEN EXIT adjust_r_loop + END IF ELSE scf_converged = .FALSE. END IF @@ -9787,35 +8257,6 @@ CONTAINS END IF ! special_case - ! slower but more reliable way to get inverted hessian - !DO ispin = 1, nspins - ! CALL compute_preconditioner( & - ! domain_prec_out=domain_model_hessian_inv(:, ispin), & - ! m_prec_out=m_model_hessian_inv(ispin), & ! RZK-warning: this one is not inverted if DOMAINs - ! m_ks=almo_scf_env%matrix_ks(ispin), & - ! m_s=almo_scf_env%matrix_s(1), & - ! m_siginv=almo_scf_env%matrix_sigma_inv(ispin), & - ! m_quench_t=quench_t(ispin), & - ! m_FTsiginv=FTsiginv(ispin), & - ! m_siginvTFTsiginv=siginvTFTsiginv(ispin), & - ! m_ST=ST(ispin), & - ! para_env=almo_scf_env%para_env, & - ! blacs_env=almo_scf_env%blacs_env, & - ! nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), & - ! domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), & - ! domain_r_down=domain_r_down(:, ispin), & - ! cpu_of_domain=almo_scf_env%cpu_of_domain, & - ! domain_map=almo_scf_env%domain_map(ispin), & - ! assume_t0_q0x=.FALSE., & - ! penalty_occ_vol=penalty_occ_vol, & - ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), & - ! eps_filter=almo_scf_env%eps_filter, & - ! neg_thr=1.0E10_dp, & - ! spin_factor=spin_factor, & - ! skip_inversion=.FALSE., & - ! special_case=my_special_case) - !ENDDO ! ispin - CASE DEFAULT CPABORT("Unknown preconditioner") @@ -9898,8 +8339,9 @@ CONTAINS ) IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step size to border: ", step_size IF (step_size > 1.0_dp .OR. step_size < 0.0_dp) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Step size (", step_size, ") must lie inside (0,1)" + END IF CPABORT("Wrong dog leg step. We should never end up here.") END IF @@ -9966,8 +8408,6 @@ CONTAINS ! Model grad norm DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(m_model_r(ispin)) - !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & - ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin model_grad_norm = MAXVAL(grad_norm_spin) @@ -10081,7 +8521,6 @@ CONTAINS END DO ! ispin ! compute the energy - !IF (.NOT. same_position) THEN CALL main_var_to_xalmos_and_loss_func( & almo_scf_env=almo_scf_env, & qs_env=qs_env, & @@ -10104,7 +8543,6 @@ CONTAINS do_penalty=penalty_occ_vol, & special_case=my_special_case) loss_trial = energy_trial + penalty_trial - !ENDIF ! not same_position rho = (loss_trial - loss_start)/expected_reduction loss_change_to_report = loss_trial - loss_start diff --git a/src/almo_scf_qs.F b/src/almo_scf_qs.F index 99b41e1c95..82bf191e1c 100644 --- a/src/almo_scf_qs.F +++ b/src/almo_scf_qs.F @@ -288,63 +288,6 @@ CONTAINS CALL dbcsr_work_create(matrix_new, work_mutable=.TRUE.) CALL dbcsr_get_info(matrix_new, nblkrows_total=nblkrows_tot, & row_blk_size=row_blk_size, col_blk_size=col_blk_size) - ! startQQQ - this part of the code scales quadratically - ! therefore it is replaced with a less general but linear scaling algorithm below - ! the quadratic algorithm is kept to be re-written later - !QQQCALL dbcsr_get_info(matrix_new, nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot) - !QQQDO row = 1, nblkrows_tot - !QQQ DO col = 1, nblkcols_tot - !QQQ tr = .FALSE. - !QQQ iblock_row = row - !QQQ iblock_col = col - !QQQ CALL dbcsr_get_stored_coordinates(matrix_new, iblock_row, iblock_col, tr, hold) - - !QQQ IF(hold==mynode) THEN - !QQQ - !QQQ ! RZK-warning replace with a function which says if this - !QQQ ! distribution block is active or not - !QQQ ! Translate indeces of distribution blocks to domain blocks - !QQQ if (size_keys(1)==almo_mat_dim_aobasis) then - !QQQ domain_row=almo_scf_env%domain_index_of_ao_block(iblock_row) - !QQQ else if (size_keys(2)==almo_mat_dim_occ .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_disc .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_full) then - !QQQ domain_row=almo_scf_env%domain_index_of_mo_block(iblock_row) - !QQQ else - !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") - !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !QQQ endif - - !QQQ if (size_keys(2)==almo_mat_dim_aobasis) then - !QQQ domain_col=almo_scf_env%domain_index_of_ao_block(iblock_col) - !QQQ else if (size_keys(2)==almo_mat_dim_occ .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_disc .OR. & - !QQQ size_keys(2)==almo_mat_dim_virt_full) then - !QQQ domain_col=almo_scf_env%domain_index_of_mo_block(iblock_col) - !QQQ else - !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") - !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) - !QQQ endif - - !QQQ ! Finds if we need this block - !QQQ ! only the block-diagonal constraint is implemented here - !QQQ active=.false. - !QQQ if (domain_row==domain_col) active=.true. - - !QQQ IF (active) THEN - !QQQ ALLOCATE (new_block(row_blk_size(iblock_row), col_blk_size(iblock_col))) - !QQQ new_block(:, :) = 1.0_dp - !QQQ CALL dbcsr_put_block(matrix_new, iblock_row, iblock_col, new_block) - !QQQ DEALLOCATE (new_block) - !QQQ ENDIF - - !QQQ ENDIF ! mynode - !QQQ ENDDO - !QQQENDDO - !QQQtake care of zero-electron fragments - ! endQQQ - end of the quadratic part ! start linear-scaling replacement: ! works only for molecular blocks AND molecular distributions DO row = 1, nblkrows_tot @@ -611,7 +554,7 @@ CONTAINS n_el_f=REAL(almo_scf_env%nelectrons_total, dp), & maxocc=2.0_dp, & flexible_electron_count=dft_control%relax_multiplicity) - ELSEIF (almo_scf_env%nspins == 2) THEN + ELSE IF (almo_scf_env%nspins == 2) THEN CALL allocate_mo_set(mo_set=mos(ispin), & nao=nrow_fm, & nmo=ncol_fm, & @@ -1496,23 +1439,6 @@ CONTAINS DEALLOCATE (last_atom_of_molecule) END IF - !mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(& - ! dbcsr_distribution(almo_scf_env%quench_t(ispin)))) - !CALL dbcsr_get_info(almo_scf_env%quench_t(ispin), distribution=dist, & - ! nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot) - !DO row = 1, nblkrows_tot - ! DO col = 1, nblkcols_tot - ! tr = .FALSE. - ! iblock_row = row - ! iblock_col = col - ! CALL dbcsr_get_stored_coordinates(almo_scf_env%quench_t(ispin),& - ! iblock_row, iblock_col, tr, hold) - ! CALL dbcsr_get_block_p(almo_scf_env%quench_t(ispin),& - ! row, col, p_old_block, found) - ! write(*,*) "RST_NOTE:", mynode, row, col, hold, found - ! ENDDO - !ENDDO - CALL timestop(handle) END SUBROUTINE almo_scf_construct_quencher diff --git a/src/almo_scf_types.F b/src/almo_scf_types.F index d4c9030aa1..a75d2577d9 100644 --- a/src/almo_scf_types.F +++ b/src/almo_scf_types.F @@ -569,8 +569,9 @@ CONTAINS DO istore = 1, MIN(almo_scf_env%almo_history%istore, almo_scf_env%almo_history%nstore) CALL dbcsr_release(almo_scf_env%almo_history%matrix_p_up_down(ispin, istore)) END DO - IF (almo_scf_env%almo_history%istore > 0) & + IF (almo_scf_env%almo_history%istore > 0) THEN CALL dbcsr_release(almo_scf_env%almo_history%matrix_t(ispin)) + END IF END DO DEALLOCATE (almo_scf_env%almo_history%matrix_p_up_down) DEALLOCATE (almo_scf_env%almo_history%matrix_t) @@ -580,8 +581,9 @@ CONTAINS CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_p_up_down(ispin, istore)) !CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_x(ispin, istore)) END DO - IF (almo_scf_env%xalmo_history%istore > 0) & + IF (almo_scf_env%xalmo_history%istore > 0) THEN CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_t(ispin)) + END IF END DO DEALLOCATE (almo_scf_env%xalmo_history%matrix_p_up_down) !DEALLOCATE (almo_scf_env%xalmo_history%matrix_x) diff --git a/src/aobasis/ai_contraction.F b/src/aobasis/ai_contraction.F index 57bacd8e99..02d87a97e3 100644 --- a/src/aobasis/ai_contraction.F +++ b/src/aobasis/ai_contraction.F @@ -439,7 +439,7 @@ CONTAINS ELSE qab(ia:ja, ib:jb) = qab(ia:ja, ib:jb) + sab(1:na, 1:nb) END IF - ELSEIF (dir == "OUT" .OR. dir == "out") THEN + ELSE IF (dir == "OUT" .OR. dir == "out") THEN ! SAB <= QAB(block) ja = ia + na - 1 jb = ib + nb - 1 diff --git a/src/aobasis/ai_eri_debug.F b/src/aobasis/ai_eri_debug.F index 4838e75ed3..ea40188793 100644 --- a/src/aobasis/ai_eri_debug.F +++ b/src/aobasis/ai_eri_debug.F @@ -128,16 +128,16 @@ CONTAINS IF (dn(1) > 0) THEN IABCD = os(an, bn, cn + i1, dn - i1) - (D(1) - C(1))*os(an, bn, cn, dn - i1) - ELSEIF (dn(2) > 0) THEN + ELSE IF (dn(2) > 0) THEN IABCD = os(an, bn, cn + i2, dn - i2) - (D(2) - C(2))*os(an, bn, cn, dn - i2) - ELSEIF (dn(3) > 0) THEN + ELSE IF (dn(3) > 0) THEN IABCD = os(an, bn, cn + i3, dn - i3) - (D(3) - C(3))*os(an, bn, cn, dn - i3) ELSE IF (bn(1) > 0) THEN IABCD = os(an + i1, bn - i1, cn, dn) - (B(1) - A(1))*os(an, bn - i1, cn, dn) - ELSEIF (bn(2) > 0) THEN + ELSE IF (bn(2) > 0) THEN IABCD = os(an + i2, bn - i2, cn, dn) - (B(2) - A(2))*os(an, bn - i2, cn, dn) - ELSEIF (bn(3) > 0) THEN + ELSE IF (bn(3) > 0) THEN IABCD = os(an + i3, bn - i3, cn, dn) - (B(3) - A(3))*os(an, bn - i3, cn, dn) ELSE IF (cn(1) > 0) THEN @@ -145,12 +145,12 @@ CONTAINS 0.5_dp*an(1)/eta*os(an - i1, bn, cn - i1, dn) + & 0.5_dp*(cn(1) - 1)/eta*os(an, bn, cn - i1 - i1, dn) - & xsi/eta*os(an + i1, bn, cn - i1, dn) - ELSEIF (cn(2) > 0) THEN + ELSE IF (cn(2) > 0) THEN IABCD = ((Q(2) - C(2)) + xsi/eta*(P(2) - A(2)))*os(an, bn, cn - i2, dn) + & 0.5_dp*an(2)/eta*os(an - i2, bn, cn - i2, dn) + & 0.5_dp*(cn(2) - 1)/eta*os(an, bn, cn - i2 - i2, dn) - & xsi/eta*os(an + i2, bn, cn - i2, dn) - ELSEIF (cn(3) > 0) THEN + ELSE IF (cn(3) > 0) THEN IABCD = ((Q(3) - C(3)) + xsi/eta*(P(3) - A(3)))*os(an, bn, cn - i3, dn) + & 0.5_dp*an(3)/eta*os(an - i3, bn, cn - i3, dn) + & 0.5_dp*(cn(3) - 1)/eta*os(an, bn, cn - i3 - i3, dn) - & @@ -161,12 +161,12 @@ CONTAINS (W(1) - P(1))*os(an - i1, bn, cn, dn, m + 1) + & 0.5_dp*(an(1) - 1)/xsi*os(an - i1 - i1, bn, cn, dn, m) - & 0.5_dp*(an(1) - 1)/xsi*rho/xsi*os(an - i1 - i1, bn, cn, dn, m + 1) - ELSEIF (an(2) > 0) THEN + ELSE IF (an(2) > 0) THEN IABCD = (P(2) - A(2))*os(an - i2, bn, cn, dn, m) + & (W(2) - P(2))*os(an - i2, bn, cn, dn, m + 1) + & 0.5_dp*(an(2) - 1)/xsi*os(an - i2 - i2, bn, cn, dn, m) - & 0.5_dp*(an(2) - 1)/xsi*rho/xsi*os(an - i2 - i2, bn, cn, dn, m + 1) - ELSEIF (an(3) > 0) THEN + ELSE IF (an(3) > 0) THEN IABCD = (P(3) - A(3))*os(an - i3, bn, cn, dn, m) + & (W(3) - P(3))*os(an - i3, bn, cn, dn, m + 1) + & 0.5_dp*(an(3) - 1)/xsi*os(an - i3 - i3, bn, cn, dn, m) - & diff --git a/src/aobasis/ai_os_rr.F b/src/aobasis/ai_os_rr.F index f5682c7b4c..f515ef089e 100644 --- a/src/aobasis/ai_os_rr.F +++ b/src/aobasis/ai_os_rr.F @@ -162,7 +162,7 @@ CONTAINS rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(az - 1, dp)*(rr(m, coa2z, 1) - rr(m + 1, coa2z, 1)) END DO END IF - ELSEIF (ay > 0) THEN + ELSE IF (ay > 0) THEN DO m = 0, mmax - la rr(m, coa, 1) = rap(2)*rr(m, coa1y, 1) - rcp(2)*rr(m + 1, coa1y, 1) END DO @@ -171,7 +171,7 @@ CONTAINS rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(ay - 1, dp)*(rr(m, coa2y, 1) - rr(m + 1, coa2y, 1)) END DO END IF - ELSEIF (ax > 0) THEN + ELSE IF (ax > 0) THEN DO m = 0, mmax - la rr(m, coa, 1) = rap(1)*rr(m, coa1x, 1) - rcp(1)*rr(m + 1, coa1x, 1) END DO @@ -225,7 +225,7 @@ CONTAINS rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(az, dp)*(rr(m, coa1z, cob1z) - rr(m + 1, coa1z, cob1z)) END DO END IF - ELSEIF (by > 0) THEN + ELSE IF (by > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(2)*rr(m, coa, cob1y) - rcp(2)*rr(m + 1, coa, cob1y) END DO @@ -239,7 +239,7 @@ CONTAINS rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(ay, dp)*(rr(m, coa1y, cob1y) - rr(m + 1, coa1y, cob1y)) END DO END IF - ELSEIF (bx > 0) THEN + ELSE IF (bx > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(1)*rr(m, coa, cob1x) - rcp(1)*rr(m + 1, coa, cob1x) END DO diff --git a/src/aobasis/ai_overlap.F b/src/aobasis/ai_overlap.F index 29b7a50a38..a3fe82c3e1 100644 --- a/src/aobasis/ai_overlap.F +++ b/src/aobasis/ai_overlap.F @@ -2050,12 +2050,12 @@ CONTAINS DO l = 0, la IF (l == 0) THEN fun(:, l) = z_one - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN fun(:, l) = CMPLX(0.0_dp, 0.5_dp*oa*gval(:), KIND=dp) - ELSEIF (l == 2) THEN + ELSE IF (l == 2) THEN fun(:, l) = CMPLX(-(0.5_dp*oa*gval(:))**2, 0.0_dp, KIND=dp) fun(:, l) = fun(:, l) + CMPLX(0.5_dp*oa, 0.0_dp, KIND=dp) - ELSEIF (l == 3) THEN + ELSE IF (l == 3) THEN fun(:, l) = CMPLX(0.0_dp, -(0.5_dp*oa*gval(:))**3, KIND=dp) fun(:, l) = fun(:, l) + CMPLX(0.0_dp, 0.75_dp*oa*oa*gval(:), KIND=dp) ELSE @@ -2065,12 +2065,12 @@ CONTAINS DO l = 0, lb IF (l == 0) THEN gun(:, l) = z_one - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN gun(:, l) = CMPLX(0.0_dp, 0.5_dp*ob*gval(:), KIND=dp) - ELSEIF (l == 2) THEN + ELSE IF (l == 2) THEN gun(:, l) = CMPLX(-(0.5_dp*ob*gval(:))**2, 0.0_dp, KIND=dp) gun(:, l) = gun(:, l) + CMPLX(0.5_dp*ob, 0.0_dp, KIND=dp) - ELSEIF (l == 3) THEN + ELSE IF (l == 3) THEN gun(:, l) = CMPLX(0.0_dp, -(0.5_dp*ob*gval(:))**3, KIND=dp) gun(:, l) = gun(:, l) + CMPLX(0.0_dp, 0.75_dp*ob*ob*gval(:), KIND=dp) ELSE diff --git a/src/aobasis/ai_overlap3_debug.F b/src/aobasis/ai_overlap3_debug.F index 2be04a16d7..76c062b1e8 100644 --- a/src/aobasis/ai_overlap3_debug.F +++ b/src/aobasis/ai_overlap3_debug.F @@ -99,25 +99,25 @@ CONTAINS IF (bn(1) > 0) THEN IACB = os_overlap3(an, cn + i1, bn - i1) + (C(1) - B(1))*os_overlap3(an, cn, bn - i1) - ELSEIF (bn(2) > 0) THEN + ELSE IF (bn(2) > 0) THEN IACB = os_overlap3(an, cn + i2, bn - i2) + (C(2) - B(2))*os_overlap3(an, cn, bn - i2) - ELSEIF (bn(3) > 0) THEN + ELSE IF (bn(3) > 0) THEN IACB = os_overlap3(an, cn + i3, bn - i3) + (C(3) - B(3))*os_overlap3(an, cn, bn - i3) ELSE IF (cn(1) > 0) THEN IACB = os_overlap3(an + i1, cn - i1, bn) + (A(1) - C(1))*os_overlap3(an, cn - i1, bn) - ELSEIF (cn(2) > 0) THEN + ELSE IF (cn(2) > 0) THEN IACB = os_overlap3(an + i2, cn - i2, bn) + (A(2) - C(2))*os_overlap3(an, cn - i2, bn) - ELSEIF (cn(3) > 0) THEN + ELSE IF (cn(3) > 0) THEN IACB = os_overlap3(an + i3, cn - i3, bn) + (A(3) - C(3))*os_overlap3(an, cn - i3, bn) ELSE IF (an(1) > 0) THEN IACB = (G(1) - A(1))*os_overlap3(an - i1, cn, bn) + & 0.5_dp*(an(1) - 1)/(xsi + xc)*os_overlap3(an - i1 - i1, cn, bn) - ELSEIF (an(2) > 0) THEN + ELSE IF (an(2) > 0) THEN IACB = (G(2) - A(2))*os_overlap3(an - i2, cn, bn) + & 0.5_dp*(an(2) - 1)/(xsi + xc)*os_overlap3(an - i2 - i2, cn, bn) - ELSEIF (an(3) > 0) THEN + ELSE IF (an(3) > 0) THEN IACB = (G(3) - A(3))*os_overlap3(an - i3, cn, bn) + & 0.5_dp*(an(3) - 1)/(xsi + xc)*os_overlap3(an - i3 - i3, cn, bn) ELSE diff --git a/src/aobasis/ai_overlap_debug.F b/src/aobasis/ai_overlap_debug.F index e25ec161b7..63bc5f7edc 100644 --- a/src/aobasis/ai_overlap_debug.F +++ b/src/aobasis/ai_overlap_debug.F @@ -87,18 +87,18 @@ CONTAINS IF (bn(1) > 0) THEN IAB = os_overlap2(an + i1, bn - i1) + (A(1) - B(1))*os_overlap2(an, bn - i1) - ELSEIF (bn(2) > 0) THEN + ELSE IF (bn(2) > 0) THEN IAB = os_overlap2(an + i2, bn - i2) + (A(2) - B(2))*os_overlap2(an, bn - i2) - ELSEIF (bn(3) > 0) THEN + ELSE IF (bn(3) > 0) THEN IAB = os_overlap2(an + i3, bn - i3) + (A(3) - B(3))*os_overlap2(an, bn - i3) ELSE IF (an(1) > 0) THEN IAB = (P(1) - A(1))*os_overlap2(an - i1, bn) + & 0.5_dp*(an(1) - 1)/xsi*os_overlap2(an - i1 - i1, bn) - ELSEIF (an(2) > 0) THEN + ELSE IF (an(2) > 0) THEN IAB = (P(2) - A(2))*os_overlap2(an - i2, bn) + & 0.5_dp*(an(2) - 1)/xsi*os_overlap2(an - i2 - i2, bn) - ELSEIF (an(3) > 0) THEN + ELSE IF (an(3) > 0) THEN IAB = (P(3) - A(3))*os_overlap2(an - i3, bn) + & 0.5_dp*(an(3) - 1)/xsi*os_overlap2(an - i3 - i3, bn) ELSE diff --git a/src/aobasis/basis_set_types.F b/src/aobasis/basis_set_types.F index 3b2b3555fa..6f25224995 100644 --- a/src/aobasis/basis_set_types.F +++ b/src/aobasis/basis_set_types.F @@ -1680,8 +1680,9 @@ CONTAINS l(nshell(iset) - ishell + i, iset) = lshell END DO END DO - IF (LEN_TRIM(line_att) /= 0) & + IF (LEN_TRIM(line_att) /= 0) THEN CPABORT("Error reading the Basis from input file!") + END IF DO ipgf = 1, npgf(iset) is_ok = cp_sll_val_next(list, val) IF (.NOT. is_ok) CPABORT("Error reading the Basis set from input file!") @@ -2503,8 +2504,9 @@ CONTAINS ng = gto_basis_set%npgf(1) DO iset = 1, nset - IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) & + IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) THEN CPABORT("different number of primitves") + END IF END DO IF (do_ortho) THEN @@ -2682,7 +2684,7 @@ CONTAINS s00 = ai*aj*(pi*ab)**1.50_dp IF (l == 0) THEN sss = s00 - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN sss = s00*ab*0.5_dp ELSE CPABORT("aovlp lvalue") diff --git a/src/arnoldi/arnoldi_data_methods.F b/src/arnoldi/arnoldi_data_methods.F index 05acfa5bdb..d88400ae01 100644 --- a/src/arnoldi/arnoldi_data_methods.F +++ b/src/arnoldi/arnoldi_data_methods.F @@ -138,13 +138,15 @@ CONTAINS CALL control%mp_group%set_handle(group_handle) CALL control%pcol_group%set_handle(pcol_handle) - IF (.NOT. subgroups_defined) & + IF (.NOT. subgroups_defined) THEN CPABORT("arnoldi only with subgroups") + END IF control%symmetric = .FALSE. ! Will need a fix for complex because there it has to be hermitian - IF (SIZE(matrix) == 1) & + IF (SIZE(matrix) == 1) THEN control%symmetric = dbcsr_get_matrix_type(matrix(1)%matrix) == dbcsr_type_symmetric + END IF ! Set the control parameters control%max_iter = max_iter @@ -158,23 +160,28 @@ CONTAINS control%nrestart = nrestarts control%generalized_ev = generalized_ev - IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) & + IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) THEN CALL cp_abort(__LOCATION__, 'with more than one eigenvalue requested '// & 'internal restarting with a previous EVEC is a bad idea, set IRAM or nrestsart=0') + END IF ! some checks for the generalized EV mode - IF (control%generalized_ev .AND. selection_crit == 1) & + IF (control%generalized_ev .AND. selection_crit == 1) THEN CALL cp_abort(__LOCATION__, & 'generalized ev can only highest OR lowest EV') - IF (control%generalized_ev .AND. nval_request /= 1) & + END IF + IF (control%generalized_ev .AND. nval_request /= 1) THEN CALL cp_abort(__LOCATION__, & 'generalized ev can only compute one EV at the time') - IF (control%generalized_ev .AND. control%nrestart == 0) & + END IF + IF (control%generalized_ev .AND. control%nrestart == 0) THEN CALL cp_abort(__LOCATION__, & 'outer loops are mandatory for generalized EV, set nrestart appropriatly') - IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) & + END IF + IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) THEN CALL cp_abort(__LOCATION__, & 'generalized ev needs exactly two matrices as input (2nd is the metric)') + END IF ALLOCATE (control%selected_ind(max_iter)) CALL set_control(arnoldi_env, control) @@ -386,8 +393,9 @@ CONTAINS INTEGER :: ev_ind INTEGER, DIMENSION(:), POINTER :: selected_ind - IF (ind > get_nval_out(arnoldi_env)) & + IF (ind > get_nval_out(arnoldi_env)) THEN CPABORT('outside range of indexed evals') + END IF selected_ind => get_sel_ind(arnoldi_env) ev_ind = selected_ind(ind) @@ -411,8 +419,9 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: selected_ind NULLIFY (evals) - IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) & + IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) THEN CPABORT('array for eval output too small') + END IF selected_ind => get_sel_ind(arnoldi_env) evals => get_evals(arnoldi_env) diff --git a/src/arnoldi/arnoldi_geev.F b/src/arnoldi/arnoldi_geev.F index 5c014fca00..88390f9e2b 100644 --- a/src/arnoldi/arnoldi_geev.F +++ b/src/arnoldi/arnoldi_geev.F @@ -144,7 +144,7 @@ CONTAINS i = 1 DO WHILE (i <= ndim) IF (ABS(eval2(i)) < EPSILON(REAL(0.0, dp))) THEN - evec_r(:, i) = evec_r(:, i)/SQRT(DOT_PRODUCT(evec_r(:, i), evec_r(:, i))) + evec_r(:, i) = evec_r(:, i)/NORM2(evec_r(:, i)) revec(:, i) = CMPLX(evec_r(:, i), REAL(0.0, dp), dp) levec(:, i) = CMPLX(evec_l(:, i), REAL(0.0, dp), dp) i = i + 1 diff --git a/src/arnoldi/arnoldi_methods.F b/src/arnoldi/arnoldi_methods.F index 3ac3ef9ef7..2790c5d1b8 100644 --- a/src/arnoldi/arnoldi_methods.F +++ b/src/arnoldi/arnoldi_methods.F @@ -561,7 +561,7 @@ CONTAINS ar_data%local_history = Zmat ! broadcast the Hessenberg matrix so we don't need to care later on - DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat); + DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat) DEALLOCATE (Zmat); DEALLOCATE (BZmat) CALL timestop(handle) diff --git a/src/atom_electronic_structure.F b/src/atom_electronic_structure.F index c180ff67a2..d490a9d9f6 100644 --- a/src/atom_electronic_structure.F +++ b/src/atom_electronic_structure.F @@ -343,10 +343,10 @@ CONTAINS xcmat%op = 0._dp CALL calculate_atom_vxc_lda(xcmat, atom, xc_section) ! ZMP added options for the zmp calculations, building external density and vxc potential - ELSEIF (need_zmp) THEN + ELSE IF (need_zmp) THEN xcmat%op = 0._dp CALL calculate_atom_zmp(ext_density=ext_density, atom=atom, lprint=.FALSE., xcmat=xcmat) - ELSEIF (need_vxc) THEN + ELSE IF (need_vxc) THEN xcmat%op = 0._dp CALL calculate_atom_ext_vxc(vxc=ext_vxc, atom=atom, lprint=.FALSE., xcmat=xcmat) ELSE @@ -503,10 +503,10 @@ CONTAINS ne = atom%state%occupation(l, k) IF (ne == 0._dp) THEN !empty shell EXIT !assume there are no holes - ELSEIF (ne == 2._dp*nm) THEN !closed shell + ELSE IF (ne == 2._dp*nm) THEN !closed shell atom%state%occa(l, k) = nm atom%state%occb(l, k) = nm - ELSEIF (atom%state%multiplicity == -2) THEN !High spin case + ELSE IF (atom%state%multiplicity == -2) THEN !High spin case atom%state%occa(l, k) = MIN(ne, nm) atom%state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_energy.F b/src/atom_energy.F index 7d2a7b853d..c14bece975 100644 --- a/src/atom_energy.F +++ b/src/atom_energy.F @@ -1103,11 +1103,11 @@ CONTAINS IF (PRESENT(counter)) THEN WRITE (str, "(I12)") counter - ELSEIF (PRESENT(rval)) THEN + ELSE IF (PRESENT(rval)) THEN WRITE (str, "(G18.8)") rval - ELSEIF (PRESENT(ival)) THEN + ELSE IF (PRESENT(ival)) THEN WRITE (str, "(I12)") ival - ELSEIF (PRESENT(cval)) THEN + ELSE IF (PRESENT(cval)) THEN WRITE (str, "(A)") TRIM(ADJUSTL(cval)) ELSE WRITE (str, "(A)") "" diff --git a/src/atom_fit.F b/src/atom_fit.F index b80ba7e82d..0f9bf3b62a 100644 --- a/src/atom_fit.F +++ b/src/atom_fit.F @@ -657,7 +657,7 @@ CONTAINS ntarget = ntarget + 1 wtot = wtot + atom%weight*w_virt/100._dp END IF - ELSEIF (k < atom%state%maxn_occ(l)) THEN + ELSE IF (k < atom%state%maxn_occ(l)) THEN atom%orbitals%wrefene(k, l, 1) = w_semi atom%orbitals%wrefchg(k, l, 1) = w_semi/100._dp atom%orbitals%crefene(k, l, 1) = t_semi @@ -735,7 +735,7 @@ CONTAINS wtot = wtot + atom%weight*2._dp*w_virt/100._dp ntarget = ntarget + 2 END IF - ELSEIF (k < atom%state%maxn_occ(l)) THEN + ELSE IF (k < atom%state%maxn_occ(l)) THEN atom%orbitals%wrefene(k, l, 1:2) = w_semi atom%orbitals%wrefchg(k, l, 1:2) = w_semi/100._dp atom%orbitals%crefene(k, l, 1:2) = t_semi diff --git a/src/atom_grb.F b/src/atom_grb.F index 2575d79300..e23bccc669 100644 --- a/src/atom_grb.F +++ b/src/atom_grb.F @@ -152,8 +152,9 @@ CONTAINS CALL allocate_grid_atom(basis%grid) CALL section_vals_val_get(grb_section, "QUADRATURE", i_val=quadtype) CALL section_vals_val_get(grb_section, "GRID_POINTS", i_val=ngp) - IF (ngp <= 0) & + IF (ngp <= 0) THEN CPABORT("# point radial grid < 0") + END IF CALL create_grid_atom(basis%grid, ngp, 1, 1, 0, quadtype) basis%grid%nr = ngp ! diff --git a/src/atom_kind_orbitals.F b/src/atom_kind_orbitals.F index 25c3265e68..30ceb56c06 100644 --- a/src/atom_kind_orbitals.F +++ b/src/atom_kind_orbitals.F @@ -273,7 +273,7 @@ CONTAINS ! total number of occupied orbitals IF (PRESENT(nocc) .AND. ghost) THEN nocc = 0 - ELSEIF (PRESENT(nocc)) THEN + ELSE IF (PRESENT(nocc)) THEN nocc = 0 DO l = 0, lmat DO k = 1, 7 diff --git a/src/atom_operators.F b/src/atom_operators.F index 3a0e95ab1d..6f1e65e81f 100644 --- a/src/atom_operators.F +++ b/src/atom_operators.F @@ -120,14 +120,14 @@ CONTAINS rc = potential%rcon sc = potential%scon cpot(1:m) = (basis%grid%rad(1:m)/rc)**sc - ELSEIF (potential%conf_type == barrier_conf) THEN + ELSE IF (potential%conf_type == barrier_conf) THEN om = potential%rcon ron = potential%scon rc = ron + om DO i = 1, m IF (basis%grid%rad(i) < ron) THEN cpot(i) = 0.0_dp - ELSEIF (basis%grid%rad(i) < rc) THEN + ELSE IF (basis%grid%rad(i) < rc) THEN x = (basis%grid%rad(i) - ron)/om x = 1._dp - x cpot(i) = -6._dp*x**5 + 15._dp*x**4 - 10._dp*x**3 + 1._dp diff --git a/src/atom_optimization.F b/src/atom_optimization.F index d2ffa6a3fc..8d4986d7a8 100644 --- a/src/atom_optimization.F +++ b/src/atom_optimization.F @@ -221,7 +221,7 @@ CONTAINS IF (nm < 1) nm = history%max_history fmat = a*history%hmat(nnow)%fmat + (1._dp - a)*history%hmat(nm)%fmat END IF - ELSEIF (history%hlen == 1) THEN + ELSE IF (history%hlen == 1) THEN fmat = history%hmat(nnow)%fmat ELSE CPABORT("Length of matrix history hlen < 1") diff --git a/src/atom_output.F b/src/atom_output.F index 59d577c206..8562be639a 100644 --- a/src/atom_output.F +++ b/src/atom_output.F @@ -192,16 +192,19 @@ CONTAINS WRITE (iw, '(T36,A,T61,F20.12)') " Virial (-V/T) ::", -atom%energy%epot/atom%energy%ekin END IF WRITE (iw, '(T36,A,T61,F20.12)') " Core Energy ::", atom%energy%ecore - IF (atom%energy%exc /= 0._dp) & + IF (atom%energy%exc /= 0._dp) THEN WRITE (iw, '(T36,A,T61,F20.12)') " XC Energy ::", atom%energy%exc + END IF WRITE (iw, '(T36,A,T61,F20.12)') " Coulomb Energy ::", atom%energy%ecoulomb - IF (atom%energy%eexchange /= 0._dp) & + IF (atom%energy%eexchange /= 0._dp) THEN WRITE (iw, '(T34,A,T61,F20.12)') "HF Exchange Energy ::", atom%energy%eexchange + END IF IF (atom%potential%ppot_type /= NO_PSEUDO) THEN WRITE (iw, '(T20,A,T61,F20.12)') " Total Pseudopotential Energy ::", atom%energy%epseudo WRITE (iw, '(T20,A,T61,F20.12)') " Local Pseudopotential Energy ::", atom%energy%eploc - IF (atom%energy%elsd /= 0._dp) & + IF (atom%energy%elsd /= 0._dp) THEN WRITE (iw, '(T20,A,T61,F20.12)') " Local Spin-potential Energy ::", atom%energy%elsd + END IF WRITE (iw, '(T20,A,T61,F20.12)') " Nonlocal Pseudopotential Energy ::", atom%energy%epnl END IF IF (atom%potential%confinement) THEN diff --git a/src/atom_pseudo.F b/src/atom_pseudo.F index 7064b7a535..c77de88e67 100644 --- a/src/atom_pseudo.F +++ b/src/atom_pseudo.F @@ -257,10 +257,10 @@ CONTAINS ne = state%occupation(l, k) IF (ne == 0._dp) THEN !empty shell EXIT !assume there are no holes - ELSEIF (ne == 2._dp*nm) THEN !closed shell + ELSE IF (ne == 2._dp*nm) THEN !closed shell state%occa(l, k) = nm state%occb(l, k) = nm - ELSEIF (state%multiplicity == -2) THEN !High spin case + ELSE IF (state%multiplicity == -2) THEN !High spin case state%occa(l, k) = MIN(ne, nm) state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_set_basis.F b/src/atom_set_basis.F index 767bc5a76e..f66006b6d4 100644 --- a/src/atom_set_basis.F +++ b/src/atom_set_basis.F @@ -204,7 +204,7 @@ CONTAINS basis%ddbf(k, i, l) = (REAL(l*(l - 1), dp)*rk**(l - 2) - & 2._dp*al*REAL(2*l + 1, dp)*rk**(l) + 4._dp*al*rk**(l + 2))*ear END DO - ELSEIF (basis%basis_type == CGTO_BASIS) THEN + ELSE IF (basis%basis_type == CGTO_BASIS) THEN DO k = 1, nr rk = basis%grid%rad(k) ear = EXP(-al*basis%grid%rad(k)**2) diff --git a/src/atom_sgp.F b/src/atom_sgp.F index 178e7e93bd..2289ec8964 100644 --- a/src/atom_sgp.F +++ b/src/atom_sgp.F @@ -122,7 +122,7 @@ CONTAINS ! generate the transformed potentials IF (is_ecp) THEN CALL ecp_sgp_constr(ecp_pot, sgp_pot, basis) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upf_sgp_constr(upf_pot, sgp_pot, basis) ELSE CPABORT("Either ecp_pot or upf_pot is needed for sgp_construction") @@ -137,7 +137,7 @@ CONTAINS ! IF (is_ecp) THEN CALL ecpints(hnl%op, basis, ecp_pot) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upfints(core%op, hnl%op, basis, upf_pot, cutpotu, sgp_pot%ac_local) ELSE CPABORT("Either ecp_pot or upf_pot is needed for sgp_construction") @@ -246,7 +246,7 @@ CONTAINS IF (do_transform) THEN IF (is_ecp) THEN CALL ecp_sgp_constr(ecp_pot, sgp_pot, atom_ref%basis) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upf_sgp_constr(upf_pot, sgp_pot, atom_ref%basis) ELSE CPABORT("Either ecp_pseudo or upf_pseudo is needed for atom_sgp_construction") @@ -279,7 +279,7 @@ CONTAINS ! IF (is_ecp) THEN CALL ecpints(hnl%op, atom_ref%basis, ecp_pot) - ELSEIF (is_upf) THEN + ELSE IF (is_upf) THEN CALL upfints(core%op, hnl%op, atom_ref%basis, upf_pot, cutpotu, sgp_pot%ac_local) ELSE CPABORT("Either ecp_pseudo or upf_pseudo is needed for atom_sgp_construction") diff --git a/src/atom_types.F b/src/atom_types.F index 502369a13b..a1a2a54115 100644 --- a/src/atom_types.F +++ b/src/atom_types.F @@ -414,8 +414,9 @@ CONTAINS CALL allocate_grid_atom(basis%grid) CALL section_vals_val_get(basis_section, "QUADRATURE", i_val=quadtype) CALL section_vals_val_get(basis_section, "GRID_POINTS", i_val=ngp) - IF (ngp <= 0) & + IF (ngp <= 0) THEN CPABORT("The number of radial grid points must be greater than zero.") + END IF CALL create_grid_atom(basis%grid, ngp, 1, 1, 0, quadtype) basis%grid%nr = ngp basis%geometrical = .FALSE. @@ -840,8 +841,9 @@ CONTAINS CALL allocate_grid_atom(gbasis%grid) ngp = SIZE(r) quadtype = do_gapw_log - IF (ngp <= 0) & + IF (ngp <= 0) THEN CPABORT("The number of radial grid points must be greater than zero.") + END IF CALL create_grid_atom(gbasis%grid, ngp, 1, 1, 0, quadtype) gbasis%grid%nr = ngp gbasis%grid%rad(:) = r(:) diff --git a/src/atom_upf.F b/src/atom_upf.F index 3a19e15d04..8c226de646 100644 --- a/src/atom_upf.F +++ b/src/atom_upf.F @@ -218,39 +218,39 @@ CONTAINS IF (nametag(2:8) == "PP_INFO") THEN CPASSERT(nametag(9:9) == ">") CALL upf_info_section(parser, pot) - ELSEIF (nametag(2:10) == "PP_HEADER") THEN + ELSE IF (nametag(2:10) == "PP_HEADER") THEN IF (.NOT. (nametag(11:11) == ">")) THEN CALL upf_header_option(parser, pot) END IF - ELSEIF (nametag(2:8) == "PP_MESH") THEN + ELSE IF (nametag(2:8) == "PP_MESH") THEN IF (.NOT. (nametag(9:9) == ">")) THEN CALL upf_mesh_option(parser, pot) END IF CALL upf_mesh_section(parser, pot) - ELSEIF (nametag(2:8) == "PP_NLCC") THEN + ELSE IF (nametag(2:8) == "PP_NLCC") THEN IF (nametag(9:9) == ">") THEN CALL upf_nlcc_section(parser, pot, .FALSE.) ELSE CALL upf_nlcc_section(parser, pot, .TRUE.) END IF - ELSEIF (nametag(2:9) == "PP_LOCAL") THEN + ELSE IF (nametag(2:9) == "PP_LOCAL") THEN IF (nametag(10:10) == ">") THEN CALL upf_local_section(parser, pot, .FALSE.) ELSE CALL upf_local_section(parser, pot, .TRUE.) END IF - ELSEIF (nametag(2:12) == "PP_NONLOCAL") THEN + ELSE IF (nametag(2:12) == "PP_NONLOCAL") THEN CPASSERT(nametag(13:13) == ">") CALL upf_nonlocal_section(parser, pot) - ELSEIF (nametag(2:13) == "PP_SEMILOCAL") THEN + ELSE IF (nametag(2:13) == "PP_SEMILOCAL") THEN CALL upf_semilocal_section(parser, pot) - ELSEIF (nametag(2:9) == "PP_PSWFC") THEN + ELSE IF (nametag(2:9) == "PP_PSWFC") THEN ! skip section for now - ELSEIF (nametag(2:11) == "PP_RHOATOM") THEN + ELSE IF (nametag(2:11) == "PP_RHOATOM") THEN ! skip section for now - ELSEIF (nametag(2:7) == "PP_PAW") THEN + ELSE IF (nametag(2:7) == "PP_PAW") THEN ! skip section for now - ELSEIF (nametag(2:6) == "/UPF>") THEN + ELSE IF (nametag(2:6) == "/UPF>") THEN EXIT END IF END IF @@ -856,7 +856,7 @@ CONTAINS END IF IF (icount > ms) EXIT END DO - ELSEIF (string(1:15) == "") THEN + ELSE IF (string(1:15) == "") THEN EXIT ELSE ! diff --git a/src/atom_utils.F b/src/atom_utils.F index 8465ff388a..ae92b95ee4 100644 --- a/src/atom_utils.F +++ b/src/atom_utils.F @@ -2549,7 +2549,7 @@ CONTAINS ja = ibptr(ia, la) jb = ibptr(ib, lb) smat(ja:ja + nna - 1, jb:jb + nnb - 1) = smat(ja:ja + nna - 1, jb:jb + nnb - 1) + sab(1:nna, 1:nnb) - ELSEIF (basis%basis_type == CGTO_BASIS) THEN + ELSE IF (basis%basis_type == CGTO_BASIS) THEN DO ka = 1, basis%nbas(la) DO kb = 1, basis%nbas(lb) ja = ibptr(ka, la) @@ -2572,7 +2572,7 @@ CONTAINS jb = ibptr(ib, lb) smat(ja:ja + nna - 1, jb:jb + nnb - 1) = smat(ja:ja + nna - 1, jb:jb + nnb - 1) & + sab(1:nna, 1:nnb) - ELSEIF (basis%basis_type == CGTO_BASIS) THEN + ELSE IF (basis%basis_type == CGTO_BASIS) THEN DO ka = 1, basis%nbas(la) DO kb = 1, basis%nbas(lb) ja = ibptr(ka, la) diff --git a/src/atoms_input.F b/src/atoms_input.F index 4e3b87bbf4..1156efb330 100644 --- a/src/atoms_input.F +++ b/src/atoms_input.F @@ -144,8 +144,9 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN CPABORT("incorrectly formatted line in coord section'"//line_att//"'") + END IF IF (wrd == 1) THEN atom_info%id_atmname(iatom) = str2id(s2s(line_att(start_c:end_c - 1))) ELSE @@ -195,24 +196,26 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN CALL cp_abort(__LOCATION__, & "Incorrectly formatted input line for atom "// & TRIM(ADJUSTL(cp_to_string(iatom)))// & " found in COORD section. Input line: <"// & TRIM(line_att)//"> ") + END IF SELECT CASE (wrd) CASE (1) atom_info%id_atmname(iatom) = str2id(s2s(line_att(start_c:end_c - 1))) CASE (2:4) CALL read_float_object(line_att(start_c:end_c - 1), & atom_info%r(wrd - 1, iatom), error_message) - IF (LEN_TRIM(error_message) /= 0) & + IF (LEN_TRIM(error_message) /= 0) THEN CALL cp_abort(__LOCATION__, & "Incorrectly formatted input line for atom "// & TRIM(ADJUSTL(cp_to_string(iatom)))// & " found in COORD section. "//TRIM(error_message)// & " Input line: <"//TRIM(line_att)//"> ") + END IF CASE (5) READ (line_att(start_c:end_c - 1), *) strtmp atom_info%id_molname(iatom) = str2id(strtmp) @@ -343,8 +346,9 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN CPABORT("incorrectly formatted line in coord section'"//line_att//"'") + END IF IF (wrd == 1) THEN at_name(ishell) = line_att(start_c:end_c - 1) CALL uppercase(at_name(ishell)) @@ -393,8 +397,9 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN CPABORT("incorrectly formatted line in coord section'"//line_att//"'") + END IF IF (wrd == 1) THEN at_name_c(ishell) = line_att(start_c:end_c - 1) CALL uppercase(at_name_c(ishell)) diff --git a/src/auto_basis.F b/src/auto_basis.F index 94bccf5995..23546df6e7 100644 --- a/src/auto_basis.F +++ b/src/auto_basis.F @@ -61,7 +61,7 @@ CONTAINS INTEGER, INTENT(IN), OPTIONAL :: basis_sort CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname + CHARACTER(LEN=default_string_length) :: bsname, kname INTEGER :: i, j, jj, l, laux, linc, lmax, lval, lx, & nsets, nx, z INTEGER, DIMENSION(0:18) :: nval @@ -84,7 +84,7 @@ CONTAINS 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp] ! CPASSERT(.NOT. ASSOCIATED(ri_aux_basis_set)) - NULLIFY (orb_basis_set) + NULLIFY (orb_basis_set, econf) IF (.NOT. PRESENT(basis_type)) THEN CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") ELSE @@ -106,6 +106,15 @@ CONTAINS CALL init_orbital_pointers(2*lmax) CALL get_basis_products(lmax, zmin, zmax, zeff, pmin, pmax, peff) CALL get_qs_kind(qs_kind, zeff=zval, elec_conf=econf, element_symbol=element_symbol) + IF (.NOT. ASSOCIATED(econf)) THEN + CALL get_qs_kind(qs_kind, name=kname) + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS RI_AUX cannot process atom kind "// & + "<"//TRIM(ADJUSTL(kname))//"> due to missing "// & + "definition of potential or electron configuration; "// & + "consider setting keyword ELEC_CONF explicitly for "// & + "GHOST atom kind that has assigned a basis set") + END IF CALL get_ptable_info(element_symbol, ielement=z) lval = 0 DO l = 0, MAXVAL(UBOUND(econf)) @@ -236,7 +245,7 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: exact_1c_terms, tda_kernel CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname + CHARACTER(LEN=default_string_length) :: bsname, kname INTEGER :: i, j, l, laux, linc, lm, lmax, lval, n1, & n2, nsets, z INTEGER, DIMENSION(0:18) :: nval @@ -267,12 +276,21 @@ CONTAINS END IF ! CPASSERT(.NOT. ASSOCIATED(lri_aux_basis_set)) - NULLIFY (orb_basis_set) + NULLIFY (orb_basis_set, econf) CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") IF (ASSOCIATED(orb_basis_set)) THEN CALL get_basis_keyfigures(orb_basis_set, lmax, zmin, zmax, zeff) CALL get_basis_products(lmax, zmin, zmax, zeff, pmin, pmax, peff) CALL get_qs_kind(qs_kind, zeff=zval, elec_conf=econf, element_symbol=element_symbol) + IF (.NOT. ASSOCIATED(econf)) THEN + CALL get_qs_kind(qs_kind, name=kname) + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS LRI_AUX cannot process atom kind "// & + "<"//TRIM(ADJUSTL(kname))//"> due to missing "// & + "definition of potential or electron configuration; "// & + "consider setting keyword ELEC_CONF explicitly for "// & + "GHOST atom kind that has assigned a basis set") + END IF CALL get_ptable_info(element_symbol, ielement=z) lval = 0 DO l = 0, MAXVAL(UBOUND(econf)) diff --git a/src/base/base_hooks.F b/src/base/base_hooks.F index dd7931e047..d31f199528 100644 --- a/src/base/base_hooks.F +++ b/src/base/base_hooks.F @@ -145,8 +145,9 @@ CONTAINS IF (ASSOCIATED(timestop_hook)) THEN CALL timestop_hook(handle) ELSE - IF (handle /= -1) & + IF (handle /= -1) THEN CALL cp_abort(cp__l("base_hooks.F", __LINE__), "Got wrong handle") + END IF END IF END SUBROUTINE timestop diff --git a/src/base/machine.F b/src/base/machine.F index 9cadaa31a7..a2e21f7fa0 100644 --- a/src/base/machine.F +++ b/src/base/machine.F @@ -741,14 +741,17 @@ CONTAINS ! on a posix system LOGNAME should be defined CALL get_environment_variable("LOGNAME", value=user, status=istat) ! nope, check alternative - IF (istat /= 0) & + IF (istat /= 0) THEN CALL get_environment_variable("USER", value=user, status=istat) + END IF ! nope, check alternative - IF (istat /= 0) & + IF (istat /= 0) THEN CALL get_environment_variable("USERNAME", value=user, status=istat) + END IF ! fall back - IF (istat /= 0) & + IF (istat /= 0) THEN user = "" + END IF END SUBROUTINE m_getlog diff --git a/src/bse_util.F b/src/bse_util.F index d6d53fbba4..3de6d00855 100644 --- a/src/bse_util.F +++ b/src/bse_util.F @@ -1481,7 +1481,7 @@ CONTAINS cell, dft_control, particle_set, pw_env) IF (iset == 1) THEN WRITE (filename, '(A6,I3.3,A5,I2.2,a11)') "_NEXC_", istate, "_NTO_", i, "_Hole_State" - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (filename, '(A6,I3.3,A5,I2.2,a15)') "_NEXC_", istate, "_NTO_", i, "_Particle_State" END IF info_approx_trunc = TRIM(ADJUSTL(info_approximation)) @@ -1493,7 +1493,7 @@ CONTAINS log_filename=.FALSE., ignore_should_output=.TRUE., mpi_io=mpi_io) IF (iset == 1) THEN WRITE (title, *) "Natural Transition Orbital Hole State", i - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (title, *) "Natural Transition Orbital Particle State", i END IF CALL cp_pw_to_cube(wf_r, unit_nr_cube, title, particles=particles, stride=stride, mpi_io=mpi_io) diff --git a/src/bsse.F b/src/bsse.F index 3abfc8c654..6869888a3d 100644 --- a/src/bsse.F +++ b/src/bsse.F @@ -370,10 +370,10 @@ CONTAINS iw = cp_print_key_unit_nr(logger, bsse_section, "PRINT%PROGRAM_RUN_INFO", & extension=".log") IF (iw > 0) THEN - WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf; + WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf IF (istat /= 0) conf_s = "exceeded" CALL compress(conf_s, full=.TRUE.) - WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc; + WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc IF (istat /= 0) conf_loc_s = "exceeded" CALL compress(conf_loc_s, full=.TRUE.) @@ -429,15 +429,17 @@ CONTAINS IF (explicit) THEN DO i = 1, nconf CALL section_vals_val_get(configurations, "GLB_CONF", i_rep_section=i, i_vals=glb_conf) - IF (SIZE(glb_conf) /= SIZE(conf)) & + IF (SIZE(glb_conf) /= SIZE(conf)) THEN CALL cp_abort(__LOCATION__, & "GLB_CONF requires a binary description of the configuration. Number of integer "// & "different from the number of fragments defined!") + END IF CALL section_vals_val_get(configurations, "SUB_CONF", i_rep_section=i, i_vals=sub_conf) - IF (SIZE(sub_conf) /= SIZE(conf)) & + IF (SIZE(sub_conf) /= SIZE(conf)) THEN CALL cp_abort(__LOCATION__, & "SUB_CONF requires a binary description of the configuration. Number of integer "// & "different from the number of fragments defined!") + END IF IF (ALL(conf == glb_conf) .AND. ALL(conf_loc == sub_conf)) THEN CALL section_vals_val_get(configurations, "CHARGE", i_rep_section=i, & i_val=present_charge) diff --git a/src/cell_methods.F b/src/cell_methods.F index fc063a2c1e..1cb33a48c5 100644 --- a/src/cell_methods.F +++ b/src/cell_methods.F @@ -461,11 +461,12 @@ CONTAINS CALL section_vals_val_get(cell_section, "CELL_FILE_NAME", explicit=cell_read_file) IF (cell_read_file) THEN ! Case 1 tmp_comb_cell = (cell_read_abc .OR. (cell_read_a .OR. (cell_read_b .OR. cell_read_c))) - IF (tmp_comb_cell) & + IF (tmp_comb_cell) THEN CALL cp_warn(__LOCATION__, & "Cell Information provided through A, B, C, or ABC in conjunction "// & "with CELL_FILE_NAME. The definition in external file will override "// & "other ones.") + END IF CALL section_vals_val_get(cell_section, "CELL_FILE_NAME", c_val=cell_file_name) CALL section_vals_val_get(cell_section, "CELL_FILE_FORMAT", i_val=cell_file_format) SELECT CASE (cell_file_format) @@ -491,10 +492,11 @@ CONTAINS read_len = cell_par CALL section_vals_val_get(cell_section, "ALPHA_BETA_GAMMA", r_vals=cell_par) read_ang = cell_par - IF (cell_read_a .OR. cell_read_b .OR. cell_read_c) & + IF (cell_read_a .OR. cell_read_b .OR. cell_read_c) THEN CALL cp_warn(__LOCATION__, & "Cell information provided through vectors A, B or C in conjunction with ABC. "// & "The definition of the ABC keyword will override the one provided by A, B and C.") + END IF ELSE ! Case 3 tmp_comb_abc = ((cell_read_a .EQV. cell_read_b) .AND. (cell_read_b .EQV. cell_read_c)) IF (tmp_comb_abc) THEN @@ -504,10 +506,11 @@ CONTAINS read_mat(:, 2) = cell_par(:) CALL section_vals_val_get(cell_section, "C", r_vals=cell_par) read_mat(:, 3) = cell_par(:) - IF (cell_read_alpha_beta_gamma) & + IF (cell_read_alpha_beta_gamma) THEN CALL cp_warn(__LOCATION__, & "The keyword ALPHA_BETA_GAMMA is ignored because it was used without the "// & "keyword ABC.") + END IF ELSE CALL cp_abort(__LOCATION__, & "Neither of the keywords CELL_FILE_NAME or ABC are specified, "// & @@ -722,10 +725,11 @@ CONTAINS CPASSERT(ASSOCIATED(cell)) ! Abort, if one of the value is set to zero - IF (ANY(multiple_unit_cell <= 0)) & + IF (ANY(multiple_unit_cell <= 0)) THEN CALL cp_abort(__LOCATION__, & "CELL%MULTIPLE_UNIT_CELL accepts only integer values larger than 0! "// & "A value of 0 or negative is meaningless!") + END IF ! Scale abc according to user request cell%hmat(:, 1) = cell%hmat(:, 1)*multiple_unit_cell(1) @@ -778,8 +782,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_a", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_length_a or _cell.length_a was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_lengths(1)) cell_lengths(1) = cp_unit_to_cp2k(cell_lengths(1), "angstrom") @@ -790,8 +795,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_b", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_length_b or _cell.length_b was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_lengths(2)) cell_lengths(2) = cp_unit_to_cp2k(cell_lengths(2), "angstrom") @@ -802,8 +808,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_c", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_length_c or _cell.length_c was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_lengths(3)) cell_lengths(3) = cp_unit_to_cp2k(cell_lengths(3), "angstrom") @@ -814,8 +821,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_alpha", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_angle_alpha or _cell.angle_alpha was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_angles(1)) cell_angles(1) = cp_unit_to_cp2k(cell_angles(1), "deg") @@ -826,8 +834,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_beta", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_angle_beta or _cell.angle_beta was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_angles(2)) cell_angles(2) = cp_unit_to_cp2k(cell_angles(2), "deg") @@ -838,8 +847,9 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_gamma", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field _cell_angle_gamma or _cell.angle_gamma was not found in CIF file! ") + END IF END IF CALL cif_get_real(parser, cell_angles(3)) cell_angles(3) = cp_unit_to_cp2k(cell_angles(3), "deg") @@ -1192,8 +1202,9 @@ CONTAINS CALL parser_search_string(parser, "CRYST1", ignore_case=.FALSE., found=found, & begin_line=.TRUE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The line was not found in PDB file! ") + END IF periodic = 1 READ (parser%input_line, *, IOSTAT=ios) cryst, cell_lengths(:), cell_angles(:) diff --git a/src/colvar_methods.F b/src/colvar_methods.F index 0489fefb36..b92eebad05 100644 --- a/src/colvar_methods.F +++ b/src/colvar_methods.F @@ -618,11 +618,12 @@ CONTAINS ALLOCATE (colvar%combine_cvs_param%variables(SIZE(my_par))) colvar%combine_cvs_param%variables = my_par ! Check that the number of COLVAR provided is equal to the number of variables.. - IF (SIZE(my_par) /= ncol) & + IF (SIZE(my_par) /= ncol) THEN CALL cp_abort(__LOCATION__, & "Number of defined COLVAR for COMBINE_COLVAR is different from the "// & "number of variables! It is not possible to define COLVARs in a COMBINE_COLVAR "// & "and avoid their usage in the combininig function!") + END IF ! Parameters ALLOCATE (colvar%combine_cvs_param%c_parameters(0)) CALL section_vals_val_get(combine_section, "PARAMETERS", n_rep_val=ncol) @@ -726,8 +727,9 @@ CONTAINS ! Read the specification of the two planes plane_sections => section_vals_get_subs_vals(plane_plane_angle_section, "PLANE") CALL section_vals_get(plane_sections, n_repetition=n_var) - IF (n_var /= 2) & + IF (n_var /= 2) THEN CPABORT("PLANE_PLANE_ANGLE Colvar section: Two PLANE sections must be provided!") + END IF ! Plane 1 CALL section_vals_val_get(plane_sections, "DEF_TYPE", i_rep_section=1, & i_val=colvar%plane_plane_angle_param%plane1%type_of_def) @@ -736,8 +738,9 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane1%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) & + IF (ASSOCIATED(cell)) THEN CALL cell_transform_input_cartesian(cell, colvar%plane_plane_angle_param%plane1%normal_vec) + END IF END IF ELSE CALL section_vals_val_get(plane_sections, "ATOMS", i_rep_section=1, & @@ -753,8 +756,9 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane2%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) & + IF (ASSOCIATED(cell)) THEN CALL cell_transform_input_cartesian(cell, colvar%plane_plane_angle_param%plane2%normal_vec) + END IF END IF ELSE CALL section_vals_val_get(plane_sections, "ATOMS", i_rep_section=2, & @@ -863,9 +867,10 @@ CONTAINS weights(ndim + 1:ndim + SIZE(wei)) = wei ndim = ndim + SIZE(wei) END DO - IF (ndim /= colvar%rmsd_param%n_atoms) & + IF (ndim /= colvar%rmsd_param%n_atoms) THEN CALL cp_abort(__LOCATION__, "CV RMSD: list of atoms and list of "// & "weights need to contain same number of entries. ") + END IF DO i = 1, ndim ii = colvar%rmsd_param%i_rmsd(i) colvar%rmsd_param%weights(ii) = weights(i) @@ -947,11 +952,13 @@ CONTAINS i_val=colvar%ring_puckering_param%iq) ! test the validity of the parameters ndim = colvar%ring_puckering_param%nring - IF (ndim <= 3) & + IF (ndim <= 3) THEN CPABORT("CV Ring Puckering: Ring size has to be 4 or larger. ") + END IF ii = colvar%ring_puckering_param%iq - IF (ABS(ii) == 1 .OR. ii < -(ndim - 1)/2 .OR. ii > ndim/2) & + IF (ABS(ii) == 1 .OR. ii < -(ndim - 1)/2 .OR. ii > ndim/2) THEN CPABORT("CV Ring Puckering: Invalid coordinate number.") + END IF ELSE IF (my_subsection(23)) THEN ! Minimum Distance wrk_section => mindist_section @@ -1326,7 +1333,7 @@ CONTAINS IF (colvar%ring_puckering_param%iq == 0) THEN WRITE (iw, '( A,T40,A)') ' COLVARS| Ring Puckering >>> coordinate', & ' Total Puckering Amplitude' - ELSEIF (colvar%ring_puckering_param%iq > 0) THEN + ELSE IF (colvar%ring_puckering_param%iq > 0) THEN WRITE (iw, '( A,T35,A,T57,I8)') ' COLVARS| Ring Puckering >>> coordinate', & ' Puckering Amplitude', & colvar%ring_puckering_param%iq @@ -2189,11 +2196,12 @@ CONTAINS CALL put_derivative(colvar, iatom, fi) END DO ELSE - IF (force_env%in_use /= use_mixed_force) & + IF (force_env%in_use /= use_mixed_force) THEN CALL cp_abort(__LOCATION__, & 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)// & ' A combination of mixed force_eval energies has been requested as '// & ' collective variable, but the MIXED env is not in use! Aborting.') + END IF CALL force_env_get(force_env, force_env_section=force_env_section) mapping_section => section_vals_get_subs_vals(force_env_section, "MIXED%MAPPING") NULLIFY (values, parameters, subsystems, particles, global_forces, map_index, glob_natoms) @@ -2683,8 +2691,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! evaluation of the angle.. - a = SQRT(DOT_PRODUCT(xij, xij)) - b = SQRT(DOT_PRODUCT(xkj, xkj)) + a = NORM2(xij) + b = NORM2(xkj) t0 = 1.0_dp/(a*b) t1 = 1.0_dp/(a**3.0_dp*b) t2 = 1.0_dp/(a*b**3.0_dp) @@ -2834,8 +2842,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! Evaluation of the angle.. - a = SQRT(DOT_PRODUCT(xij, xij)) - b = SQRT(DOT_PRODUCT(xkj, xkj)) + a = NORM2(xij) + b = NORM2(xkj) t0 = 1.0_dp/(a*b) t1 = 1.0_dp/(a**3.0_dp*b) t2 = 1.0_dp/(a*b**3.0_dp) @@ -3137,10 +3145,6 @@ CONTAINS TYPE(particle_list_type), POINTER :: particles_i TYPE(particle_type), DIMENSION(:), POINTER :: my_particles - ! settings for numerical derivatives - !REAL(KIND=dp) :: ri_step, dx_bond_j, dy_bond_j, dz_bond_j - !INTEGER :: idel - n_atoms_to = colvar%qparm_param%n_atoms_to n_atoms_from = colvar%qparm_param%n_atoms_from rcut = colvar%qparm_param%rcut @@ -3159,10 +3163,6 @@ CONTAINS CPASSERT(r1cut < rcut) denominator_tolerance = 1.0E-8_dp - !ri_step=0.1 - !DO idel=-50, 50 - !ftmp(:) = 0.0_dp - qparm = 0.0_dp inv_n_atoms_from = 1.0_dp/REAL(n_atoms_from, KIND=dp) DO ii = 1, n_atoms_from @@ -3200,11 +3200,10 @@ CONTAINS shift(:) = 0.0_dp shift(idim) = 1.0_dp xij_shift = MATMUL(cell%hmat, shift) - rij_shift = SQRT(DOT_PRODUCT(xij_shift, xij_shift)) + rij_shift = NORM2(xij_shift) ncells(idim) = FLOOR(rcut/rij_shift - 0.5) END DO !idim - !IF (mm.eq.0) WRITE(*,'(A8,3I3,A3,I10)') "Ncells:", ncells, "J:", j shift(1:3) = 0.0_dp DO aa = -ncells(1), ncells(1) DO bb = -ncells(2), ncells(2) @@ -3215,12 +3214,7 @@ CONTAINS shift(2) = REAL(bb, KIND=dp) shift(3) = REAL(cc, KIND=dp) xij = MATMUL(cell%hmat, ss0(:) + shift(:)) - rij = SQRT(DOT_PRODUCT(xij, xij)) - !IF (rij > rcut) THEN - ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " --", shift, rij - !ELSE - ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " ++", shift, rij - !ENDIF + rij = NORM2(xij) IF (rij > rcut) CYCLE ! update qlm @@ -3236,7 +3230,7 @@ CONTAINS IF (i == j) CYCLE jloop xij(:) = xpj(:) - xpi(:) - rij = SQRT(DOT_PRODUCT(xij, xij)) + rij = NORM2(xij) IF (rij > rcut) CYCLE jloop ! update qlm @@ -3251,11 +3245,6 @@ CONTAINS ! this factor is necessary if one whishes to sum over m=0,L ! instead of m=-L,+L. This is off now because it is cheap and safe fact = 1.0_dp - !IF (ABS(mm) > 0) THEN - ! fact = 2.0_dp - !ELSE - ! fact = 1.0_dp - !ENDIF IF (nbond < denominator_tolerance) THEN CPWARN("QPARM: number of neighbors is very close to zero!") @@ -3274,7 +3263,6 @@ CONTAINS END DO ! loop over m pre_fac = (4.0_dp*pi)/(2.0_dp*l + 1) - !WRITE(*,'(A8,2F10.5)') " si = ", SQRT(pre_fac*ql) qparm = qparm + SQRT(pre_fac*ql) ftmp(:) = 0.5_dp*SQRT(pre_fac/ql)*d_ql_dxi(:) ! multiply by -1 because aparently we have to save the force, not the gradient @@ -3287,10 +3275,6 @@ CONTAINS colvar%ss = qparm*inv_n_atoms_from colvar%dsdr(:, :) = colvar%dsdr(:, :)*inv_n_atoms_from - !WRITE(*,'(A15,3E20.10)') "COLVAR+DER = ", ri_step*idel, colvar%ss, -ftmp(1) - - !ENDDO ! numercal derivative - END SUBROUTINE qparm_colvar ! ************************************************************************************************** @@ -3323,7 +3307,6 @@ CONTAINS exp_fac, fi, plm, pre_fac, sqrt_c1 REAL(KIND=dp), DIMENSION(3) :: dcosTheta, dfi - !bond = 1.0_dp/(1.0_dp+EXP(alpha*(rij-rcut))) ! RZK: infinitely differentiable smooth cutoff function ! that is precisely 1.0 below r1cut and precisely 0.0 above rcut IF (rij > rcut) THEN @@ -3366,18 +3349,10 @@ CONTAINS sqrt_c1 = SQRT(((2*ll + 1)*fac(ll - ABS(mm)))/(4*pi*fac(ll + ABS(mm)))) pre_fac = bond*sqrt_c1 dylm = pre_fac*dplm - !WHY? IF (plm < 0.0_dp) THEN - !WHY? dylm = -pre_fac*dplm - !WHY? ELSE - !WHY? dylm = pre_fac*dplm - !WHY? ENDIF re_qlm = re_qlm + pre_fac*plm*COS(mm*fi) im_qlm = im_qlm + pre_fac*plm*SIN(mm*fi) - !WRITE(*,'(A8,2I4,F10.5)') " Qlm = ", mm, j, bond - !WRITE(*,'(A8,2I4,2F10.5)') " Qlm = ", mm, j, re_qlm, im_qlm - dcosTheta(:) = xij(:)*xij(3)/(rij**3) dcosTheta(3) = dcosTheta(3) - 1.0_dp/rij ! use tangent half-angle formula to compute d_fi/d_xi @@ -4595,7 +4570,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL rpath_dist_rmsd(colvar, my_particles) - ELSEIF (colvar%reaction_path_param%rmsd) THEN + ELSE IF (colvar%reaction_path_param%rmsd) THEN CALL rpath_rmsd(colvar, my_particles) ELSE CALL rpath_colvar(colvar, cell, my_particles) @@ -4948,7 +4923,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL dpath_dist_rmsd(colvar, my_particles) - ELSEIF (colvar%reaction_path_param%rmsd) THEN + ELSE IF (colvar%reaction_path_param%rmsd) THEN CALL dpath_rmsd(colvar, my_particles) ELSE CALL dpath_colvar(colvar, cell, my_particles) @@ -5864,11 +5839,12 @@ CONTAINS DO j = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format for COORD_A (CV rmsd). Very probably the"// & " line with title is missing or is empty. Please check the XYZ file and rerun your job!") + END IF READ (parser%input_line, *) dummy_char, rptr(1:3) r_ref((j - 1)*3 + 1, i) = cp_unit_to_cp2k(rptr(1), "angstrom") r_ref((j - 1)*3 + 2, i) = cp_unit_to_cp2k(rptr(2), "angstrom") @@ -5966,12 +5942,7 @@ CONTAINS iamin = wcai(i) END IF END DO -! zero=0.0_dp -! CALL put_derivative(colvar, 1, zero) -! CALL put_derivative(colvar, 2,zero) -! CALL put_derivative(colvar, 3, zero) -! write(*,'(2(i0,1x),4(f16.8,1x))')idmin,iamin,wc(1)%WannierHamDiag(idmin),wc(1)%WannierHamDiag(iamin),dmin,amin colvar%ss = wc(1)%WannierHamDiag(idmin) - wc(1)%WannierHamDiag(iamin) DEALLOCATE (wcai) DEALLOCATE (wcdi) @@ -5988,7 +5959,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = SQRT(DOT_PRODUCT(xv, xv)) + distance = NORM2(xv) END FUNCTION distance END SUBROUTINE Wc_colvar @@ -6007,8 +5978,8 @@ CONTAINS TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & - OPTIONAL, POINTER :: particles - TYPE(qs_environment_type), POINTER, OPTIONAL :: qs_env ! optional just because I am lazy... but I should get rid of it... + OPTIONAL, POINTER :: particles + TYPE(qs_environment_type), OPTIONAL, POINTER :: qs_env INTEGER :: Od, H, Oa REAL(dp) :: rOd(3), rOa(3), rH(3), & @@ -6105,7 +6076,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = SQRT(DOT_PRODUCT(xv, xv)) + distance = NORM2(xv) END FUNCTION distance END SUBROUTINE HBP_colvar diff --git a/src/common/array_sort.fypp b/src/common/array_sort.fypp index 2b39e3b783..86ebeb1f97 100644 --- a/src/common/array_sort.fypp +++ b/src/common/array_sort.fypp @@ -97,9 +97,9 @@ ! Merge will be performed directly in arr. Need backup of first sublist. tmp_arr(1:m) = arr(1:m) tmp_idx(1:m) = indices(1:m) - i = 1; ! number of elemens consumed from 1st sublist - j = 1; ! number of elemens consumed from 2nd sublist - k = 1; ! number of elemens already merged + i = 1 ! number of elements consumed from 1st sublist + j = 1 ! number of elements consumed from 2nd sublist + k = 1 ! number of elements already merged DO WHILE (i <= m .and. j <= size(arr) - m) IF (${prefix}$_less_than(arr(m + j), tmp_arr(i))) THEN diff --git a/src/common/bibliography.F b/src/common/bibliography.F index 621576c26d..38ca082835 100644 --- a/src/common/bibliography.F +++ b/src/common/bibliography.F @@ -66,7 +66,7 @@ MODULE bibliography Kantorovich2008a, Wellendorff2012, Niklasson2014, Borstnik2014, & Rayson2009, Grimme2011, Fattebert2002, Andreussi2012, & Khaliullin2007, Khaliullin2008, Merlot2014, Lin2009, Lin2013, Lin2016ACE, & - Batzner2022, DelBen2015, Souza2002, Umari2002, Stengel2009, & + Batzner2022, Batatia2022, DelBen2015, Souza2002, Umari2002, Stengel2009, & Luber2014, Berghold2011, DelBen2015b, Campana2009, & Schiffmann2015, Bruck2014, Rappe1992, Ceriotti2012, & Ceriotti2010, Walewski2014, Monkhorst1976, MacDonald1978, Worlton1972, & @@ -164,6 +164,13 @@ CONTAINS source="Nat. Commun.", volume="13", pages="2453", & year=2022, doi="10.1038/s41467-022-29939-5") + CALL add_reference(key=Batatia2022, & + authors=s2a("I. Batatia", "D. P. Kovacs", "G. N. C. Simm", "C. Ortner", "G. Csanyi"), & + title="MACE: Higher order equivariant message passing neural networks "// & + "for fast and accurate force fields", & + source="Adv. Neural Inf. Process. Syst.", volume="35", pages="11423-11436", & + year=2022, doi="10.48550/arXiv.2206.07697") + CALL add_reference(key=VandenCic2006, & authors=s2a("E. Vanden-Eijnden", "G. Ciccotti"), & title="Second-order integrators for Langevin equations with holonomic constraints", & diff --git a/src/common/cp_array_utils.F b/src/common/cp_array_utils.F index 87fd4d9949..a2bbe6c591 100644 --- a/src/common/cp_array_utils.F +++ b/src/common/cp_array_utils.F @@ -152,8 +152,9 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) & + IF (SIZE(array) > 0) THEN WRITE (unit=unit_nr, fmt=el_format, advance="no") array(SIZE(array)) + END IF ELSE DO i = 1, SIZE(array) - 1 WRITE (unit=unit_nr, fmt=defaultFormat, advance="no") array(i) @@ -163,8 +164,9 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) & + IF (SIZE(array) > 0) THEN WRITE (unit=unit_nr, fmt=defaultFormat, advance="no") array(SIZE(array)) + END IF END IF WRITE (unit=unit_nr, fmt="(' )')") call m_flush(unit_nr) @@ -289,8 +291,7 @@ CONTAINS !> \note !> the array should be ordered in growing order ! ************************************************************************************************** - FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) & - result(res) + FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) result(res) ${type1}$, intent(in) :: array(:) ${type1}$, intent(in) :: el INTEGER, INTENT(in), OPTIONAL :: l_index, u_index diff --git a/src/common/cp_error_handling.F b/src/common/cp_error_handling.F index 2d0192f8e0..e54780c0d3 100644 --- a/src/common/cp_error_handling.F +++ b/src/common/cp_error_handling.F @@ -63,8 +63,9 @@ CONTAINS CALL delay_non_master() ! cleaner output if all ranks abort simultaneously unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) & - unit_nr = default_output_unit ! fall back to stdout + IF (unit_nr <= 0) THEN + unit_nr = default_output_unit + END IF ! fall back to stdout CALL print_abort_message(message, location, unit_nr) CALL print_stack(unit_nr) @@ -125,8 +126,9 @@ CONTAINS ! we (ab)use the logger to determine the first MPI rank unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) & - wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second. + IF (unit_nr <= 0) THEN + wait_time = wait_time + 1.0_dp + END IF ! rank-0 gets a head start of one second. !$ IF (omp_get_thread_num() /= 0) & !$ wait_time = wait_time + 1.0_dp ! master threads gets another second diff --git a/src/common/cp_log_handling.F b/src/common/cp_log_handling.F index be0caf7b9e..b8ea2ea26e 100644 --- a/src/common/cp_log_handling.F +++ b/src/common/cp_log_handling.F @@ -303,8 +303,9 @@ CONTAINS logger%ref_count = 1 IF (PRESENT(template_logger)) THEN - IF (template_logger%ref_count < 1) & + IF (template_logger%ref_count < 1) THEN CPABORT(routineP//" template_logger%ref_count<1") + END IF logger%print_level = template_logger%print_level logger%default_global_unit_nr = template_logger%default_global_unit_nr logger%close_local_unit_on_dealloc = template_logger%close_local_unit_on_dealloc @@ -339,16 +340,19 @@ CONTAINS logger%suffix = "" END IF IF (PRESENT(para_env)) logger%para_env => para_env - IF (.NOT. ASSOCIATED(logger%para_env)) & + IF (.NOT. ASSOCIATED(logger%para_env)) THEN CPABORT(routineP//" para env not associated") - IF (.NOT. logger%para_env%is_valid()) & + END IF + IF (.NOT. logger%para_env%is_valid()) THEN CPABORT(routineP//" para_env%ref_count<1") + END IF CALL logger%para_env%retain() IF (PRESENT(print_level)) logger%print_level = print_level - IF (PRESENT(default_global_unit_nr)) & + IF (PRESENT(default_global_unit_nr)) THEN logger%default_global_unit_nr = default_global_unit_nr + END IF IF (PRESENT(global_filename)) THEN logger%global_filename = global_filename logger%close_global_unit_on_dealloc = .TRUE. @@ -362,8 +366,9 @@ CONTAINS END IF END IF - IF (PRESENT(default_local_unit_nr)) & + IF (PRESENT(default_local_unit_nr)) THEN logger%default_local_unit_nr = default_local_unit_nr + END IF IF (PRESENT(local_filename)) THEN logger%local_filename = local_filename logger%close_local_unit_on_dealloc = .TRUE. @@ -407,8 +412,9 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_retain', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) & + IF (logger%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF logger%ref_count = logger%ref_count + 1 END SUBROUTINE cp_logger_retain @@ -426,8 +432,9 @@ CONTAINS routineP = moduleN//':'//routineN IF (ASSOCIATED(logger)) THEN - IF (logger%ref_count < 1) & + IF (logger%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF logger%ref_count = logger%ref_count - 1 IF (logger%ref_count == 0) THEN IF (logger%close_global_unit_on_dealloc .AND. & @@ -476,8 +483,9 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) & + IF (lggr%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF res = level >= lggr%print_level END FUNCTION cp_logger_would_log @@ -547,8 +555,9 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_set_log_level', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) & + IF (logger%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF logger%print_level = level END SUBROUTINE cp_logger_set_log_level @@ -584,8 +593,9 @@ CONTAINS NULLIFY (lggr) END IF IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) & + IF (lggr%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF IF (PRESENT(local)) loc = local IF (PRESENT(skip_not_ionode)) skip = skip_not_ionode @@ -692,8 +702,9 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) & + IF (lggr%ref_count < 1) THEN CPABORT(routineP//" logger%ref_count<1") + END IF IF (PRESENT(local)) loc = local IF (loc) THEN res = TRIM(root)//TRIM(lggr%suffix)//'_p'// & diff --git a/src/common/cp_result_methods.F b/src/common/cp_result_methods.F index c62fe15576..8b943915df 100644 --- a/src/common/cp_result_methods.F +++ b/src/common/cp_result_methods.F @@ -178,14 +178,16 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) & + IF (nrep <= 0) THEN CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") + END IF DO i = 1, nlist IF (TRIM(results%result_label(i)) == TRIM(description)) THEN - IF (results%result_value(i)%value%type_in_use /= result_type_real) & + IF (results%result_value(i)%value%type_in_use /= result_type_real) THEN CPABORT("Attempt to retrieve a RESULT which is not a REAL!") + END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT @@ -251,14 +253,16 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) & + IF (nrep <= 0) THEN CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") + END IF DO i = 1, nlist IF (TRIM(results%result_label(i)) == TRIM(description)) THEN - IF (results%result_value(i)%value%type_in_use /= result_type_real) & + IF (results%result_value(i)%value%type_in_use /= result_type_real) THEN CPABORT("Attempt to retrieve a RESULT which is not a REAL!") + END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT diff --git a/src/common/cp_units.F b/src/common/cp_units.F index 9677341fd4..d398b9f92f 100644 --- a/src/common/cp_units.F +++ b/src/common/cp_units.F @@ -650,10 +650,11 @@ CONTAINS CPABORT("unknown electric field unit:"//TRIM(cp_to_string(basic_unit))) END SELECT CASE (cp_ukind_none) - IF (basic_unit /= cp_units_none) & + IF (basic_unit /= cp_units_none) THEN CALL cp_abort(__LOCATION__, & "if the kind of the unit is none also unit must be undefined,not:" & //TRIM(cp_to_string(basic_unit))) + END IF CASE default CPABORT("unknown kind of unit:"//TRIM(cp_to_string(basic_kind))) END SELECT @@ -679,10 +680,11 @@ CONTAINS my_power = 1 IF (PRESENT(power)) my_power = power IF (basic_unit == cp_units_none .AND. basic_kind /= cp_ukind_undef) THEN - IF (basic_kind /= cp_units_none) & + IF (basic_kind /= cp_units_none) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(cp_to_string(basic_unit))) + END IF END IF SELECT CASE (basic_kind) CASE (cp_ukind_undef) @@ -862,9 +864,10 @@ CONTAINS IF (accept_undefined) my_accept_undefined = accept_undefined IF (PRESENT(power)) my_power = power IF (basic_unit == cp_units_none) THEN - IF (.NOT. my_accept_undefined .AND. basic_kind == cp_units_none) & + IF (.NOT. my_accept_undefined .AND. basic_kind == cp_units_none) THEN CALL cp_abort(__LOCATION__, "unit not yet fully specified, unit of kind "// & TRIM(cp_to_string(basic_kind))) + END IF END IF SELECT CASE (basic_kind) CASE (cp_ukind_undef) @@ -900,10 +903,11 @@ CONTAINS res = "K_e" CASE (cp_units_none) res = "energy" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown energy unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -931,10 +935,11 @@ CONTAINS res = "au_temp" CASE (cp_units_none) res = "temperature" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown temperature unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -956,10 +961,11 @@ CONTAINS res = "au_p" CASE (cp_units_none) res = "pressure" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown pressure unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -971,10 +977,11 @@ CONTAINS res = "deg" CASE (cp_units_none) res = "angle" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown angle unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -992,10 +999,11 @@ CONTAINS res = "wavenumber_t" CASE (cp_units_none) res = "time" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown time unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1009,10 +1017,11 @@ CONTAINS res = "m_e" CASE (cp_units_none) res = "mass" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown mass unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1024,10 +1033,11 @@ CONTAINS res = "au_pot" CASE (cp_units_none) res = "potential" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown potential unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1041,10 +1051,11 @@ CONTAINS res = "au_f" CASE (cp_units_none) res = "force" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown potential unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1060,10 +1071,11 @@ CONTAINS res = "au_efield" CASE (cp_units_none) res = "electric field" - IF (.NOT. my_accept_undefined) & + IF (.NOT. my_accept_undefined) THEN CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) + END IF CASE default CPABORT("unknown efield unit:"//TRIM(cp_to_string(basic_unit))) END SELECT diff --git a/src/common/distribution_1d_types.F b/src/common/distribution_1d_types.F index 8e23f4b29f..c875a3129f 100644 --- a/src/common/distribution_1d_types.F +++ b/src/common/distribution_1d_types.F @@ -104,8 +104,9 @@ CONTAINS CALL para_env%retain() distribution_1d%listbased_distribution = .FALSE. - IF (PRESENT(listbased_distribution)) & + IF (PRESENT(listbased_distribution)) THEN distribution_1d%listbased_distribution = listbased_distribution + END IF ALLOCATE (distribution_1d%n_el(my_n_lists), distribution_1d%list(my_n_lists)) diff --git a/src/common/fparser.F b/src/common/fparser.F index 2e373db097..04f4f47f12 100644 --- a/src/common/fparser.F +++ b/src/common/fparser.F @@ -407,10 +407,10 @@ CONTAINS DO j = b, e IF (Func(j:j) == '(') THEN ParCnt = ParCnt + 1 - ELSEIF (Func(j:j) == ')') THEN + ELSE IF (Func(j:j) == ')') THEN ParCnt = ParCnt - 1 IF (ParCnt == 0) EXIT - ELSEIF (ParCnt == 1 .AND. Func(j:j) == ',') THEN + ELSE IF (ParCnt == 1 .AND. Func(j:j) == ',') THEN ArgPos = j ArgCnt = ArgCnt + 1 END IF @@ -748,7 +748,7 @@ CONTAINS DO j = b + 1, e - 1 IF (F(j:j) == '(') THEN k = k + 1 - ELSEIF (F(j:j) == ')') THEN + ELSE IF (F(j:j) == ')') THEN k = k - 1 END IF IF (k < 0) EXIT @@ -792,11 +792,11 @@ CONTAINS ! WRITE(*,*)'1. F(b:e) = "+..."' CALL CompileSubstr(i, F, b + 1, e, Var) RETURN - ELSEIF (CompletelyEnclosed(F, b, e)) THEN ! Case 2: F(b:e) = '(...)' + ELSE IF (CompletelyEnclosed(F, b, e)) THEN ! Case 2: F(b:e) = '(...)' ! WRITE(*,*)'2. F(b:e) = "(...)"' CALL CompileSubstr(i, F, b + 1, e - 1, Var) RETURN - ELSEIF (SCAN(F(b:b), calpha) > 0) THEN + ELSE IF (SCAN(F(b:b), calpha) > 0) THEN n = MathFunctionIndex(F(b:e)) IF (n > 0) THEN b2 = b + INDEX(F(b:e), '(') - 1 @@ -807,13 +807,13 @@ CONTAINS RETURN END IF END IF - ELSEIF (F(b:b) == '-') THEN + ELSE IF (F(b:b) == '-') THEN IF (CompletelyEnclosed(F, b + 1, e)) THEN ! Case 4: F(b:e) = '-(...)' ! WRITE(*,*)'4. F(b:e) = "-(...)"' CALL CompileSubstr(i, F, b + 2, e - 1, Var) CALL AddCompiledByte(i, cNeg) RETURN - ELSEIF (SCAN(F(b + 1:b + 1), calpha) > 0) THEN + ELSE IF (SCAN(F(b + 1:b + 1), calpha) > 0) THEN n = MathFunctionIndex(F(b + 1:e)) IF (n > 0) THEN b2 = b + INDEX(F(b + 1:e), '(') @@ -835,7 +835,7 @@ CONTAINS DO j = e, b, -1 IF (F(j:j) == ')') THEN k = k + 1 - ELSEIF (F(j:j) == '(') THEN + ELSE IF (F(j:j) == '(') THEN k = k - 1 END IF IF (k == 0 .AND. F(j:j) == Ops(io) .AND. IsBinaryOp(j, F)) THEN @@ -900,9 +900,9 @@ CONTAINS DO j = b, e IF (F(j:j) == '(') THEN ParCnt = ParCnt + 1 - ELSEIF (F(j:j) == ')') THEN + ELSE IF (F(j:j) == ')') THEN ParCnt = ParCnt - 1 - ELSEIF (ParCnt == 0 .AND. F(j:j) == ',') THEN + ELSE IF (ParCnt == 0 .AND. F(j:j) == ',') THEN CALL CompileSubstr(i, F, b2, j - 1, Var) b2 = j + 1 END IF @@ -938,17 +938,17 @@ CONTAINS IF (F(j:j) == '+' .OR. F(j:j) == '-') THEN ! Plus or minus sign: IF (j == 1) THEN ! - leading unary operator ? res = .FALSE. - ELSEIF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? + ELSE IF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? res = .FALSE. - ELSEIF (SCAN(F(j + 1:j + 1), '0123456789') > 0 .AND. & ! - in exponent of real number ? - SCAN(F(j - 1:j - 1), 'eEdD') > 0) THEN + ELSE IF (SCAN(F(j + 1:j + 1), '0123456789') > 0 .AND. & ! - in exponent of real number ? + SCAN(F(j - 1:j - 1), 'eEdD') > 0) THEN Dflag = .FALSE.; Pflag = .FALSE. k = j - 1 DO WHILE (k > 1) ! step to the left in mantissa k = k - 1 IF (SCAN(F(k:k), '0123456789') > 0) THEN Dflag = .TRUE. - ELSEIF (F(k:k) == '.') THEN + ELSE IF (F(k:k) == '.') THEN IF (Pflag) THEN EXIT ! * EXIT: 2nd appearance of '.' ELSE @@ -1011,7 +1011,7 @@ CONTAINS CASE ('+', '-') ! Permitted only IF (Bflag) THEN InMan = .TRUE.; Bflag = .FALSE. ! - at beginning of mantissa - ELSEIF (Eflag) THEN + ELSE IF (Eflag) THEN InExp = .TRUE.; Eflag = .FALSE. ! - at beginning of exponent ELSE EXIT ! - otherwise STOP @@ -1019,7 +1019,7 @@ CONTAINS CASE ('0':'9') ! Mark IF (Bflag) THEN InMan = .TRUE.; Bflag = .FALSE. ! - beginning of mantissa - ELSEIF (Eflag) THEN + ELSE IF (Eflag) THEN InExp = .TRUE.; Eflag = .FALSE. ! - beginning of exponent END IF IF (InMan) DInMan = .TRUE. ! Mantissa contains digit @@ -1028,7 +1028,7 @@ CONTAINS IF (Bflag) THEN Pflag = .TRUE. ! - mark 1st appearance of '.' InMan = .TRUE.; Bflag = .FALSE. ! mark beginning of mantissa - ELSEIF (InMan .AND. .NOT. Pflag) THEN + ELSE IF (InMan .AND. .NOT. Pflag) THEN Pflag = .TRUE. ! - mark 1st appearance of '.' ELSE EXIT ! - otherwise STOP diff --git a/src/common/gfun.F b/src/common/gfun.F index 55c55bf64b..515c79098e 100644 --- a/src/common/gfun.F +++ b/src/common/gfun.F @@ -62,7 +62,7 @@ CONTAINS IF (t <= 12.0_dp) THEN ! downward recursion - g(nmax) = gfun_taylor(nmax, t); + g(nmax) = gfun_taylor(nmax, t) DO i = nmax, 1, -1 g(i - 1) = (1.0_dp - 2.0_dp*t*g(i))/(2.0_dp*i - 1.0_dp) END DO diff --git a/src/common/hash_map.fypp b/src/common/hash_map.fypp index ee755920b3..ff5e066b74 100644 --- a/src/common/hash_map.fypp +++ b/src/common/hash_map.fypp @@ -81,11 +81,13 @@ initial_capacity_ = 11 END IF - IF (initial_capacity_ < 1) & + IF (initial_capacity_ < 1) THEN CPABORT("initial_capacity < 1") + END IF - IF (ASSOCIATED(hash_map%buckets)) & + IF (ASSOCIATED(hash_map%buckets)) THEN CPABORT("hash map is already initialized.") + END IF ALLOCATE (hash_map%buckets(initial_capacity_)) hash_map%size = 0 diff --git a/src/common/list.fypp b/src/common/list.fypp index 37524a2570..f0adb39843 100644 --- a/src/common/list.fypp +++ b/src/common/list.fypp @@ -87,15 +87,18 @@ initial_capacity_ = 11 If (PRESENT(initial_capacity)) initial_capacity_ = initial_capacity - IF (initial_capacity_ < 0) & + IF (initial_capacity_ < 0) THEN CPABORT("list_${valuetype}$_create: initial_capacity < 0") + END IF - IF (ASSOCIATED(list%arr)) & + IF (ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_create: list is already initialized.") + END IF ALLOCATE (list%arr(initial_capacity_), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_init: allocation failed") + END IF list%size = 0 END SUBROUTINE list_${valuetype}$_init @@ -112,8 +115,9 @@ SUBROUTINE list_${valuetype}$_destroy(list) TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_destroy: list is not initialized.") + END IF do i = 1, list%size deallocate (list%arr(i)%p) @@ -137,12 +141,15 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_in}$, intent(in) :: value INTEGER, intent(in) :: pos - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_set: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_set: pos < 1") - IF (pos > list%size) & + END IF + IF (pos > list%size) THEN CPABORT("list_${valuetype}$_set: pos > size") + END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_set @@ -159,15 +166,18 @@ ${valuetype_in}$, intent(in) :: value INTEGER :: stat - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_push: list is not initialized.") - if (list%size == size(list%arr)) & - call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) + END IF + IF (list%size == size(list%arr)) THEN + CALL change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) + END IF list%size = list%size + 1 ALLOCATE (list%arr(list%size)%p, stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_push: allocation failed") + END IF list%arr(list%size)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_push @@ -187,15 +197,19 @@ INTEGER, intent(in) :: pos INTEGER :: i, stat - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_insert: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_insert: pos < 1") - IF (pos > list%size + 1) & + END IF + IF (pos > list%size + 1) THEN CPABORT("list_${valuetype}$_insert: pos > size+1") + END IF - if (list%size == size(list%arr)) & + if (list%size == size(list%arr)) THEN call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) + END IF list%size = list%size + 1 do i = list%size, pos + 1, -1 @@ -203,8 +217,9 @@ end do ALLOCATE (list%arr(pos)%p, stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_insert: allocation failed.") + END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_insert @@ -221,10 +236,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_peek: list is not initialized.") - IF (list%size < 1) & + END IF + IF (list%size < 1) THEN CPABORT("list_${valuetype}$_peek: list is empty.") + END IF value ${value_assign}$list%arr(list%size)%p%value END FUNCTION list_${valuetype}$_peek @@ -245,10 +262,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_pop: list is not initialized.") - IF (list%size < 1) & + END IF + IF (list%size < 1) THEN CPABORT("list_${valuetype}$_pop: list is empty.") + END IF value ${value_assign}$list%arr(list%size)%p%value deallocate (list%arr(list%size)%p) @@ -266,12 +285,13 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) & + IF (.not. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_clear: list is not initialized.") + END IF - do i = 1, list%size + DO i = 1, list%size deallocate (list%arr(i)%p) - end do + END DO list%size = 0 END SUBROUTINE list_${valuetype}$_clear @@ -290,12 +310,15 @@ INTEGER, intent(in) :: pos ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_get: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_get: pos < 1") - IF (pos > list%size) & + END IF + IF (pos > list%size) THEN CPABORT("list_${valuetype}$_get: pos > size") + END IF value ${value_assign}$list%arr(pos)%p%value @@ -314,17 +337,20 @@ INTEGER, intent(in) :: pos INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_del: list is not initialized.") - IF (pos < 1) & + END IF + IF (pos < 1) THEN CPABORT("list_${valuetype}$_det: pos < 1") - IF (pos > list%size) & + END IF + IF (pos > list%size) THEN CPABORT("list_${valuetype}$_det: pos > size") + END IF deallocate (list%arr(pos)%p) - do i = pos, list%size - 1 + DO i = pos, list%size - 1 list%arr(i)%p => list%arr(i + 1)%p - end do + END DO list%size = list%size - 1 @@ -342,8 +368,9 @@ TYPE(list_${valuetype}$_type), intent(in) :: list INTEGER :: size - IF (.not. ASSOCIATED(list%arr)) & + IF (.NOT. ASSOCIATED(list%arr)) THEN CPABORT("list_${valuetype}$_size: list is not initialized.") + END IF size = list%size END FUNCTION list_${valuetype}$_size @@ -363,29 +390,34 @@ TYPE(private_item_p_type_${valuetype}$), DIMENSION(:), POINTER :: old_arr new_cap = new_capacity - IF (new_cap < 0) & + IF (new_cap < 0) THEN CPABORT("list_${valuetype}$_change_capacity: new_capacity < 0") - IF (new_cap < list%size) & + END IF + IF (new_cap < list%size) THEN CPABORT("list_${valuetype}$_change_capacity: new_capacity < size") + END IF IF (new_cap > HUGE(i)) THEN - IF (size(list%arr) == HUGE(i)) & + IF (size(list%arr) == HUGE(i)) THEN CPABORT("list_${valuetype}$_change_capacity: list has reached integer limit.") + END IF new_cap = HUGE(i) ! grow as far as possible END IF old_arr => list%arr allocate (list%arr(new_cap), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_change_capacity: allocation failed") + END IF - do i = 1, list%size + DO i = 1, list%size allocate (list%arr(i)%p, stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("list_${valuetype}$_change_capacity: allocation failed") + END IF list%arr(i)%p%value ${value_assign}$old_arr(i)%p%value - deallocate (old_arr(i)%p) - end do - deallocate (old_arr) + DEALLOCATE (old_arr(i)%p) + END DO + DEALLOCATE (old_arr) END SUBROUTINE change_capacity_${valuetype}$ #:enddef diff --git a/src/common/mathlib.F b/src/common/mathlib.F index adf19a3a6e..e1c5791b79 100644 --- a/src/common/mathlib.F +++ b/src/common/mathlib.F @@ -187,8 +187,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = SQRT(DOT_PRODUCT(a, a)) - length_of_b = SQRT(DOT_PRODUCT(b, b)) + length_of_a = NORM2(a) + length_of_b = NORM2(b) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a @@ -997,8 +997,9 @@ CONTAINS ! set singular values that are too small to zero DO i = 1, n IF (sig(i) > rskip*MAXVAL(sig)) THEN - IF (PRESENT(determinant)) & + IF (PRESENT(determinant)) THEN determinant = determinant*sig(i) + END IF sig_plus(i, i) = 1._dp/sig(i) ELSE sig_plus(i, i) = 0.0_dp @@ -1975,12 +1976,14 @@ CONTAINS IF (n /= SIZE(C_out, 2)) CPABORT("Incompatible (cols) result array 3 (C).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF CALL timeset(routineN, handle) @@ -2018,12 +2021,14 @@ CONTAINS IF (n /= SIZE(C_out, 2)) CPABORT("Incompatible (cols) result array 3 (C).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF CALL timeset(routineN, handle) @@ -2068,16 +2073,19 @@ CONTAINS IF (n /= SIZE(D_out, 2)) CPABORT("Incompatible (cols) result array 4 (D).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF IF (.NOT. (C_trans == 'N' .OR. C_trans == 'n' .OR. & C_trans == 'T' .OR. C_trans == 't' .OR. & - C_trans == 'C' .OR. C_trans == 'c')) & + C_trans == 'C' .OR. C_trans == 'c')) THEN CPABORT("Unknown transpose character for array 3 (C).") + END IF CALL timeset(routineN, handle) @@ -2127,16 +2135,19 @@ CONTAINS IF (n /= SIZE(D_out, 2)) CPABORT("Incompatible (cols) result array 4 (D).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) & + A_trans == 'C' .OR. A_trans == 'c')) THEN CPABORT("Unknown transpose character for array 1 (A).") + END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) & + B_trans == 'C' .OR. B_trans == 'c')) THEN CPABORT("Unknown transpose character for array 2 (B).") + END IF IF (.NOT. (C_trans == 'N' .OR. C_trans == 'n' .OR. & C_trans == 'T' .OR. C_trans == 't' .OR. & - C_trans == 'C' .OR. C_trans == 'c')) & + C_trans == 'C' .OR. C_trans == 'c')) THEN CPABORT("Unknown transpose character for array 3 (C).") + END IF CALL timeset(routineN, handle) diff --git a/src/common/memory_utilities_unittest.F b/src/common/memory_utilities_unittest.F index 5534658c10..7aeb64e973 100644 --- a/src/common/memory_utilities_unittest.F +++ b/src/common/memory_utilities_unittest.F @@ -32,11 +32,13 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) & + IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) THEN ERROR STOP "check_real_rank1_allocated: reallocating changed the initial values" + END IF - IF (.NOT. ALL(real_arr(11:20) == 0.)) & + IF (.NOT. ALL(real_arr(11:20) == 0.)) THEN ERROR STOP "check_real_rank1_allocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -53,8 +55,9 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:20) == 0.)) & + IF (.NOT. ALL(real_arr(1:20) == 0.)) THEN ERROR STOP "check_real_rank1_unallocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -73,11 +76,13 @@ CONTAINS CALL reallocate(real_arr, 1, 10, 1, 5) - IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) & + IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) THEN ERROR STOP "check_real_rank2_allocated: reallocating changed the initial values" + END IF - IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) & + IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) THEN ERROR STOP "check_real_rank2_allocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -94,8 +99,9 @@ CONTAINS CALL reallocate(real_arr, 1, 10, 1, 5) - IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) & + IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) THEN ERROR STOP "check_real_rank2_unallocated: reallocation failed to initialise new values with 0." + END IF DEALLOCATE (real_arr) @@ -114,11 +120,13 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) & + IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) THEN ERROR STOP "check_string_rank1_allocated: reallocating changed the initial values" + END IF - IF (.NOT. ALL(str_arr(11:20) == "")) & + IF (.NOT. ALL(str_arr(11:20) == "")) THEN ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." + END IF DEALLOCATE (str_arr) @@ -135,8 +143,9 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:20) == "")) & + IF (.NOT. ALL(str_arr(1:20) == "")) THEN ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." + END IF DEALLOCATE (str_arr) diff --git a/src/common/parallel_rng_types.F b/src/common/parallel_rng_types.F index 970e64ec22..e969d79b88 100644 --- a/src/common/parallel_rng_types.F +++ b/src/common/parallel_rng_types.F @@ -512,8 +512,9 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: antithetic, extended_precision TYPE(rng_stream_type) :: rng_stream - IF (LEN_TRIM(name) > rng_name_length) & + IF (LEN_TRIM(name) > rng_name_length) THEN CPABORT("given random number generator name is too long") + END IF rng_stream%name = TRIM(name) @@ -630,14 +631,16 @@ CONTAINS LOGICAL, INTENT(OUT), OPTIONAL :: buffer_filled IF (PRESENT(name)) name = self%name - IF (PRESENT(distribution_type)) & + IF (PRESENT(distribution_type)) THEN distribution_type = self%distribution_type + END IF IF (PRESENT(bg)) bg = self%bg IF (PRESENT(cg)) cg = self%cg IF (PRESENT(ig)) ig = self%ig IF (PRESENT(antithetic)) antithetic = self%antithetic - IF (PRESENT(extended_precision)) & + IF (PRESENT(extended_precision)) THEN extended_precision = self%extended_precision + END IF IF (PRESENT(buffer)) buffer = self%buffer IF (PRESENT(buffer_filled)) buffer_filled = self%buffer_filled END SUBROUTINE get @@ -1131,8 +1134,9 @@ CONTAINS my_write_all = .FALSE. - IF (PRESENT(write_all)) & + IF (PRESENT(write_all)) THEN my_write_all = write_all + END IF WRITE (UNIT=output_unit, FMT="(/,T2,A,/)") & "Random number stream <"//TRIM(self%name)//">:" diff --git a/src/common/parallel_rng_types_unittest.F b/src/common/parallel_rng_types_unittest.F index 87cf2640f7..142e5f2ab9 100644 --- a/src/common/parallel_rng_types_unittest.F +++ b/src/common/parallel_rng_types_unittest.F @@ -32,14 +32,16 @@ PROGRAM parallel_rng_types_TEST nsamples = 1000 nargs = command_argument_count() - IF (nargs > 1) & + IF (nargs > 1) then ERROR STOP "Usage: parallel_rng_types_TEST []" + end if IF (nargs == 1) THEN CALL get_command_argument(1, arg) READ (arg, *, iostat=stat) nsamples - IF (stat /= 0) & + IF (stat /= 0) then ERROR STOP "Usage: parallel_rng_types_TEST []" + end if END IF CALL mp_world_init(mpi_comm) @@ -60,8 +62,9 @@ PROGRAM parallel_rng_types_TEST distribution_type=UNIFORM, & extended_precision=.TRUE.) - IF (ionode) & + IF (ionode) then CALL rng_stream%write(default_output_unit) + end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -94,8 +97,9 @@ PROGRAM parallel_rng_types_TEST distribution_type=GAUSSIAN, & extended_precision=.TRUE.) - IF (ionode) & + IF (ionode) then CALL rng_stream%write(default_output_unit) + end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -162,8 +166,9 @@ CONTAINS CALL rng_stream%get(ig=ig, cg=cg, bg=bg, name=name) IF (ANY(ig /= ig_orig) .OR. ANY(cg /= cg_orig) .OR. ANY(bg /= bg_orig) & - .OR. (name /= name_orig)) & + .OR. (name /= name_orig)) then ERROR STOP "Stream dump and load roundtrip failed" + end if WRITE (UNIT=default_output_unit, FMT="(T4,A)") & "Roundtrip successful" @@ -185,8 +190,9 @@ CONTAINS WRITE (UNIT=default_output_unit, FMT="(T4,A10,A433)") & "GENERATED:", rng_record - IF (rng_record /= serialized_string) & + IF (rng_record /= serialized_string) then ERROR STOP "Serialized record does not match the expected output" + end if WRITE (UNIT=default_output_unit, FMT="(T4,A)") & "Serialized record matches the expected output" @@ -214,19 +220,22 @@ CONTAINS arr = orig CALL rng_stream%shuffle(arr) - IF (ALL(arr == orig)) & + IF (ALL(arr == orig)) then ERROR STOP "shuffle failed: array was left untouched" + end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." - IF (ANY(arr /= orig(arr))) & + IF (ANY(arr /= orig(arr))) then ERROR STOP "shuffle failed: the shuffled original is not the shuffled original" + end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." ! sort and compare to orig mask = .TRUE. DO idx = 1, size(orig) - IF (MINVAL(arr, mask) /= orig(idx)) & + IF (MINVAL(arr, mask) /= orig(idx)) then ERROR STOP "shuffle failed: there is at least one unknown index" + end if mask(MINLOC(arr, mask)) = .FALSE. END DO WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." @@ -235,8 +244,9 @@ CONTAINS CALL rng_stream%reset() CALL rng_stream%shuffle(arr2) - IF (ANY(arr2 /= arr)) & + IF (ANY(arr2 /= arr)) then ERROR STOP "shuffle failed: array was shuffled differently with same rng state" + end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." WRITE (UNIT=default_output_unit, FMT="(T4,A)") & diff --git a/src/common/reference_manager.F b/src/common/reference_manager.F index f900554659..8ba42beaff 100644 --- a/src/common/reference_manager.F +++ b/src/common/reference_manager.F @@ -332,14 +332,18 @@ CONTAINS WRITE (unit, '(T3,A)') ''//thebib(i)%ref%source//'' ! DOI, volume, pages, year, month. - IF (ALLOCATED(thebib(i)%ref%doi)) & + IF (ALLOCATED(thebib(i)%ref%doi)) THEN WRITE (unit, '(T3,A)') ''//TRIM(substitute_special_xml_tokens(thebib(i)%ref%doi))//'' - IF (ALLOCATED(thebib(i)%ref%volume)) & + END IF + IF (ALLOCATED(thebib(i)%ref%volume)) THEN WRITE (unit, '(T3,A)') ''//thebib(i)%ref%volume//'' - IF (ALLOCATED(thebib(i)%ref%pages)) & + END IF + IF (ALLOCATED(thebib(i)%ref%pages)) THEN WRITE (unit, '(T3,A)') ''//thebib(i)%ref%pages//'' - IF (thebib(i)%ref%year > 0) & + END IF + IF (thebib(i)%ref%year > 0) THEN WRITE (unit, '(T3,A,I4.4,A)') '', thebib(i)%ref%year, '' + END IF WRITE (unit, '(T2,A)') '' END DO diff --git a/src/common/spherical_harmonics.F b/src/common/spherical_harmonics.F index 52d62548c6..96bd808f89 100644 --- a/src/common/spherical_harmonics.F +++ b/src/common/spherical_harmonics.F @@ -1805,30 +1805,42 @@ CONTAINS REAL(KIND=dp) :: sumk, t ! Check validity of the input parameters - IF (j1 < 0.0_dp) & + IF (j1 < 0.0_dp) THEN CPABORT("The angular momentum quantum number j1 has to be nonnegative") - IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) & + END IF + IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) THEN CPABORT("The angular momentum quantum number j1 has to be integer or half-integer") - IF (j2 < 0.0_dp) & + END IF + IF (j2 < 0.0_dp) THEN CPABORT("The angular momentum quantum number j2 has to be nonnegative") - IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) & + END IF + IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) THEN CPABORT("The angular momentum quantum number j2 has to be integer or half-integer") - IF (J < 0.0_dp) & + END IF + IF (J < 0.0_dp) THEN CPABORT("The angular momentum quantum number J has to be nonnegative") - IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) & + END IF + IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) THEN CPABORT("The angular momentum quantum number J has to be integer or half-integer") - IF ((ABS(m1) - j1) > EPSILON(m1)) & + END IF + IF ((ABS(m1) - j1) > EPSILON(m1)) THEN CPABORT("The angular momentum quantum number m1 has to satisfy -j1 <= m1 <= j1") - IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) & + END IF + IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) THEN CPABORT("The angular momentum quantum number m1 has to be integer or half-integer") - IF ((ABS(m2) - j2) > EPSILON(m2)) & + END IF + IF ((ABS(m2) - j2) > EPSILON(m2)) THEN CPABORT("The angular momentum quantum number m2 has to satisfy -j2 <= m1 <= j2") - IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) & + END IF + IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) THEN CPABORT("The angular momentum quantum number m2 has to be integer or half-integer") - IF ((ABS(M) - J) > EPSILON(M)) & + END IF + IF ((ABS(M) - J) > EPSILON(M)) THEN CPABORT("The angular momentum quantum number M has to satisfy -J <= M <= J") - IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) & + END IF + IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) THEN CPABORT("The angular momentum quantum number M has to be integer or half-integer") + END IF IF (is_integer(j1 + j2 + J) .AND. & is_integer(j1 + m1) .AND. & @@ -1872,8 +1884,8 @@ CONTAINS ! ************************************************************************************************** !> \brief Compute the Wigner 3-j symbol -!> / j1 j2 j3 \ -!> \ m1 m2 m3 / +!> ( j1 j2 j3 ) +!> ( m1 m2 m3 ) !> using the Clebsch-Gordon coefficients !> \param j1 Angular momentum quantum number of the first state | j1 m1 > !> \param m1 Magnetic quantum number of the first first state | j1 m1 > diff --git a/src/common/splines.F b/src/common/splines.F index 6d808dfad9..bcfc9252d5 100644 --- a/src/common/splines.F +++ b/src/common/splines.F @@ -311,21 +311,21 @@ CONTAINS i1 = 1 IF (n < 2) THEN CALL stop_error("error in iix: n < 2") - ELSEIF (n == 2) THEN + ELSE IF (n == 2) THEN i1 = 1 - ELSEIF (n == 3) THEN + ELSE IF (n == 3) THEN IF (x <= xi(2)) THEN ! first element i1 = 1 ELSE i1 = 2 END IF - ELSEIF (x <= xi(1)) THEN ! left end + ELSE IF (x <= xi(1)) THEN ! left end i1 = 1 - ELSEIF (x <= xi(2)) THEN ! first element + ELSE IF (x <= xi(2)) THEN ! first element i1 = 1 - ELSEIF (x <= xi(3)) THEN ! second element + ELSE IF (x <= xi(3)) THEN ! second element i1 = 2 - ELSEIF (x >= xi(n)) THEN ! right end + ELSE IF (x >= xi(n)) THEN ! right end i1 = n - 1 ELSE ! bisection: xi(i1) <= x < xi(i2) diff --git a/src/common/timings.F b/src/common/timings.F index fb81e07f11..d327324b23 100644 --- a/src/common/timings.F +++ b/src/common/timings.F @@ -96,8 +96,9 @@ CONTAINS IF (PRESENT(timer_env)) timer_env_ => timer_env IF (.NOT. PRESENT(timer_env)) CALL timer_env_create(timer_env_) - IF (.NOT. ASSOCIATED(timer_env_)) & + IF (.NOT. ASSOCIATED(timer_env_)) THEN CPABORT("add_timer_env: not associated") + END IF CALL timer_env_retain(timer_env_) IF (.NOT. list_isready(timers_stack)) CALL list_init(timers_stack) @@ -157,10 +158,12 @@ CONTAINS SUBROUTINE timer_env_retain(timer_env) TYPE(timer_env_type), POINTER :: timer_env - IF (.NOT. ASSOCIATED(timer_env)) & + IF (.NOT. ASSOCIATED(timer_env)) THEN CPABORT("timer_env_retain: not associated") - IF (timer_env%ref_count < 0) & + END IF + IF (timer_env%ref_count < 0) THEN CPABORT("timer_env_retain: negativ ref_count") + END IF timer_env%ref_count = timer_env%ref_count + 1 END SUBROUTINE timer_env_retain @@ -176,10 +179,12 @@ CONTAINS TYPE(callgraph_item_type), DIMENSION(:), POINTER :: ct_items TYPE(routine_stat_type), POINTER :: r_stat - IF (.NOT. ASSOCIATED(timer_env)) & + IF (.NOT. ASSOCIATED(timer_env)) THEN CPABORT("timer_env_release: not associated") - IF (timer_env%ref_count < 0) & + END IF + IF (timer_env%ref_count < 0) THEN CPABORT("timer_env_release: negativ ref_count") + END IF timer_env%ref_count = timer_env%ref_count - 1 IF (timer_env%ref_count > 0) RETURN @@ -437,10 +442,12 @@ CONTAINS TYPE(timer_env_type), POINTER :: timer_env ! catch edge cases where timer_env is not yet/anymore available - IF (.NOT. list_isready(timers_stack)) & + IF (.NOT. list_isready(timers_stack)) THEN RETURN - IF (list_size(timers_stack) == 0) & + END IF + IF (list_size(timers_stack) == 0) THEN RETURN + END IF timer_env => list_peek(timers_stack) WRITE (unit_nr, '(/,A,/)') " ===== Routine Calling Stack ===== " diff --git a/src/common/timings_report.F b/src/common/timings_report.F index eedcf3e659..03b5a4166d 100644 --- a/src/common/timings_report.F +++ b/src/common/timings_report.F @@ -77,8 +77,9 @@ CONTAINS CALL list_init(reports) CALL collect_reports_from_ranks(reports, cost_type, para_env) - IF (list_size(reports) > 0 .AND. iw > 0) & + IF (list_size(reports) > 0 .AND. iw > 0) THEN CALL print_reports(reports, iw, r_timings, sort_by_self_time, cost_type, report_maxloc, para_env) + END IF ! deallocate reports DO WHILE (list_size(reports) > 0) @@ -111,8 +112,9 @@ CONTAINS TYPE(timer_env_type), POINTER :: timer_env NULLIFY (r_stat, r_report, timer_env) - IF (.NOT. list_isready(reports)) & + IF (.NOT. list_isready(reports)) THEN CPABORT("BUG") + END IF timer_env => get_timer_env() @@ -232,8 +234,9 @@ CONTAINS TYPE(routine_report_type), POINTER :: r_report_i, r_report_j NULLIFY (r_report_i, r_report_j) - IF (.NOT. list_isready(reports)) & + IF (.NOT. list_isready(reports)) THEN CPABORT("BUG") + END IF ! are we printing timing or energy ? SELECT CASE (cost_type) diff --git a/src/common/util.F b/src/common/util.F index f20e1ebfff..1c1988135b 100644 --- a/src/common/util.F +++ b/src/common/util.F @@ -174,7 +174,7 @@ CONTAINS IF (j == 1) THEN DO i = 1, isize INDEX(i) = i - ENDDO + END DO END IF ! Allocate scratch arrays diff --git a/src/commutator_rpnl.F b/src/commutator_rpnl.F index db7084cbf9..669f952309 100644 --- a/src/commutator_rpnl.F +++ b/src/commutator_rpnl.F @@ -217,7 +217,7 @@ CONTAINS nprj_ppnl => gpotential(kkind)%gth_potential%nprj_ppnl ppnl_radius = gpotential(kkind)%gth_potential%ppnl_radius vprj_ppnl => gpotential(kkind)%gth_potential%vprj_ppnl - ELSEIF (spot) THEN + ELSE IF (spot) THEN CPABORT('SGP not implemented') ELSE CPABORT('PPNL unknown') @@ -868,282 +868,304 @@ CONTAINS IF (my_rxrv) THEN ! x-component (y [z,Vnl] - z [y, Vnl]) - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 9), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! yzV - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 3), na, & - ! bcint(1, 1, 4), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! -yVz - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 9), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! -zyV - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 4), na, & - ! bcint(1, 1, 3), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! zVy - ! with MATMUL IF (iatom <= jatom) THEN + ! yzV blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! -yVz blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! -yVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) + ! -zyV blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -zyV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zVy blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! zVy + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 3))) ELSE + ! yzV blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! -yVz blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! -yVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) + ! -zyV blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! -zyV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zVy blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 3))) ! zVy + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 3))) END IF ! y-component (z [x,Vnl] - x [z, Vnl]) - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 7), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! zxV - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 4), na, & - ! bcint(1, 1, 2), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! -zVx - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 7), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! -xzV - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 2), na, & - ! bcint(1, 1, 4), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! xVz - ! with MATMUL IF (iatom <= jatom) THEN + ! zxV blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zxV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! -zVx blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! -zVx + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 2))) + ! -xzV blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -xzV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xVz blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ELSE + ! zxV blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! zxV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! -zVx blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 2))) ! -zVx + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 2))) + ! -xzV blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! -xzV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xVz blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) END IF ! z-component (x [y,Vnl] - y [x, Vnl]) - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 6), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! xyV - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 2), na, & - ! bcint(1, 1, 3), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! -xVy - ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 6), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! -yxV - ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 3), na, & - ! bcint(1, 1, 2), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! yVx - ! with MATMUL IF (iatom <= jatom) THEN + ! xyV blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! -xVy blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! -xVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) + ! -yxV blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -yxV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zVx blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! zVx + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 2))) ELSE + ! xyV blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! -xVy blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! -xVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) + ! -yxV blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! -yxV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zVx blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 2))) ! zVx + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 2))) END IF END IF IF (my_rrv) THEN ! r_alpha * r_beta * Vnl - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 5), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(1)%block, SIZE(blocks_rrv(1)%block, 1)) ! xxV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 6), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(2)%block, SIZE(blocks_rrv(2)%block, 1)) ! xyV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 7), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(3)%block, SIZE(blocks_rrv(3)%block, 1)) ! xzV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 8), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(4)%block, SIZE(blocks_rrv(4)%block, 1)) ! yyV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 9), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(5)%block, SIZE(blocks_rrv(5)%block, 1)) ! yzV - ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 10), na, & - ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(6)%block, SIZE(blocks_rrv(6)%block, 1)) ! zzV - ! with MATMUL IF (iatom <= jatom) THEN + ! xxV blocks_rrv(1)%block(1:na, 1:nb) = blocks_rrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xyV blocks_rrv(2)%block(1:na, 1:nb) = blocks_rrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xzV blocks_rrv(3)%block(1:na, 1:nb) = blocks_rrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yyV blocks_rrv(4)%block(1:na, 1:nb) = blocks_rrv(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yzV blocks_rrv(5)%block(1:na, 1:nb) = blocks_rrv(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zzV blocks_rrv(6)%block(1:na, 1:nb) = blocks_rrv(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ELSE + ! xxV blocks_rrv(1)%block(1:nb, 1:na) = blocks_rrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xyV blocks_rrv(2)%block(1:nb, 1:na) = blocks_rrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xzV blocks_rrv(3)%block(1:nb, 1:na) = blocks_rrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yyV blocks_rrv(4)%block(1:nb, 1:na) = blocks_rrv(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yzV blocks_rrv(5)%block(1:nb, 1:na) = blocks_rrv(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zzV blocks_rrv(6)%block(1:nb, 1:na) = blocks_rrv(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) END IF ! - Vnl * r_alpha * r_beta - ! with LAPACK - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 5), nb, 1.0_dp, blocks_rrv(1)%block, SIZE(blocks_rrv(1)%block, 1)) ! Vxx - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 6), nb, 1.0_dp, blocks_rrv(2)%block, SIZE(blocks_rrv(2)%block, 1)) ! Vxy - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 7), nb, 1.0_dp, blocks_rrv(3)%block, SIZE(blocks_rrv(3)%block, 1)) ! Vxz - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 8), nb, 1.0_dp, blocks_rrv(4)%block, SIZE(blocks_rrv(4)%block, 1)) ! Vyy - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 9), nb, 1.0_dp, blocks_rrv(5)%block, SIZE(blocks_rrv(5)%block, 1)) ! Vyz - ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & - ! bcint(1, 1, 10), nb, 1.0_dp, blocks_rrv(6)%block, SIZE(blocks_rrv(6)%block, 1)) ! Vzz - ! with MATMUL IF (iatom <= jatom) THEN + ! -Vxx blocks_rrv(1)%block(1:na, 1:nb) = blocks_rrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! -Vxx + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) + ! -Vxy blocks_rrv(2)%block(1:na, 1:nb) = blocks_rrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! -Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) + ! -Vxz blocks_rrv(3)%block(1:na, 1:nb) = blocks_rrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! -Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) + ! -Vyy blocks_rrv(4)%block(1:na, 1:nb) = blocks_rrv(4)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! -Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) + ! -Vyz blocks_rrv(5)%block(1:na, 1:nb) = blocks_rrv(5)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! -Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) + ! -Vzz blocks_rrv(6)%block(1:na, 1:nb) = blocks_rrv(6)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! -Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ELSE + ! -Vxx blocks_rrv(1)%block(1:nb, 1:na) = blocks_rrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! -Vxx + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) + ! -Vxy blocks_rrv(2)%block(1:nb, 1:na) = blocks_rrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! -Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) + ! -Vxz blocks_rrv(3)%block(1:nb, 1:na) = blocks_rrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! -Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) + ! -Vyy blocks_rrv(4)%block(1:nb, 1:na) = blocks_rrv(4)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! -Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) + ! -Vyz blocks_rrv(5)%block(1:nb, 1:na) = blocks_rrv(5)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! -Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) + ! -Vzz blocks_rrv(6)%block(1:nb, 1:na) = blocks_rrv(6)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! -Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) END IF END IF IF (my_rvr) THEN ! r_alpha * Vnl * r_beta IF (iatom <= jatom) THEN + ! xVx blocks_rvr(1)%block(1:na, 1:nb) = blocks_rvr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! xVx + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 2))) + ! xVy blocks_rvr(2)%block(1:na, 1:nb) = blocks_rvr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! xVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) + ! xVz blocks_rvr(3)%block(1:na, 1:nb) = blocks_rvr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) + ! yVy blocks_rvr(4)%block(1:na, 1:nb) = blocks_rvr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! yVy + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 3))) + ! yVz blocks_rvr(5)%block(1:na, 1:nb) = blocks_rvr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! yVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) + ! zVz blocks_rvr(6)%block(1:na, 1:nb) = blocks_rvr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! zVz + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 4))) ELSE + ! xVx blocks_rvr(1)%block(1:nb, 1:na) = blocks_rvr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 2))) ! xVx + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 2))) + ! xVy blocks_rvr(2)%block(1:nb, 1:na) = blocks_rvr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! xVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) + ! xVz blocks_rvr(3)%block(1:nb, 1:na) = blocks_rvr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) + ! yVy blocks_rvr(4)%block(1:nb, 1:na) = blocks_rvr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 3))) ! yVy + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 3))) + ! yVz blocks_rvr(5)%block(1:nb, 1:na) = blocks_rvr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! yVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) + ! zVz blocks_rvr(6)%block(1:nb, 1:na) = blocks_rvr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 4))) ! zVz + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 4))) END IF END IF IF (my_rrv_vrr) THEN ! r_alpha * r_beta * Vnl IF (iatom <= jatom) THEN + ! xxV blocks_rrv_vrr(1)%block(1:na, 1:nb) = blocks_rrv_vrr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xyV blocks_rrv_vrr(2)%block(1:na, 1:nb) = blocks_rrv_vrr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! xzV blocks_rrv_vrr(3)%block(1:na, 1:nb) = blocks_rrv_vrr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yyV blocks_rrv_vrr(4)%block(1:na, 1:nb) = blocks_rrv_vrr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! yzV blocks_rrv_vrr(5)%block(1:na, 1:nb) = blocks_rrv_vrr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) + ! zzV blocks_rrv_vrr(6)%block(1:na, 1:nb) = blocks_rrv_vrr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ELSE + ! xxV blocks_rrv_vrr(1)%block(1:nb, 1:na) = blocks_rrv_vrr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xyV blocks_rrv_vrr(2)%block(1:nb, 1:na) = blocks_rrv_vrr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) + ! xzV blocks_rrv_vrr(3)%block(1:nb, 1:na) = blocks_rrv_vrr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yyV blocks_rrv_vrr(4)%block(1:nb, 1:na) = blocks_rrv_vrr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) + ! yzV blocks_rrv_vrr(5)%block(1:nb, 1:na) = blocks_rrv_vrr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) + ! zzV blocks_rrv_vrr(6)%block(1:nb, 1:na) = blocks_rrv_vrr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) END IF ! + Vnl * r_alpha * r_beta IF (iatom <= jatom) THEN + ! +Vxx blocks_rrv_vrr(1)%block(1:na, 1:nb) = blocks_rrv_vrr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! +Vxx + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) + ! +Vxy blocks_rrv_vrr(2)%block(1:na, 1:nb) = blocks_rrv_vrr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! +Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) + ! +Vxz blocks_rrv_vrr(3)%block(1:na, 1:nb) = blocks_rrv_vrr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! +Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) + ! +Vyy blocks_rrv_vrr(4)%block(1:na, 1:nb) = blocks_rrv_vrr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! +Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) + ! +Vyz blocks_rrv_vrr(5)%block(1:na, 1:nb) = blocks_rrv_vrr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! +Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) + ! +Vzz blocks_rrv_vrr(6)%block(1:na, 1:nb) = blocks_rrv_vrr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! +Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ELSE + ! +Vxx blocks_rrv_vrr(1)%block(1:nb, 1:na) = blocks_rrv_vrr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! +Vxx + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) + ! +Vxy blocks_rrv_vrr(2)%block(1:nb, 1:na) = blocks_rrv_vrr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! +Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) + ! +Vxz blocks_rrv_vrr(3)%block(1:nb, 1:na) = blocks_rrv_vrr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! +Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) + ! +Vyy blocks_rrv_vrr(4)%block(1:nb, 1:na) = blocks_rrv_vrr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! +Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) + ! +Vyz blocks_rrv_vrr(5)%block(1:nb, 1:na) = blocks_rrv_vrr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! +Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) + ! +Vzz blocks_rrv_vrr(6)%block(1:nb, 1:na) = blocks_rrv_vrr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! +Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) END IF END IF ! The indices are stored in i_1, i_x, ..., i_zzz - ! matrix_r_rxvr(alpha, beta) - ! = sum_(gamma delta) epsilon_(alpha gamma delta) - ! (r_beta * r_gamma * V_nl * r_delta - r_beta * r_gamma * r_delta * V_nl) - ! = sum_(gamma delta) epsilon_(alpha gamma delta) r_beta * r_gamma * V_nl * r_delta ! TODO: is this set to zero before? IF (my_r_rxvr) THEN diff --git a/src/constraint.F b/src/constraint.F index e6d1308ea4..c8bdc9e2fa 100644 --- a/src/constraint.F +++ b/src/constraint.F @@ -157,43 +157,51 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL shake_3x3_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL shake_4x6_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL shake_colv_int(molecule, particle_set, pos, vel, dt, ishake_int, & cell, imass, int_max_sigma) + END IF END DO Shake_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL shake_int_info(log_unit, i, ishake_int, max_sigma) ! Virtual Site - IF (nvsitecon /= 0) & + IF (nvsitecon /= 0) THEN CALL shake_vsite_int(molecule, pos) + END IF END DO END DO MOL ! Intermolecular constraints IF (do_ext_constraint) THEN CALL update_temporary_set(group, pos=pos, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL shake_3x3_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL shake_4x6_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL shake_colv_ext(gci, particle_set, pos, vel, dt, ishake_ext, & cell, imass, max_sigma) + END IF ! Virtual Site - IF (gci%nvsite /= 0) & + IF (gci%nvsite /= 0) THEN CALL shake_vsite_ext(gci, pos) + END IF CALL restore_temporary_set(particle_set, local_particles, pos=pos, vel=vel) END IF CALL shake_ext_info(log_unit, ishake_ext, max_sigma) @@ -283,15 +291,18 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL rattle_3x3_int(molecule, particle_set, vel, dt) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL rattle_4x6_int(molecule, particle_set, vel, dt) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL rattle_colv_int(molecule, particle_set, vel, dt, & irattle_int, cell, imass, int_max_sigma) + END IF END DO Rattle_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL rattle_int_info(log_unit, i, irattle_int, max_sigma) @@ -301,15 +312,18 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL rattle_3x3_ext(gci, particle_set, vel, dt) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL rattle_4x6_ext(gci, particle_set, vel, dt) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL rattle_colv_ext(gci, particle_set, vel, dt, & irattle_ext, cell, imass, max_sigma) + END IF CALL restore_temporary_set(particle_set, local_particles, vel=vel) END IF CALL rattle_ext_info(log_unit, irattle_ext, max_sigma) @@ -417,17 +431,20 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL shake_roll_3x3_int(molecule, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_int, int_max_sigma) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL shake_roll_4x6_int(molecule, particle_set, pos, vel, r_shake, & dt, ishake_int, int_max_sigma) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL shake_roll_colv_int(molecule, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_int, cell, imass, int_max_sigma) + END IF END DO Shake_Roll_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL shake_int_info(log_unit, i, ishake_int, max_sigma) @@ -441,20 +458,24 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, pos=pos, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL shake_roll_3x3_ext(gci, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_ext, max_sigma) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL shake_roll_4x6_ext(gci, particle_set, pos, vel, r_shake, & dt, ishake_ext, max_sigma) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL shake_roll_colv_ext(gci, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_ext, cell, imass, max_sigma) + END IF ! Virtual Site - IF (gci%nvsite /= 0) & + IF (gci%nvsite /= 0) THEN CPABORT("Virtual Site Constraint/Restraint not implemented for SHAKE_ROLL!") + END IF CALL restore_temporary_set(particle_set, local_particles, pos=pos, vel=vel) END IF CALL shake_ext_info(log_unit, ishake_ext, max_sigma) @@ -564,17 +585,20 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) & + IF (n3x3con /= 0) THEN CALL rattle_roll_3x3_int(molecule, particle_set, vel, r_rattle, dt, & veps) + END IF ! 4x6 - IF (n4x6con /= 0) & + IF (n4x6con /= 0) THEN CALL rattle_roll_4x6_int(molecule, particle_set, vel, r_rattle, dt, & veps) + END IF ! Collective Variables - IF (ncolv%ntot /= 0) & + IF (ncolv%ntot /= 0) THEN CALL rattle_roll_colv_int(molecule, particle_set, vel, r_rattle, dt, & irattle_int, veps, cell, imass, int_max_sigma) + END IF END DO Rattle_Roll_Intramolecular max_sigma = MAX(max_sigma, int_max_sigma) CALL rattle_int_info(log_unit, i, irattle_int, max_sigma) @@ -584,17 +608,20 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(para_env, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) & + IF (gci%ng3x3 /= 0) THEN CALL rattle_roll_3x3_ext(gci, particle_set, vel, r_rattle, dt, & veps) + END IF ! 4x6 - IF (gci%ng4x6 /= 0) & + IF (gci%ng4x6 /= 0) THEN CALL rattle_roll_4x6_ext(gci, particle_set, vel, r_rattle, dt, & veps) + END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) & + IF (gci%ncolv%ntot /= 0) THEN CALL rattle_roll_colv_ext(gci, particle_set, vel, r_rattle, dt, & irattle_ext, veps, cell, imass, max_sigma) + END IF CALL restore_temporary_set(particle_set, local_particles, vel=vel) END IF CALL rattle_ext_info(log_unit, irattle_ext, max_sigma) @@ -708,7 +735,7 @@ CONTAINS IF (log_unit > 0) THEN IF (id_type == "S") THEN label = "Shake Lagrangian Multipliers:" - ELSEIF (id_type == "R") THEN + ELSE IF (id_type == "R") THEN label = "Rattle Lagrangian Multipliers:" ELSE CPABORT("Only S for Shake or R for Rattle are supported for Lagrangian Multipliers") @@ -743,11 +770,12 @@ CONTAINS "Molecule Nr.:", i, " Nr. Iterations:", ishake_int, " Max. Err.:", max_sigma END IF ! Notify a not converged SHAKE - IF (ishake_int > Max_Shake_Iter) & + IF (ishake_int > Max_Shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Shake NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intramolecular constraint loop for Molecule nr. "//cp_to_string(i)// & ". CP2K continues but results could be meaningless. ") + END IF END SUBROUTINE shake_int_info ! ************************************************************************************************** @@ -769,10 +797,11 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged SHAKE - IF (ishake_ext > Max_Shake_Iter) & + IF (ishake_ext > Max_Shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Shake NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intermolecular constraint. CP2K continues but results could be meaningless.") + END IF END SUBROUTINE shake_ext_info ! ************************************************************************************************** @@ -794,11 +823,12 @@ CONTAINS "Molecule Nr.:", i, " Nr. Iterations:", irattle_int, " Max. Err.:", max_sigma END IF ! Notify a not converged RATTLE - IF (irattle_int > Max_shake_Iter) & + IF (irattle_int > Max_shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Rattle NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intramolecular constraint loop for Molecule nr. "//cp_to_string(i)// & ". CP2K continues but results could be meaningless.") + END IF END SUBROUTINE rattle_int_info ! ************************************************************************************************** @@ -820,10 +850,11 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged RATTLE - IF (irattle_ext > Max_shake_Iter) & + IF (irattle_ext > Max_shake_Iter) THEN CALL cp_warn(__LOCATION__, & "Rattle NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intermolecular constraint. CP2K continues but results could be meaningless.") + END IF END SUBROUTINE rattle_ext_info ! ************************************************************************************************** diff --git a/src/constraint_fxd.F b/src/constraint_fxd.F index 225416d12d..b4f9e7b7e8 100644 --- a/src/constraint_fxd.F +++ b/src/constraint_fxd.F @@ -398,8 +398,9 @@ CONTAINS DO k = 1, SIZE(fixd_list) IF (fixd_list(k)%fixd == j) THEN IF (fixd_list(k)%itype /= use_perd_xyz) CYCLE - IF (.NOT. fixd_list(k)%restraint%active) & + IF (.NOT. fixd_list(k)%restraint%active) THEN colvar%dsdr(:, i) = 0.0_dp + END IF EXIT END IF END DO diff --git a/src/constraint_util.F b/src/constraint_util.F index 0570c248f1..dec377128b 100644 --- a/src/constraint_util.F +++ b/src/constraint_util.F @@ -554,8 +554,8 @@ CONTAINS v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) diag = MATMUL(r_shake, v_shake) r_shake = diag - ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & - PRESENT(vector_r)) THEN + ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & + PRESENT(vector_r)) THEN DO i = 1, 3 r_shake(i, i) = vector_r(i)*vector_v(i) v_shake(i, i) = vector_v(i) @@ -569,7 +569,7 @@ CONTAINS diag(2, 2) = vector_v(2) diag(3, 3) = vector_v(3) v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) - ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN + ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN DO i = 1, 3 v_shake(i, i) = vector_v(i) END DO diff --git a/src/constraint_vsite.F b/src/constraint_vsite.F index 12c4cd96c5..ffdbb8ba52 100644 --- a/src/constraint_vsite.F +++ b/src/constraint_vsite.F @@ -94,14 +94,16 @@ CONTAINS molecule_kind => molecule%molecule_kind CALL get_molecule_kind(molecule_kind, nconstraint=nconstraint, nvsite=nvsitecon) IF (nconstraint == 0) CYCLE - IF (nvsitecon /= 0) & + IF (nvsitecon /= 0) THEN CALL force_vsite_int(molecule, particle_set) + END IF END DO END DO MOL ! Intermolecular Virtual Site Constraints IF (do_ext_constraint) THEN - IF (gci%nvsite /= 0) & + IF (gci%nvsite /= 0) THEN CALL force_vsite_ext(gci, particle_set) + END IF END IF END SUBROUTINE vsite_force_control diff --git a/src/core_ppl.F b/src/core_ppl.F index c1041e16d2..e47510449d 100644 --- a/src/core_ppl.F +++ b/src/core_ppl.F @@ -448,7 +448,7 @@ CONTAINS IF (ecp_semi_local) THEN CALL get_potential(potential=sgp_potential, sl_lmax=slmax, & npot=npot, nrpot=nrpot, apot=apot, bpot=bpot) - ELSEIF (ecp_local) THEN + ELSE IF (ecp_local) THEN IF (SUM(ABS(aloc(1:nloc))) < 1.0e-12_dp) CYCLE END IF ELSE @@ -498,7 +498,7 @@ CONTAINS rab, dab, rac, dac, rbc, dbc, & hab(:, :, iset, jset), ppl_work, pab(:, :, iset, jset), & force_a, force_b, ppl_fwork) - ELSEIF (libgrpp_local) THEN + ELSE IF (libgrpp_local) THEN !$OMP CRITICAL(type1) CALL libgrpp_local_forces_ref(la_max(iset), la_min(iset), npgfa(iset), & rpgfa(:, iset), zeta(:, iset), & @@ -556,7 +556,7 @@ CONTAINS CALL virial_pair_force(pv_thread, f0, force_a, rac) CALL virial_pair_force(pv_thread, f0, force_b, rbc) END IF - ELSEIF (do_dR) THEN + ELSE IF (do_dR) THEN hab2_w = 0._dp CALL ppl_integral( & la_max(iset), la_min(iset), npgfa(iset), & @@ -584,7 +584,7 @@ CONTAINS nexp_ppl, alpha_ppl, nct_ppl, cval_ppl, ppl_radius, & rab, dab, rac, dac, rbc, dbc, hab(:, :, iset, jset), ppl_work) - ELSEIF (libgrpp_local) THEN + ELSE IF (libgrpp_local) THEN !If the local part of the potential is more complex, we need libgrpp !$OMP CRITICAL(type1) CALL libgrpp_local_integrals(la_max(iset), la_min(iset), npgfa(iset), & diff --git a/src/core_ppnl.F b/src/core_ppnl.F index 906658762a..7fc2104d7e 100644 --- a/src/core_ppnl.F +++ b/src/core_ppnl.F @@ -667,7 +667,7 @@ CONTAINS END IF IF (do_dR) THEN - i = 1; j = 2; + i = 1; j = 2 katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN h_block(1:na, 1:nb) = h_block(1:na, 1:nb) + & @@ -686,7 +686,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 2; j = 3; + i = 2; j = 3 katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_2block(1:na, 1:nb) = r_2block(1:na, 1:nb) + & @@ -705,7 +705,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 3; j = 4; + i = 3; j = 4 katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_3block(1:na, 1:nb) = r_3block(1:na, 1:nb) + & diff --git a/src/cp2k_debug.F b/src/cp2k_debug.F index 3d288eeb82..c426ba1006 100644 --- a/src/cp2k_debug.F +++ b/src/cp2k_debug.F @@ -612,7 +612,7 @@ CONTAINS IF (dft_control%apply_efield) THEN dft_control%efield_fields(1)%efield%strength = amplitude dft_control%efield_fields(1)%efield%polarisation(1:3) = poldir(1:3) - ELSEIF (dft_control%apply_period_efield) THEN + ELSE IF (dft_control%apply_period_efield) THEN dft_control%period_efield%strength = amplitude dft_control%period_efield%polarisation(1:3) = poldir(1:3) ELSE diff --git a/src/cp2k_info.F b/src/cp2k_info.F index afd451a01d..cc90bc1d31 100644 --- a/src/cp2k_info.F +++ b/src/cp2k_info.F @@ -46,7 +46,7 @@ MODULE cp2k_info #endif !!! Keep version in sync with CMakeLists.txt !!! - CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.1 (Development Version)" + CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.2 (Development Version)" CHARACTER(LEN=*), PARAMETER :: cp2k_year = "2026" CHARACTER(LEN=*), PARAMETER :: cp2k_home = "https://www.cp2k.org/" diff --git a/src/cp_control_types.F b/src/cp_control_types.F index 47d3cb3bf7..4470a26447 100644 --- a/src/cp_control_types.F +++ b/src/cp_control_types.F @@ -891,8 +891,9 @@ CONTAINS SUBROUTINE mulliken_control_release(mulliken_restraint_control) TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken_restraint_control - IF (ASSOCIATED(mulliken_restraint_control%atoms)) & + IF (ASSOCIATED(mulliken_restraint_control%atoms)) THEN DEALLOCATE (mulliken_restraint_control%atoms) + END IF mulliken_restraint_control%strength = 0.0_dp mulliken_restraint_control%target = 0.0_dp mulliken_restraint_control%natoms = 0 @@ -927,10 +928,12 @@ CONTAINS SUBROUTINE ddapc_control_release(ddapc_restraint_control) TYPE(ddapc_restraint_type), INTENT(INOUT) :: ddapc_restraint_control - IF (ASSOCIATED(ddapc_restraint_control%atoms)) & + IF (ASSOCIATED(ddapc_restraint_control%atoms)) THEN DEALLOCATE (ddapc_restraint_control%atoms) - IF (ASSOCIATED(ddapc_restraint_control%coeff)) & + END IF + IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN DEALLOCATE (ddapc_restraint_control%coeff) + END IF ddapc_restraint_control%strength = 0.0_dp ddapc_restraint_control%target = 0.0_dp ddapc_restraint_control%natoms = 0 @@ -1207,18 +1210,21 @@ CONTAINS IF (ASSOCIATED(proj_mo_list)) THEN DO i = 1, SIZE(proj_mo_list) IF (ASSOCIATED(proj_mo_list(i)%proj_mo)) THEN - IF (ALLOCATED(proj_mo_list(i)%proj_mo%ref_mo_index)) & + IF (ALLOCATED(proj_mo_list(i)%proj_mo%ref_mo_index)) THEN DEALLOCATE (proj_mo_list(i)%proj_mo%ref_mo_index) + END IF IF (ALLOCATED(proj_mo_list(i)%proj_mo%mo_ref)) THEN DO mo_ref_nbr = 1, SIZE(proj_mo_list(i)%proj_mo%mo_ref) CALL cp_fm_release(proj_mo_list(i)%proj_mo%mo_ref(mo_ref_nbr)) END DO DEALLOCATE (proj_mo_list(i)%proj_mo%mo_ref) END IF - IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_index)) & + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_index)) THEN DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_index) - IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) & + END IF + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) THEN DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_occ) + END IF DEALLOCATE (proj_mo_list(i)%proj_mo) END IF END DO @@ -1244,8 +1250,9 @@ CONTAINS IF (ASSOCIATED(efield_fields(i)%efield%envelop_i_vars)) THEN DEALLOCATE (efield_fields(i)%efield%envelop_i_vars) END IF - IF (ASSOCIATED(efield_fields(i)%efield%polarisation)) & + IF (ASSOCIATED(efield_fields(i)%efield%polarisation)) THEN DEALLOCATE (efield_fields(i)%efield%polarisation) + END IF DEALLOCATE (efield_fields(i)%efield) END IF END DO diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index 3a2478e19e..abe607899e 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -164,20 +164,23 @@ CONTAINS CALL section_vals_val_get(xc_section, "gradient_cutoff", r_val=gradient_cut) CALL section_vals_val_get(xc_section, "tau_cutoff", r_val=tau_cut) ! Perform numerical stability checks and possibly correct the issues - IF (density_cut <= EPSILON(0.0_dp)*100.0_dp) & + IF (density_cut <= EPSILON(0.0_dp)*100.0_dp) THEN CALL cp_warn(__LOCATION__, & "DENSITY_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") + END IF density_cut = MAX(EPSILON(0.0_dp)*100.0_dp, density_cut) - IF (gradient_cut <= EPSILON(0.0_dp)*100.0_dp) & + IF (gradient_cut <= EPSILON(0.0_dp)*100.0_dp) THEN CALL cp_warn(__LOCATION__, & "GRADIENT_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") + END IF gradient_cut = MAX(EPSILON(0.0_dp)*100.0_dp, gradient_cut) - IF (tau_cut <= EPSILON(0.0_dp)*100.0_dp) & + IF (tau_cut <= EPSILON(0.0_dp)*100.0_dp) THEN CALL cp_warn(__LOCATION__, & "TAU_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") + END IF tau_cut = MAX(EPSILON(0.0_dp)*100.0_dp, tau_cut) CALL section_vals_val_set(xc_section, "density_cutoff", r_val=density_cut) CALL section_vals_val_set(xc_section, "gradient_cutoff", r_val=gradient_cut) @@ -242,7 +245,18 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - isize = -1 + SELECT CASE (tmpstringlist(1)) + CASE ("X") + ! Do nothing + CASE DEFAULT + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS: the size is invalid for the "// & + "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & + "use one of SMALL, MEDIUM, LARGE, HUGE for "// & + "the size. The syntax AUTO_BASIS X X is a "// & + "reserved case for using NO automatically "// & + "generated basis sets.") + END SELECT CASE ("SMALL") isize = 0 CASE ("MEDIUM") @@ -405,8 +419,9 @@ CONTAINS IF (dft_control%admm_control%purification_method == do_admm_purify_mo_diag .OR. & dft_control%admm_control%purification_method == do_admm_purify_mo_no_diag) THEN - IF (dft_control%admm_control%method /= do_admm_basis_projection) & + IF (dft_control%admm_control%method /= do_admm_basis_projection) THEN CPABORT("ADMM: Chosen purification requires BASIS_PROJECTION") + END IF IF (.NOT. do_ot) CPABORT("ADMM: MO-based purification requires OT.") END IF @@ -429,9 +444,10 @@ CONTAINS CALL section_vals_val_get(dft_section, "MULTIPLICITY", i_val=dft_control%multiplicity) CALL section_vals_val_get(dft_section, "RELAX_MULTIPLICITY", r_val=dft_control%relax_multiplicity) IF (dft_control%relax_multiplicity > 0.0_dp) THEN - IF (.NOT. dft_control%uks) & + IF (.NOT. dft_control%uks) THEN CALL cp_abort(__LOCATION__, "The option RELAX_MULTIPLICITY is only valid for "// & "unrestricted Kohn-Sham (UKS) calculations") + END IF END IF !Read the HAIR PROBES input section if present @@ -567,8 +583,9 @@ CONTAINS CALL section_vals_val_get(tmp_section, "POLARISATION", r_vals=pol) dft_control%period_efield%polarisation(1:3) = pol(1:3) IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) & + IF (ASSOCIATED(cell)) THEN CALL cell_transform_input_cartesian(cell, dft_control%period_efield%polarisation(1:3)) + END IF END IF CALL section_vals_val_get(tmp_section, "D_FILTER", r_vals=pol) dft_control%period_efield%d_filter(1:3) = pol(1:3) @@ -648,7 +665,12 @@ CONTAINS END IF ! periodic fields don't work with RTP - CPASSERT(.NOT. do_rtp) + IF (do_rtp) THEN + CALL cp_abort(__LOCATION__, & + "Periodic efield cannot be used with RTP. When restarting a "// & + "run with periodic efield, set RESTART_RTP under &EXT_RESTART "// & + "section to .FALSE. explicitly if RESTART_DEFAULT is .TRUE.") + END IF IF (dft_control%period_efield%displacement_field) THEN CALL cite_reference(Stengel2009) ELSE @@ -1217,8 +1239,9 @@ CONTAINS jj = jj + SIZE(tmplist) END DO qs_control%mulliken_restraint_control%natoms = jj - IF (qs_control%mulliken_restraint_control%natoms < 1) & + IF (qs_control%mulliken_restraint_control%natoms < 1) THEN CPABORT("Need at least 1 atom to use mulliken constraints") + END IF ALLOCATE (qs_control%mulliken_restraint_control%atoms(qs_control%mulliken_restraint_control%natoms)) jj = 0 DO k = 1, n_rep @@ -1266,10 +1289,11 @@ CONTAINS CALL section_vals_val_get(se_section, "INTEGRAL_SCREENING", & i_val=qs_control%se_control%integral_screening) IF (qs_control%method_id == do_method_pnnl) THEN - IF (qs_control%se_control%integral_screening /= do_se_IS_slater) & + IF (qs_control%se_control%integral_screening /= do_se_IS_slater) THEN CALL cp_warn(__LOCATION__, & "PNNL semi-empirical parameterization supports only the Slater type "// & "integral scheme. Revert to Slater and continue the calculation.") + END IF qs_control%se_control%integral_screening = do_se_IS_slater END IF ! Global Arrays variable @@ -1334,21 +1358,23 @@ CONTAINS qs_control%se_control%do_ewald = .FALSE. qs_control%se_control%do_ewald_r3 = .FALSE. qs_control%se_control%do_ewald_gks = .TRUE. - IF (qs_control%method_id /= do_method_pnnl) & + IF (qs_control%method_id /= do_method_pnnl) THEN CALL cp_abort(__LOCATION__, & "A periodic semi-empirical calculation was requested with a long-range "// & "summation on the single integral evaluation. This scheme is supported "// & "only by the PNNL parameterization.") + END IF CASE (do_se_lr_ewald_r3) qs_control%se_control%do_ewald = .TRUE. qs_control%se_control%do_ewald_r3 = .TRUE. qs_control%se_control%do_ewald_gks = .FALSE. - IF (qs_control%se_control%integral_screening /= do_se_IS_kdso) & + IF (qs_control%se_control%integral_screening /= do_se_IS_kdso) THEN CALL cp_abort(__LOCATION__, & "A periodic semi-empirical calculation was requested with a long-range "// & "summation for the slowly convergent part 1/R^3, which is not congruent "// & "with the integral screening chosen. The only integral screening supported "// & "by this periodic type calculation is the standard Klopman-Dewar-Sabelli-Ohno.") + END IF END SELECT ! dispersion pair potentials @@ -1412,18 +1438,21 @@ CONTAINS "DFTB/TBLITE_MIXER") IF (qs_control%do_ls_scf) THEN IF (dftb_scc_mixer_explicit .AND. & - qs_control%dftb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & + qs_control%dftb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN CALL cp_warn(__LOCATION__, & "DFTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - IF (dftb_tblite_mixer_explicit) & + END IF + IF (dftb_tblite_mixer_explicit) THEN CALL cp_warn(__LOCATION__, & "DFTB/TBLITE_MIXER settings are ignored with QS/LS_SCF; LS_SCF controls "// & "the density-matrix optimization.") + END IF qs_control%dftb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF - IF (qs_control%dftb_control%tblite_mixer_damping <= 0.0_dp) & + IF (qs_control%dftb_control%tblite_mixer_damping <= 0.0_dp) THEN CPABORT("DFTB/TBLITE_MIXER/DAMPING must be positive") + END IF CALL section_vals_val_get(dftb_section, "EPS_DISP", & r_val=qs_control%dftb_control%eps_disp) CALL section_vals_val_get(dftb_section, "DO_EWALD", explicit=explicit) @@ -1483,8 +1512,9 @@ CONTAINS CALL section_vals_val_get(xtb_tblite, "_SECTION_PARAMETERS_", l_val=tblite_section_active) qs_control%xtb_control%do_tblite = (qs_control%xtb_control%gfn_type == gfn_tblite) IF (qs_control%xtb_control%do_tblite) THEN - IF (.NOT. tblite_section_active) & + IF (.NOT. tblite_section_active) THEN CPABORT("XTB/GFN_TYPE TBLITE requires an XTB/TBLITE section") + END IF ! The CP2K-internal GFN1 defaults are still used to initialize shared xTB fields. qs_control%xtb_control%gfn_type = gfn1xtb ELSE IF (tblite_section_active) THEN @@ -1505,37 +1535,43 @@ CONTAINS qs_control%xtb_control%tblite_mixer_max_weight, & qs_control%xtb_control%tblite_mixer_weight_factor, & "XTB/TBLITE_MIXER") - IF (xtb_tblite_mixer_explicit) & + IF (xtb_tblite_mixer_explicit) THEN CALL section_vals_val_get(xtb_tblite_mixer, "DAMPING", & explicit=qs_control%xtb_control%tblite_mixer_damping_explicit) + END IF IF ((.NOT. qs_control%xtb_control%do_tblite) .AND. & qs_control%xtb_control%gfn_type == 0) THEN IF (xtb_scc_mixer_explicit .AND. & qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_auto .AND. & - qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE for CP2K-internal GFN0-xTB; "// & "GFN0-xTB has no SCC variables to mix.") - IF (xtb_tblite_mixer_explicit) & + END IF + IF (xtb_tblite_mixer_explicit) THEN CALL cp_warn(__LOCATION__, & "XTB/TBLITE_MIXER settings are ignored for CP2K-internal GFN0-xTB; "// & "GFN0-xTB has no SCC variables to mix.") + END IF qs_control%xtb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF IF (qs_control%do_ls_scf) THEN IF (xtb_scc_mixer_explicit .AND. & - qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - IF (xtb_tblite_mixer_explicit) & + END IF + IF (xtb_tblite_mixer_explicit) THEN CALL cp_warn(__LOCATION__, & "XTB/TBLITE_MIXER settings are ignored with QS/LS_SCF; LS_SCF controls "// & "the density-matrix optimization.") + END IF qs_control%xtb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF - IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) THEN CPABORT("XTB/TBLITE_MIXER/DAMPING must be positive") + END IF CALL section_vals_val_get(xtb_section, "DO_EWALD", explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(xtb_section, "DO_EWALD", & @@ -1855,14 +1891,17 @@ CONTAINS c_val=qs_control%xtb_control%tblite_param_file) CALL section_vals_val_get(xtb_tblite, "ACCURACY", & r_val=qs_control%xtb_control%tblite_accuracy) - IF (qs_control%xtb_control%tblite_accuracy <= 0.0_dp) & + IF (qs_control%xtb_control%tblite_accuracy <= 0.0_dp) THEN CPABORT("XTB/TBLITE/ACCURACY must be positive") - IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & + END IF + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) THEN CPABORT("XTB/TBLITE_MIXER/DAMPING must be positive") + END IF CALL section_vals_val_get(xtb_tblite, "REFERENCE_CLI", l_val=tblite_reference_cli) CALL section_vals_get(xtb_tblite_ref_cli, explicit=tblite_reference_cli_section) - IF (tblite_reference_cli .AND. (.NOT. tblite_reference_cli_section)) & + IF (tblite_reference_cli .AND. (.NOT. tblite_reference_cli_section)) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI keyword requires an XTB/TBLITE/REFERENCE_CLI section") + END IF IF (tblite_reference_cli .OR. tblite_reference_cli_section) THEN CALL read_xtb_reference_cli_section(xtb_tblite_ref_cli, qs_control%xtb_control%reference_cli, cell) qs_control%xtb_control%reference_cli%enabled = .TRUE. @@ -1926,8 +1965,9 @@ CONTAINS IF (omega0 <= 0.0_dp) CPABORT(TRIM(section_name)//"/OMEGA0 must be positive") IF (min_weight <= 0.0_dp) CPABORT(TRIM(section_name)//"/MIN_WEIGHT must be positive") IF (max_weight <= 0.0_dp) CPABORT(TRIM(section_name)//"/MAX_WEIGHT must be positive") - IF (max_weight < min_weight) & + IF (max_weight < min_weight) THEN CPABORT(TRIM(section_name)//"/MAX_WEIGHT must not be smaller than MIN_WEIGHT") + END IF IF (weight_factor <= 0.0_dp) CPABORT(TRIM(section_name)//"/WEIGHT_FACTOR must be positive") END SUBROUTINE read_tblite_mixer_section @@ -1976,11 +2016,13 @@ CONTAINS CALL section_vals_val_get(solvation_section, "SOLVENT", c_val=ref_cli%solvation_solvent) CALL section_vals_val_get(solvation_section, "BORN_KERNEL", i_val=ref_cli%solvation_born_kernel) CALL section_vals_val_get(solvation_section, "SOLUTION_STATE", i_val=ref_cli%solvation_state) - IF (LEN_TRIM(ref_cli%solvation_solvent) == 0) & + IF (LEN_TRIM(ref_cli%solvation_solvent) == 0) THEN CPABORT("REFERENCE_CLI implicit solvation needs SOLVENT") + END IF IF (ref_cli%solvation_model == tblite_cli_solvation_cpcm .AND. & - ref_cli%solvation_born_kernel /= tblite_cli_born_kernel_auto) & + ref_cli%solvation_born_kernel /= tblite_cli_born_kernel_auto) THEN CPABORT("BORN_KERNEL is invalid with MODEL CPCM") + END IF IF (ref_cli%solvation_state /= tblite_cli_solution_state_gsolv) THEN SELECT CASE (ref_cli%solvation_model) CASE (tblite_cli_solvation_alpb, tblite_cli_solvation_gbsa) @@ -1992,18 +2034,21 @@ CONTAINS END IF CALL section_vals_val_get(ref_cli_section, "ELECTRONIC_TEMPERATURE_GUESS", & r_val=ref_cli%electronic_temperature_guess) - IF (ref_cli%electronic_temperature_guess < 0.0_dp) & + IF (ref_cli%electronic_temperature_guess < 0.0_dp) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/ELECTRONIC_TEMPERATURE_GUESS must not be negative") - IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) & + END IF + IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/ELECTRONIC_TEMPERATURE_GUESS requires GUESS CEH") + END IF guess_section => section_vals_get_subs_vals(ref_cli_section, "GUESS_CLI") CALL section_vals_get(guess_section, explicit=ref_cli%guess_cli%enabled) IF (ref_cli%guess_cli%enabled) THEN CALL section_vals_val_get(guess_section, "METHOD", i_val=ref_cli%guess_cli%method) CALL section_vals_val_get(guess_section, "ELECTRONIC_TEMPERATURE_GUESS", & r_val=ref_cli%guess_cli%electronic_temperature_guess) - IF (ref_cli%guess_cli%electronic_temperature_guess < 0.0_dp) & + IF (ref_cli%guess_cli%electronic_temperature_guess < 0.0_dp) THEN CPABORT("REFERENCE_CLI/GUESS_CLI/ELECTRONIC_TEMPERATURE_GUESS must not be negative") + END IF CALL section_vals_val_get(guess_section, "SOLVER", i_val=ref_cli%guess_cli%solver) CALL section_vals_val_get(guess_section, "EFIELD", explicit=ref_cli%guess_cli%efield_active) IF (ref_cli%guess_cli%efield_active) THEN @@ -2034,10 +2079,12 @@ CONTAINS CALL section_vals_val_get(fit_section, "INPUT_FILE", c_val=ref_cli%fit_cli%input_file) CALL section_vals_val_get(fit_section, "DRY_RUN", l_val=ref_cli%fit_cli%dry_run) CALL section_vals_val_get(fit_section, "COPY", c_val=ref_cli%fit_cli%copy_file) - IF (LEN_TRIM(ref_cli%fit_cli%param_file) == 0) & + IF (LEN_TRIM(ref_cli%fit_cli%param_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/FIT_CLI needs PARAM_FILE") - IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) & + END IF + IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/FIT_CLI needs INPUT_FILE") + END IF END IF tagdiff_section => section_vals_get_subs_vals(ref_cli_section, "TAGDIFF_CLI") CALL section_vals_get(tagdiff_section, explicit=ref_cli%tagdiff_cli%enabled) @@ -2045,10 +2092,12 @@ CONTAINS CALL section_vals_val_get(tagdiff_section, "ACTUAL", c_val=ref_cli%tagdiff_cli%actual_file) CALL section_vals_val_get(tagdiff_section, "REFERENCE", c_val=ref_cli%tagdiff_cli%reference_file) CALL section_vals_val_get(tagdiff_section, "FIT", l_val=ref_cli%tagdiff_cli%fit) - IF (LEN_TRIM(ref_cli%tagdiff_cli%actual_file) == 0) & + IF (LEN_TRIM(ref_cli%tagdiff_cli%actual_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/TAGDIFF_CLI needs ACTUAL") - IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) & + END IF + IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) THEN CPABORT("XTB/TBLITE/REFERENCE_CLI/TAGDIFF_CLI needs REFERENCE") + END IF END IF CALL section_vals_val_get(ref_cli_section, "KEEP_FILES", l_val=ref_cli%keep_files) CALL section_vals_val_get(ref_cli_section, "ERROR_LIMIT", r_val=ref_cli%error_limit) @@ -2122,7 +2171,18 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - isize = -1 + SELECT CASE (tmpstringlist(1)) + CASE ("X") + ! Do nothing + CASE DEFAULT + CALL cp_abort(__LOCATION__, & + "AUTO_BASIS: the size is invalid for the "// & + "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & + "use one of SMALL, MEDIUM, LARGE, HUGE for "// & + "the size. The syntax AUTO_BASIS X X is a "// & + "reserved case for using NO automatically "// & + "generated basis sets.") + END SELECT CASE ("SMALL") isize = 0 CASE ("MEDIUM") @@ -2148,8 +2208,9 @@ CONTAINS END IF END DO - IF (t_control%conv < 0) & + IF (t_control%conv < 0) THEN t_control%conv = ABS(t_control%conv) + END IF ! DIPOLE_MOMENTS subsection dipole_section => section_vals_get_subs_vals(t_section, "DIPOLE_MOMENTS") @@ -2191,9 +2252,10 @@ CONTAINS CALL section_vals_val_get(mgrid_section, "PROGRESSION_FACTOR", & r_val=t_control%mgrid_progression_factor, explicit=explicit) IF (explicit) THEN - IF (t_control%mgrid_progression_factor <= 1.0_dp) & + IF (t_control%mgrid_progression_factor <= 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "Progression factor should be greater then 1.0 to ensure multi-grid ordering") + END IF ELSE t_control%mgrid_progression_factor = qs_control%progression_factor END IF @@ -2227,8 +2289,9 @@ CONTAINS IF (.NOT. explicit) t_control%mgrid_skip_load_balance = qs_control%skip_load_balance_distributed IF (ASSOCIATED(t_control%mgrid_e_cutoff)) THEN - IF (SIZE(t_control%mgrid_e_cutoff) /= t_control%mgrid_ngrids) & + IF (SIZE(t_control%mgrid_e_cutoff) /= t_control%mgrid_ngrids) THEN CPABORT("Inconsistent values for number of multi-grids") + END IF ! sort multi-grids in descending order according to their cutoff values t_control%mgrid_e_cutoff = -t_control%mgrid_e_cutoff @@ -2243,8 +2306,9 @@ CONTAINS xc_section => section_vals_get_subs_vals(t_section, "XC") xc_func => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL") CALL section_vals_get(xc_func, explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL xc_functionals_expand(xc_func, xc_section) + END IF ! sTDA subsection stda_section => section_vals_get_subs_vals(t_section, "STDA") @@ -2464,8 +2528,7 @@ CONTAINS dft_control%period_efield%strength END IF - IF (SQRT(DOT_PRODUCT(dft_control%period_efield%polarisation, & - dft_control%period_efield%polarisation)) < EPSILON(0.0_dp)) THEN + IF (NORM2(dft_control%period_efield%polarisation) < EPSILON(0.0_dp)) THEN CPABORT("Invalid (too small) polarisation vector specified for PERIODIC_EFIELD") END IF END IF @@ -2874,8 +2937,9 @@ CONTAINS ELSE WRITE (UNIT=output_unit, FMT="(T2,A,T71,F10.1)") & "QS| Density cutoff [a.u.]:", qs_control%cutoff - IF (qs_control%commensurate_mgrids) & + IF (qs_control%commensurate_mgrids) THEN WRITE (UNIT=output_unit, FMT="(T2,A)") "QS| Using commensurate multigrids" + END IF WRITE (UNIT=output_unit, FMT="(T2,A,T71,F10.1)") & "QS| Multi grid cutoff [a.u.]: 1) grid level", qs_control%e_cutoff(1) WRITE (UNIT=output_unit, FMT="(T2,A,I3,A,T71,F10.1)") & @@ -3005,9 +3069,10 @@ CONTAINS IF (qs_control%ddapc_restraint) THEN DO i = 1, SIZE(qs_control%ddapc_restraint_control) ddapc_restraint_control => qs_control%ddapc_restraint_control(i) - IF (SIZE(qs_control%ddapc_restraint_control) > 1) & + IF (SIZE(qs_control%ddapc_restraint_control) > 1) THEN WRITE (UNIT=output_unit, FMT="(T2,A,T3,I8)") & - "QS| parameters for DDAPC restraint number", i + "QS| parameters for DDAPC restraint number", i + END IF WRITE (UNIT=output_unit, FMT="(T2,A,T73,ES8.1)") & "QS| ddapc restraint target", ddapc_restraint_control%target WRITE (UNIT=output_unit, FMT="(T2,A,T73,ES8.1)") & @@ -3078,8 +3143,9 @@ CONTAINS IF (PRESENT(ddapc_restraint_section)) THEN IF (ASSOCIATED(qs_control%ddapc_restraint_control)) THEN - IF (SIZE(qs_control%ddapc_restraint_control) >= 2) & + IF (SIZE(qs_control%ddapc_restraint_control) >= 2) THEN CPABORT("ET_COUPLING cannot be used in combination with a normal restraint") + END IF ELSE ddapc_section => ddapc_restraint_section ALLOCATE (qs_control%ddapc_restraint_control(1)) @@ -3118,8 +3184,9 @@ CONTAINS END DO IF (jj < 1) CPABORT("Need at least 1 atom to use ddapc constraints") ddapc_restraint_control%natoms = jj - IF (ASSOCIATED(ddapc_restraint_control%atoms)) & + IF (ASSOCIATED(ddapc_restraint_control%atoms)) THEN DEALLOCATE (ddapc_restraint_control%atoms) + END IF ALLOCATE (ddapc_restraint_control%atoms(ddapc_restraint_control%natoms)) jj = 0 DO k = 1, n_rep @@ -3131,8 +3198,9 @@ CONTAINS END DO END DO - IF (ASSOCIATED(ddapc_restraint_control%coeff)) & + IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN DEALLOCATE (ddapc_restraint_control%coeff) + END IF ALLOCATE (ddapc_restraint_control%coeff(ddapc_restraint_control%natoms)) ddapc_restraint_control%coeff = 1.0_dp @@ -3144,13 +3212,15 @@ CONTAINS i_rep_val=k, r_vals=rtmplist) DO j = 1, SIZE(rtmplist) jj = jj + 1 - IF (jj > ddapc_restraint_control%natoms) & + IF (jj > ddapc_restraint_control%natoms) THEN CPABORT("Need the same number of coeff as there are atoms ") + END IF ddapc_restraint_control%coeff(jj) = rtmplist(j) END DO END DO - IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) & + IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) THEN CPABORT("Need no or the same number of coeff as there are atoms.") + END IF END DO k = 0 DO i = 1, SIZE(qs_control%ddapc_restraint_control) @@ -3339,12 +3409,13 @@ CONTAINS proj_mo_section => section_vals_get_subs_vals(rtp_section, "PRINT%PROJECTION_MO") CALL section_vals_get(proj_mo_section, explicit=is_present) IF (is_present) THEN - IF (dft_control%rtp_control%linear_scaling) & + IF (dft_control%rtp_control%linear_scaling) THEN CALL cp_abort(__LOCATION__, & "You have defined a time dependent projection of mos, but "// & "only the density matrix is propagated (DENSITY_PROPAGATION "// & ".TRUE.). Please either use MO-based real time DFT or do not "// & "define any PRINT%PROJECTION_MO section") + END IF dft_control%rtp_control%is_proj_mo = .TRUE. ELSE dft_control%rtp_control%is_proj_mo = .FALSE. @@ -3429,8 +3500,9 @@ CONTAINS DO i = 1, n_elems DO j = 1, 2 IF (dft_control%rtp_control%print_pol_elements(i, j) > 3 .OR. & - dft_control%rtp_control%print_pol_elements(i, j) < 1) & + dft_control%rtp_control%print_pol_elements(i, j) < 1) THEN CPABORT("Polarisation tensor element not 1,2 or 3 in at least one index") + END IF END DO END DO END IF @@ -3553,8 +3625,9 @@ CONTAINS END DO dft_control%probe(i)%natoms = jj - IF (dft_control%probe(i)%natoms < 1) & + IF (dft_control%probe(i)%natoms < 1) THEN CPABORT("Need at least 1 atom to use hair probes formalism") + END IF ALLOCATE (dft_control%probe(i)%atom_ids(dft_control%probe(i)%natoms)) jj = 0 diff --git a/src/cp_dbcsr_cholesky.F b/src/cp_dbcsr_cholesky.F index 5ba00f221a..8fdcc256cc 100644 --- a/src/cp_dbcsr_cholesky.F +++ b/src/cp_dbcsr_cholesky.F @@ -214,8 +214,9 @@ CONTAINS CALL copy_dbcsr_to_fm(matrixb, fm_matrixb) !CALL copy_dbcsr_to_fm(matrixout, fm_matrixout) - IF (op /= "SOLVE" .AND. op /= "MULTIPLY") & + IF (op /= "SOLVE" .AND. op /= "MULTIPLY") THEN CPABORT("wrong argument op") + END IF IF (PRESENT(pos)) THEN SELECT CASE (pos) diff --git a/src/cp_dbcsr_operations.F b/src/cp_dbcsr_operations.F index 46f66297ec..bb6ba62a78 100644 --- a/src/cp_dbcsr_operations.F +++ b/src/cp_dbcsr_operations.F @@ -611,8 +611,9 @@ CONTAINS row_blk_size, col_blk_size_right_out) CALL copy_fm_to_dbcsr(fm_in, in) - IF (ncol /= k_out .OR. my_beta /= 0.0_dp) & + IF (ncol /= k_out .OR. my_beta /= 0.0_dp) THEN CALL copy_fm_to_dbcsr(fm_out, out) + END IF CALL timeset(routineN//'_core', timing_handle_mult) CALL dbcsr_multiply("N", "N", my_alpha, matrix, in, my_beta, out, & @@ -648,8 +649,9 @@ CONTAINS n1 = SIZE(sizes1) n2 = SIZE(sizes2) - IF (n1 /= n2) & + IF (n1 /= n2) THEN CPABORT("distributions must be equal!") + END IF sizes1(1:n1) = sizes2(1:n1) used = SUM(sizes1(1:n1)) ! If sizes1 does not cover everything, then we increase the @@ -723,8 +725,9 @@ CONTAINS NULLIFY (col_dist_left) IF (ncol > 0) THEN - IF (.NOT. dbcsr_valid_index(sparse_matrix)) & + IF (.NOT. dbcsr_valid_index(sparse_matrix)) THEN CPABORT("sparse_matrix must pre-exist") + END IF ! ! Setup matrix_v CALL cp_fm_get_info(matrix_v, ncol_global=k) @@ -830,25 +833,6 @@ CONTAINS WRITE (*, *) 'PRESENT (matrix_g)', PRESENT(matrix_g) WRITE (*, *) 'matrix_type=', dbcsr_get_matrix_type(sparse_matrix) WRITE (*, *) 'norm(sm+alpha*v*g^t - fm+alpha*v*g^t)/n=', norm/REAL(nao, dp) - IF (norm/REAL(nao, dp) > 1e-12_dp) THEN - !WRITE(*,*) 'fm_matrix' - !DO j=1,SIZE(fm_matrix%local_data,2) - ! DO i=1,SIZE(fm_matrix%local_data,1) - ! WRITE(*,'(A,I3,A,I3,A,E26.16,A)') 'a(',i,',',j,')=',fm_matrix%local_data(i,j),';' - ! ENDDO - !ENDDO - !WRITE(*,*) 'mat_v' - !CALL dbcsr_print(mat_v) - !WRITE(*,*) 'mat_g' - !CALL dbcsr_print(mat_g) - !WRITE(*,*) 'sparse_matrix' - !CALL dbcsr_print(sparse_matrix) - !WRITE(*,*) 'sparse_matrix2 (-sm + sparse(fm))' - !CALL dbcsr_print(sparse_matrix2) - !WRITE(*,*) 'sparse_matrix3 (copy of sm input)' - !CALL dbcsr_print(sparse_matrix3) - !stop - END IF CALL dbcsr_release(sparse_matrix2) CALL dbcsr_release(sparse_matrix3) CALL cp_fm_release(fm_matrix) @@ -1025,11 +1009,13 @@ CONTAINS estimated_blocks = max_blocks_per_bin*nbins ALLOCATE (blk_dist(estimated_blocks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_dist") + END IF ALLOCATE (blk_sizes(estimated_blocks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_sizes") + END IF element_stack = 0 nblks = 0 DO blk_layer = 1, max_blocks_per_bin @@ -1051,23 +1037,27 @@ CONTAINS block_size => blk_sizes ELSE ALLOCATE (block_distribution(nblks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_dist") + END IF block_distribution(:) = blk_dist(1:nblks) DEALLOCATE (blk_dist) ALLOCATE (block_size(nblks), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_sizes") + END IF block_size(:) = blk_sizes(1:nblks) DEALLOCATE (blk_sizes) END IF ELSE ALLOCATE (block_distribution(0), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_dist") + END IF ALLOCATE (block_size(0), stat=stat) - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("blk_sizes") + END IF END IF 1579 FORMAT(I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5) IF (debug_mod) THEN diff --git a/src/cp_ddapc_forces.F b/src/cp_ddapc_forces.F index 979571da7f..7c30a8d718 100644 --- a/src/cp_ddapc_forces.F +++ b/src/cp_ddapc_forces.F @@ -217,7 +217,7 @@ CONTAINS END IF IF (iparticle1 /= iparticle2) THEN ra = rvec - r = SQRT(DOT_PRODUCT(ra, ra)) + r = NORM2(ra) t2 = -1.0_dp/(r*r)*factor drvec = ra/r*q1t*q2t d_el(1:3, iparticle1) = d_el(1:3, iparticle1) + t2*drvec diff --git a/src/cp_ddapc_methods.F b/src/cp_ddapc_methods.F index 5265a249ed..c8630ca686 100644 --- a/src/cp_ddapc_methods.F +++ b/src/cp_ddapc_methods.F @@ -204,7 +204,7 @@ CONTAINS iparticle2, istart_g, s_dim REAL(KIND=dp) :: g2, gcut2, tmp REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: my_Am, my_Amw - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq(:, :, :) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq !NB precalculate as many things outside of the innermost loop as possible, in particular w(ig)*gfunc(ig,igauus1)*gfunc(ig,igauss2) @@ -766,7 +766,7 @@ CONTAINS ! IF (iparticle1 /= iparticle2) THEN ra = rvec - r = SQRT(DOT_PRODUCT(ra, ra)) + r = NORM2(ra) my_val = factor/r END IF EwM(idim) = my_val - factor*g_ewald diff --git a/src/cp_ddapc_util.F b/src/cp_ddapc_util.F index 7fe0888cdc..d9ff69876d 100644 --- a/src/cp_ddapc_util.F +++ b/src/cp_ddapc_util.F @@ -355,7 +355,8 @@ CONTAINS bv(:) = 0.0_dp cv(:) = 1.0_dp/Vol CALL build_b_vector(bv, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut); bv(:) = bv(:)/Vol + particle_set, radii, rho_tot_g, gcut) + bv(:) = bv(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv) c1 = DOT_PRODUCT(cv, MATMUL(cp_ddapc_env%AmI, bv)) - ch_dens c1 = c1/cp_ddapc_env%c0 @@ -718,11 +719,13 @@ CONTAINS bv2(:) = 0.0_dp particle_set(iparticle)%r(i) = rvec(i) + dx CALL build_b_vector(bv1, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut); bv1(:) = bv1(:)/Vol + particle_set, radii, rho_tot_g, gcut) + bv1(:) = bv1(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv1) particle_set(iparticle)%r(i) = rvec(i) - dx CALL build_b_vector(bv2, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut); bv2(:) = bv2(:)/Vol + particle_set, radii, rho_tot_g, gcut) + bv2(:) = bv2(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv2) ddbv(:) = (bv1(:) - bv2(:))/(2.0_dp*dx) DO kk = 1, SIZE(ddbv) diff --git a/src/cp_eri_mme_interface.F b/src/cp_eri_mme_interface.F index b94212c6d3..d7e45fb6dc 100644 --- a/src/cp_eri_mme_interface.F +++ b/src/cp_eri_mme_interface.F @@ -563,8 +563,9 @@ CONTAINS WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Cutoff error:", param%par%err_c WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Total error (minimax + cutoff):", param%par%err_mm + param%par%err_c END IF - IF (param%par%print_calib) & + IF (param%par%print_calib) THEN WRITE (unit_nr, '(T2, A, T68, F13.10)') "ERI_MME| Minimax scaling constant in AM-GM estimate:", param%par%C_mm + END IF END IF END IF @@ -786,8 +787,9 @@ CONTAINS CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL", i_val=potential) CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL_PARAM", r_val=pot_par) - IF (nzet <= 0) & + IF (nzet <= 0) THEN CPABORT("Number of exponents NZET must be greater than 0.") + END IF CALL init_orbital_pointers(l_max) diff --git a/src/cp_external_control.F b/src/cp_external_control.F index 4b32395cde..3ae0189fef 100644 --- a/src/cp_external_control.F +++ b/src/cp_external_control.F @@ -63,8 +63,9 @@ CONTAINS external_comm = comm external_master_id = in_external_master_id - IF (PRESENT(in_scf_energy_message_tag)) & + IF (PRESENT(in_scf_energy_message_tag)) THEN scf_energy_message_tag = in_scf_energy_message_tag + END IF IF (PRESENT(in_exit_tag)) THEN ! the exit tag should be different from the mpi_probe tag default CPASSERT(in_exit_tag /= -1) @@ -203,7 +204,7 @@ CONTAINS IF (PRESENT(target_time)) THEN my_target_time = target_time my_start_time = start_time - ELSEIF (PRESENT(globenv)) THEN + ELSE IF (PRESENT(globenv)) THEN my_target_time = globenv%cp2k_target_time my_start_time = globenv%cp2k_start_time ELSE diff --git a/src/cp_subsys_methods.F b/src/cp_subsys_methods.F index e85b894a4c..73ce1a9e0a 100644 --- a/src/cp_subsys_methods.F +++ b/src/cp_subsys_methods.F @@ -128,16 +128,19 @@ CONTAINS subsys%para_env => para_env my_use_motion_section = .FALSE. - IF (PRESENT(use_motion_section)) & + IF (PRESENT(use_motion_section)) THEN my_use_motion_section = use_motion_section + END IF my_force_env_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL") - IF (PRESENT(force_env_section)) & + IF (PRESENT(force_env_section)) THEN my_force_env_section => force_env_section + END IF my_subsys_section => section_vals_get_subs_vals(my_force_env_section, "SUBSYS") - IF (PRESENT(subsys_section)) & + IF (PRESENT(subsys_section)) THEN my_subsys_section => subsys_section + END IF CALL section_vals_val_get(my_subsys_section, "SEED", i_vals=seed_vals) IF (SIZE(seed_vals) == 1) THEN @@ -288,8 +291,9 @@ CONTAINS CPASSERT(.NOT. ASSOCIATED(small_subsys)) CPASSERT(ASSOCIATED(big_subsys)) - IF (big_subsys%para_env /= small_para_env) & + IF (big_subsys%para_env /= small_para_env) THEN CPABORT("big_subsys%para_env==small_para_env") + END IF !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- diff --git a/src/cryssym.F b/src/cryssym.F index 4c28f5b550..5f8c7e52e5 100644 --- a/src/cryssym.F +++ b/src/cryssym.F @@ -1755,7 +1755,7 @@ CONTAINS csym%kplink(1, j) = i wkp(i) = wkp(i) + 1.0_dp kpop(j) = kr - ELSEIF (csym%kplink(1, j) /= i) THEN + ELSE IF (csym%kplink(1, j) /= i) THEN ! Approximate K290 operation sets need not be closed for structures whose ! coordinates lie close to several symmetry tolerances. Keep the existing ! disjoint orbit instead of aborting or double-counting this mesh point. diff --git a/src/csvr_system_types.F b/src/csvr_system_types.F index e4e349bce2..4095fc67c4 100644 --- a/src/csvr_system_types.F +++ b/src/csvr_system_types.F @@ -148,8 +148,9 @@ CONTAINS SUBROUTINE csvr_thermo_dealloc(nvt) TYPE(csvr_thermo_type), DIMENSION(:), POINTER :: nvt - IF (ASSOCIATED(nvt)) & + IF (ASSOCIATED(nvt)) THEN DEALLOCATE (nvt) + END IF END SUBROUTINE csvr_thermo_dealloc END MODULE csvr_system_types diff --git a/src/ct_methods.F b/src/ct_methods.F index 2aa855445a..22bc2f77a4 100644 --- a/src/ct_methods.F +++ b/src/ct_methods.F @@ -39,6 +39,7 @@ MODULE ct_methods USE iterate_matrix, ONLY: matrix_sqrt_Newton_Schulz USE kinds, ONLY: dp USE machine, ONLY: m_walltime + USE mathconstants, ONLY: pi #include "./base/base_uses.f90" IMPLICIT NONE @@ -1378,14 +1379,12 @@ CONTAINS INTEGER, INTENT(OUT) :: nmins INTEGER :: i, nroots - REAL(KIND=dp) :: DD, der, p, phi, pi, q, temp1, temp2, u, & - v, y1, y2, y2i, y2r, y3 + REAL(KIND=dp) :: DD, der, p, phi, q, temp1, temp2, u, v, & + y1, y2, y2i, y2r, y3 REAL(KIND=dp), DIMENSION(3) :: x ! CALL timeset(routineN,handle) - pi = ACOS(-1.0_dp) - ! Step 0: Check coefficients and find the true order of the eq IF (a == 0.0_dp) THEN IF (b == 0.0_dp) THEN @@ -1520,8 +1519,9 @@ CONTAINS ! create a matrix for eigenvectors CALL dbcsr_work_create(c, work_mutable=.TRUE.) - IF (do_eigenvalues) & + IF (do_eigenvalues) THEN CALL dbcsr_work_create(e, work_mutable=.TRUE.) + END IF CALL dbcsr_iterator_readonly_start(iter, matrix) diff --git a/src/ct_types.F b/src/ct_types.F index 2d93d0acc8..120685b60b 100644 --- a/src/ct_types.F +++ b/src/ct_types.F @@ -66,31 +66,6 @@ MODULE ct_types REAL(KIND=dp) :: energy_correction = 0.0_dp -!SPIN!!! ! metric matrices for covariant to contravariant transformations -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_up=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_down=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_up=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_down=>NULL() -!SPIN!!! -!SPIN!!! ! kohn-sham, covariant-covariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_ks=>NULL() -!SPIN!!! ! density, contravariant-contravariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_p=>NULL() -!SPIN!!! ! occ orbitals, contravariant-covariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_t=>NULL() -!SPIN!!! ! virt orbitals, contravariant-covariant representation -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_v=>NULL() -!SPIN!!! -!SPIN!!! ! to avoid building Occ-by-N and Virt-vy-N matrices inside -!SPIN!!! ! the ct routines get them from the external code -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_qp_template=>NULL() -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_pq_template=>NULL() -!SPIN!!! -!SPIN!!! ! single excitation amplitudes -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_x -!SPIN!!! ! residuals -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_res - ! metric matrices for covariant to contravariant transformations TYPE(dbcsr_type), POINTER :: p_index_up => NULL() TYPE(dbcsr_type), POINTER :: p_index_down => NULL() @@ -154,7 +129,6 @@ CONTAINS env%order_lanczos = 3 env%eps_lancsoz = 1.0E-4_dp env%max_iter_lanczos = 40 - !env%nspins = -1 env%converged = .FALSE. env%conjugator = cg_polak_ribiere @@ -231,22 +205,6 @@ CONTAINS qq_preconditioner_full, & pp_preconditioner_full -!INTEGER , OPTIONAL :: nspins -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_up -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_down -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_up -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_down -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_ks -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_p -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_t -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_v -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_qp_template -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_pq_template -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_x -!SPIN!!! -!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), OPTIONAL :: copy_matrix_x -!INTEGER :: ispin - IF (PRESENT(use_occ_orbs)) use_occ_orbs = env%use_occ_orbs IF (PRESENT(use_virt_orbs)) use_virt_orbs = env%use_virt_orbs IF (PRESENT(occ_orbs_orthogonal)) occ_orbs_orthogonal = & @@ -267,7 +225,6 @@ CONTAINS IF (PRESENT(eps_convergence)) eps_convergence = env%eps_convergence IF (PRESENT(eps_filter)) eps_filter = env%eps_filter IF (PRESENT(max_iter)) max_iter = env%max_iter - !IF (PRESENT(nspins)) nspins = env%nspins IF (PRESENT(matrix_ks)) matrix_ks => env%matrix_ks IF (PRESENT(matrix_p)) matrix_p => env%matrix_p IF (PRESENT(matrix_t)) matrix_t => env%matrix_t @@ -281,12 +238,8 @@ CONTAINS IF (PRESENT(p_index_down)) p_index_down => env%p_index_down IF (PRESENT(q_index_down)) q_index_down => env%q_index_down IF (PRESENT(copy_matrix_x)) THEN - !DO ispin=1,env%nspins - !CALL dbcsr_copy(copy_matrix_x(ispin),env%matrix_x(ispin)) CALL dbcsr_copy(copy_matrix_x, env%matrix_x) - !ENDDO END IF - !IF (PRESENT(matrix_x)) matrix_x => env%matrix_x IF (PRESENT(energy_correction)) energy_correction = env%energy_correction IF (PRESENT(converged)) converged = env%converged @@ -352,20 +305,6 @@ CONTAINS LOGICAL, OPTIONAL :: qq_preconditioner_full, & pp_preconditioner_full -!INTEGER , OPTIONAL :: nspins -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_up -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_down -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_up -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_down -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_ks -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_p -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_t -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_v -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_qp_template -!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_pq_template -! set para_env and blacs_env which are needed to operate with full matrices -! it would be nice to have everything with cp_dbcsr matrices, well maybe later - env%para_env => para_env env%blacs_env => blacs_env @@ -389,7 +328,6 @@ CONTAINS IF (PRESENT(eps_convergence)) env%eps_convergence = eps_convergence IF (PRESENT(eps_filter)) env%eps_filter = eps_filter IF (PRESENT(max_iter)) env%max_iter = max_iter - !IF (PRESENT(nspins)) env%nspins = nspins IF (PRESENT(conjugator)) env%conjugator = conjugator IF (PRESENT(matrix_ks)) env%matrix_ks => matrix_ks IF (PRESENT(matrix_p)) env%matrix_p => matrix_p @@ -415,18 +353,12 @@ CONTAINS TYPE(ct_step_env_type) :: env -!INTEGER :: ispin - NULLIFY (env%para_env) NULLIFY (env%blacs_env) !DO ispin=1,env%nspins CALL dbcsr_release(env%matrix_x) CALL dbcsr_release(env%matrix_res) - !CALL dbcsr_release(env%matrix_x(ispin)) - !CALL dbcsr_release(env%matrix_res(ispin)) - !ENDDO - !DEALLOCATE(env%matrix_x,env%matrix_res) NULLIFY (env%p_index_up) NULLIFY (env%p_index_down) diff --git a/src/dbm/dbm_api.F b/src/dbm/dbm_api.F index 7cb521797f..af1f6bc705 100644 --- a/src/dbm/dbm_api.F +++ b/src/dbm/dbm_api.F @@ -182,8 +182,9 @@ CONTAINS num_blocks_diff = ABS(num_blocks - num_blocks_dbcsr) IF (num_blocks_diff /= 0) THEN WRITE (*, *) "num_blocks mismatch dbcsr:", num_blocks_dbcsr, "new:", num_blocks - IF (DBM_VALIDATE_NBLOCKS_MATCH) & + IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN CPABORT("num_blocks mismatch") + END IF END IF IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN diff --git a/src/dbm/dbm_tests.F b/src/dbm/dbm_tests.F index ed7e5efcd3..ee10d2ee4d 100644 --- a/src/dbm/dbm_tests.F +++ b/src/dbm/dbm_tests.F @@ -439,7 +439,7 @@ CONTAINS INTEGER(KIND=int_8) :: map map = ((irow - 1 + icol*INT(nrow, int_8))*(1 + MODULO(ival, 2**16)))*2 + 1 + 0*ncol ! ncol used - iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12; ! keep odd + iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12 ! keep odd iseed(3) = INT(MODULO(IEOR(map, 3541_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(2) = INT(MODULO(IEOR(map, 1153_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(1) = INT(MODULO(IEOR(map, 2029_int_8), 2_int_8**12)); map = map/2_int_8**12 diff --git a/src/dbt/dbt_allocate_wrap.F b/src/dbt/dbt_allocate_wrap.F index a4e10a477b..19e02c8664 100644 --- a/src/dbt/dbt_allocate_wrap.F +++ b/src/dbt/dbt_allocate_wrap.F @@ -56,7 +56,7 @@ CONTAINS ELSE shape_prv = shape_spec END IF - ELSEIF (PRESENT(source)) THEN + ELSE IF (PRESENT(source)) THEN IF (PRESENT(order)) THEN shape_prv(order) = SHAPE(source) ELSE diff --git a/src/dbt/dbt_array_list_methods.F b/src/dbt/dbt_array_list_methods.F index e607940865..8b24135672 100644 --- a/src/dbt/dbt_array_list_methods.F +++ b/src/dbt/dbt_array_list_methods.F @@ -51,7 +51,7 @@ MODULE dbt_array_list_methods TYPE array_list INTEGER, DIMENSION(:), ALLOCATABLE :: col_data INTEGER, DIMENSION(:), ALLOCATABLE :: ptr - END TYPE + END TYPE array_list INTERFACE get_ith_array MODULE PROCEDURE allocate_and_get_ith_array @@ -128,7 +128,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE + END SUBROUTINE create_array_list ! ************************************************************************************************** !> \brief extract a subset of arrays @@ -151,7 +151,7 @@ CONTAINS CALL create_array_list(array_sublist, ndata, ${varlist("data", nmax=dim)}$) END IF #:endfor - END FUNCTION + END FUNCTION array_sublist ! ************************************************************************************************** !> \brief destroy array list. @@ -161,7 +161,7 @@ CONTAINS TYPE(array_list), INTENT(INOUT) :: list DEALLOCATE (list%ptr, list%col_data) - END SUBROUTINE + END SUBROUTINE destroy_array_list ! ************************************************************************************************** !> \brief Get all arrays contained in list @@ -185,7 +185,7 @@ CONTAINS o(1:ndata) = i_selected(:) ELSE ndata = number_of_arrays(list) - o(1:ndata) = (/(i, i=1, ndata)/) + o(1:ndata) = [(i, i=1, ndata)] END IF ASSOCIATE (ptr => list%ptr, col_data => list%col_data) @@ -215,7 +215,7 @@ CONTAINS END ASSOCIATE - END SUBROUTINE + END SUBROUTINE get_ith_array ! ************************************************************************************************** !> \brief get ith array @@ -231,7 +231,7 @@ CONTAINS ALLOCATE (array, source=col_data(ptr(i):ptr(i + 1) - 1)) END ASSOCIATE - END SUBROUTINE + END SUBROUTINE allocate_and_get_ith_array ! ************************************************************************************************** !> \brief sizes of arrays stored in list @@ -288,7 +288,7 @@ CONTAINS partial_sum = partial_sum + list_in%col_data(i_ptr) END DO END DO - END SUBROUTINE + END SUBROUTINE array_offsets ! ************************************************************************************************** !> \brief reorder array list. @@ -309,7 +309,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE + END SUBROUTINE reorder_arrays ! ************************************************************************************************** !> \brief check whether two array lists are equal @@ -320,7 +320,7 @@ CONTAINS LOGICAL :: check_equal check_equal = array_eq_i(list1%col_data, list2%col_data) .AND. array_eq_i(list1%ptr, list2%ptr) - END FUNCTION + END FUNCTION check_equal ! ************************************************************************************************** !> \brief check whether two arrays are equal @@ -337,6 +337,6 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION + END FUNCTION array_eq_i END MODULE dbt_array_list_methods diff --git a/src/dbt/dbt_methods.F b/src/dbt/dbt_methods.F index 1acfd36763..13cc921049 100644 --- a/src/dbt/dbt_methods.F +++ b/src/dbt/dbt_methods.F @@ -231,7 +231,7 @@ CONTAINS IF (.NOT. PRESENT(order)) THEN IF (array_eq_i(map1_in_1, map2_in_1) .AND. array_eq_i(map1_in_2, map2_in_2)) THEN dist_compatible_tas = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) - ELSEIF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN + ELSE IF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN dist_compatible_tensor = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) END IF END IF @@ -239,7 +239,7 @@ CONTAINS IF (dist_compatible_tas) THEN CALL dbt_tas_copy(out_tmp_1%matrix_rep, in_tmp_3%matrix_rep, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) - ELSEIF (dist_compatible_tensor) THEN + ELSE IF (dist_compatible_tensor) THEN CALL dbt_copy_nocomm(in_tmp_3, out_tmp_1, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) ELSE @@ -1274,7 +1274,7 @@ CONTAINS ALLOCATE (tensor2_out) CALL dbt_remap(tensor2, ind2_linked, ind2_free, tensor2_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata2, move_data=move_data_2) - ELSEIF (compat1 == 2) THEN ! linked index is second 2d dimension + ELSE IF (compat1 == 2) THEN ! linked index is second 2d dimension ! get distribution of linked index, tensor 2 must adopt this distribution ! get grid dimensions of linked index ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) @@ -1315,7 +1315,7 @@ CONTAINS ALLOCATE (tensor1_out) CALL dbt_remap(tensor1, ind1_linked, ind1_free, tensor1_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata1, move_data=move_data_1) - ELSEIF (compat2 == 2) THEN + ELSE IF (compat2 == 2) THEN ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) CALL dbt_get_mapping_info(dist_in%pgrid%nd_index_grid, dims2_2d=mp_dims) ALLOCATE (tensor1_out) @@ -1419,7 +1419,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_in%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN + ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1442,7 +1442,7 @@ CONTAINS IF (compat1 == 1 .AND. compat2 == 2) THEN trans = .FALSE. - ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN + ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN trans = .TRUE. ELSE CPABORT("this should not happen") @@ -1453,7 +1453,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_out%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN + ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1526,7 +1526,7 @@ CONTAINS compat_map = 0 IF (array_eq_i(map1, compat_ind)) THEN compat_map = 1 - ELSEIF (array_eq_i(map2, compat_ind)) THEN + ELSE IF (array_eq_i(map2, compat_ind)) THEN compat_map = 2 END IF diff --git a/src/dbt/dbt_split.F b/src/dbt/dbt_split.F index 20cd9d4d81..e3ac768476 100644 --- a/src/dbt/dbt_split.F +++ b/src/dbt/dbt_split.F @@ -272,7 +272,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE dbt_split_blocks_generic ! ************************************************************************************************** !> \brief Split tensor blocks into smaller blocks of maximum size PRODUCT(block_sizes). @@ -331,7 +331,7 @@ CONTAINS nodata=nodata) #:endfor - END SUBROUTINE + END SUBROUTINE dbt_split_blocks ! ************************************************************************************************** !> \brief Copy tensor with split blocks to tensor with original block sizes. @@ -480,7 +480,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE dbt_split_copyback ! ************************************************************************************************** !> \brief split two tensors with same total sizes but different block sizes such that they have @@ -503,7 +503,8 @@ CONTAINS INTEGER, DIMENSION(ndims_tensor(tensor1)), & INTENT(IN), OPTIONAL :: order LOGICAL, INTENT(IN), OPTIONAL :: nodata1, nodata2, move_data - INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, ${varlist("blk_size_split_2")}$, & + INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, & + ${varlist("blk_size_split_2")}$, & blk_size_d_1, blk_size_d_2, blk_size_d_split INTEGER :: size_sum_1, size_sum_2, size_sum, bind_1, bind_2, isplit, bs, idim, i LOGICAL :: move_prv, nodata1_prv, nodata2_prv @@ -551,7 +552,7 @@ CONTAINS size_sum = size_sum + bs isplit = isplit + 1 blk_size_d_split(isplit) = bs - ELSEIF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN + ELSE IF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN bind_2 = bind_2 + 1 bs = blk_size_d_2(bind_2) blk_size_d_1(bind_1 + 1) = blk_size_d_1(bind_1 + 1) - bs @@ -608,7 +609,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE + END SUBROUTINE dbt_make_compatible_blocks ! ************************************************************************************************** !> \author Patrick Seewald @@ -698,6 +699,6 @@ CONTAINS CALL dbt_copy_contraction_storage(tensor_in, tensor_out) CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE dbt_crop - END MODULE + END MODULE dbt_split diff --git a/src/dbt/dbt_types.F b/src/dbt/dbt_types.F index a7aa6929ad..1a7d1b14ba 100644 --- a/src/dbt/dbt_types.F +++ b/src/dbt/dbt_types.F @@ -211,7 +211,7 @@ CONTAINS CALL dbt_get_mapping_info(map_grid, & dims_2d=grid_dims, & dims1_2d=new_dbt_tas_dist_t%dims_grid) - ELSEIF (which_dim == 2) THEN + ELSE IF (which_dim == 2) THEN ALLOCATE (new_dbt_tas_dist_t%dims(ndims_mapping_column(map_blks))) ALLOCATE (index_map(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -335,7 +335,7 @@ CONTAINS dims_2d_i8=matrix_dims, & map1_2d=index_map, & dims1_2d=new_dbt_tas_blk_size_t%dims) - ELSEIF (which_dim == 2) THEN + ELSE IF (which_dim == 2) THEN ALLOCATE (index_map(ndims_mapping_column(map_blks))) ALLOCATE (new_dbt_tas_blk_size_t%dims(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -455,7 +455,7 @@ CONTAINS IF (idim /= SIZE(tensor_dims_sorted)) THEN dims(idim + 1:) = 0 CALL mp_dims_create(pdims_rem, dims(idim + 1:)) - ELSEIF (lb_ratio_prv < 0.5_dp) THEN + ELSE IF (lb_ratio_prv < 0.5_dp) THEN ! resort to a less strict load imbalance factor dims(:) = dims_store CALL dbt_mp_dims_create(nodes, dims, tensor_dims, 0.5_dp) @@ -836,7 +836,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(dist%refcount)) THEN abort = .TRUE. - ELSEIF (dist%refcount < 1) THEN + ELSE IF (dist%refcount < 1) THEN abort = .TRUE. END IF @@ -1264,7 +1264,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(tensor%refcount)) THEN abort = .TRUE. - ELSEIF (tensor%refcount < 1) THEN + ELSE IF (tensor%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_mm.F b/src/dbt/tas/dbt_tas_mm.F index 12d8654603..1050765b34 100644 --- a/src/dbt/tas/dbt_tas_mm.F +++ b/src/dbt/tas/dbt_tas_mm.F @@ -276,7 +276,7 @@ CONTAINS WRITE (unit_nr_prv, "(T4,A,T68,I13)") "Est. optimal split factor:", nsplit END IF - ELSEIF (batched_repl > 0) THEN + ELSE IF (batched_repl > 0) THEN nsplit = nsplit_batched nsplit_opt = nsplit max_mm_dim = max_mm_dim_batched @@ -342,7 +342,7 @@ CONTAINS IF (matrix_c%do_batched == 1) THEN matrix_c%mm_storage%batched_beta = beta - ELSEIF (matrix_c%do_batched > 1) THEN + ELSE IF (matrix_c%do_batched > 1) THEN matrix_c%mm_storage%batched_beta = matrix_c%mm_storage%batched_beta*beta END IF @@ -355,7 +355,7 @@ CONTAINS IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rs%matrix) IF (matrix_c%do_batched >= 1) matrix_c%mm_storage%store_batched => matrix_c_rs - ELSEIF (matrix_c%do_batched == 3) THEN + ELSE IF (matrix_c%do_batched == 3) THEN matrix_c_rs => matrix_c%mm_storage%store_batched END IF @@ -446,7 +446,7 @@ CONTAINS matrix_b%mm_storage%store_batched_repl => matrix_b_rep CALL dbt_tas_set_batched_state(matrix_b, state=3) END IF - ELSEIF (matrix_b%do_batched == 3) THEN + ELSE IF (matrix_b%do_batched == 3) THEN matrix_b_rep => matrix_b%mm_storage%store_batched_repl END IF @@ -532,14 +532,14 @@ CONTAINS matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) END IF - ELSEIF (matrix_c%do_batched == 2) THEN + ELSE IF (matrix_c%do_batched == 2) THEN ALLOCATE (matrix_c_rep) CALL dbt_tas_replicate(matrix_c_rs%matrix, dbt_tas_info(matrix_a_rs), matrix_c_rep, nodata=nodata_3) ! just leave sparsity structure for retain sparsity but no values IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rep%matrix) matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) - ELSEIF (matrix_c%do_batched == 3) THEN + ELSE IF (matrix_c%do_batched == 3) THEN matrix_c_rep => matrix_c%mm_storage%store_batched_repl END IF @@ -625,7 +625,7 @@ CONTAINS matrix_a%mm_storage%store_batched_repl => matrix_a_rep CALL dbt_tas_set_batched_state(matrix_a, state=3) END IF - ELSEIF (matrix_a%do_batched == 3) THEN + ELSE IF (matrix_a%do_batched == 3) THEN matrix_a_rep => matrix_a%mm_storage%store_batched_repl END IF @@ -740,7 +740,7 @@ CONTAINS CALL dbt_tas_destroy(matrix_c_rs) DEALLOCATE (matrix_c_rs) IF (PRESENT(filter_eps)) CALL dbt_tas_filter(matrix_c, filter_eps) - ELSEIF (matrix_c%do_batched > 0) THEN + ELSE IF (matrix_c%do_batched > 0) THEN IF (matrix_c%mm_storage%batched_out) THEN matrix_c%mm_storage%batched_trans = (transc_prv .NEQV. transc) END IF diff --git a/src/dbt/tas/dbt_tas_split.F b/src/dbt/tas/dbt_tas_split.F index aa7522631e..c9e7d8fb28 100644 --- a/src/dbt/tas/dbt_tas_split.F +++ b/src/dbt/tas/dbt_tas_split.F @@ -266,7 +266,7 @@ CONTAINS nsplit_list_square(count_square) = split count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split - ELSEIF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN + ELSE IF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split END IF @@ -277,10 +277,10 @@ CONTAINS IF (count_square > 0) THEN minpos = MINLOC(ABS(nsplit_list_square(1:count_square) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_square(minpos) - ELSEIF (count_accept > 0) THEN + ELSE IF (count_accept > 0) THEN minpos = MINLOC(ABS(nsplit_list_accept(1:count_accept) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_accept(minpos) - ELSEIF (count > 0) THEN + ELSE IF (count > 0) THEN minpos = MINLOC(ABS(nsplit_list(1:count) - nsplit), DIM=1) get_opt_nsplit = nsplit_list(minpos) ELSE @@ -462,7 +462,7 @@ CONTAINS IF (.NOT. ASSOCIATED(split_info%refcount)) THEN abort = .TRUE. - ELSEIF (split_info%refcount < 1) THEN + ELSE IF (split_info%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_util.F b/src/dbt/tas/dbt_tas_util.F index 0f8d27acd9..60f323a9d1 100644 --- a/src/dbt/tas/dbt_tas_util.F +++ b/src/dbt/tas/dbt_tas_util.F @@ -53,7 +53,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE + END SUBROUTINE swap_i8 ! ************************************************************************************************** !> \brief ... @@ -68,7 +68,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE + END SUBROUTINE swap_i ! ************************************************************************************************** !> \brief ... @@ -87,7 +87,7 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION + END FUNCTION array_eq_i ! ************************************************************************************************** !> \brief ... @@ -106,6 +106,6 @@ CONTAINS array_eq_i8 = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i8 = ALL(arr1 == arr2) #endif - END FUNCTION + END FUNCTION array_eq_i8 END MODULE diff --git a/src/dbx/cp_dbcsr_api.F b/src/dbx/cp_dbcsr_api.F index cdd57dca4e..bd02f16ab1 100644 --- a/src/dbx/cp_dbcsr_api.F +++ b/src/dbx/cp_dbcsr_api.F @@ -235,10 +235,11 @@ CONTAINS TYPE(dbcsr_type), POINTER :: matrix CALL dbcsr_release(matrix) - IF (dbcsr_valid_index(matrix)) & + IF (dbcsr_valid_index(matrix)) THEN CALL cp_abort(__LOCATION__, & 'You should not "deallocate" a referenced matrix. '// & 'Avoid pointers to DBCSR matrices.') + END IF DEALLOCATE (matrix) END SUBROUTINE dbcsr_deallocate_matrix diff --git a/src/debug_os_integrals.F b/src/debug_os_integrals.F index 49887cda40..19c1160f8f 100644 --- a/src/debug_os_integrals.F +++ b/src/debug_os_integrals.F @@ -75,7 +75,7 @@ CONTAINS ALLOCATE (swork(lds, lds, 1)) sab = 0._dp rab(:) = B(:) - A(:) - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) xa_work(1) = xa xb_work(1) = xb rpgfa = 20._dp @@ -219,11 +219,11 @@ CONTAINS !--------------------------------------- rab(:) = B(:) - A(:) - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) rac(:) = C(:) - A(:) - dac = SQRT(DOT_PRODUCT(rac, rac)) + dac = NORM2(rac) rbc(:) = C(:) - B(:) - dbc = SQRT(DOT_PRODUCT(rbc, rbc)) + dbc = NORM2(rbc) ALLOCATE (sabc(ncoset(la_max), ncoset(lb_max), ncoset(lc_max))) xa_work(1) = xa xb_work(1) = xb @@ -422,7 +422,7 @@ CONTAINS ALLOCATE (swork(lds, lds)) saabb = 0._dp rab(:) = B(:) - A(:) - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) xa_work1(1) = xa1 xa_work2(1) = xa2 xb_work1(1) = xb1 diff --git a/src/dft_plus_u.F b/src/dft_plus_u.F index de3bec26f0..0337c70cd1 100644 --- a/src/dft_plus_u.F +++ b/src/dft_plus_u.F @@ -189,7 +189,7 @@ CONTAINS !> \date 02.07.2008 !> \par !> \f{eqnarray*}{ -!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U}\\\ +!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U} !> & = & E^{\rm DFT} + \frac{1}{2}(U - J)\sum_\mu (q_\mu - q_\mu^2)\\[1ex] !> V_{\mu\nu}^{\rm DFT+U} & = & V_{\mu\nu}^{\rm DFT} + V_{\mu\nu}^{\rm U}\\\ !> & = & \frac{\partial E^{\rm DFT}} @@ -766,10 +766,11 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) & + IF (energy%dft_plus_u < 0.0_dp) THEN CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Lowdin charges!") + END IF ! Release (local) full matrices NULLIFY (fm_s_half) @@ -1991,10 +1992,11 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) & + IF (energy%dft_plus_u < 0.0_dp) THEN CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Mulliken charges!") + END IF ! Release local work storage diff --git a/src/distribution_2d_types.F b/src/distribution_2d_types.F index 8473cd37f5..a02fb10510 100644 --- a/src/distribution_2d_types.F +++ b/src/distribution_2d_types.F @@ -132,8 +132,9 @@ CONTAINS END IF IF (PRESENT(n_col_distribution)) THEN IF (ASSOCIATED(distribution_2d%col_distribution)) THEN - IF (n_col_distribution > distribution_2d%n_col_distribution) & + IF (n_col_distribution > distribution_2d%n_col_distribution) THEN CPABORT("n_col_distribution<=distribution_2d%n_col_distribution") + END IF ! else alloc col_distribution? END IF distribution_2d%n_col_distribution = n_col_distribution @@ -145,15 +146,17 @@ CONTAINS END IF IF (PRESENT(n_row_distribution)) THEN IF (ASSOCIATED(distribution_2d%row_distribution)) THEN - IF (n_row_distribution > distribution_2d%n_row_distribution) & + IF (n_row_distribution > distribution_2d%n_row_distribution) THEN CPABORT("n_row_distribution<=distribution_2d%n_row_distribution") + END IF ! else alloc row_distribution? END IF distribution_2d%n_row_distribution = n_row_distribution END IF - IF (PRESENT(local_rows_ptr)) & + IF (PRESENT(local_rows_ptr)) THEN distribution_2d%local_rows => local_rows_ptr + END IF IF (.NOT. ASSOCIATED(distribution_2d%local_rows)) THEN CPASSERT(PRESENT(n_local_rows)) ALLOCATE (distribution_2d%local_rows(SIZE(n_local_rows))) @@ -164,11 +167,13 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_rows(SIZE(distribution_2d%local_rows))) IF (PRESENT(n_local_rows)) THEN - IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) & + IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) THEN CPABORT("SIZE(distribution_2d%n_local_rows)==SIZE(n_local_rows)") + END IF DO i = 1, SIZE(distribution_2d%n_local_rows) - IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) & + IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) THEN CPABORT("SIZE(distribution_2d%local_rows(i)%array)>=n_local_rows(i)") + END IF distribution_2d%n_local_rows(i) = n_local_rows(i) END DO ELSE @@ -178,8 +183,9 @@ CONTAINS END DO END IF - IF (PRESENT(local_cols_ptr)) & + IF (PRESENT(local_cols_ptr)) THEN distribution_2d%local_cols => local_cols_ptr + END IF IF (.NOT. ASSOCIATED(distribution_2d%local_cols)) THEN CPASSERT(PRESENT(n_local_cols)) ALLOCATE (distribution_2d%local_cols(SIZE(n_local_cols))) @@ -190,11 +196,13 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_cols(SIZE(distribution_2d%local_cols))) IF (PRESENT(n_local_cols)) THEN - IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) & + IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) THEN CPABORT("SIZE(distribution_2d%n_local_cols)==SIZE(n_local_cols)") + END IF DO i = 1, SIZE(distribution_2d%n_local_cols) - IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) & + IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) THEN CPABORT("SIZE(distribution_2d%local_cols(i)%array)>=n_local_cols(i)") + END IF distribution_2d%n_local_cols(i) = n_local_cols(i) END DO ELSE @@ -315,8 +323,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%row_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%row_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) & + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -336,8 +345,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%col_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%col_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) & + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -355,8 +365,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_rows) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_rows(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) & + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -395,8 +406,9 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_cols) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_cols(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) & + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) THEN WRITE (unit=unit_nr, fmt='()') + END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE diff --git a/src/distribution_methods.F b/src/distribution_methods.F index c2a143497c..6442052837 100644 --- a/src/distribution_methods.F +++ b/src/distribution_methods.F @@ -207,12 +207,14 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_count, bin, bin_price, found) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("No topmost heap element found.") + END IF ipe = bin - IF (bin_price /= workload_count(ipe)) & + IF (bin_price /= workload_count(ipe)) THEN CPABORT("inconsistent heap") + END IF workload_count(ipe) = workload_count(ipe) + nload IF (ipe == mype) THEN @@ -245,12 +247,14 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_fill, bin, bin_price, found) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("No topmost heap element found.") + END IF ipe = bin - IF (bin_price /= workload_fill(ipe)) & + IF (bin_price /= workload_fill(ipe)) THEN CPABORT("inconsistent heap") + END IF workload_fill(ipe) = workload_fill(ipe) + nload is_local = (ipe == mype) @@ -275,8 +279,9 @@ CONTAINS END DO - IF (ANY(workload_fill /= workload_count)) & + IF (ANY(workload_fill /= workload_count)) THEN CPABORT("Inconsistent heaps encountered") + END IF CALL cp_heap_release(bin_heap_count) CALL cp_heap_release(bin_heap_fill) @@ -563,8 +568,9 @@ CONTAINS CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model) IF (.NOT. molecular_distribution) THEN DO iatom = 1, natom - IF (iatom > nclusters) & + IF (iatom > nclusters) THEN CPABORT("Bounds error") + END IF CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) cluster_list(iatom) = iatom SELECT CASE (cost_model) @@ -619,8 +625,9 @@ CONTAINS nprow, cluster_row_distribution(:, 1), npcol, cluster_col_distribution(:, 1)) ELSE IF (basic_cluster_optimization) THEN - IF (molecular_distribution) & + IF (molecular_distribution) THEN CPABORT("clustering and molecular blocking NYI") + END IF ALLOCATE (pbc_scaled_coords(3, natom), coords(3, natom)) DO iatom = 1, natom CALL real_to_scaled(pbc_scaled_coords(:, iatom), pbc(particle_set(iatom)%r(:), cell), cell) @@ -864,15 +871,18 @@ CONTAINS DO cluster_index = nclusters, 1, -1 cluster = cluster_list(cluster_index) CALL cp_heap_get_first(bin_heap, bin, bin_price, found) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("No topmost heap element found.") + END IF ! prow = INT((bin - 1)*pgrid_gcd/npcols) - IF (prow >= nprows) & + IF (prow >= nprows) THEN CPABORT("Invalid process row.") + END IF pcol = INT((bin - 1)*pgrid_gcd/nprows) - IF (pcol >= npcols) & + IF (pcol >= npcols) THEN CPABORT("Invalid process column.") + END IF row_distribution(cluster) = prow + 1 col_distribution(cluster) = pcol + 1 ! @@ -1197,7 +1207,7 @@ CONTAINS balance_new = MAXVAL(REAL(nat_cluster, KIND=dp))/MINVAL(REAL(nat_cluster, KIND=dp)) IF (balance_new < balance) THEN balance = balance_new - min_seed = seed + i*40; + min_seed = seed + i*40 END IF ELSE found = .TRUE. @@ -1314,7 +1324,7 @@ CONTAINS devi = HUGE(1.0_dp) DO j = 1, i - 1 dvec = pbc(cent_coord(:, j), cent_coord(:, i), cell) - dist = SQRT(DOT_PRODUCT(dvec, dvec)) + dist = NORM2(dvec) IF (dist < devi) devi = dist END DO rn = rng_stream%next() diff --git a/src/dm_ls_chebyshev.F b/src/dm_ls_chebyshev.F index 0b707213c6..ea57800af1 100644 --- a/src/dm_ls_chebyshev.F +++ b/src/dm_ls_chebyshev.F @@ -263,27 +263,33 @@ CONTAINS DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp1) - CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) !matrix_dummy2= - CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) !first term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) !second term of chebyshev poly(matrix) + !matrix_dummy2= + CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) + !first term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) + !second term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) END DO DO icheb = 2, ncheb - 1 t1 = m_walltime() + !matrix multiplication(Recursion) CALL dbcsr_multiply("N", "N", 2.0_dp, matrix_F, matrix_tmp2, & - -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) !matrix multiplication(Recursion) + -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL dbcsr_copy(matrix_tmp3, matrix_tmp1) CALL dbcsr_copy(matrix_tmp1, matrix_tmp2) CALL dbcsr_copy(matrix_tmp2, matrix_tmp3) - CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) !icheb+1 th coefficient + !icheb+1 th coefficient + CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) CALL kernel(kernel_g(icheb + 1), icheb + 1, ncheb) DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp2) - CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) !second term of chebyshev poly(matrix) + !second term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) CALL dbcsr_trace(matrix_dummy2(iwindow), trace=trace_dm(iwindow)) !icheb+1 th coefficient diff --git a/src/dm_ls_scf.F b/src/dm_ls_scf.F index e5d9d07e2c..97b662fb2b 100644 --- a/src/dm_ls_scf.F +++ b/src/dm_ls_scf.F @@ -588,7 +588,7 @@ CONTAINS DO ispin = 1, nspin IF (nonscf) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) - ELSEIF (ls_scf_env%do_rho_mixing) THEN + ELSE IF (ls_scf_env%do_rho_mixing) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) ELSE IF (iscf == 1) THEN @@ -657,10 +657,12 @@ CONTAINS IF (ls_scf_env%nspins == 1) nelectron_spin_real = nelectron_spin_real/2 IF (do_transport) THEN - IF (ls_scf_env%has_s_preconditioner) & + IF (ls_scf_env%has_s_preconditioner) THEN CPABORT("NOT YET IMPLEMENTED with S preconditioner. ") - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & + END IF + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN CPABORT("NOT YET IMPLEMENTED with molecular clustering. ") + END IF extra_scf = maxscf_reached .OR. scf_converged ! get the current Kohn-Sham matrix (ks) and return matrix_p evaluated using an external C routine @@ -691,11 +693,13 @@ CONTAINS eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos, & iounit=-1) CASE (ls_scf_pexsi) - IF (ls_scf_env%has_s_preconditioner) & + IF (ls_scf_env%has_s_preconditioner) THEN CPABORT("S preconditioning not implemented in combination with the PEXSI library. ") - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & + END IF + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN CALL cp_abort(__LOCATION__, & "Molecular clustering not implemented in combination with the PEXSI library. ") + END IF CALL density_matrix_pexsi(ls_scf_env%pexsi, ls_scf_env%matrix_p(ispin), ls_scf_env%pexsi%matrix_w(ispin), & ls_scf_env%pexsi%kTS(ispin), matrix_mixing_old(ispin), ls_scf_env%matrix_s, & nelectron_spin_real, ls_scf_env%mu_spin(ispin), iscf, ispin) @@ -834,8 +838,9 @@ CONTAINS END IF ! store the matrix for a next scf run - IF (.NOT. ls_scf_env%do_pao) & + IF (.NOT. ls_scf_env%do_pao) THEN CALL ls_scf_store_result(ls_scf_env) + END IF ! write homo and lumo energy and occupation (if not already part of the output) IF (ls_scf_env%curvy_steps) THEN @@ -908,8 +913,9 @@ CONTAINS END DO DEALLOCATE (ls_scf_env%matrix_ks) - IF (ls_scf_env%do_pexsi) & + IF (ls_scf_env%do_pexsi) THEN CALL pexsi_finalize_scf(ls_scf_env%pexsi, ls_scf_env%mu_spin) + END IF CALL timestop(handle) diff --git a/src/dm_ls_scf_create.F b/src/dm_ls_scf_create.F index f094e7e7d6..2ae4abd5c4 100644 --- a/src/dm_ls_scf_create.F +++ b/src/dm_ls_scf_create.F @@ -155,8 +155,9 @@ CONTAINS ! initialize PEXSI IF (ls_scf_env%do_pexsi) THEN - IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) & + IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) THEN CPABORT("EPS_FILTER_MATRIX must be set to 0 for PEXSI.") + END IF CALL lib_pexsi_init(ls_scf_env%pexsi, ls_scf_env%para_env, ls_scf_env%nspins) END IF @@ -263,8 +264,9 @@ CONTAINS CALL section_vals_get(mixing_section, explicit=ls_scf_env%do_rho_mixing) CALL section_vals_val_get(mixing_section, "METHOD", i_val=ls_scf_env%density_mixing_method) - IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) & + IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) THEN CPABORT("LS_DIIS and RHO_MIXING are not compatible.") + END IF pexsi_section => section_vals_get_subs_vals(input, "DFT%LS_SCF%PEXSI") CALL section_vals_get(pexsi_section) @@ -313,14 +315,18 @@ CONTAINS END SELECT ! verify some requirements for the curvy steps - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) & + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) THEN CPABORT("CURVY_STEPS cannot be used together with PEXSI.") - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) & + END IF + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) THEN CPABORT("CURVY_STEPS cannot be used together with TRANSPORT.") - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) & + END IF + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) THEN CPABORT("S Preconditioning not implemented in combination with CURVY_STEPS.") - IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) & + END IF + IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) THEN CPABORT("CURVY_STEPS requires the use of the sqrt inversion.") + END IF ! verify requirements for direct submatrix sign methods IF (ls_scf_env%sign_method == ls_scf_sign_submatrix & @@ -328,8 +334,9 @@ CONTAINS ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & - ) .AND. .NOT. ls_scf_env%sign_symmetric) & + ) .AND. .NOT. ls_scf_env%sign_symmetric) THEN CPABORT("DIRECT submatrix sign methods require SIGN_SYMMETRIC being set.") + END IF IF (ls_scf_env%fixed_mu .AND. ( & ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & diff --git a/src/dm_ls_scf_curvy.F b/src/dm_ls_scf_curvy.F index 1548418d0d..e1c9375c9b 100644 --- a/src/dm_ls_scf_curvy.F +++ b/src/dm_ls_scf_curvy.F @@ -95,9 +95,10 @@ CONTAINS ! If new search direction has to be computed transform H into the orthnormal basis - IF (ls_scf_env%curvy_data%line_search_step == 1) & + IF (ls_scf_env%curvy_data%line_search_step == 1) THEN CALL transform_matrix_orth(ls_scf_env%matrix_ks, ls_scf_env%matrix_s_sqrt_inv, & ls_scf_env%eps_filter) + END IF ! Set the energies for the line search and make sure to give the correct energy back to scf_main ls_scf_env%curvy_data%energies(lsstep) = energy diff --git a/src/dm_ls_scf_methods.F b/src/dm_ls_scf_methods.F index e74da48ab7..b51f08d513 100644 --- a/src/dm_ls_scf_methods.F +++ b/src/dm_ls_scf_methods.F @@ -516,8 +516,9 @@ CONTAINS IF (sign_symmetric) THEN - IF (.NOT. PRESENT(matrix_s_sqrt_inv)) & + IF (.NOT. PRESENT(matrix_s_sqrt_inv)) THEN CPABORT("Argument matrix_s_sqrt_inv required if sign_symmetric is set") + END IF CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv2, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) @@ -577,8 +578,9 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix + END IF IF (sign_symmetric) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & @@ -688,8 +690,9 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix + END IF CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & 0.0_dp, matrix_tmp, filter_eps=threshold) @@ -942,8 +945,9 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(trace_gx)) & + IF (abnormal_value(trace_gx)) THEN CPABORT("trace_gx is an abnormal value (NaN/Inf).") + END IF ! a branch of 1 or 2 appears to lead to a less accurate electron number count and premature exit ! if it turns out this does not exit because we get stuck in branch 1/2 for a reason we need to refine further @@ -969,13 +973,15 @@ CONTAINS CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_x_nosym, & 0.0_dp, matrix_p, filter_eps=threshold) - ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, where fk is evaluated using the stored values for gamma + ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, + ! where fk is evaluated using the stored values for gamma ! E. Rubensson et al., Chem Phys Lett 432, 2006, 591-594 - mu_a = 0.0_dp; mu_b = 1.0_dp; + mu_a = 0.0_dp; mu_b = 1.0_dp mu_fa = evaluate_trs4_polynomial(mu_a, gamma_values, i - 1) - 0.5_dp DO j = 1, 40 mu_c = 0.5*(mu_a + mu_b) - mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp ! i-1 because in the last iteration, only convergence is checked + ! i-1 because in the last iteration, only convergence is checked + mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp IF (ABS(mu_fc) < 1.0E-6_dp .OR. (mu_b - mu_a)/2 < 1.0E-6_dp) EXIT !TODO: define threshold values IF (mu_fc*mu_fa > 0) THEN diff --git a/src/dm_ls_scf_qs.F b/src/dm_ls_scf_qs.F index 7fc0b72aca..5ae581f005 100644 --- a/src/dm_ls_scf_qs.F +++ b/src/dm_ls_scf_qs.F @@ -322,8 +322,9 @@ CONTAINS CALL timeset(routineN, handle) my_keep_sparsity = .TRUE. - IF (PRESENT(keep_sparsity)) & + IF (PRESENT(keep_sparsity)) THEN my_keep_sparsity = keep_sparsity + END IF IF (.NOT. ls_mstruct%do_pao) THEN CALL dbcsr_create(matrix_declustered, template=matrix_qs) @@ -583,8 +584,9 @@ CONTAINS ! compute the corresponding KS matrix and new energy, mix density if requested CALL qs_rho_update_rho(rho, qs_env=qs_env) IF (ls_scf_env%do_rho_mixing) THEN - IF (ls_scf_env%density_mixing_method == direct_mixing_nr) & + IF (ls_scf_env%density_mixing_method == direct_mixing_nr) THEN CPABORT("Direct P mixing not implemented in linear scaling SCF. ") + END IF IF (ls_scf_env%density_mixing_method >= gspace_mixing_nr) THEN IF (iscf > MAX(ls_scf_env%mixing_store%nskip_mixing, 1)) THEN CALL gspace_mixing(qs_env, ls_scf_env%density_mixing_method, & @@ -839,9 +841,9 @@ CONTAINS CALL get_qs_env(qs_env, rho_atom_set=rho_atom) CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & ls_scf_env%para_env, rho_atom=rho_atom) - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(ls_scf_env%mixing_store) - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & diff --git a/src/dm_ls_scf_types.F b/src/dm_ls_scf_types.F index 07123e6801..1d26e1d570 100644 --- a/src/dm_ls_scf_types.F +++ b/src/dm_ls_scf_types.F @@ -208,10 +208,12 @@ CONTAINS DEALLOCATE (ls_scf_env%matrix_p) END IF - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) & + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) THEN CALL section_vals_release(ls_scf_env%chebyshev%print_key_dos) - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) & + END IF + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) THEN CALL section_vals_release(ls_scf_env%chebyshev%print_key_cube) + END IF IF (ASSOCIATED(ls_scf_env%chebyshev%min_energy)) THEN DEALLOCATE (ls_scf_env%chebyshev%min_energy) END IF @@ -228,8 +230,9 @@ CONTAINS CALL lib_pexsi_finalize(ls_scf_env%pexsi) END IF - IF (ls_scf_env%do_pao) & + IF (ls_scf_env%do_pao) THEN CALL pao_finalize(ls_scf_env%pao_env) + END IF DEALLOCATE (ls_scf_env) diff --git a/src/domain_submatrix_methods.F b/src/domain_submatrix_methods.F index b70d9fc507..ac020751c0 100644 --- a/src/domain_submatrix_methods.F +++ b/src/domain_submatrix_methods.F @@ -937,33 +937,6 @@ CONTAINS END DO - ! simple but quadratically scaling procedure - ! loop over local blocks - !CALL dbcsr_iterator_start(iter,matrix) - !DO WHILE (dbcsr_iterator_blocks_left(iter)) - ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& - ! row_size=row_size,col_size=col_size) - ! DO idomain = 1, ndomains - ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ELSE - ! domain_needs_block=(idomain==col& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ENDIF - ! IF (domain_needs_block) THEN - ! transp=.FALSE. - ! dest_node=node_of_domain(idomain) - ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& - ! ! idomain, idomain, transp, dest_node) - ! send_descriptor(1,dest_node+1)=send_descriptor(1,dest_node+1)+1 - ! send_descriptor(2,dest_node+1)=send_descriptor(2,dest_node+1)+& - ! row_size*col_size - ! ENDIF - ! ENDDO - !ENDDO - !CALL dbcsr_iterator_stop(iter) - ! communicate number of blocks and their sizes to the other nodes CALL group%alltoall(send_descriptor, recv_descriptor, ldesc) @@ -1058,15 +1031,6 @@ CONTAINS IF (block_node == myNode) THEN CALL dbcsr_get_block_p(matrix, row, col, block_p, found, row_size, col_size) IF (found) THEN - !col_offset=0 - !DO icol=1,col_size - ! start_data=send_offset_cpu(dest_node+1)+& - ! offset_block(dest_node+1)+& - ! col_offset - ! send_data(start_data+1:start_data+row_size)=& - ! data_p(1:row_size,icol) - ! col_offset=col_offset+row_size - !ENDDO col_offset = row_size*col_size start_data = send_offset_cpu(dest_node + 1) + & offset_block(dest_node + 1) @@ -1086,45 +1050,6 @@ CONTAINS END DO ! loop over rows END DO - ! more simple but quadratically scaling version - !CALL dbcsr_iterator_start(iter,matrix) - !DO WHILE (dbcsr_iterator_blocks_left(iter)) - ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& - ! row_size=row_size,col_size=col_size) - ! DO idomain = 1, ndomains - ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ELSE - ! domain_needs_block=(idomain==col& - ! .AND.qblk_exists(domain_map,row,idomain)) - ! ENDIF - ! IF (domain_needs_block) THEN - ! transp=.FALSE. - ! dest_node=node_of_domain(idomain) - ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& - ! ! idomain, idomain, transp, dest_node) - ! ! place the data appropriately - ! col_offset=0 - ! DO icol=1,col_size - ! start_data=send_offset_cpu(dest_node+1)+& - ! offset_block(dest_node+1)+& - ! col_offset - ! send_data(start_data+1:start_data+row_size)=& - ! data_p(1:row_size,icol) - ! col_offset=col_offset+row_size - ! ENDDO - ! offset_block(dest_node+1)=offset_block(dest_node+1)+col_size*row_size - ! ! fill out row,col information - ! send_data2(send_offset2_cpu(dest_node+1)+& - ! offset2_block(dest_node+1)+1)=row - ! send_data2(send_offset2_cpu(dest_node+1)+& - ! offset2_block(dest_node+1)+2)=col - ! offset2_block(dest_node+1)=offset2_block(dest_node+1)+2 - ! ENDIF - ! ENDDO - !ENDDO - !CALL dbcsr_iterator_stop(iter) ! send-receive all blocks CALL group%alltoall(send_data, send_size_cpu, send_offset_cpu, & @@ -1142,9 +1067,6 @@ CONTAINS ! copy blocks into submatrices CALL dbcsr_get_info(matrix, col_blk_size=col_blk_size, row_blk_size=row_blk_size) -! ALLOCATE(subm_row_size(ndomains),subm_col_size(ndomains)) -! subm_row_size(:)=0 -! subm_col_size(:)=0 ndomains2 = SIZE(submatrix) IF (ndomains2 /= ndomains) THEN CPABORT("wrong submatrix size") @@ -1159,9 +1081,6 @@ CONTAINS submatrix(:)%domain = -1 DO idomain = 1, ndomains dest_node = node_of_domain(idomain) - !transp=.FALSE. - !CALL dbcsr_get_stored_coordinates(distr_pattern,& - ! idomain, idomain, transp, dest_node) IF (dest_node == mynode) THEN submatrix(idomain)%domain = idomain submatrix(idomain)%nbrows = 0 @@ -1174,12 +1093,9 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) - !DO row = 1, nblkrows_tot - ! IF (qblk_exists(domain_map,row,idomain)) THEN first_row(row) = submatrix(idomain)%nrows + 1 submatrix(idomain)%nrows = submatrix(idomain)%nrows + row_blk_size(row) submatrix(idomain)%nbrows = submatrix(idomain)%nbrows + 1 - ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_row(submatrix(idomain)%nbrows)) ALLOCATE (submatrix(idomain)%size_brow(submatrix(idomain)%nbrows)) @@ -1190,12 +1106,9 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) - !DO row = 1, nblkrows_tot - ! IF (first_row(row).ne.-1) THEN submatrix(idomain)%dbcsr_row(smrow) = row submatrix(idomain)%size_brow(smrow) = row_blk_size(row) smrow = smrow + 1 - ! ENDIF END DO ! loop over the necessary columns @@ -1216,17 +1129,9 @@ CONTAINS ELSE col = idomain END IF - !DO col = 1, nblkcols_tot - ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain)) - ! ELSE - ! domain_needs_block=(col==idomain) ! RZK-warning col belongs to the domain - ! ENDIF - ! IF (domain_needs_block) THEN first_col(col) = submatrix(idomain)%ncols + 1 submatrix(idomain)%ncols = submatrix(idomain)%ncols + col_blk_size(col) submatrix(idomain)%nbcols = submatrix(idomain)%nbcols + 1 - ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_col(submatrix(idomain)%nbcols)) @@ -1250,12 +1155,9 @@ CONTAINS ELSE col = idomain END IF - !DO col = 1, nblkcols_tot - ! IF (first_col(col).ne.-1) THEN submatrix(idomain)%dbcsr_col(smcol) = col submatrix(idomain)%size_bcol(smcol) = col_blk_size(col) smcol = smcol + 1 - ! ENDIF END DO ALLOCATE (submatrix(idomain)%mdata( & diff --git a/src/ec_orth_solver.F b/src/ec_orth_solver.F index 1a8a904a72..65e07cfaf7 100644 --- a/src/ec_orth_solver.F +++ b/src/ec_orth_solver.F @@ -241,8 +241,9 @@ CONTAINS ! Tr(r_0 * r_0) CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, norm_rr(ispin)) - IF (abnormal_value(norm_rr(ispin))) & + IF (abnormal_value(norm_rr(ispin))) THEN CPABORT("Preconditioner: Tr[r_j*r_j] is an abnormal value (NaN/Inf)") + END IF IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0") norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp))) @@ -272,8 +273,9 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) & + IF (abnormal_value(new_norm(ispin))) THEN CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") + END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps*0.001_dp & @@ -710,8 +712,9 @@ CONTAINS CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin)) CPABORT("tr(Ap_j*p_j) < 0") - IF (abnormal_value(norm_cA(ispin))) & + IF (abnormal_value(norm_cA(ispin))) THEN CPABORT("Preconditioner: Tr[Ap_j*p_j] is an abnormal value (NaN/Inf)") + END IF END IF @@ -790,8 +793,9 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_z0(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) & + IF (abnormal_value(new_norm(ispin))) THEN CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") + END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps .OR. new_norm(ispin) < linres_control%eps) THEN diff --git a/src/eeq_data.F b/src/eeq_data.F index dc1bdef0d6..b030a0bde8 100644 --- a/src/eeq_data.F +++ b/src/eeq_data.F @@ -247,7 +247,7 @@ CONTAINS IF (PRESENT(eta)) eta = eeqGam(za) IF (PRESENT(kcn)) kcn = eeqkCN(za) IF (PRESENT(rad)) rad = eeqAlp(za) - ELSEIF (model == 2) THEN + ELSE IF (model == 2) THEN CPASSERT(za <= max_elem) IF (PRESENT(chi)) chi = eeq_chi(za) IF (PRESENT(eta)) eta = eeq_eta(za) diff --git a/src/eeq_method.F b/src/eeq_method.F index 7e86e08ea0..7e4c0f94f4 100644 --- a/src/eeq_method.F +++ b/src/eeq_method.F @@ -1611,7 +1611,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1693,7 +1693,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1764,7 +1764,7 @@ CONTAINS dfilter(1:3) = dft_control%period_efield%d_filter(1:3) fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi omega = cell%deth @@ -1882,7 +1882,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*dft_control%period_efield%strength use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer) diff --git a/src/efield_tb_methods.F b/src/efield_tb_methods.F index 11fbabcaf5..a7395d9325 100644 --- a/src/efield_tb_methods.F +++ b/src/efield_tb_methods.F @@ -281,7 +281,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'efield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) + COMPLEX(KIND=dp), DIMENSION(3) :: zi INTEGER :: atom_a, atom_b, handle, ia, iac, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, & @@ -334,7 +334,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -452,7 +452,7 @@ CONTAINS NULLIFY (sap_int) IF (dft_control%qs_control%dftb) THEN CPABORT("DFTB stress tensor for periodic efield not implemented") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL xtb_dsint_list(qs_env, sap_int) ELSE CPABORT("TB method unknown") @@ -612,7 +612,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'dfield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) + COMPLEX(KIND=dp), DIMENSION(3) :: zi INTEGER :: atom_a, atom_b, handle, i, ia, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, nspin @@ -674,7 +674,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/efield_utils.F b/src/efield_utils.F index 352369cdca..59efeb61bc 100644 --- a/src/efield_utils.F +++ b/src/efield_utils.F @@ -140,7 +140,7 @@ CONTAINS IF (DOT_PRODUCT(efield%polarisation, efield%polarisation) == 0) THEN pol(:) = 1.0_dp/3.0_dp ELSE - pol(:) = efield%polarisation(:)/(SQRT(DOT_PRODUCT(efield%polarisation, efield%polarisation))) + pol(:) = efield%polarisation(:)/NORM2(efield%polarisation) END IF SELECT CASE (efield%envelop_id) @@ -151,10 +151,12 @@ CONTAINS efield%phase_offset*pi)*pol(:) END IF CASE (ramp_env) - IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) & + IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) THEN strength = E_0*(sim_step - efield%envelop_i_vars(1))/(efield%envelop_i_vars(2) - efield%envelop_i_vars(1)) - IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) & + END IF + IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) THEN strength = E_0*(efield%envelop_i_vars(4) - sim_step)/(efield%envelop_i_vars(4) - efield%envelop_i_vars(3)) + END IF IF (sim_step > efield%envelop_i_vars(4) .AND. efield%envelop_i_vars(4) > 0) strength = 0.0_dp IF (sim_step <= efield%envelop_i_vars(1)) strength = 0.0_dp field = field + strength*COS(sim_time*nu*twopi + & diff --git a/src/eip_silicon.F b/src/eip_silicon.F index 1e5bf4d308..0d611e56c8 100644 --- a/src/eip_silicon.F +++ b/src/eip_silicon.F @@ -34,6 +34,7 @@ MODULE eip_silicon USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_para_env_type USE particle_types, ONLY: particle_type USE physcon, ONLY: angstrom,& @@ -926,25 +927,17 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & - ener_var, coord_var, count + REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + ener, coord, ener_var, coord_var, count - DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: s2, s3, sz - INTEGER, ALLOCATABLE, DIMENSION(:) :: num2, num3, numz - - REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, rlc3i, tcoord, & - tcoord2, tener, tener2 - INTEGER :: iam, iat, iat1, iat2, ii, i, il, in, indlst, indlstx, istop, & - istopg, l2, l3, laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, & - l1, myspaceout, ncx, nn, nnbrx, npr + INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & + laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, myspaceout, ncx, nn, nnbrx, npr + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb, num2, num3, numz + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, & + rlc3i, tcoord, tcoord2, tener, tener2 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz, s2, s3, sz, txyz ! cut=par_a cut = 3.1213820e0_dp + 1.e-14_dp @@ -1564,8 +1557,6 @@ CONTAINS END IF !$OMP END PARALLEL -! write(*,*) 'ener,norm force', & -! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2021,16 +2012,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz - INTEGER :: icell, lstb, lay - REAL(KIND=dp) :: rel, cut2 + REAL(KIND=dp) :: rxyz(3, nn) + INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst - DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & - lstb(0:myspace - 1), rel(5, 0:myspace - 1) - - INTEGER :: jat, k1, k2, k3, jj - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + INTEGER :: jat, jj, k1, k2, k3 + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -2091,25 +2079,18 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & - ener_var, coord_var, count + REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + ener, coord, ener_var, coord_var, count - DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik - - REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & - tcoord2, tener, tener2 - INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, & - istop, istopg, l1, l2, l3, ll1, ll2, ll3, lot, ncx, nn, & - nnbrx, npjkx, npjx, laymx, npr, rlc1i, rlc2i, rlc3i, & - myspace, myspaceout + INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & + laymx, ll1, ll2, ll3, lot, myspace, myspaceout, ncx, nn, nnbrx, npjkx, npjx, npr, rlc1i, & + rlc2i, rlc3i + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & + tcoord2, tener, tener2 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik, rel, rxyz, txyz ! tmax_phi= 0.4500000e+01_dp ! cut=tmax_phi @@ -2720,8 +2701,6 @@ CONTAINS END IF !$OMP END PARALLEL -! write(*,*) 'ener,norm force', & -! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2759,115 +2738,78 @@ CONTAINS ! with them and their contribution to the energy (tener). ! In addition the coordination number tcoord and the second moment of the ! local energy tener2 and coordination number tcoord2 are returned - INTEGER :: iat1, iat2, nat, lsta, lstb - REAL(KIND=dp) :: rel, tener, tener2, tcoord, tcoord2 + INTEGER :: iat1, iat2, nat, lsta(2, nat) + REAL(KIND=dp) :: tener, tener2, tcoord, tcoord2 INTEGER :: nnbrx - REAL(KIND=dp) :: txyz, f2ij + REAL(KIND=dp) :: rel(5, nnbrx*nat) + INTEGER :: lstb(nnbrx*nat) + REAL(KIND=dp) :: txyz(3, nat) INTEGER :: npjx - REAL(KIND=dp) :: f3ij + REAL(KIND=dp) :: f2ij(3, npjx) INTEGER :: npjkx - REAL(KIND=dp) :: f3ik + REAL(KIND=dp) :: f3ij(3, npjkx), f3ik(3, npjkx) INTEGER :: istop - DIMENSION lsta(2, nat), lstb(nnbrx*nat), rel(5, nnbrx*nat), txyz(3, nat) - DIMENSION f2ij(3, npjx), f3ij(3, npjkx), f3ik(3, npjkx) - REAL(KIND=dp), PARAMETER :: tmin_phi = 0.1500000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_phi = 0.4500000e+01_dp - REAL(KIND=dp), PARAMETER :: hi_phi = 3.00000000000e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_phi = 5.55555555555556e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_phi = 1.85185185185185e-002_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_phi = & - [0.69299400000000e+01_dp, -0.43995000000000e+00_dp, & - -0.17012300000000e+01_dp, -0.16247300000000e+01_dp, & - -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & - -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, & - -0.96100000000000e-02_dp, 0.00000000000000e+00_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_phi = & - [0.16533229480429e+03_dp, 0.39415410391417e+02_dp, & - 0.68710036300407e+01_dp, 0.53406950884203e+01_dp, & - 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & - -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, & - -0.40087646318907e-01_dp, -0.23942617684055e+00_dp] - REAL(KIND=dp), PARAMETER :: tmin_rho = 0.1500000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_rho = 0.3500000e+01_dp - REAL(KIND=dp), PARAMETER :: hi_rho = 5.00000000000e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_rho = 3.33333333333333e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_rho = 6.66666666666667e-003_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: cof_rho = & - [0.13747000000000e+00_dp, -0.14831000000000e+00_dp, & - -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & - -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, & - -0.66620000000000e+00_dp, -0.57328000000000e+00_dp, & - -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & - 0.00000000000000e+00_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: dof_rho = & - [-0.32275496741918e+01_dp, -0.64119006516165e+01_dp, & - 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & - 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, & - 0.47189016693543e+00_dp, 0.20569572748420e+01_dp, & - 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & - -0.12371959895186e+02_dp] - REAL(KIND=dp), PARAMETER :: tmin_fff = 0.1500000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp - REAL(KIND=dp), PARAMETER :: hi_fff = 4.50000000000e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_fff = 3.70370370370370e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_fff = & - [0.12503100000000e+01_dp, 0.86821000000000e+00_dp, & - 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & - 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, & - 0.27145000000000e+00_dp, 0.14814000000000e+00_dp, & - 0.48550000000000e-01_dp, 0.00000000000000e+00_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_fff = & - [0.27904652711432e+02_dp, -0.45230754228635e+01_dp, & - 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & - -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, & - -0.50891685571587e+00_dp, 0.66278396115427e+00_dp, & - 0.73976101109878e+00_dp, 0.25795319944506e+01_dp] - REAL(KIND=dp), PARAMETER :: tmin_uuu = -0.1770930e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_uuu = 0.7908520e+01_dp - REAL(KIND=dp), PARAMETER :: hi_uuu = 0.723181585730594e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_uuu = 0.230463095238095e0_dp - REAL(KIND=dp), PARAMETER :: h2sixth_uuu = 0.318679429600340e0_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_uuu = & - [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & - 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, & - 0.12668900000000e+01_dp, 0.16299800000000e+01_dp, & - 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_uuu = & - [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & - -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, & - -0.15815242579643e-01_dp, 0.26112640061855e-01_dp, & - -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] - REAL(KIND=dp), PARAMETER :: tmin_ggg = -0.1000000e+01_dp - REAL(KIND=dp), PARAMETER :: tmax_ggg = 0.8001400e+00_dp - REAL(KIND=dp), PARAMETER :: hi_ggg = 3.88858644327663e0_dp - REAL(KIND=dp), PARAMETER :: hsixth_ggg = 4.28604761904762e-002_dp - REAL(KIND=dp), PARAMETER :: h2sixth_ggg = 1.10221225156463e-002_dp - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_ggg = & - [0.52541600000000e+01_dp, 0.23591500000000e+01_dp, & - 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & - 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, & - 0.49485900000000e+01_dp, 0.56179900000000e+01_dp] - REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_ggg = & - [0.15826876132396e+02_dp, 0.31176239377907e+02_dp, & - 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & - 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, & - -0.18823313223755e+02_dp, -0.77183416481005e+01_dp] + REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: cof_rho = [0.13747000000000e+00_dp, & + -0.14831000000000e+00_dp, -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & + -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, -0.66620000000000e+00_dp, & + -0.57328000000000e+00_dp, -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & + 0.00000000000000e+00_dp] + REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: dof_rho = [-0.32275496741918e+01_dp, & + -0.64119006516165e+01_dp, 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & + 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, 0.47189016693543e+00_dp, & + 0.20569572748420e+01_dp, 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & + -0.12371959895186e+02_dp] + REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: cof_ggg = [0.52541600000000e+01_dp, & + 0.23591500000000e+01_dp, 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & + 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, 0.49485900000000e+01_dp, & + 0.56179900000000e+01_dp], cof_uuu = [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & + 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, 0.12668900000000e+01_dp, & + 0.16299800000000e+01_dp, 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] + REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: dof_ggg = [0.15826876132396e+02_dp, & + 0.31176239377907e+02_dp, 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & + 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, -0.18823313223755e+02_dp, & + -0.77183416481005e+01_dp], dof_uuu = [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & + -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, -0.15815242579643e-01_dp, & + 0.26112640061855e-01_dp, -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] + REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: cof_fff = [0.12503100000000e+01_dp, & + 0.86821000000000e+00_dp, 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & + 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, 0.27145000000000e+00_dp, & + 0.14814000000000e+00_dp, 0.48550000000000e-01_dp, 0.00000000000000e+00_dp], cof_phi = [ & + 0.69299400000000e+01_dp, -0.43995000000000e+00_dp, -0.17012300000000e+01_dp, & + -0.16247300000000e+01_dp, -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & + -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, -0.96100000000000e-02_dp, & + 0.00000000000000e+00_dp] + REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: dof_fff = [0.27904652711432e+02_dp, & + -0.45230754228635e+01_dp, 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & + -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, -0.50891685571587e+00_dp, & + 0.66278396115427e+00_dp, 0.73976101109878e+00_dp, 0.25795319944506e+01_dp], dof_phi = [ & + 0.16533229480429e+03_dp, 0.39415410391417e+02_dp, 0.68710036300407e+01_dp, & + 0.53406950884203e+01_dp, 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & + -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, -0.40087646318907e-01_dp, & + -0.23942617684055e+00_dp] + REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp, & + h2sixth_ggg = 1.10221225156463e-002_dp, h2sixth_phi = 1.85185185185185e-002_dp, & + h2sixth_rho = 6.66666666666667e-003_dp, h2sixth_uuu = 0.318679429600340e0_dp, & + hi_fff = 4.50000000000e0_dp, hi_ggg = 3.88858644327663e0_dp, hi_phi = 3.00000000000e0_dp, & + hi_rho = 5.00000000000e0_dp, hi_uuu = 0.723181585730594e0_dp, & + hsixth_fff = 3.70370370370370e-002_dp, hsixth_ggg = 4.28604761904762e-002_dp, & + hsixth_phi = 5.55555555555556e-002_dp, hsixth_rho = 3.33333333333333e-002_dp, & + hsixth_uuu = 0.230463095238095e0_dp + REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp, tmax_ggg = 0.8001400e+00_dp, & + tmax_phi = 0.4500000e+01_dp, tmax_rho = 0.3500000e+01_dp, tmax_uuu = 0.7908520e+01_dp, & + tmin_fff = 0.1500000e+01_dp, tmin_ggg = -0.1000000e+01_dp, tmin_phi = 0.1500000e+01_dp, & + tmin_rho = 0.1500000e+01_dp, tmin_uuu = -0.1770930e+01_dp - REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, & - b_ggg, cof1_fff, cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, & - cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, cof_fff_klo, & - cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, & - dens2, dens3, dof_fff_khi, dof_fff_klo, dof_ggg_khi, & - dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, ep_uuu, & - fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, & - gjik, gjikp, rho, rhop, rij, rik, sij, sik, t1, t2, t3, t4, & - tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, ypt2_fff, & - ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg - - INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, khi_fff, khi_ggg, & - klo_fff, klo_ggg + INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, & + khi_fff, khi_ggg, klo_fff, klo_ggg + REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, b_ggg, cof1_fff, & + cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, & + cof_fff_klo, cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, dens2, dens3, & + dof_fff_khi, dof_fff_klo, dof_ggg_khi, dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, & + ep_uuu, fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, gjik, gjikp, rho, rhop, & + rij, rik, sij, sik, t1, t2, t3, t4, tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, & + ypt2_fff, ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg ! initialize temporary private scalars for reduction sum on energies and ! private workarray txyz for forces forces @@ -3211,16 +3153,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz - INTEGER :: icell, lstb, lay - REAL(KIND=dp) :: rel, cut2 + REAL(KIND=dp) :: rxyz(3, nn) + INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst - DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & - lstb(0:myspace - 1), rel(5, 0:myspace - 1) - - INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, xrel, yrel, zrel, tti + INTEGER :: jat, jj, k1, k2, k3 + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel loop_k3: DO k3 = l3 - 1, l3 + 1 loop_k2: DO k2 = l2 - 1, l2 + 1 @@ -3268,14 +3207,14 @@ CONTAINS !> \param yp ... ! ************************************************************************************************** SUBROUTINE splint(ya, y2a, tmin, tmax, hsixth, h2sixth, hi, n, x, y, yp) - REAL(KIND=dp) :: ya, y2a, tmin, tmax, hsixth, h2sixth, hi + REAL(KIND=dp) :: tmin, tmax, hsixth, h2sixth, hi INTEGER :: n - REAL(KIND=dp) :: x, y, yp + REAL(KIND=dp) :: y2a(0:n - 1), ya(0:n - 1), x, y, yp - DIMENSION y2a(0:n - 1), ya(0:n - 1) - REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, tt, & - y2a_khi, ya_klo, y2a_klo, ya_khi, ypt1, ypt2, yt1, yt2 - INTEGER :: klo, khi + INTEGER :: khi, klo + REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, & + tt, y2a_khi, y2a_klo, ya_khi, ya_klo, & + ypt1, ypt2, yt1, yt2 ! interpolate if the argument is outside the cubic spline interval [tmin,tmax] tt = (x - tmin)*hi @@ -3356,15 +3295,15 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, real(8) : total potential energy, 2-body and 3-body, in eV -! count, real(8) : increased by 1.d0 at each call of this subroutine, -! needs to be initialized to 0.d0 before calling this routine for the first time +! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV +! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, +! needs to be initialized to 0._dp before calling this routine for the first time ! ! Other variables: ! p: the 2-body potential energy @@ -3377,9 +3316,12 @@ CONTAINS !***************************************************************************************** INTEGER :: nat - REAL(8) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + REAL(dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & etot, count + REAL(KIND=dp), PARAMETER :: eps = 2.167239428587_dp, ra = 1.8_dp, & + sigma = 2.0951_dp + INTEGER :: i, iam, iat, ii, il, in, indlst, & indlstx, ipb, l1, l2, l3, laymx, ll1, & ll2, ll3, myspace, myspaceout, ncx, & @@ -3387,18 +3329,14 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(8) :: cut, cut2, eps, esigma, fx(nat), & - fx3(nat), fy(nat), fy3(nat), fz(nat), & - fz3(nat), isigma, p, p3, pv3, ra, & - rlc1i, rlc2i, rlc3i, sigma - REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(dp) :: cut, cut2, esigma, fx(nat), fx3(nat), & + fy(nat), fy3(nat), fz(nat), fz3(nat), & + isigma, p, p3, pv3, rlc1i, rlc2i, rlc3i + REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - PARAMETER(ra=1.8d0) - PARAMETER(sigma=2.0951d0, eps=2.167239428587d0) - - count = count + 1.d0 - cut = sigma*ra*2.d0 - isigma = 1.d0/sigma + count = count + 1._dp + cut = sigma*ra*2._dp + isigma = 1._dp/sigma esigma = eps*isigma ! linear scaling calculation of verlet list, only serial @@ -3872,15 +3810,15 @@ CONTAINS !start energy and force calculation------------------------------------------------------- !set all variables to zero - p = 0.0d0 - p3 = 0.0d0 - pv3 = 0.0d0 - fx(:) = 0.0d0 - fy(:) = 0.0d0 - fz(:) = 0.0d0 - fx3(:) = 0.0d0 - fy3(:) = 0.0d0 - fz3(:) = 0.0d0 + p = 0.0_dp + p3 = 0.0_dp + pv3 = 0.0_dp + fx(:) = 0.0_dp + fy(:) = 0.0_dp + fz(:) = 0.0_dp + fx3(:) = 0.0_dp + fy3(:) = 0.0_dp + fz3(:) = 0.0_dp !----------------------------------------------------------------------------------------- ! triple loop for the 2 and 3-body forces ! do 20 i @@ -3916,23 +3854,22 @@ CONTAINS !> \param c ... !> \return ... ! ************************************************************************************************** - REAL(8) FUNCTION f(c) - REAL(8) :: c + REAL(KIND=dp) FUNCTION f(c) + REAL(KIND=dp) :: c - REAL(8) :: aa, bb, c4, crainv, ra + REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & + bb = 0.6022245584_dp, ra = 1.8_dp - PARAMETER(aa=7.049556277d0) - PARAMETER(ra=1.8d0, bb=0.6022245584d0) + REAL(KIND=dp) :: c4, crainv - IF ((c - ra) < 0.d0) THEN - crainv = 1.0d0/(c - ra) + IF ((c - ra) < 0._dp) THEN + crainv = 1.0_dp/(c - ra) c4 = c*c*c*c - f = aa*bb*4.0d0/(c4*c)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv + f = aa*bb*4.0_dp/(c4*c)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv ELSE - f = 0.d0 + f = 0._dp END IF - RETURN END FUNCTION f ! ************************************************************************************************** @@ -3940,18 +3877,17 @@ CONTAINS !> \param d ... !> \return ... ! ************************************************************************************************** - REAL(8) FUNCTION pe(d) - REAL(8) :: d + REAL(KIND=dp) FUNCTION pe(d) + REAL(KIND=dp) :: d - REAL(8), PARAMETER :: aa = 7.049556277d0, bb = 0.6022245584d0, & - ra = 1.8d0 + REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & + bb = 0.6022245584_dp, ra = 1.8_dp - IF ((d - ra) < 0.d0) THEN - pe = aa*(bb/(d*d*d*d) - 1.0d0)*dexp(1.0d0/(d - ra)) + IF ((d - ra) < 0._dp) THEN + pe = aa*(bb/(d*d*d*d) - 1.0_dp)*EXP(1.0_dp/(d - ra)) ELSE - pe = 0.d0 + pe = 0._dp END IF - RETURN END FUNCTION pe !------------------------------------------------------------------------------------------ @@ -3981,13 +3917,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(8) :: rxyz(3, nn) + REAL(KIND=dp) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(8) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(8) :: rr2, tt, tti, xrel, yrel, zrel + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -4004,7 +3940,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1.d0/tt + tti = 1._dp/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -4041,24 +3977,25 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE sw_subfeniat_l(i, nat, nnbrx, rel, p, p3, fx, fy, fz, fx3, fy3, fz3, lstb, lsta, isigma, sigma) INTEGER, INTENT(IN) :: i, nat, nnbrx - REAL(8), INTENT(IN) :: rel(5, nnbrx*nat) - REAL(8), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & + REAL(KIND=dp), INTENT(IN) :: rel(5, nnbrx*nat) + REAL(KIND=dp), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & fx3(nat), fy3(nat), fz3(nat) INTEGER, INTENT(IN) :: lstb(nnbrx*nat), lsta(2, nat) - REAL(8), INTENT(IN) :: isigma, sigma + REAL(KIND=dp), INTENT(IN) :: isigma, sigma + + REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & + bb = 0.6022245584_dp, gam = 1.2_dp, & + ra = 1.8_dp, ramda = 21.0_dp INTEGER :: Ipb, Ipe, j, k, l, m, nij - REAL(8) :: aa, bb, c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, & - gam, hi, hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, & - hiyik0, hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, & - hjxjk, hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, & - HJZIJ1, HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, & - hkyik0, hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, & - invrij, invrija, invrik, invrika, invrjk, invrjka, ra, ramda, refi, refj - REAL(8) :: refk, rij, rija, rik, rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk - - PARAMETER(gam=1.2d0, ramda=21.0d0, aa=7.049556277d0) - PARAMETER(ra=1.8d0, bb=0.6022245584d0) + REAL(KIND=dp) :: c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, hi, & + hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, hiyik0, & + hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, hjxjk, & + hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, HJZIJ1, & + HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, hkyik0, & + hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, invrij, & + invrija, invrik, invrika, invrjk, invrjka, refi, refj, refk, rij, rija, rik + REAL(KIND=dp) :: rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -4073,11 +4010,11 @@ CONTAINS yij = rel(2, l)*rij zij = rel(3, l)*rij - IF (rij >= 2.d0*ra) CYCLE + IF (rij >= 2._dp*ra) CYCLE IF (rij < ra) THEN - crainv = 1.0d0/(rij - ra) + crainv = 1.0_dp/(rij - ra) c4 = rij*rij*rij*rij - force = aa*bb*4.0d0/(c4*rij)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv + force = aa*bb*4.0_dp/(c4*rij)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv fx(i) = force*xij*invrij + fx(i) fy(i) = force*yij*invrij + fy(i) @@ -4087,7 +4024,7 @@ CONTAINS fy(j) = -force*yij*invrij + fy(j) fz(j) = -force*zij*invrij + fz(j) - p = p + aa*(bb/(rij*rij*rij*rij) - 1.0d0)*dexp(1.0d0/(rij - ra)) + p = p + aa*(bb/(rij*rij*rij*rij) - 1.0_dp)*EXP(1.0_dp/(rij - ra)) nij = 1 END IF @@ -4108,42 +4045,42 @@ CONTAINS zjk = zik - zij rjk = SQRT(xjk*xjk + yjk*yjk + zjk*zjk) - invrjk = 1.d0/rjk + invrjk = 1._dp/rjk IF ((rjk >= ra) .AND. (nij == 0)) CYCLE cosjik = (xij*xik + yij*yik + zij*zik)*(invrij*invrik) cosijk = (-xij*xjk - yij*yjk - zij*zjk)*(invrij*invrjk) cosikj = (xik*xjk + yik*yjk + zik*zjk)*(invrik*invrjk) - cosjik3 = cosjik + 1.0d0/3.0d0 - cosijk3 = cosijk + 1.0d0/3.0d0 - cosikj3 = cosikj + 1.0d0/3.0d0 + cosjik3 = cosjik + 1.0_dp/3.0_dp + cosijk3 = cosijk + 1.0_dp/3.0_dp + cosikj3 = cosikj + 1.0_dp/3.0_dp rija = rij - ra rika = rik - ra rjka = rjk - ra - invrija = 1.d0/rija - invrika = 1.d0/rika - invrjka = 1.d0/rjka + invrija = 1._dp/rija + invrika = 1._dp/rika + invrjka = 1._dp/rjka - IF (rija >= 0.0d0) THEN - refi = 0.0d0 - refj = 0.0d0 + IF (rija >= 0.0_dp) THEN + refi = 0.0_dp + refj = 0.0_dp refk = ramda*EXP(gam*invrika + gam*invrjka) - ELSE IF ((rija < 0.0d0) .AND. (rika < 0.0d0)) THEN - IF (rjka < 0.0d0) THEN + ELSE IF ((rija < 0.0_dp) .AND. (rika < 0.0_dp)) THEN + IF (rjka < 0.0_dp) THEN refi = ramda*EXP(gam*invrija + gam*invrika) refj = ramda*EXP(gam*invrija + gam*invrjka) refk = ramda*EXP(gam*invrika + gam*invrjka) ELSE refi = ramda*EXP(gam*invrija + gam*invrika) - refj = 0.0d0 - refk = 0.0d0 + refj = 0.0_dp + refk = 0.0_dp END IF - ELSE IF ((rija < 0.0d0) .AND. (rjka < 0.0d0)) THEN - refi = 0.0d0 + ELSE IF ((rija < 0.0_dp) .AND. (rjka < 0.0_dp)) THEN + refi = 0.0_dp refj = ramda*EXP(gam*invrija + gam*invrjka) - refk = 0.0d0 + refk = 0.0_dp ELSE CYCLE END IF @@ -4153,60 +4090,60 @@ CONTAINS hk = refk*cosikj3*cosikj3 p3 = p3 + hi + hj + hk - hixij0 = 2.0d0*(xik*invrik - xij*cosjik*invrij) + hixij0 = 2.0_dp*(xik*invrik - xij*cosjik*invrij) hixij1 = gam*xij*cosjik3*(invrija*invrija) hixij = refi*cosjik3*(hixij0 - hixij1)*invrij - hixik0 = 2.0d0*(xij*invrij - xik*cosjik*invrik) + hixik0 = 2.0_dp*(xij*invrij - xik*cosjik*invrik) hixik1 = gam*xik*cosjik3*(invrika*invrika) hixik = refi*cosjik3*(hixik0 - hixik1)*invrik - hjxij0 = 2.0d0*(-xjk*invrjk - xij*cosijk*invrij) + hjxij0 = 2.0_dp*(-xjk*invrjk - xij*cosijk*invrij) hjxij1 = gam*xij*cosijk3*(invrija*invrija) hjxij = refj*cosijk3*(hjxij0 - hjxij1)*invrij - hkxik0 = 2.0d0*(xjk*invrjk - xik*cosikj*invrik) + hkxik0 = 2.0_dp*(xjk*invrjk - xik*cosikj*invrik) hkxik1 = gam*xik*cosikj3*(invrika*invrika) hkxik = refk*cosikj3*(hkxik0 - hkxik1)*invrik - hjxjk0 = 2.0d0*(-xij*invrij - xjk*cosijk*invrjk) + hjxjk0 = 2.0_dp*(-xij*invrij - xjk*cosijk*invrjk) hjxjk1 = gam*xjk*cosijk3*(invrjka*invrjka) hjxjk = refj*cosijk3*(hjxjk0 - hjxjk1)*invrjk - hkxkj0 = 2.0d0*(-xik*invrik + xjk*cosikj*invrjk) + hkxkj0 = 2.0_dp*(-xik*invrik + xjk*cosikj*invrjk) hkxkj1 = gam*xjk*cosikj3*(invrjka*invrjka) hkxkj = refk*cosikj3*(hkxkj0 + hkxkj1)*invrjk - hiyij0 = 2.0d0*(yik*invrik - yij*cosjik*invrij) + hiyij0 = 2.0_dp*(yik*invrik - yij*cosjik*invrij) hiyij1 = gam*yij*cosjik3*(invrija*invrija) hiyij = refi*cosjik3*(hiyij0 - hiyij1)*invrij - hiyik0 = 2.0d0*(yij*invrij - yik*cosjik*invrik) + hiyik0 = 2.0_dp*(yij*invrij - yik*cosjik*invrik) hiyik1 = gam*yik*cosjik3*(invrika*invrika) hiyik = refi*cosjik3*(hiyik0 - hiyik1)*invrik - hjyij0 = 2.0d0*(-yjk*invrjk - yij*cosijk*invrij) + hjyij0 = 2.0_dp*(-yjk*invrjk - yij*cosijk*invrij) hjyij1 = gam*yij*cosijk3*(invrija*invrija) hjyij = refj*cosijk3*(hjyij0 - hjyij1)*invrij - hkyik0 = 2.0d0*(yjk*invrjk - yik*cosikj*invrik) + hkyik0 = 2.0_dp*(yjk*invrjk - yik*cosikj*invrik) hkyik1 = gam*yik*cosikj3*(invrika*invrika) hkyik = refk*cosikj3*(hkyik0 - hkyik1)*invrik - hjyjk0 = 2.0d0*(-yij*invrij - yjk*cosijk*invrjk) + hjyjk0 = 2.0_dp*(-yij*invrij - yjk*cosijk*invrjk) hjyjk1 = gam*yjk*cosijk3*(invrjka*invrjka) hjyjk = refj*cosijk3*(hjyjk0 - hjyjk1)*invrjk - hkykj0 = 2.0d0*(-yik*invrik + yjk*cosikj*invrjk) + hkykj0 = 2.0_dp*(-yik*invrik + yjk*cosikj*invrjk) hkykj1 = gam*yjk*cosikj3*(invrjka*invrjka) hkykj = refk*cosikj3*(hkykj0 + hkykj1)*invrjk - hizij0 = 2.0d0*(zik*invrik - zij*cosjik*invrij) + hizij0 = 2.0_dp*(zik*invrik - zij*cosjik*invrij) hizij1 = gam*zij*cosjik3*(invrija*invrija) hizij = refi*cosjik3*(hizij0 - hizij1)*invrij - hizik0 = 2.0d0*(zij*invrij - zik*cosjik*invrik) + hizik0 = 2.0_dp*(zij*invrij - zik*cosjik*invrik) hizik1 = gam*zik*cosjik3*(invrika*invrika) hizik = refi*cosjik3*(hizik0 - hizik1)*invrik - hjzij0 = 2.0d0*(-zjk*invrjk - zij*cosijk*invrij) + hjzij0 = 2.0_dp*(-zjk*invrjk - zij*cosijk*invrij) hjzij1 = gam*zij*cosijk3*(invrija*invrija) hjzij = refj*cosijk3*(hjzij0 - hjzij1)*invrij - hkzik0 = 2.0d0*(zjk*invrjk - zik*cosikj*invrik) + hkzik0 = 2.0_dp*(zjk*invrjk - zik*cosikj*invrik) hkzik1 = gam*zik*cosikj3*(invrika*invrika) hkzik = refk*cosikj3*(hkzik0 - hkzik1)*invrik - hjzjk0 = 2.0d0*(-zij*invrij - zjk*cosijk*invrjk) + hjzjk0 = 2.0_dp*(-zij*invrij - zjk*cosijk*invrjk) hjzjk1 = gam*zjk*cosijk3*(invrjka*invrjka) hjzjk = refj*cosijk3*(hjzjk0 - hjzjk1)*invrjk - hkzkj0 = 2.0d0*(-zik*invrik + zjk*cosikj*invrjk) + hkzkj0 = 2.0_dp*(-zik*invrik + zjk*cosikj*invrjk) hkzkj1 = gam*zjk*cosikj3*(invrjka*invrjka) hkzkj = refk*cosikj3*(hkzkj0 + hkzkj1)*invrjk @@ -4251,32 +4188,32 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, real(8) : total potential energy, 2-body and 3-body, in eV -! count, real(8) : increased by 1.d0 at each call of this subroutine, -! needs to be initialized to 0.d0 before calling this routine for the first time +! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV +! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, +! needs to be initialized to 0._dp before calling this routine for the first time !***************************************************************************************** INTEGER :: nat - REAL(8) :: alat(3), rxyz(3, nat), fxyz(3, nat), & + REAL(KIND=dp) :: alat(3), rxyz(3, nat), fxyz(3, nat), & etot, count INTEGER :: iat, NNmax, Npmax INTEGER, ALLOCATABLE, DIMENSION(:) :: Kinds, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - REAL(8) :: Uatot, Urtot, xbox, ybox, zbox - REAL(8), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf - REAL(8), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn - REAL(8), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X + REAL(KIND=dp) :: Uatot, Urtot, xbox, ybox, zbox + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf + REAL(KIND=dp), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn + REAL(KIND=dp), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X INTEGER:: nnbrx, nnbrxt INTEGER :: i - count = count + 1.d0 + count = count + 1._dp DO iat = 1, nat rxyz(1, iat) = MODULO(MODULO(rxyz(1, iat), alat(1)), alat(1)) @@ -4296,7 +4233,7 @@ CONTAINS DO i = 1, nat kinds(i) = 2 !Since all atoms are Si, all of kind 2 END DO - fxyz = 0.0d0 + fxyz = 0.0_dp xbox = alat(1); ybox = alat(2); zbox = alat(3) CALL tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) CALL tersoff_pairlist_energy_forces(nat, Npmax, NNmax, xbox, ybox, zbox, Kinds, rxyz, R1, R2, Cr, & @@ -4324,14 +4261,15 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) - REAL(8), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X - REAL(8), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass + REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X + REAL(KIND=dp), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass - REAL(8), PARAMETER :: C_ala = 2.2119d0, C_alr = 3.4879d0, C_b = 1.5724d-7, C_c = 3.8049d4, & - C_Ca = 3.4674d2, C_Cr = 1.3936d3, C_d = 4.3484d0, C_h = -5.7058d-1, C_mass = 12.0d0, & - C_n = 7.2751d-1, C_R1 = 1.8d0, C_R2 = 2.1d0, Si_ala = 1.7322d0, Si_alr = 2.4799d0, & - Si_b = 1.1000d-6, Si_c = 1.0039d5, Si_Ca = 4.7118d2, Si_Cr = 1.8308d3, Si_d = 1.6217d1, & - Si_h = -5.9825d-1, Si_mass = 28.0855d0, Si_n = 7.8734d-1, Si_R1 = 2.7d0, Si_R2 = 3.3d0 + REAL(KIND=dp), PARAMETER :: C_ala = 2.2119_dp, C_alr = 3.4879_dp, C_b = 1.5724e-7_dp, & + C_c = 3.8049e4_dp, C_Ca = 3.4674e2_dp, C_Cr = 1.3936e3_dp, C_d = 4.3484_dp, & + C_h = -5.7058e-1_dp, C_mass = 12.0_dp, C_n = 7.2751e-1_dp, C_R1 = 1.8_dp, C_R2 = 2.1_dp, & + Si_ala = 1.7322_dp, Si_alr = 2.4799_dp, Si_b = 1.1000e-6_dp, Si_c = 1.0039e5_dp, & + Si_Ca = 4.7118e2_dp, Si_Cr = 1.8308e3_dp, Si_d = 1.6217e1_dp, Si_h = -5.9825e-1_dp, & + Si_mass = 28.0855_dp, Si_n = 7.8734e-1_dp, Si_R1 = 2.7_dp, Si_R2 = 3.3_dp !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version @@ -4345,48 +4283,48 @@ CONTAINS !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version -!Increased Cutoff, originally 3.0d0 +!Increased Cutoff, originally 3.0_dp Cr(1, 1) = C_Cr Cr(2, 2) = Si_Cr - Cr(1, 2) = dsqrt(Cr(1, 1)*Cr(2, 2)) + Cr(1, 2) = SQRT(Cr(1, 1)*Cr(2, 2)) Cr(2, 1) = Cr(1, 2) Ca(1, 1) = C_Ca Ca(2, 2) = Si_Ca - Ca(1, 2) = dsqrt(Ca(1, 1)*Ca(2, 2)) + Ca(1, 2) = SQRT(Ca(1, 1)*Ca(2, 2)) Ca(2, 1) = Ca(1, 2) R1(1, 1) = C_R1 R1(2, 2) = Si_R1 - R1(1, 2) = dsqrt(R1(1, 1)*R1(2, 2)) + R1(1, 2) = SQRT(R1(1, 1)*R1(2, 2)) R1(2, 1) = R1(1, 2) R2(1, 1) = C_R2 R2(2, 2) = Si_R2 - R2(1, 2) = dsqrt(R2(1, 1)*R2(2, 2)) + R2(1, 2) = SQRT(R2(1, 1)*R2(2, 2)) R2(2, 1) = R2(1, 2) - X(1, 1) = 1.0d0 - X(2, 2) = 1.0d0 - X(1, 2) = 0.9776d0 - X(2, 1) = 0.9776d0 + X(1, 1) = 1.0_dp + X(2, 2) = 1.0_dp + X(1, 2) = 0.9776_dp + X(2, 1) = 0.9776_dp alr(1, 1) = C_alr alr(2, 2) = Si_alr - alr(1, 2) = 0.5d0*(alr(1, 1) + alr(2, 2)) + alr(1, 2) = 0.5_dp*(alr(1, 1) + alr(2, 2)) alr(2, 1) = alr(1, 2) ala(1, 1) = C_ala ala(2, 2) = Si_ala - ala(1, 2) = 0.5d0*(ala(1, 1) + ala(2, 2)) + ala(1, 2) = 0.5_dp*(ala(1, 1) + ala(2, 2)) ala(2, 1) = ala(1, 2) Pn(1) = C_n Pn(2) = Si_n - Co_bcd(1) = C_b*(1.0d0 + C_c*C_c/(C_d*C_d)) - Co_bcd(2) = Si_b*(1.0d0 + Si_c*Si_c/(Si_d*Si_d)) + Co_bcd(1) = C_b*(1.0_dp + C_c*C_c/(C_d*C_d)) + Co_bcd(2) = Si_b*(1.0_dp + Si_c*Si_c/(Si_d*Si_d)) bcsq(1) = C_b*C_c*C_c bcsq(2) = Si_b*Si_c*Si_c @@ -4439,35 +4377,32 @@ CONTAINS XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, & Pn, Co_bcd, bcsq, dsq, h, F, Uatot, dkEij) INTEGER, INTENT(in) :: Nmol, Npmax, NNmax - REAL(8), INTENT(in) :: xbox, ybox, zbox + REAL(KIND=dp), INTENT(in) :: xbox, ybox, zbox INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(8), DIMENSION(1:3*Nmol), INTENT(in) :: R - REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X - REAL(8), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf - REAL(8), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf - REAL(8), INTENT(out) :: Urtot + REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(in) :: R + REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X + REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf + REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf + REAL(KIND=dp), INTENT(out) :: Urtot INTEGER :: lsta(2, Nmol) INTEGER, INTENT(inout) :: nnbrx INTEGER :: lstb(nnbrx*Nmol) - REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(8), DIMENSION(1:3*Nmol), INTENT(out) :: F - REAL(8), INTENT(out) :: Uatot - REAL(8), DIMENSION(1:3*NNmax) :: dkEij + REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(out) :: F + REAL(KIND=dp), INTENT(out) :: Uatot + REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij INTEGER :: i, iam, iat, ii, il, in, indlst, indlstx, Ipb, istopg, jat, l1, l2, l3, laymx, & ll1, ll2, ll3, myspace, myspaceout, nat, ncx, ndat, nn, npjkx, npjx, npr, Nptot INTEGER, ALLOCATABLE, DIMENSION(:) :: lay INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(8) :: alat(3), cut, cut2, pi, rlc1i, rlc2i, & - rlc3i, rxyz0(3, Nmol), xhalf, yhalf, & - zhalf - REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(KIND=dp) :: alat(3), cut, cut2, rlc1i, rlc2i, rlc3i, & + rxyz0(3, Nmol), xhalf, yhalf, zhalf + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - pi = dacos(-1.0d0) - - xhalf = 0.5d0*xbox - yhalf = 0.5d0*ybox - zhalf = 0.5d0*zbox + xhalf = 0.5_dp*xbox + yhalf = 0.5_dp*ybox + zhalf = 0.5_dp*zbox nat = Nmol @@ -4950,29 +4885,28 @@ CONTAINS istopg = 0 !end of creating pairlist part------------------------------------------------------------ !Energy----------------------------------------------------------------------------------- - Urtot = 0.0d0 + Urtot = 0.0_dp Nptot = 0 - F = 0.0d0 - Uatot = 0.0d0 + F = 0.0_dp + Uatot = 0.0_dp DO_I: DO i = 1, Nmol - CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel, pi) + CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) END DO DO_I - Urtot = 0.5d0*Urtot + Urtot = 0.5_dp*Urtot !Force------------------------------------------------------------------------------------ - F = 0.0d0 - Uatot = 0.0d0 + F = 0.0_dp + Uatot = 0.0_dp DO_If: DO i = 1, Nmol CALL tersoff_subfiat_l(i,Nmol,Npmax,NNmax,Kinds,Pn,Co_bcd,bcsq,dsq,h,XYZRrefdf,UadUrdf,F,Uatot,dkEij,lsta,lstb,nnbrx) END DO DO_If - F = 0.5d0*F - Uatot = 0.5d0*Uatot + F = 0.5_dp*F + Uatot = 0.5_dp*Uatot !----------------------------------------------------------------------------------------- DEALLOCATE (rxyz, icell, lay, rel) - RETURN END SUBROUTINE tersoff_pairlist_energy_forces !----------------------------------------------------------------------------------------- @@ -5002,13 +4936,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(8) :: rxyz(3, nn) + REAL(KIND=dp) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(8) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(8) :: rr2, tt, tti, xrel, yrel, zrel + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -5025,7 +4959,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1.d0/tt + tti = 1._dp/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -5061,22 +4995,20 @@ CONTAINS !> \param lstb ... !> \param nnbrx ... !> \param rel ... -!> \param pi ... ! ************************************************************************************************** - SUBROUTINE tersoff_subeniat_l(i,Nmol,Npmax,Kinds,X,R1,R2,Cr,Ca,alr,ala,XYZRrefdf,UadUrdf,Urtot,lsta,lstb,nnbrx,rel,pi) +SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala - REAL(8), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf - REAL(8), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf - REAL(8), INTENT(inout) :: Urtot + REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala + REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf + REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf + REAL(KIND=dp), INTENT(inout) :: Urtot INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) - REAL(8), INTENT(in) :: rel(5, nnbrx*Nmol) - REAL(8) :: pi + REAL(KIND=dp), INTENT(in) :: rel(5, nnbrx*Nmol) INTEGER :: j, Ki, Kj, l, Nppt3, Nppt6, Nptot - REAL(8) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & + REAL(KIND=dp) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & R2ij, Rij, Rreij, Ua, Ur, Xij, Yij, Zij ! ####################################### @@ -5107,13 +5039,13 @@ CONTAINS alrij = alr(Ki, Kj) alaij = ala(Ki, Kj) - Ur = Cr(Ki, Kj)*dexp(-alrij*Rij) - Ua = -Ca(Ki, Kj)*dexp(-alaij*Rij)*X(Ki, Kj) + Ur = Cr(Ki, Kj)*EXP(-alrij*Rij) + Ua = -Ca(Ki, Kj)*EXP(-alaij*Rij)*X(Ki, Kj) R1ij = R1(Ki, Kj) IF (Rij <= R1ij) THEN - XYZRrefdf(Nppt6 + 5) = 1.0d0 - XYZRrefdf(Nppt6 + 6) = 0.0d0 + XYZRrefdf(Nppt6 + 5) = 1.0_dp + XYZRrefdf(Nppt6 + 6) = 0.0_dp Urtot = Urtot + Ur UadUrdf(Nppt3 + 1) = Ua UadUrdf(Nppt3 + 2) = -alrij*Ur @@ -5121,8 +5053,8 @@ CONTAINS ELSE PL1 = pi/(R2ij - R1ij) PL2 = PL1*(Rij - R1ij) - fij = 0.5d0 + 0.5d0*dcos(PL2) - dfij = -0.5d0*PL1*dsin(PL2) + fij = 0.5_dp + 0.5_dp*COS(PL2) + dfij = -0.5_dp*PL1*SIN(PL2) XYZRrefdf(Nppt6 + 5) = fij XYZRrefdf(Nppt6 + 6) = dfij Urtot = Urtot + fij*Ur @@ -5158,20 +5090,20 @@ CONTAINS INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax, NNmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(8), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf - REAL(8), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf - REAL(8), DIMENSION(1:3*Nmol), INTENT(inout) :: F - REAL(8), INTENT(inout) :: Uatot - REAL(8), DIMENSION(1:3*NNmax) :: dkEij + REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf + REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf + REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(inout) :: F + REAL(KIND=dp), INTENT(inout) :: Uatot + REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) INTEGER :: ij, ijpt3, ijpt6, ik, ikpt6, Ipb, Ipe, & Ipt3, Jpt3, Ki, Kpt3, Nkpt3 - REAL(8) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, Co_mb2, & - Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, dGi, & - djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, Rreij, & - Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik + REAL(KIND=dp) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, & + Co_mb2, Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, & + dGi, djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, & + Rreij, Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -5184,9 +5116,9 @@ CONTAINS Co_cdi = Co_bcd(Ki) - dFxi = 0.0d0 - dFyi = 0.0d0 - dFzi = 0.0d0 + dFxi = 0.0_dp + dFyi = 0.0_dp + dFzi = 0.0_dp DO_J: DO ij = Ipb, Ipe, +1 @@ -5200,11 +5132,11 @@ CONTAINS fij = XYZRrefdf(IJpt6 + 5) dfij = XYZRrefdf(IJpt6 + 6) - Eij = 0.0d0 - djEij = 0.0d0 - dXjEij2 = 0.0d0 - dYjEij2 = 0.0d0 - dZjEij2 = 0.0d0 + Eij = 0.0_dp + djEij = 0.0_dp + dXjEij2 = 0.0_dp + dYjEij2 = 0.0_dp + dZjEij2 = 0.0_dp Nkpt3 = -3 DO_K: DO ik = Ipb, Ipe, +1 @@ -5225,9 +5157,9 @@ CONTAINS COSijk = XRreij*XRreik + YRreij*YRreik + ZRreij*ZRreik Co_hcosi = hi - COSijk - Co_dhcosi = 1.0d0/(dsqi + Co_hcosi*Co_hcosi) + Co_dhcosi = 1.0_dp/(dsqi + Co_hcosi*Co_hcosi) Gi = -bcsqi*Co_dhcosi - dGi = 2.0d0*Co_hcosi*Co_dhcosi*Gi + dGi = 2.0_dp*Co_hcosi*Co_dhcosi*Gi Gi = Gi + Co_cdi Eij = Eij + fik*Gi @@ -5249,22 +5181,22 @@ CONTAINS dkEij(Nkpt3 + 3) = Co1_dkEij*ZRreik + Co2_dkEij*ZRreij ELSE - dkEij(Nkpt3 + 1) = 0.0d0 - dkEij(Nkpt3 + 2) = 0.0d0 - dkEij(Nkpt3 + 3) = 0.0d0 + dkEij(Nkpt3 + 1) = 0.0_dp + dkEij(Nkpt3 + 2) = 0.0_dp + dkEij(Nkpt3 + 3) = 0.0_dp END IF IKIJ END DO DO_K - Bij = 1.0d0 + Eij**Pni - Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5d0/Pni) + Bij = 1.0_dp + Eij**Pni + Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5_dp/Pni) Uatot = Uatot + Ua - Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5d0/Pni) + Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5_dp/Pni) CEij: IF (Nkpt3 > 0) THEN - Co_mb1 = Ua*0.5d0*Eij**(Pni - 1.0d0)/Bij + Co_mb1 = Ua*0.5_dp*Eij**(Pni - 1.0_dp)/Bij Co_mb2 = Co_mb1*Rreij Nkpt3 = -3 diff --git a/src/emd/rt_bse_types.F b/src/emd/rt_bse_types.F index 7688b6c8d8..b9b647119f 100644 --- a/src/emd/rt_bse_types.F +++ b/src/emd/rt_bse_types.F @@ -99,7 +99,8 @@ MODULE rt_bse_types !> \param dft_control DFT control parameters !> \param ham_effective Real and imaginary part of the effective Hamiltonian used to propagate !> the density matrix -!> \param ham_reference Reference Hamiltonian, which does not change in the propagation = DFT+G0W0 - initial Hartree - initial COHSEX +!> \param ham_reference Reference Hamiltonian, which does not change in the +!> propagation = DFT+G0W0 - initial Hartree - initial COHSEX !> \param ham_workspace Workspace matrices for use with the Hamiltonian propagation - storage of !> exponential propagators etc. !> \param rho Density matrix at the current time step @@ -145,7 +146,7 @@ MODULE rt_bse_types moments_field => NULL() INTEGER :: sim_step = 0, & sim_start = 0, & - ! Needed for continuation runs for loading of previous moments trace + ! Needed to continue runs by loading previous moments trace sim_start_orig = 0, & sim_nsteps = -1, & ! Default reference point type for output moments diff --git a/src/emd/rt_delta_pulse.F b/src/emd/rt_delta_pulse.F index 8bf9e04b2e..f768c0abae 100644 --- a/src/emd/rt_delta_pulse.F +++ b/src/emd/rt_delta_pulse.F @@ -159,8 +159,9 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_old=mos_old, mos_new=mos_new) IF (rtp_control%apply_delta_pulse) THEN - IF (dft_control%qs_control%dftb) & + IF (dft_control%qs_control%dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) + END IF IF (rtp_control%periodic) THEN IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T40))") & diff --git a/src/emd/rt_projection_mo_utils.F b/src/emd/rt_projection_mo_utils.F index 36e8080ca9..60ea2ff4aa 100644 --- a/src/emd/rt_projection_mo_utils.F +++ b/src/emd/rt_projection_mo_utils.F @@ -103,9 +103,10 @@ CONTAINS i_val=proj_mo%ref_nlumo) ! Relevent only in EMD - IF (.NOT. rtp_control%fixed_ions) & + IF (.NOT. rtp_control%fixed_ions) THEN CALL section_vals_val_get(proj_mo_section, "PROPAGATE_REF", i_rep_section=i_rep, & l_val=proj_mo%propagate_ref) + END IF ! If no reference .wfn is provided, using the restart SCF file: IF (proj_mo%ref_mo_file_name == "DEFAULT") THEN @@ -136,11 +137,12 @@ CONTAINS CALL section_vals_val_get(proj_mo_section, "TD_MO_SPIN", i_rep_section=i_rep, & i_val=proj_mo%td_mo_spin) - IF (proj_mo%td_mo_spin > SIZE(mos)) & + IF (proj_mo%td_mo_spin > SIZE(mos)) THEN CALL cp_abort(__LOCATION__, & "You asked to project the time dependent BETA spin while the "// & "real time DFT run has only one spin defined. "// & "Please set TD_MO_SPIN to 1 or use UKS.") + END IF CALL section_vals_val_get(proj_mo_section, "TD_MO_INDEX", i_rep_section=i_rep, & i_vals=tmp_ints) @@ -160,10 +162,11 @@ CONTAINS ALLOCATE (proj_mo%td_mo_occ(SIZE(proj_mo%td_mo_index))) proj_mo%td_mo_occ(:) = 0.0_dp DO j_td = 1, SIZE(proj_mo%td_mo_index) - IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) & + IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) THEN CALL cp_abort(__LOCATION__, & "The MO number available in the Time Dependent run "// & "is smaller than the MO number you have required in TD_MO_INDEX.") + END IF proj_mo%td_mo_occ(j_td) = mos(proj_mo%td_mo_spin)%occupation_numbers(proj_mo%td_mo_index(j_td)) END DO END IF @@ -237,9 +240,10 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(proj_mo%ref_mo_file_name), exist=is_file) - IF (.NOT. is_file) & + IF (.NOT. is_file) THEN CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(proj_mo%ref_mo_file_name)) + END IF CALL open_file(file_name=proj_mo%ref_mo_file_name, & file_action="READ", & @@ -254,10 +258,11 @@ CONTAINS IF (para_env%is_source()) CALL close_file(unit_number=restart_unit) - IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) & + IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) THEN CALL cp_abort(__LOCATION__, & "Projection on spin BETA is not possible as the reference wavefunction "// & "only has one spin channel. Use a reference .wfn calculated with UKS/LSD, or set REF_MO_SPIN to 1") + END IF ! Store only the mos required nbr_mo_max = mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%ncol_global @@ -269,19 +274,21 @@ CONTAINS END DO ELSE DO i_ref = 1, SIZE(proj_mo%ref_mo_index) - IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) & + IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) THEN CALL cp_abort(__LOCATION__, & "The number of MOs available in the reference wavefunction "// & "is smaller than the MO number you have requested in REF_MO_INDEX.") + END IF END DO END IF nbr_ref_mo = SIZE(proj_mo%ref_mo_index) - IF (nbr_ref_mo > nbr_mo_max) & + IF (nbr_ref_mo > nbr_mo_max) THEN CALL cp_abort(__LOCATION__, & "The total number of requested MOs is larger than what is available in the reference wavefunction. "// & "If you are trying to project onto virtual states, make sure they are included in the .wfn file "// & "e.g., by the ADDED_MOS keyword in the SCF section of the input when calculating your reference.") + END IF ! Store ALLOCATE (proj_mo%mo_ref(nbr_ref_mo)) @@ -290,14 +297,16 @@ CONTAINS nrow_global=mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%nrow_global, & ncol_global=1) - IF (dft_control%rtp_control%fixed_ions) & + IF (dft_control%rtp_control%fixed_ions) THEN CALL cp_fm_create(mo_coeff_temp, mo_ref_fmstruct, 'mo_ref') + END IF DO mo_index = 1, nbr_ref_mo real_mo_index = proj_mo%ref_mo_index(mo_index) - IF (real_mo_index > nbr_mo_max) & + IF (real_mo_index > nbr_mo_max) THEN CALL cp_abort(__LOCATION__, & "One of reference mo index is larger then the total number of available mo in the .wfn file.") + END IF ! fill with the reference mo values CALL cp_fm_create(proj_mo%mo_ref(mo_index), mo_ref_fmstruct, 'mo_ref') @@ -324,8 +333,9 @@ CONTAINS DEALLOCATE (mo_ref_temp) CALL cp_fm_struct_release(mo_ref_fmstruct) - IF (dft_control%rtp_control%fixed_ions) & + IF (dft_control%rtp_control%fixed_ions) THEN CALL cp_fm_release(mo_coeff_temp) + END IF END SUBROUTINE read_reference_mo_from_wfn @@ -372,8 +382,9 @@ CONTAINS ! Does not compute the projection if not the required time step IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & print_mo_section, ""), & - cp_p_file)) & + cp_p_file)) THEN RETURN + END IF IF (.NOT. dft_control%rtp_control%fixed_ions) THEN CALL get_qs_env(qs_env, & diff --git a/src/emd/rt_propagation_methods.F b/src/emd/rt_propagation_methods.F index fe656f3197..95cde86d30 100644 --- a/src/emd/rt_propagation_methods.F +++ b/src/emd/rt_propagation_methods.F @@ -165,12 +165,14 @@ CONTAINS ! either in the lengh or velocity gauge. ! should be called after qs_energies_init and before qs_ks_update_qs_env IF (dft_control%apply_efield_field) THEN - IF (ANY(cell%perd(1:3) /= 0)) & + IF (ANY(cell%perd(1:3) /= 0)) THEN CPABORT("Length gauge (efield) and periodicity are not compatible") + END IF CALL efield_potential_lengh_gauge(qs_env) ELSE IF (rtp_control%velocity_gauge) THEN - IF (dft_control%apply_vector_potential) & + IF (dft_control%apply_vector_potential) THEN CALL update_vector_potential(qs_env, dft_control) + END IF CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) END IF @@ -408,8 +410,9 @@ CONTAINS DO i = 1, SIZE(exp_H_new) CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_new(i)%matrix, 0.0_dp, prefac) - IF (propagator == do_em) & + IF (propagator == do_em) THEN CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_old(i)%matrix, 1.0_dp, prefac) + END IF END DO CALL timestop(handle) diff --git a/src/emd/rt_propagation_output.F b/src/emd/rt_propagation_output.F index 1cee221fad..8a78ff7660 100644 --- a/src/emd/rt_propagation_output.F +++ b/src/emd/rt_propagation_output.F @@ -197,19 +197,23 @@ CONTAINS REAL(n_electrons, dp) WRITE (UNIT=output_unit, FMT="((T3,A,T59,F22.14))") & "Total energy:", rtp%energy_new - IF (run_type == ehrenfest) & + IF (run_type == ehrenfest) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old - IF (run_type == real_time_propagation) & + "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old + END IF + IF (run_type == real_time_propagation) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to initial state:", rtp%energy_new - rtp%energy_old - IF (PRESENT(delta_iter)) & + "Energy difference to initial state:", rtp%energy_new - rtp%energy_old + END IF + IF (PRESENT(delta_iter)) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,E20.6))") & - "Convergence:", delta_iter + "Convergence:", delta_iter + END IF IF (rtp%converged) THEN - IF (run_type == real_time_propagation) & + IF (run_type == real_time_propagation) THEN WRITE (UNIT=output_unit, FMT="((T3,A,T61,F12.2))") & - "Time needed for propagation:", used_time + "Time needed for propagation:", used_time + END IF WRITE (UNIT=output_unit, FMT="(/,(T3,A,3X,F16.14))") & "CONVERGENCE REACHED", rtp%energy_new - rtp%energy_old END IF @@ -220,22 +224,25 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_new=mos_new) CALL rt_calculate_orthonormality(orthonormality, & mos_new, matrix_s(1)%matrix) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, FMT="(/,(T3,A,T60,F20.10))") & - "Max deviation from orthonormalization:", orthonormality + "Max deviation from orthonormalization:", orthonormality + END IF END IF END IF - IF (output_unit > 0) & + IF (output_unit > 0) THEN CALL m_flush(output_unit) + END IF CALL cp_print_key_finished_output(output_unit, logger, rtp_section, & "PRINT%PROGRAM_RUN_INFO") IF (rtp%converged) THEN dft_section => section_vals_get_subs_vals(input, "DFT") IF (BTEST(cp_print_key_should_output(logger%iter_info, & - dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) & + dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) THEN CALL print_field_applied(qs_env, dft_section) + END IF CALL make_moment(qs_env) IF (BTEST(cp_print_key_should_output(logger%iter_info, & dft_section, "REAL_TIME_PROPAGATION%PRINT%E_CONSTITUENTS"), cp_p_file)) THEN @@ -406,9 +413,10 @@ CONTAINS rtp%energy_old = rtp%energy_new - IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) & + IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) THEN CALL cp_abort(__LOCATION__, "EMD did not converge, either increase MAX_ITER "// & "or use a smaller TIMESTEP") + END IF END SUBROUTINE rt_prop_output @@ -838,7 +846,7 @@ CONTAINS CHARACTER(len=14) :: ext CHARACTER(len=2) :: sdir INTEGER :: dir, handle, print_unit - INTEGER, DIMENSION(:), POINTER :: stride(:) + INTEGER, DIMENSION(:), POINTER :: stride LOGICAL :: mpi_io TYPE(cp_logger_type), POINTER :: logger TYPE(current_env_type) :: current_env @@ -886,7 +894,7 @@ CONTAINS IF (dir == 1) THEN sdir = "-x" - ELSEIF (dir == 2) THEN + ELSE IF (dir == 2) THEN sdir = "-y" ELSE sdir = "-z" diff --git a/src/emd/rt_propagation_utils.F b/src/emd/rt_propagation_utils.F index 6e6997f20e..431a2fefee 100644 --- a/src/emd/rt_propagation_utils.F +++ b/src/emd/rt_propagation_utils.F @@ -318,9 +318,10 @@ CONTAINS dft_section=dft_section) CALL set_uniform_occupation_mo_array(mo_array, nspin) - IF (dft_control%rtp_control%apply_wfn_mix_init_restart) & + IF (dft_control%rtp_control%apply_wfn_mix_init_restart) THEN CALL wfn_mix(mo_array, particle_set, dft_section, qs_kind_set, para_env, output_unit, & for_rtp=.TRUE.) + END IF DO ispin = 1, nspin CALL calculate_density_matrix(mo_array(ispin), p_rmpv(ispin)%matrix) @@ -423,8 +424,9 @@ CONTAINS DO mo = 1, mo_array(ispin)%nmo IF (mo_array(ispin)%occupation_numbers(mo) /= 0.0 .AND. & mo_array(ispin)%occupation_numbers(mo) /= 1.0 .AND. & - mo_array(ispin)%occupation_numbers(mo) /= 2.0) & + mo_array(ispin)%occupation_numbers(mo) /= 2.0) THEN is_uniform = .FALSE. + END IF END DO mo_array(ispin)%uniform_occupation = is_uniform END DO diff --git a/src/emd/rt_propagator_init.F b/src/emd/rt_propagator_init.F index 69e42afdd0..7d1cbfd570 100644 --- a/src/emd/rt_propagator_init.F +++ b/src/emd/rt_propagator_init.F @@ -161,7 +161,7 @@ CONTAINS DO imat = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(imat), mos_next(imat)) END DO - ELSEIF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN + ELSE IF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN ELSE IF (rtp%linear_scaling) THEN CALL compute_exponential_sparse(exp_H_new, propagator_matrix, rtp_control, rtp) diff --git a/src/energy_corrections.F b/src/energy_corrections.F index e0ea3c5191..e79c921c09 100644 --- a/src/energy_corrections.F +++ b/src/energy_corrections.F @@ -1726,7 +1726,7 @@ CONTAINS IF (dft_control%do_admm_mo) THEN CPASSERT(.NOT. qs_env%run_rtp) CALL admm_mo_calc_rho_aux(qs_env) - ELSEIF (dft_control%do_admm_dm) THEN + ELSE IF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF diff --git a/src/environment.F b/src/environment.F index f981bdf787..dfc1ca86d0 100644 --- a/src/environment.F +++ b/src/environment.F @@ -470,8 +470,9 @@ CONTAINS iw = cp_print_key_unit_nr(logger, root_section, "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG", & extension=".Log") - IF (iw > 0) & + IF (iw > 0) THEN CALL globenv%gaussian_rng_stream%write(iw, write_all=.TRUE.) + END IF CALL cp_print_key_finished_output(iw, logger, root_section, & "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG") @@ -594,8 +595,9 @@ CONTAINS IF (trace .AND. (.NOT. trace_master .OR. para_env%mepos == 0)) THEN unit_nr = -1 - IF (logger%para_env%is_source() .OR. .NOT. trace_master) & + IF (logger%para_env%is_source() .OR. .NOT. trace_master) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) + END IF WRITE (tracing_string, "(I6.6,A1,I6.6)") para_env%mepos, ":", para_env%num_pe IF (ASSOCIATED(trace_routines)) THEN CALL timings_setup_tracing(trace_max, unit_nr, tracing_string, trace_routines) @@ -682,8 +684,9 @@ CONTAINS CPABORT("FARMING program supports only NONE as run type") END IF - IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) & + IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) THEN CPABORT("TEST program supports only NONE as run type") + END IF CALL m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree) MemTotal_avr = MemTotal @@ -1231,8 +1234,9 @@ CONTAINS IF (ierr /= 0) CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') ELSE READ (txt(1:n), FMT="(I2,A1,I2,A1,I2)", IOSTAT=ierr) hours, c1, minutes, c2, seconds - IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") & + IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") THEN CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') + END IF walltime = 3600.0_dp*REAL(hours, dp) + 60.0_dp*REAL(minutes, dp) + REAL(seconds, dp) END IF END SUBROUTINE cp2k_get_walltime @@ -1331,15 +1335,18 @@ CONTAINS IF (cg_mode /= CALLGRAPH_NONE) THEN CALL section_vals_val_get(root_section, "GLOBAL%CALLGRAPH_FILE_NAME", c_val=cg_filename) IF (LEN_TRIM(cg_filename) == 0) cg_filename = TRIM(logger%iter_info%project_name) - IF (cg_mode == CALLGRAPH_ALL) & !incorporate mpi-rank into filename + IF (cg_mode == CALLGRAPH_ALL) THEN + !incorporate mpi-rank into filename cg_filename = TRIM(cg_filename)//"_"//TRIM(ADJUSTL(cp_to_string(para_env%mepos))) + END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,3X,A)") "Writing callgraph to: "//TRIM(cg_filename)//".callgraph" WRITE (UNIT=iw, FMT="()") WRITE (UNIT=iw, FMT="(T2,A)") "-------------------------------------------------------------------------------" END IF - IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) & + IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) THEN CALL timings_report_callgraph(TRIM(cg_filename)//".callgraph") + END IF END IF CALL cp_print_key_finished_output(iw, logger, root_section, & diff --git a/src/eri_mme/eri_mme_error_control.F b/src/eri_mme/eri_mme_error_control.F index 4c8a63e1c6..645678d1f4 100644 --- a/src/eri_mme/eri_mme_error_control.F +++ b/src/eri_mme/eri_mme_error_control.F @@ -92,13 +92,15 @@ CONTAINS max_iter = 100 - IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) & + IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) THEN CALL cp_abort(__LOCATION__, "difference of boundaries for cutoff "// & "(MAX - MIN) must be greater than cutoff precision.") + END IF - IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) & + IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) THEN CALL cp_abort(__LOCATION__, & "relative delta to modify initial cutoff interval (DELTA) must be in (0, 1)") + END IF cutoff_lr(1) = cutoff_l cutoff_lr(2) = cutoff_r @@ -113,10 +115,11 @@ CONTAINS ! 1) find valid initial values for bisection DO iter1 = 1, max_iter + 1 - IF (iter1 > max_iter) & + IF (iter1 > max_iter) THEN CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine initial "// & "cutoff interval has been exceeded.") + END IF cutoff_lr(1) = MAX(cutoff_lr(1), 0.5_dp*G_min**2) ! approx.) is hit @@ -144,9 +147,10 @@ CONTAINS "ERI_MME| Step, cutoff (min, max, mid), err(minimax), err(cutoff), err diff" DO iter2 = 1, max_iter + 1 - IF (iter2 > max_iter) & + IF (iter2 > max_iter) THEN CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine cutoff has been exceeded") + END IF cutoff_mid = 0.5_dp*(cutoff_lr(1) + cutoff_lr(2)) CALL cutoff_minimax_error(cutoff_mid, hmat, h_inv, vol, G_min, zet_min, l_mm, zet_max, l_max_zet, & @@ -337,9 +341,10 @@ CONTAINS gr = 0.5_dp*(SQRT(5.0_dp) - 1.0_dp) ! golden ratio ! Find valid starting values for golden section search DO iter = 1, max_iter + 1 - IF (iter > max_iter) & + IF (iter > max_iter) THEN CALL cp_abort(__LOCATION__, "Maximum number of iterations for finding "// & "exponent maximizing cutoff error has been exceeded.") + END IF CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_max_tmp, C, err_ctff_curr, para_env) IF (err_ctff_prev >= err_ctff_curr) THEN diff --git a/src/eri_mme/eri_mme_gaussian.F b/src/eri_mme/eri_mme_gaussian.F index fea8e96a21..1cde9784a6 100644 --- a/src/eri_mme/eri_mme_gaussian.F +++ b/src/eri_mme/eri_mme_gaussian.F @@ -133,7 +133,7 @@ CONTAINS CPASSERT(G_max > G_min) IF (potential_prv == eri_mme_coulomb .OR. potential_prv == eri_mme_longrange) THEN minimax_Rc = (G_max/G_min)**2 - ELSEIF (potential_prv == eri_mme_yukawa) THEN + ELSE IF (potential_prv == eri_mme_yukawa) THEN minimax_Rc = (G_max**2 + pot_par**2)/(G_min**2 + pot_par**2) END IF @@ -165,9 +165,9 @@ CONTAINS IF (PRESENT(err_minimax)) THEN IF (potential_prv == eri_mme_coulomb) THEN err_minimax = err_minimax/G_min**2 - ELSEIF (potential_prv == eri_mme_yukawa) THEN + ELSE IF (potential_prv == eri_mme_yukawa) THEN err_minimax = err_minimax/(G_min**2 + pot_par**2) - ELSEIF (potential_prv == eri_mme_longrange) THEN + ELSE IF (potential_prv == eri_mme_longrange) THEN err_minimax = err_minimax/G_min**2 ! approx. of Coulomb err_minimax = err_minimax*EXP(-G_min**2/pot_par**2) ! exponential factor END IF diff --git a/src/eri_mme/eri_mme_lattice_summation.F b/src/eri_mme/eri_mme_lattice_summation.F index 4fd3228772..a5f8da4731 100644 --- a/src/eri_mme/eri_mme_lattice_summation.F +++ b/src/eri_mme/eri_mme_lattice_summation.F @@ -89,7 +89,7 @@ CONTAINS IF (PRESENT(G_rad)) G_rad = exp_radius(l_max, alpha_G, sum_precision, 1.0_dp, epsabs=G_res) IF (PRESENT(R_rad)) R_rad = exp_radius(l_max, alpha_R, sum_precision, 1.0_dp, epsabs=R_res) - END SUBROUTINE + END SUBROUTINE eri_mme_2c_get_rads ! ************************************************************************************************** !> \brief Get summation radii for 3c integrals @@ -149,7 +149,7 @@ CONTAINS R_rads_3(2) = exp_radius(la_max + lb_max + lc_max, alpha_R, sum_precision, 1.0_dp, R_res) END IF - END SUBROUTINE + END SUBROUTINE eri_mme_3c_get_rads ! ************************************************************************************************** !> \brief Get summation bounds for 2c integrals @@ -212,7 +212,7 @@ CONTAINS n_sum_3d(2) = nsum_2c_rspace_3d(ns_R, la_max, lb_max) END IF - END SUBROUTINE + END SUBROUTINE eri_mme_2c_get_bounds ! ************************************************************************************************** !> \brief Get summation bounds for 3c integrals @@ -326,7 +326,7 @@ CONTAINS n_sum_3d(3) = nsum_3c_rspace_3d(ns3_R1, ns3_R2, la_max, lb_max, lc_max) END IF - END SUBROUTINE + END SUBROUTINE eri_mme_3c_get_bounds ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -341,7 +341,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_1d nsum_2c_gspace_1d = NINT(ns_G*(2*exp_w + (l + m + 1)*5), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_gspace_1d ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in G space in 1 dimension @@ -380,7 +380,7 @@ CONTAINS END DO END DO - S_G(:) = REAL(S_G_c(0:l_max)*i_pow((/(l, l=0, l_max)/)))*inv_lgth + S_G(:) = REAL(S_G_c(0:l_max)*i_pow([(l, l=0, l_max)]))*inv_lgth END SUBROUTINE pgf_sum_2c_gspace_1d ! ************************************************************************************************** @@ -396,7 +396,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_3d nsum_2c_gspace_3d = NINT(ns_G*(2*exp_w + ncoset(l + m)*7), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_gspace_3d ! ************************************************************************************************** !> \brief As pgf_sum_2c_gspace_1d but 3d sum required for non-orthorhombic cells @@ -495,7 +495,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_1d nsum_2c_rspace_1d = NINT(ns_R*(exp_w + (l + m + 1)*3), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_rspace_1d ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in R space in 1 dimension @@ -553,7 +553,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_3d nsum_2c_rspace_3d = NINT(ns_R*(exp_w + ncoset(l + m)*(4 + ncoset(l + m)*4)), KIND=int_8) - END FUNCTION + END FUNCTION nsum_2c_rspace_3d ! ************************************************************************************************** !> \brief As pgf_sum_2c_rspace_1d but 3d sum required for non-orthorhombic cells @@ -611,7 +611,8 @@ CONTAINS END DO DO lco = 1, ncoset(l_max) CALL get_l(lco, l, lx, ly, lz) - S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot ! cost: 4 flops + ! cost: 4 flops + S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot END DO END DO END DO @@ -794,7 +795,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_gspace_1d nsum_3c_gspace_1d = 15 - END FUNCTION + END FUNCTION nsum_3c_gspace_1d ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -810,7 +811,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_product_3c_gspace_1d nsum_product_3c_gspace_1d = MIN(19, NINT(ns_G*(3 + ns_R*2))) - END FUNCTION + END FUNCTION nsum_product_3c_gspace_1d ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -826,7 +827,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_rspace_1d nsum_3c_rspace_1d = NINT(MIN((4 + ns_R1*2), ns_R1*(ns_R2 + 1)), KIND=int_8) - END FUNCTION + END FUNCTION nsum_3c_rspace_1d ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -954,7 +955,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE + END SUBROUTINE pgf_sum_3c_rspace_1d_generic ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -1009,7 +1010,7 @@ CONTAINS #:for l in range(0, l_tot_max) #:for k in range(0, l+2) #:if k0 - h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# + h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# #:else h_to_c_${k}$_${l+1}$ = 0.0_dp #:endif @@ -1087,15 +1088,15 @@ CONTAINS #:for l in range(0,l_max+1) #:for t in range(0,l+m+2) #:if l < l_max - E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}# +c2*E_${t}$_${l}$_${m}$&#{endif}# #{if t0 and t<=l-1+m}#-${2*l}$*E_${t}$_${l-1}$_${m}$#{endif}#) #:endif #:if m < m_max - E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}#+c3*E_${t}$_${l}$_${m}$&#{endif}# - #{if t0 and t<=m-1+l}#-${2*m}$*E_${t}$_${l}$_${m-1}$#{endif}#) #:endif #:endfor @@ -1115,7 +1116,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE + END SUBROUTINE pgf_sum_3c_rspace_1d_${l_max}$_${m_max}$_${n_max}$_exp_${prop_exp}$ #:endfor #:endfor #:endfor @@ -1265,7 +1266,7 @@ CONTAINS nsum_3c_gspace_3d = NINT(ns_G1*ns_G2*(5*exp_w + ncoset(l)*ncoset(m)*ncoset(n)*4), KIND=int_8) - END FUNCTION + END FUNCTION nsum_3c_gspace_3d ! ************************************************************************************************** !> \brief ... @@ -1427,7 +1428,7 @@ CONTAINS END SELECT S_G = REAL(S_G_c, KIND=dp)/vol**2 - END SUBROUTINE + END SUBROUTINE pgf_sum_3c_gspace_3d ! ************************************************************************************************** !> \brief ... @@ -1543,7 +1544,7 @@ CONTAINS 3*nsum_gaussian_overlap(l, m, 1) + & ncoset(l)*ncoset(m)*(ncoset(l + m)*4 + ncoset(n)*8)), & KIND=int_8) - END FUNCTION + END FUNCTION nsum_product_3c_gspace_3d ! ************************************************************************************************** !> \brief ... @@ -1764,7 +1765,7 @@ CONTAINS ncoset(l + m)*2 + ncoset(n)*ncoset(l + m)*4)), & KIND=int_8) - END FUNCTION + END FUNCTION nsum_3c_rspace_3d ! ************************************************************************************************** !> \brief ... @@ -1962,7 +1963,7 @@ CONTAINS ELSE nsum_gaussian_overlap = nsum_gaussian_overlap + loop*32 END IF - END FUNCTION + END FUNCTION nsum_gaussian_overlap ! ************************************************************************************************** !> \brief ... @@ -1981,7 +1982,7 @@ CONTAINS IF (PRESENT(lx)) lx = indco(1, lco) IF (PRESENT(ly)) ly = indco(2, lco) IF (PRESENT(lz)) lz = indco(3, lco) - END SUBROUTINE + END SUBROUTINE get_l ! ************************************************************************************************** !> \brief ... @@ -1993,10 +1994,10 @@ CONTAINS COMPLEX(KIND=dp) :: i_pow COMPLEX(KIND=dp), DIMENSION(0:3), PARAMETER :: & - ip = (/(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)/) + ip = [(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)] i_pow = ip(MOD(i, 4)) - END FUNCTION + END FUNCTION i_pow END MODULE eri_mme_lattice_summation diff --git a/src/eri_mme/eri_mme_test.F b/src/eri_mme/eri_mme_test.F index f67388aac6..923b19c2c9 100644 --- a/src/eri_mme/eri_mme_test.F +++ b/src/eri_mme/eri_mme_test.F @@ -158,8 +158,9 @@ CONTAINS acc_check = .TRUE. END IF - IF (.NOT. acc_check) & + IF (.NOT. acc_check) THEN CPABORT("Actual error greater than upper bound estimate.") + END IF END IF END IF diff --git a/src/eri_mme/eri_mme_types.F b/src/eri_mme/eri_mme_types.F index 2f40d28ab0..25f94e1ae1 100644 --- a/src/eri_mme/eri_mme_types.F +++ b/src/eri_mme/eri_mme_types.F @@ -127,8 +127,9 @@ CONTAINS CHARACTER(len=2) :: string WRITE (string, '(I2)') n_minimax_max - IF (n_minimax > n_minimax_max) & + IF (n_minimax > n_minimax_max) THEN CPABORT("The maximum allowed number of minimax points N_MINIMAX is "//TRIM(string)) + END IF param%n_minimax = n_minimax param%n_grids = 1 diff --git a/src/et_coupling_proj.F b/src/et_coupling_proj.F index f387e74c79..dae0f3d119 100644 --- a/src/et_coupling_proj.F +++ b/src/et_coupling_proj.F @@ -150,8 +150,9 @@ CONTAINS IF (ASSOCIATED(ec)) THEN - IF (ASSOCIATED(ec%fermi)) & + IF (ASSOCIATED(ec%fermi)) THEN DEALLOCATE (ec%fermi) + END IF IF (ASSOCIATED(ec%m_transf)) THEN CALL cp_fm_release(matrix=ec%m_transf) DEALLOCATE (ec%m_transf) @@ -166,8 +167,9 @@ CONTAINS IF (ASSOCIATED(ec%block)) THEN DO i = 1, SIZE(ec%block) - IF (ASSOCIATED(ec%block(i)%atom)) & + IF (ASSOCIATED(ec%block(i)%atom)) THEN DEALLOCATE (ec%block(i)%atom) + END IF IF (ASSOCIATED(ec%block(i)%mo)) THEN DO j = 1, SIZE(ec%block(i)%mo) CALL deallocate_mo_set(ec%block(i)%mo(j)) @@ -242,8 +244,9 @@ CONTAINS DO i = 1, n_atoms CALL get_atomic_kind(particle_set(i)%atomic_kind, kind_number=j) CALL get_qs_kind(qs_kind_set(j), basis_set=ao_basis_set) - IF (.NOT. ASSOCIATED(ao_basis_set)) & + IF (.NOT. ASSOCIATED(ao_basis_set)) THEN CPABORT('Unsupported basis set type. ') + END IF CALL get_gto_basis_set(gto_basis_set=ao_basis_set, & nset=n_set, nshell=n_shell, l=ang_mom_id) DO j = 1, n_set @@ -300,8 +303,9 @@ CONTAINS ! Count unique atoms DO j = 1, SIZE(atom_id) ! Check atom ID validity - IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) & + IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) THEN CPABORT('invalid fragment atom ID ('//TRIM(ADJUSTL(cp_to_string(atom_id(j))))//')') + END IF ! Check if the atom is not in previously-defined blocks found = .FALSE. DO k = 1, i - 1 @@ -346,12 +350,15 @@ CONTAINS END DO ! Clean memory - IF (ASSOCIATED(atom_nf)) & + IF (ASSOCIATED(atom_nf)) THEN DEALLOCATE (atom_nf) - IF (ASSOCIATED(atom_ps)) & + END IF + IF (ASSOCIATED(atom_ps)) THEN DEALLOCATE (atom_ps) - IF (ASSOCIATED(t)) & + END IF + IF (ASSOCIATED(t)) THEN DEALLOCATE (t) + END IF END SUBROUTINE set_block_data @@ -409,8 +416,9 @@ CONTAINS ! Routine name for debug purposes ! Local variables - IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) & + IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) THEN CPABORT('cannot reorder Hamiltonian, working-matrix structure is not equivalent') + END IF ! Matrix-element reordering nr = 1 @@ -672,8 +680,9 @@ CONTAINS END DO ! Clean memory - IF (ALLOCATED(dat)) & + IF (ALLOCATED(dat)) THEN DEALLOCATE (dat) + END IF END SUBROUTINE hamiltonian_block_diag @@ -718,8 +727,9 @@ CONTAINS END IF END DO - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT('MO-fraction atom ID not defined in the block') + END IF ! sum MO coefficients from the atom DO k = 1, blk_at(j)%n_ao @@ -773,8 +783,9 @@ CONTAINS IF (n > 0) THEN - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(/,T3,A/)') 'Block state fractions:' + END IF ! Number of AO functions CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) @@ -809,8 +820,9 @@ CONTAINS IF (ASSOCIATED(list_mo)) THEN IF (j > 1) THEN - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, *) + END IF END IF DO l = 1, SIZE(list_mo) @@ -820,13 +832,15 @@ CONTAINS list_mo(l), list_at) c2 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(2), & list_mo(l), list_at) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(I5,A,I5,2F20.10)') j, ' /', list_mo(l), c1, c2 + END IF ELSE c1 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(1), & list_mo(l), list_at) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(I5,A,I5,F20.10)') j, ' /', list_mo(l), c1 + END IF END IF END DO @@ -873,8 +887,9 @@ CONTAINS ! Routine name for debug purposes prnt_fm = .FALSE. - IF (PRESENT(fermi)) & + IF (PRESENT(fermi)) THEN prnt_fm = fermi + END IF IF (output_unit > 0) THEN @@ -884,11 +899,13 @@ CONTAINS IF (n_spins > 1) THEN mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) & + IF (PRESENT(mx_mo_a)) THEN mx_a = MIN(mo(1)%nmo, mx_mo_a) + END IF mx_b = mo(2)%nmo - IF (PRESENT(mx_mo_b)) & + IF (PRESENT(mx_mo_b)) THEN mx_b = MIN(mo(2)%nmo, mx_mo_b) + END IF n = MAX(mx_a, mx_b) DO i = 1, n @@ -918,8 +935,9 @@ CONTAINS ELSE mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) & + IF (PRESENT(mx_mo_a)) THEN mx_a = MIN(mo(1)%nmo, mx_mo_a) + END IF DO i = 1, mx_a WRITE (output_unit, '(T3,I10,2F12.4)') & @@ -984,8 +1002,9 @@ CONTAINS my_pos = "APPEND" END IF - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(/,T3,A/)') 'Printing coupling elements to output files' + END IF DO i = 1, ec%n_blocks DO j = i + 1, ec%n_blocks @@ -1104,15 +1123,16 @@ CONTAINS ALLOCATE (vec_t(n_mo)) CPASSERT(ASSOCIATED(vec_t)) CALL cp_fm_vectorssum(mat_t, vec_t) - vec_t = 1.0_dp/DSQRT(vec_t) + vec_t = 1.0_dp/SQRT(vec_t) CALL cp_fm_column_scale(mo%mo_coeff, vec_t) ! Clean memory CALL cp_fm_struct_release(fmstruct=fm_s) CALL cp_fm_release(matrix=mat_sc) CALL cp_fm_release(matrix=mat_t) - IF (ASSOCIATED(vec_t)) & + IF (ASSOCIATED(vec_t)) THEN DEALLOCATE (vec_t) + END IF END SUBROUTINE normalize_mo_vectors @@ -1222,24 +1242,28 @@ CONTAINS ! Number of states n_mo = mat_u%matrix_struct%nrow_global - IF (n_mo /= mat_u%matrix_struct%ncol_global) & + IF (n_mo /= mat_u%matrix_struct%ncol_global) THEN CPABORT('block state matrix is not square') - IF (n_mo /= SIZE(vec_e)) & + END IF + IF (n_mo /= SIZE(vec_e)) THEN CPABORT('inconsistent number of states / energies') + END IF ! Maximal occupancy CALL get_qs_env(qs_env, dft_control=dft_cntrl) mx_occ = 2.0_dp - IF (dft_cntrl%nspins > 1) & + IF (dft_cntrl%nspins > 1) THEN mx_occ = 1.0_dp + END IF ! Number of electrons n_el = ec%block(id)%n_electrons IF (dft_cntrl%nspins > 1) THEN n_el = n_el/2 IF (MOD(ec%block(id)%n_electrons, 2) == 1) THEN - IF (spin == 1) & + IF (spin == 1) THEN n_el = n_el + 1 + END IF END IF END IF @@ -1518,8 +1542,9 @@ CONTAINS ! Parallel calculation - master thread master = .FALSE. - IF (output_unit > 0) & + IF (output_unit > 0) THEN master = .TRUE. + END IF ! Header IF (master) THEN @@ -1603,20 +1628,23 @@ CONTAINS CPABORT('ET_COUPLING not implemented with kpoints') ELSE ! no K-points - IF (master) & + IF (master) THEN WRITE (output_unit, '(T3,A)') 'No K-point sampling (Gamma point only)' + END IF END IF IF (dft_cntrl%nspins == 2) THEN - IF (master) & + IF (master) THEN WRITE (output_unit, '(/,T3,A)') 'Spin-polarized calculation' + END IF !<--- Open shell / No K-points ------------------------------------------------>! ! State eneries of the whole system - IF (mo(1)%nao /= mo(2)%nao) & + IF (mo(1)%nao /= mo(2)%nao) THEN CPABORT('different number of alpha/beta AO basis functions') + END IF IF (master) THEN WRITE (output_unit, '(/,T3,A,I10)') & 'Number of AO basis functions = ', mo(1)%nao @@ -1648,8 +1676,9 @@ CONTAINS ELSE - IF (master) & + IF (master) THEN WRITE (output_unit, '(/,T3,A)') 'Spin-restricted calculation' + END IF !<--- Close shell / No K-points ----------------------------------------------->! diff --git a/src/ewald_spline_util.F b/src/ewald_spline_util.F index 9ebfcab6e5..74f69713b4 100644 --- a/src/ewald_spline_util.F +++ b/src/ewald_spline_util.F @@ -398,10 +398,10 @@ CONTAINS END DO Na = SQRT(dxTerm*dxTerm + dyTerm*dyTerm + dzTerm*dzTerm) dn = Eval_d_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) - Nn = SQRT(DOT_PRODUCT(dn, dn)) + Nn = NORM2(dn) Fterm = Eval_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) tmp1 = ABS(Term - Fterm) - tmp2 = SQRT(DOT_PRODUCT(dn - [dxTerm, dyTerm, dzTerm], dn - [dxTerm, dyTerm, dzTerm])) + tmp2 = NORM2(dn - [dxTerm, dyTerm, dzTerm]) errf = errf + tmp1 maxerrorf = MAX(maxerrorf, tmp1) errd = errd + tmp2 diff --git a/src/ewalds.F b/src/ewalds.F index c5df25968f..b10f460437 100644 --- a/src/ewalds.F +++ b/src/ewalds.F @@ -364,9 +364,9 @@ CONTAINS charges) TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set(:) + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(distribution_1d_type), POINTER :: local_particles - REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self(:) + REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self REAL(KIND=dp), DIMENSION(:), POINTER :: charges INTEGER :: ewald_type, ii, iparticle_kind, & diff --git a/src/ewalds_multipole.F b/src/ewalds_multipole.F index 06a4c1f867..96abbf552e 100644 --- a/src/ewalds_multipole.F +++ b/src/ewalds_multipole.F @@ -61,6 +61,17 @@ MODULE ewalds_multipole IMPLICIT NONE PRIVATE + TYPE charge_mono_type + REAL(KIND=dp), DIMENSION(:), & + POINTER :: charge => NULL() + REAL(KIND=dp), DIMENSION(:, :), & + POINTER :: pos => NULL() + END TYPE charge_mono_type + TYPE multi_charge_type + TYPE(charge_mono_type), DIMENSION(:), & + POINTER :: charge_typ => NULL() + END TYPE multi_charge_type + LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_r_space = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_g_space = .FALSE. @@ -1276,16 +1287,6 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, iw, debug_r_space) - TYPE charge_mono_type - REAL(KIND=dp), DIMENSION(:), & - POINTER :: charge - REAL(KIND=dp), DIMENSION(:, :), & - POINTER :: pos - END TYPE charge_mono_type - TYPE multi_charge_type - TYPE(charge_mono_type), DIMENSION(:), & - POINTER :: charge_typ - END TYPE multi_charge_type TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(fist_nonbond_env_type), POINTER :: nonbond_env @@ -1607,7 +1608,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = SQRT(DOT_PRODUCT(rm, rm)) + r = NORM2(rm) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1646,7 +1647,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = SQRT(DOT_PRODUCT(rm, rm)) + r = NORM2(rm) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1727,7 +1728,7 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%charge(2)) ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 2)) CALL random_stream%fill(rvec) - rvec = rvec/(2.0_dp*SQRT(DOT_PRODUCT(rvec, rvec)))*dx + rvec = rvec/(2.0_dp*NORM2(rvec))*dx multipoles(i)%charge_typ(isize)%charge(1) = echarge multipoles(i)%charge_typ(isize)%pos(1:3, 1) = rvec multipoles(i)%charge_typ(isize)%charge(2) = -echarge @@ -1742,9 +1743,9 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 4)) CALL random_stream%fill(rvec1) CALL random_stream%fill(rvec2) - rvec1 = rvec1/SQRT(DOT_PRODUCT(rvec1, rvec1)) + rvec1 = rvec1/NORM2(rvec1) rvec2 = rvec2 - DOT_PRODUCT(rvec2, rvec1)*rvec1 - rvec2 = rvec2/SQRT(DOT_PRODUCT(rvec2, rvec2)) + rvec2 = rvec2/NORM2(rvec2) ! rvec1 = rvec1/2.0_dp*dx rvec2 = rvec2/2.0_dp*dx diff --git a/src/ewalds_multipole_sr.fypp b/src/ewalds_multipole_sr.fypp index 4f8b2f528b..99d3e9d09d 100644 --- a/src/ewalds_multipole_sr.fypp +++ b/src/ewalds_multipole_sr.fypp @@ -246,7 +246,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = dexp(-dampa_ij*r) + dampaexpi = EXP(-dampa_ij*r) dampfunci = dampsumfi*dampaexpi*dampfac_ij dampfuncdiffi = -dampa_ij*dampaexpi* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -267,7 +267,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = dexp(-dampa_ji*r) + dampaexpj = EXP(-dampa_ji*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ji dampfuncdiffj = -dampa_ji*dampaexpj* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & @@ -287,7 +287,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = dexp(-dampa_ij*r) + dampaexpj = EXP(-dampa_ij*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ij dampfuncdiffj = -dampa_ij*dampaexpj* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -308,7 +308,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = dexp(-dampa_ji*r) + dampaexpi = EXP(-dampa_ji*r) dampfunci = dampsumfi*dampaexpi*dampfac_ji dampfuncdiffi = -dampa_ji*dampaexpi* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & diff --git a/src/excited_states.F b/src/excited_states.F index a5ab99bb5d..13329ec4db 100644 --- a/src/excited_states.F +++ b/src/excited_states.F @@ -112,9 +112,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=ex_env%debug_forces) ELSE ! KS-DFT diff --git a/src/exstates_types.F b/src/exstates_types.F index 1b9c77dd55..d7d535d6b9 100644 --- a/src/exstates_types.F +++ b/src/exstates_types.F @@ -106,8 +106,9 @@ CONTAINS CALL cp_fm_release(ex_env%wfn_history%evect) CALL cp_fm_release(ex_env%wfn_history%cpmos) - IF (ALLOCATED(ex_env%gw_eigen)) & + IF (ALLOCATED(ex_env%gw_eigen)) THEN DEALLOCATE (ex_env%gw_eigen) + END IF DEALLOCATE (ex_env) diff --git a/src/f77_interface.F b/src/f77_interface.F index 125ff2d120..28be264b2a 100644 --- a/src/f77_interface.F +++ b/src/f77_interface.F @@ -755,11 +755,12 @@ CONTAINS ! Check that the order of the force_eval is the correct one CALL section_vals_val_get(force_env_sections, "METHOD", i_val=method_name_id, & i_rep_section=i_force_eval(1)) - IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) & + IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) THEN CALL cp_abort(__LOCATION__, & "In case of multiple force_eval the MAIN force_eval (the first in the list of FORCE_EVAL_ORDER or "// & "the one omitted from that order list) must be a MIXED_ENV type calculation. Please check your "// & "input file and possibly correct the MULTIPLE_FORCE_EVAL%FORCE_EVAL_ORDER. ") + END IF IF (method_name_id == do_mixed) THEN check = ASSOCIATED(force_env%mixed_env%sub_para_env) @@ -807,8 +808,9 @@ CONTAINS IF (method_name_id == do_qmmm) THEN qmmmx_section => section_vals_get_subs_vals(force_env_section, "QMMM%FORCE_MIXING") CALL section_vals_get(qmmmx_section, explicit=do_qmmm_force_mixing) - IF (do_qmmm_force_mixing) & - method_name_id = do_qmmmx ! QMMM Force-Mixing has its own (hidden) method_id + IF (do_qmmm_force_mixing) THEN + method_name_id = do_qmmmx + END IF ! QMMM Force-Mixing has its own (hidden) method_id END IF SELECT CASE (method_name_id) @@ -943,8 +945,9 @@ CONTAINS ! Release force_env_section IF (nforce_eval > 1) CALL section_vals_release(force_env_section) END DO - IF (use_multiple_para_env) & + IF (use_multiple_para_env) THEN CALL cp_rm_default_logger() + END IF DEALLOCATE (group_distribution) DEALLOCATE (i_force_eval) timer_env => get_timer_env() diff --git a/src/farming_methods.F b/src/farming_methods.F index 006de02994..eeb540f8e2 100644 --- a/src/farming_methods.F +++ b/src/farming_methods.F @@ -304,7 +304,7 @@ CONTAINS WRITE (output_unit, "(T2,A)") & "FARMING| ---- WARNING ---- failed to open ("//TRIM(farming_env%restart_file_name)//"), starting at 1" END IF - CLOSE (iunit, IOSTAT=stat) + CLOSE (iunit) END IF CALL cp_print_key_finished_output(output_unit, logger, farming_section, & diff --git a/src/farming_types.F b/src/farming_types.F index 3324a31dbb..45820baede 100644 --- a/src/farming_types.F +++ b/src/farming_types.F @@ -38,7 +38,8 @@ MODULE farming_types LOGICAL :: restart = .FALSE. LOGICAL :: CYCLE = .FALSE. LOGICAL :: captain_minion = .FALSE. - INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() ! user preference for partitioning the cpus + ! user preference for partitioning the cpus + INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() CHARACTER(LEN=default_path_length) :: restart_file_name = "" ! restart file for farming CHARACTER(LEN=default_path_length) :: cwd = "" ! directory we started from INTEGER :: Njobs = -1 ! how many jobs to run diff --git a/src/fist_efield_methods.F b/src/fist_efield_methods.F index 72be6551ad..86afa8d109 100644 --- a/src/fist_efield_methods.F +++ b/src/fist_efield_methods.F @@ -103,7 +103,7 @@ CONTAINS END IF fieldpol = efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*efield%strength dfilter = efield%dfilter diff --git a/src/fist_environment_types.F b/src/fist_environment_types.F index 5a49675dc1..ba016dd434 100644 --- a/src/fist_environment_types.F +++ b/src/fist_environment_types.F @@ -187,7 +187,7 @@ CONTAINS IF (PRESENT(subsys)) subsys => fist_env%subsys IF (PRESENT(efield)) efield => fist_env%efield - IF (ASSOCIATED(fist_env%subsys)) & + IF (ASSOCIATED(fist_env%subsys)) THEN CALL cp_subsys_get(fist_env%subsys, & atomic_kinds=atomic_kinds, & local_molecules=local_molecules, & @@ -200,6 +200,7 @@ CONTAINS multipoles=fist_multipoles, & results=results, & cell=cell) + END IF IF (PRESENT(atomic_kind_set)) atomic_kind_set => atomic_kinds%els IF (PRESENT(particle_set)) particle_set => particles%els IF (PRESENT(molecule_kind_set)) molecule_kind_set => molecule_kinds%els diff --git a/src/fist_force.F b/src/fist_force.F index 2cff3aba15..f2ab3a0281 100644 --- a/src/fist_force.F +++ b/src/fist_force.F @@ -735,7 +735,7 @@ CONTAINS shell_particle_set(i)%f(3) = fshell_total(3, i) + fgshell_coulomb(3, i) END DO - ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms @@ -767,7 +767,7 @@ CONTAINS shell_particle_set(i)%f(2) = fshell_total(2, i) shell_particle_set(i)%f(3) = fshell_total(3, i) END DO - ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms diff --git a/src/fist_intra_force.F b/src/fist_intra_force.F index 882ca5fe8f..9838cd3333 100644 --- a/src/fist_intra_force.F +++ b/src/fist_intra_force.F @@ -272,9 +272,9 @@ CONTAINS b32 = particle_set(index_c)%r - particle_set(index_b)%r b12 = pbc(b12, cell) b32 = pbc(b32, cell) - d12 = SQRT(DOT_PRODUCT(b12, b12)) + d12 = NORM2(b12) id12 = 1.0_dp/d12 - d32 = SQRT(DOT_PRODUCT(b32, b32)) + d32 = NORM2(b32) id32 = 1.0_dp/d32 dist = DOT_PRODUCT(b12, b32) theta = (dist*id12*id32) @@ -343,11 +343,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = SQRT(DOT_PRODUCT(tm, tm)) + sm = NORM2(tm) ism = 1.0_dp/sm - sn = SQRT(DOT_PRODUCT(tn, tn)) + sn = NORM2(tn) isn = 1.0_dp/sn - s32 = SQRT(DOT_PRODUCT(t32, t32)) + s32 = NORM2(t32) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -415,11 +415,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = SQRT(DOT_PRODUCT(tm, tm)) + sm = NORM2(tm) ism = 1.0_dp/sm - sn = SQRT(DOT_PRODUCT(tn, tn)) + sn = NORM2(tn) isn = 1.0_dp/sn - s32 = SQRT(DOT_PRODUCT(t32, t32)) + s32 = NORM2(t32) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -483,8 +483,8 @@ CONTAINS tm(1) = t32(2)*t12(3) - t12(2)*t32(3) tm(2) = -t32(1)*t12(3) + t12(1)*t32(3) tm(3) = t32(1)*t12(2) - t12(1)*t32(2) - sm = SQRT(DOT_PRODUCT(tm, tm)) - s32 = SQRT(DOT_PRODUCT(t32, t32)) + sm = NORM2(tm) + s32 = NORM2(t32) CALL force_opbends(opbend_list(iopbend)%opbend_kind%id_type, & s32, tm, t41, t42, t43, & opbend_list(iopbend)%opbend_kind%k, & diff --git a/src/fist_neighbor_list_control.F b/src/fist_neighbor_list_control.F index f16cc70787..0e23752054 100644 --- a/src/fist_neighbor_list_control.F +++ b/src/fist_neighbor_list_control.F @@ -39,14 +39,9 @@ MODULE fist_neighbor_list_control section_vals_val_get USE kinds, ONLY: dp USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: ace_type,& - allegro_type,& - gal21_type,& - gal_type,& - nequip_type,& - pair_potential_pp_type,& - siepmann_type,& - tersoff_type + USE pair_potential_types, ONLY: & + ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & + pair_potential_pp_type, siepmann_type, tersoff_type USE particle_types, ONLY: particle_type #include "./base/base_uses.f90" @@ -236,6 +231,9 @@ CONTAINS IF (ANY(potparm%pot(ikind, jkind)%pot%type == nequip_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF + IF (ANY(potparm%pot(ikind, jkind)%pot%type == mace_type)) THEN + full_nl(ikind, jkind) = .TRUE. + END IF IF (ANY(potparm%pot(ikind, jkind)%pot%type == ace_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF diff --git a/src/fist_neighbor_lists.F b/src/fist_neighbor_lists.F index 803244aac8..34694b9879 100644 --- a/src/fist_neighbor_lists.F +++ b/src/fist_neighbor_lists.F @@ -685,7 +685,7 @@ CONTAINS ra(:) = pbc(particle_set(atom_a)%r, cell) rb(:) = pbc(particle_set(atom_b)%r, cell) rab = rb(:) - ra(:) + cell_v - dab = SQRT(DOT_PRODUCT(rab, rab)) + dab = NORM2(rab) IF (ilist <= neighbor_kind_pair%nscale) THEN WRITE (UNIT=output_unit, FMT="(T3,2(I6,3(1X,F10.6)),3(1X,I3),10X,F8.4,L4,F11.5,F9.5)") & atom_a, ra(1:3)*conv, & diff --git a/src/fist_nonbond_env_types.F b/src/fist_nonbond_env_types.F index c90883e177..045df06365 100644 --- a/src/fist_nonbond_env_types.F +++ b/src/fist_nonbond_env_types.F @@ -23,8 +23,8 @@ MODULE fist_nonbond_env_types USE kinds, ONLY: default_string_length,& dp USE pair_potential_types, ONLY: & - ace_type, allegro_type, gal21_type, gal_type, nequip_type, pair_potential_pp_release, & - pair_potential_pp_type, siepmann_type, tersoff_type + ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & + pair_potential_pp_release, pair_potential_pp_type, siepmann_type, tersoff_type USE torch_api, ONLY: torch_model_release,& torch_model_type #include "./base/base_uses.f90" @@ -189,29 +189,36 @@ CONTAINS IF (PRESENT(rlist_lowsq)) rlist_lowsq => fist_nonbond_env%rlist_lowsq IF (PRESENT(ij_kind_full_fac)) ij_kind_full_fac => fist_nonbond_env%ij_kind_full_fac IF (PRESENT(nonbonded)) nonbonded => fist_nonbond_env%nonbonded - IF (PRESENT(r_last_update)) & + IF (PRESENT(r_last_update)) THEN r_last_update => fist_nonbond_env%r_last_update - IF (PRESENT(r_last_update_pbc)) & + END IF + IF (PRESENT(r_last_update_pbc)) THEN r_last_update_pbc => fist_nonbond_env%r_last_update_pbc - IF (PRESENT(rshell_last_update_pbc)) & + END IF + IF (PRESENT(rshell_last_update_pbc)) THEN rshell_last_update_pbc => fist_nonbond_env%rshell_last_update_pbc - IF (PRESENT(rcore_last_update_pbc)) & + END IF + IF (PRESENT(rcore_last_update_pbc)) THEN rcore_last_update_pbc => fist_nonbond_env%rcore_last_update_pbc - IF (PRESENT(cell_last_update)) & + END IF + IF (PRESENT(cell_last_update)) THEN cell_last_update => fist_nonbond_env%cell_last_update + END IF IF (PRESENT(lup)) lup = fist_nonbond_env%lup IF (PRESENT(aup)) aup = fist_nonbond_env%aup IF (PRESENT(ei_scale14)) ei_scale14 = fist_nonbond_env%ei_scale14 IF (PRESENT(vdw_scale14)) vdw_scale14 = fist_nonbond_env%vdw_scale14 - IF (PRESENT(shift_cutoff)) & + IF (PRESENT(shift_cutoff)) THEN shift_cutoff = fist_nonbond_env%shift_cutoff + END IF IF (PRESENT(do_electrostatics)) do_electrostatics = fist_nonbond_env%do_electrostatics IF (PRESENT(natom_types)) natom_types = fist_nonbond_env%natom_types IF (PRESENT(counter)) counter = fist_nonbond_env%counter IF (PRESENT(last_update)) last_update = fist_nonbond_env%last_update IF (PRESENT(num_update)) num_update = fist_nonbond_env%num_update - IF (PRESENT(long_range_correction)) & + IF (PRESENT(long_range_correction)) THEN long_range_correction = fist_nonbond_env%long_range_correction + END IF END SUBROUTINE fist_nonbond_env_get ! ************************************************************************************************** @@ -283,29 +290,36 @@ CONTAINS IF (PRESENT(charges)) fist_nonbond_env%charges => charges IF (PRESENT(rlist_lowsq)) fist_nonbond_env%rlist_lowsq => rlist_lowsq IF (PRESENT(nonbonded)) fist_nonbond_env%nonbonded => nonbonded - IF (PRESENT(r_last_update)) & + IF (PRESENT(r_last_update)) THEN fist_nonbond_env%r_last_update => r_last_update - IF (PRESENT(r_last_update_pbc)) & + END IF + IF (PRESENT(r_last_update_pbc)) THEN fist_nonbond_env%r_last_update_pbc => r_last_update_pbc - IF (PRESENT(rshell_last_update_pbc)) & + END IF + IF (PRESENT(rshell_last_update_pbc)) THEN fist_nonbond_env%rshell_last_update_pbc => rshell_last_update_pbc - IF (PRESENT(rcore_last_update_pbc)) & + END IF + IF (PRESENT(rcore_last_update_pbc)) THEN fist_nonbond_env%rcore_last_update_pbc => rcore_last_update_pbc - IF (PRESENT(cell_last_update)) & + END IF + IF (PRESENT(cell_last_update)) THEN fist_nonbond_env%cell_last_update => cell_last_update + END IF IF (PRESENT(lup)) fist_nonbond_env%lup = lup IF (PRESENT(aup)) fist_nonbond_env%aup = aup IF (PRESENT(ei_scale14)) fist_nonbond_env%ei_scale14 = ei_scale14 IF (PRESENT(vdw_scale14)) fist_nonbond_env%vdw_scale14 = vdw_scale14 - IF (PRESENT(shift_cutoff)) & + IF (PRESENT(shift_cutoff)) THEN fist_nonbond_env%shift_cutoff = shift_cutoff + END IF IF (PRESENT(do_electrostatics)) fist_nonbond_env%do_electrostatics = do_electrostatics IF (PRESENT(natom_types)) fist_nonbond_env%natom_types = natom_types IF (PRESENT(counter)) fist_nonbond_env%counter = counter IF (PRESENT(last_update)) fist_nonbond_env%last_update = last_update IF (PRESENT(num_update)) fist_nonbond_env%num_update = num_update - IF (PRESENT(long_range_correction)) & + IF (PRESENT(long_range_correction)) THEN fist_nonbond_env%long_range_correction = long_range_correction + END IF END SUBROUTINE fist_nonbond_env_set ! ************************************************************************************************** @@ -483,6 +497,10 @@ CONTAINS fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp END IF + IF (ANY(potparm%pot(idim, jdim)%pot%type == mace_type)) THEN + fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp + fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp + END IF IF (ANY(potparm%pot(idim, jdim)%pot%type == allegro_type)) THEN fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp diff --git a/src/fist_nonbond_force.F b/src/fist_nonbond_force.F index 6de5a4894d..0d6680b31c 100644 --- a/src/fist_nonbond_force.F +++ b/src/fist_nonbond_force.F @@ -38,9 +38,9 @@ MODULE fist_nonbond_force USE message_passing, ONLY: mp_comm_type USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, gal21_type, gal_type, nequip_type, nosh_nosh, & - nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, siepmann_type, & - tersoff_type + ace_type, allegro_type, deepmd_type, gal21_type, gal_type, mace_type, nequip_type, & + nosh_nosh, nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, & + siepmann_type, tersoff_type USE particle_types, ONLY: particle_type USE shell_potential_types, ONLY: get_shell,& shell_kind_type @@ -231,6 +231,7 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & + .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = 0.5_dp*fac_ei @@ -722,6 +723,7 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & + .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = fac_ei*0.5_dp diff --git a/src/floquet_utils.F b/src/floquet_utils.F index b5e0f05f72..182c1a0e93 100644 --- a/src/floquet_utils.F +++ b/src/floquet_utils.F @@ -303,7 +303,7 @@ CONTAINS ! E_factor(α) = (i E(α) exp(i·φ(α)))/(2ω) where α = x,y,z DO i_dir = 1, 3 - efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(DCOS(phi(i_dir)), DSIN(phi(i_dir)), KIND=dp)/(2*omega) + efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(COS(phi(i_dir)), SIN(phi(i_dir)), KIND=dp)/(2*omega) END DO DO i_dir = 1, 3 diff --git a/src/fm/cp_cfm_types.F b/src/fm/cp_cfm_types.F index 17c77dc1eb..2ae9174c83 100644 --- a/src/fm/cp_cfm_types.F +++ b/src/fm/cp_cfm_types.F @@ -439,8 +439,9 @@ CONTAINS ! * the source matrix is distributed across a number of processes, or ! * not all elements of the target matrix will be assigned, e.g. ! when the target matrix is larger then the source matrix - IF (do_zero) & + IF (do_zero) THEN CALL zcopy(SIZE(target_m), z_zero, 0, target_m(1, 1), 1) + END IF IF (tr_a) THEN DO j = start_col_local, end_col_local @@ -668,14 +669,17 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN CPABORT("internal local_data has different sizes") + END IF CALL zcopy(SIZE(source%local_data), source%local_data(1, 1), 1, destination%local_data(1, 1), 1) ELSE - IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) & + IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) THEN CPABORT("cannot copy between full matrixes of differen sizes") - IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) & + END IF + IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) THEN CPABORT("cannot copy between full matrixes of differen sizes") + END IF #if defined(__parallel) CALL pzcopy(source%matrix_struct%nrow_global* & source%matrix_struct%ncol_global, & @@ -1068,7 +1072,8 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another + ! routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends diff --git a/src/fm/cp_fm_diag_utils.F b/src/fm/cp_fm_diag_utils.F index 8ac6dc147e..d613da3fc9 100644 --- a/src/fm/cp_fm_diag_utils.F +++ b/src/fm/cp_fm_diag_utils.F @@ -200,12 +200,14 @@ CONTAINS ncpu = num_pe_old - nzero ! Avoid layouts with odd number of CPUs (blacs grid layout will be square) - IF (ncpu > 2) & + IF (ncpu > 2) THEN ncpu = ncpu - MODULO(ncpu, 2) + END IF ! if there are no zero-width columns and the number of processors was even, leave it at that - IF (ncpu == num_pe_old) & + IF (ncpu == num_pe_old) THEN RETURN + END IF ! Iteratively search for the maximum number of CPUs for ELPA ! On each step, we test whether the blacs grid created with ncpu processes @@ -216,8 +218,9 @@ CONTAINS gcd_max = -1 DO ipe = 1, CEILING(SQRT(REAL(ncpu, dp))) jpe = ncpu/ipe - IF (ipe*jpe /= ncpu) & + IF (ipe*jpe /= ncpu) THEN CYCLE + END IF IF (gcd(ipe, jpe) >= gcd_max) THEN npcol = jpe gcd_max = gcd(ipe, jpe) @@ -228,17 +231,20 @@ CONTAINS ! (snippet copied from cp_fm_struct.F:cp_fm_struct_create) nzero = 0 DO ipe = 0, npcol - 1 - IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) & + IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) THEN nzero = nzero + 1 + END IF END DO - IF (nzero == 0) & + IF (nzero == 0) THEN EXIT + END IF ncpu = ncpu - nzero - IF (ncpu > 2) & + IF (ncpu > 2) THEN ncpu = ncpu - MODULO(ncpu, 2) + END IF END DO END FUNCTION cp_fm_max_ncpu_non_zero_column @@ -423,8 +429,9 @@ CONTAINS eigenvectors_new = eigenvectors END IF - IF (PRESENT(redist_info)) & + IF (PRESENT(redist_info)) THEN redist_info = rdinfo + END IF #else MARK_USED(matrix) diff --git a/src/fm/cp_fm_elpa.F b/src/fm/cp_fm_elpa.F index c55f3ba75f..0fed54533c 100644 --- a/src/fm/cp_fm_elpa.F +++ b/src/fm/cp_fm_elpa.F @@ -192,8 +192,9 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: one_stage, qr, should_print #if defined(__ELPA) - IF (elpa_init(20180525) /= ELPA_OK) & + IF (elpa_init(20180525) /= ELPA_OK) THEN CPABORT("The linked ELPA library does not support the required API version") + END IF IF (PRESENT(one_stage)) elpa_one_stage = one_stage IF (PRESENT(should_print)) elpa_print = should_print IF (PRESENT(qr)) elpa_qr = qr @@ -294,8 +295,9 @@ CONTAINS caller_is_elpa=.TRUE., redist_info=rdinfo) ! Call ELPA on CPUs that hold the new matrix - IF (ASSOCIATED(matrix_new%matrix_struct)) & + IF (ASSOCIATED(matrix_new%matrix_struct)) THEN CALL cp_fm_diag_elpa_base(matrix_new, eigenvectors_new, eigenvalues, rdinfo) + END IF ! Redistribute results and clean up CALL cp_fm_redistribute_end(matrix, eigenvectors, eigenvalues, matrix_new, eigenvectors_new) @@ -389,12 +391,14 @@ CONTAINS ! Matrix order must be even use_qr = elpa_qr .AND. (MODULO(n, 2) == 0) ! Matrix order and block size must be greater than or equal to 64 - IF (.NOT. elpa_qr_unsafe) & + IF (.NOT. elpa_qr_unsafe) THEN use_qr = use_qr .AND. (n >= 64) .AND. (nblk >= 64) + END IF ! Check if eigenvalues computed with elpa_qr_unsafe should be verified - IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) & + IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) THEN check_eigenvalues = .TRUE. + END IF CALL matrix%matrix_struct%para_env%bcast(check_eigenvalues) @@ -497,8 +501,9 @@ CONTAINS CALL elpa_obj%set("solver", & MERGE(ELPA_SOLVER_1STAGE, ELPA_SOLVER_2STAGE, elpa_one_stage), & success) - IF (success /= ELPA_OK) & + IF (success /= ELPA_OK) THEN CPABORT("Setting solver for ELPA failed") + END IF ! enabling the GPU must happen before setting the kernel SELECT CASE (elpa_kernel) @@ -539,8 +544,9 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (success /= ELPA_OK) & + IF (success /= ELPA_OK) THEN CPABORT("ELPA failed to diagonalize a matrix") + END IF IF (check_eigenvalues) THEN ! run again without QR @@ -548,11 +554,13 @@ CONTAINS CPASSERT(success == ELPA_OK) CALL elpa_obj%eigenvectors(matrix_noqr%local_data, eval_noqr, eigenvectors_noqr%local_data, success) - IF (success /= ELPA_OK) & + IF (success /= ELPA_OK) THEN CPABORT("ELPA failed to diagonalize a matrix even without QR decomposition") + END IF - IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) & + IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) THEN CPABORT("ELPA failed to calculate Eigenvalues with ELPA's QR decomposition") + END IF DEALLOCATE (eval_noqr) CALL cp_fm_release(matrix_noqr) diff --git a/src/fm/cp_fm_struct.F b/src/fm/cp_fm_struct.F index 717f915611..3082c01518 100644 --- a/src/fm/cp_fm_struct.F +++ b/src/fm/cp_fm_struct.F @@ -232,8 +232,9 @@ CONTAINS ALLOCATE (fmstruct%nrow_locals(0:(fmstruct%context%num_pe(1) - 1)), & fmstruct%ncol_locals(0:(fmstruct%context%num_pe(2) - 1))) - IF (.NOT. PRESENT(template_fmstruct)) & + IF (.NOT. PRESENT(template_fmstruct)) THEN fmstruct%first_p_pos = [0, 0] + END IF IF (PRESENT(first_p_pos)) fmstruct%first_p_pos = first_p_pos fmstruct%nrow_locals = 0 @@ -266,10 +267,12 @@ CONTAINS CALL m_flush(iunit) END IF - IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) & + IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) THEN CPABORT("sum of local cols not equal global cols") - IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) & + END IF + IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) THEN CPABORT("sum of local row not equal global rows") + END IF #else ! block = full matrix fmstruct%nrow_block = fmstruct%nrow_global @@ -281,10 +284,11 @@ CONTAINS fmstruct%local_leading_dimension = MAX(fmstruct%local_leading_dimension, & fmstruct%nrow_locals(fmstruct%context%mepos(1))) IF (PRESENT(local_leading_dimension)) THEN - IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) & + IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) THEN CALL cp_abort(__LOCATION__, "local_leading_dimension too small ("// & cp_to_string(local_leading_dimension)//"<"// & cp_to_string(fmstruct%local_leading_dimension)//")") + END IF fmstruct%local_leading_dimension = local_leading_dimension END IF diff --git a/src/fm/cp_fm_types.F b/src/fm/cp_fm_types.F index 75d6c4e816..756ad2f27e 100644 --- a/src/fm/cp_fm_types.F +++ b/src/fm/cp_fm_types.F @@ -482,8 +482,9 @@ CONTAINS my_ncol = matrix%matrix_struct%ncol_global IF (PRESENT(ncol)) my_ncol = ncol - IF (ncol_global < (my_start_col + my_ncol - 1)) & + IF (ncol_global < (my_start_col + my_ncol - 1)) THEN CPABORT("ncol_global>=(my_start_col+my_ncol-1)") + END IF ALLOCATE (buff(nrow_global)) @@ -1268,7 +1269,7 @@ CONTAINS IF (PRESENT(dir)) THEN IF (dir == 'c' .OR. dir == 'C') THEN docol = .TRUE. - ELSEIF (dir == 'r' .OR. dir == 'R') THEN + ELSE IF (dir == 'r' .OR. dir == 'R') THEN docol = .FALSE. ELSE CPABORT('Wrong argument DIR') @@ -1326,11 +1327,12 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN CALL cp_abort(__LOCATION__, & "Cannot copy full matrix <"//TRIM(source%name)// & "> to full matrix <"//TRIM(destination%name)// & ">. The local_data blocks have different sizes.") + END IF CALL dcopy(SIZE(source%local_data, 1)*SIZE(source%local_data, 2), & source%local_data, 1, destination%local_data, 1) ELSE @@ -1472,17 +1474,21 @@ CONTAINS na = msource%matrix_struct%nrow_global nb = mtarget%matrix_struct%nrow_global ! nrow must be <= na and nb - IF (nrow > na) & + IF (nrow > na) THEN CPABORT("cannot copy because nrow > number of rows of source matrix") - IF (nrow > nb) & + END IF + IF (nrow > nb) THEN CPABORT("cannot copy because nrow > number of rows of target matrix") + END IF na = msource%matrix_struct%ncol_global nb = mtarget%matrix_struct%ncol_global ! ncol must be <= na_col and nb_col - IF (ncol > na) & + IF (ncol > na) THEN CPABORT("cannot copy because nrow > number of rows of source matrix") - IF (ncol > nb) & + END IF + IF (ncol > nb) THEN CPABORT("cannot copy because nrow > number of rows of target matrix") + END IF #if defined(__parallel) desca(:) = msource%matrix_struct%descriptor(:) @@ -1716,7 +1722,8 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another + ! routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends @@ -2012,10 +2019,12 @@ CONTAINS ! check whether source is available on this process IF (ASSOCIATED(source%matrix_struct)) THEN desca = source%matrix_struct%descriptor - IF (nrows > source%matrix_struct%nrow_global) & + IF (nrows > source%matrix_struct%nrow_global) THEN CPABORT("nrows is greater than nrow_global of source") - IF (ncols > source%matrix_struct%ncol_global) & + END IF + IF (ncols > source%matrix_struct%ncol_global) THEN CPABORT("ncols is greater than ncol_global of source") + END IF smat => source%local_data ELSE desca = -1 @@ -2024,10 +2033,12 @@ CONTAINS ! check destination is available on this process IF (ASSOCIATED(destination%matrix_struct)) THEN descb = destination%matrix_struct%descriptor - IF (nrows > destination%matrix_struct%nrow_global) & + IF (nrows > destination%matrix_struct%nrow_global) THEN CPABORT("nrows is greater than nrow_global of destination") - IF (ncols > destination%matrix_struct%ncol_global) & + END IF + IF (ncols > destination%matrix_struct%ncol_global) THEN CPABORT("ncols is greater than ncol_global of destination") + END IF dmat => destination%local_data ELSE descb = -1 diff --git a/src/force_env_methods.F b/src/force_env_methods.F index 28cbe7e2ac..abb560ea63 100644 --- a/src/force_env_methods.F +++ b/src/force_env_methods.F @@ -404,8 +404,9 @@ CONTAINS "PRINT%PROGRAM_RUN_INFO") ! terminate the run if the value of the potential is abnormal - IF (abnormal_value(e_pot)) & + IF (abnormal_value(e_pot)) THEN CPABORT("Potential energy is an abnormal value (NaN/Inf).") + END IF ! Print forces, if requested print_forces = cp_print_key_unit_nr(logger, force_env%force_env_section, "PRINT%FORCES", & @@ -625,13 +626,15 @@ CONTAINS (.NOT. use_full_grid) ! Preserve restrictions selected during initial setup. The explicit DEBUG expert option ! remains available for symmetry diagnostics on otherwise unsupported cell matrices. - IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & + IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN use_inversion_symmetry_only = .TRUE. + END IF non_lower_triangular_cell = (ABS(cell%hmat(2, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 2)) > eps_cell) - IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & + IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN use_inversion_symmetry_only = .TRUE. + END IF dynamic_symmetry = kpoint_symmetry .AND. .NOT. use_full_grid .AND. & .NOT. use_inversion_symmetry_only IF (run_type_id == debug_run .AND. .NOT. fd_energy .AND. .NOT. dynamic_symmetry .AND. & @@ -1282,8 +1285,9 @@ CONTAINS !Transfer results source = 0 IF (ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) THEN - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN source = force_env%para_env%mepos + END IF END IF CALL force_env%para_env%sum(source) CALL cp_results_mp_bcast(results(iforce_eval)%results, source, force_env%para_env) @@ -1394,14 +1398,17 @@ CONTAINS CALL section_vals_val_get(mixed_section, "MIXED_CDFT%LAMBDA", r_val=lambda) ! Get the states which determine the forces CALL section_vals_val_get(mixed_section, "MIXED_CDFT%FORCE_STATES", i_vals=itmplist) - IF (SIZE(itmplist) /= 2) & + IF (SIZE(itmplist) /= 2) THEN CALL cp_abort(__LOCATION__, & "Keyword FORCE_STATES takes exactly two input values.") - IF (ANY(itmplist < 0)) & + END IF + IF (ANY(itmplist < 0)) THEN CPABORT("Invalid force_eval index.") + END IF istate = itmplist - IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) & + IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) THEN CPABORT("Invalid force_eval index.") + END IF mixed_energy%pot = lambda*energies(istate(1)) + (1.0_dp - lambda)*energies(istate(2)) ! General Mapping of forces... CALL mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces, virials, results, & @@ -1515,8 +1522,9 @@ CONTAINS ! Get Mapping index array natom = SIZE(particles(iforce_eval)%list%els) ! Serial mode need to deallocate first - IF (ASSOCIATED(map_index)) & + IF (ASSOCIATED(map_index)) THEN DEALLOCATE (map_index) + END IF CALL get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, & map_index) @@ -1526,8 +1534,9 @@ CONTAINS particles(iforce_eval)%list%els(iparticle)%r = particles_mix%els(jparticle)%r END DO ! Mixed CDFT + QMMM: Need to translate now - IF (force_env%mixed_env%do_mixed_qmmm_cdft) & + IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN CALL apply_qmmm_translate(force_env%sub_force_env(iforce_eval)%force_env%qmmm_env) + END IF END DO ! For mixed CDFT calculations parallelized over CDFT states ! build weight and gradient on all processors before splitting into groups and @@ -1593,8 +1602,9 @@ CONTAINS nforce_eval = SIZE(force_env%sub_force_env) nvar = force_env%mixed_env%cdft_control%nconstraint ! Transfer cdft strengths for writing restart - IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) & + IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) THEN ALLOCATE (force_env%mixed_env%strength(nforce_eval, nvar)) + END IF force_env%mixed_env%strength = 0.0_dp DO iforce_eval = 1, nforce_eval IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE @@ -1604,14 +1614,16 @@ CONTAINS CALL force_env_get(force_env%sub_force_env(iforce_eval)%force_env, qs_env=qs_env) END IF CALL get_qs_env(qs_env, dft_control=dft_control) - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN force_env%mixed_env%strength(iforce_eval, :) = dft_control%qs_control%cdft_control%strength(:) + END IF END DO CALL force_env%para_env%sum(force_env%mixed_env%strength) ! Mixed CDFT: calculate ET coupling IF (force_env%mixed_env%do_mixed_et) THEN - IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) & + IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) THEN CALL mixed_cdft_calculate_coupling(force_env) + END IF END IF END IF @@ -2133,9 +2145,10 @@ CONTAINS ! Calculate potential gradient if the step has been accepted. Otherwise, we reuse the previous one - IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) & + IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) THEN CALL calculate_embed_pot_grad(force_env%sub_force_env(ref_subsys_number)%force_env%qs_env, & diff_rho_r, diff_rho_spin, opt_embed) + END IF ! Take the embedding step CALL opt_embed_step(diff_rho_r, diff_rho_spin, opt_embed, embed_pot, spin_embed_pot, rho_r_ref, & force_env%sub_force_env(ref_subsys_number)%force_env%qs_env) diff --git a/src/force_env_types.F b/src/force_env_types.F index 339fcfeb75..f13f5bfbf1 100644 --- a/src/force_env_types.F +++ b/src/force_env_types.F @@ -230,10 +230,12 @@ CONTAINS CALL cp_add_default_logger(my_logger) END IF CALL force_env_release(force_env%sub_force_env(i)%force_env) - IF (force_env%in_use == use_mixed_force) & + IF (force_env%in_use == use_mixed_force) THEN CALL cp_rm_default_logger() - IF (force_env%in_use == use_embed) & + END IF + IF (force_env%in_use == use_embed) THEN CALL cp_rm_default_logger() + END IF END DO DEALLOCATE (force_env%sub_force_env) END IF diff --git a/src/force_env_utils.F b/src/force_env_utils.F index 699045290f..aba2988c97 100644 --- a/src/force_env_utils.F +++ b/src/force_env_utils.F @@ -393,7 +393,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) DO iparticle = 1, SIZE(particles%els) force = particles%els(iparticle)%f(:) - mod_force = SQRT(DOT_PRODUCT(force, force)) + mod_force = NORM2(force) IF ((mod_force > max_value) .AND. (mod_force /= 0.0_dp)) THEN force = force/mod_force*max_value particles%els(iparticle)%f(:) = force diff --git a/src/force_fields_all.F b/src/force_fields_all.F index 061e971116..798fe280b8 100644 --- a/src/force_fields_all.F +++ b/src/force_fields_all.F @@ -64,10 +64,11 @@ MODULE force_fields_all spline_nonbond_control USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, nequip_type, & - nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, pair_potential_pp_create, & - pair_potential_pp_type, pair_potential_single_add, pair_potential_single_clean, & - pair_potential_single_copy, pair_potential_single_type, sh_sh, siepmann_type, tersoff_type + ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, mace_type, & + nequip_type, nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, & + pair_potential_pp_create, pair_potential_pp_type, pair_potential_single_add, & + pair_potential_single_clean, pair_potential_single_copy, pair_potential_single_type, & + sh_sh, siepmann_type, tersoff_type USE particle_types, ONLY: allocate_particle_set,& particle_type USE physcon, ONLY: bohr @@ -2025,11 +2026,12 @@ CONTAINS only_qm = qmmm_ff_precond_only_qm(id1=atmname, is_link=is_link_atom) CALL uppercase(atmname) - IF (charge /= -HUGE(0.0_dp)) & + IF (charge /= -HUGE(0.0_dp)) THEN CALL cp_warn(__LOCATION__, & "The charge for atom index ("//cp_to_string(iatom)//") and atom name ("// & TRIM(atmname)//") was already defined. The charge associated to this kind"// & " will be set to an uninitialized value and only the atom specific charge will be used! ") + END IF charge = -HUGE(0.0_dp) ! Check if the potential really requires the charge definition.. @@ -2171,10 +2173,11 @@ CONTAINS inp_info%shell_list(j)%shell%charge_shell charge = 0.0_dp IF (found) THEN - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "CORE-SHELL model defined for KIND ("//TRIM(atmname)//")"// & " ignoring charge definition! ") + END IF ELSE found = .TRUE. END IF @@ -2192,7 +2195,7 @@ CONTAINS atmname == inp_info%nonbonded%pot(j)%pot%at2) THEN SELECT CASE (inp_info%nonbonded%pot(j)%pot%type(1)) CASE (ea_type, tersoff_type, siepmann_type, nequip_type, & - allegro_type, deepmd_type, ace_type) + allegro_type, deepmd_type, ace_type, mace_type) ! Charge is zero for EAM, TERSOFF and SIEPMANN type potential ! Do nothing.. CASE DEFAULT @@ -2929,18 +2932,20 @@ CONTAINS ((name_atm_a) == (inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" ADDING! ") + END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declarations: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") + END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. @@ -2971,18 +2976,20 @@ CONTAINS ((name_atm_a) == (qmmm_env%inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" Adding QM/MM forcefield specifications") + END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING QM/MM forcefield specifications! ") + END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), & " ", TRIM(name_atm_b) @@ -3227,18 +3234,20 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") + END IF END IF found = .TRUE. END IF @@ -3268,18 +3277,20 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") + END IF END IF found = .TRUE. END IF @@ -3306,18 +3317,20 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> ADDING") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> OVERWRITING") + END IF END IF found = .TRUE. END DO @@ -3351,18 +3364,20 @@ CONTAINS END IF IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> ADDING QM/MM forcefield specifications") + END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> OVERWRITING QM/MM forcefield specifications") + END IF END IF found = .TRUE. END IF @@ -3633,9 +3648,10 @@ CONTAINS IF (PRESENT(atm3)) fmt = fmt + 1 IF (PRESENT(atm4)) fmt = fmt + 1 CALL integer_to_string(fmt - 1, sfmt) - IF (fmt > 1) & + IF (fmt > 1) THEN my_format = '(T2,"FORCEFIELD| Missing ","'//TRIM(type_name)// & '",T40,"(",A9,'//TRIM(sfmt)//'(",",A9),")")' + END IF IF (PRESENT(fatal)) fatal = .TRUE. ! Check for previous already stored equal force fields IF (ASSOCIATED(array)) nsize = SIZE(array) @@ -3660,8 +3676,9 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN found = .TRUE. + END IF CASE ("Urey-Bradley") IF (INDEX(array(i) (21:39), "Urey-Bradley") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3671,8 +3688,9 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN found = .TRUE. + END IF CASE ("Torsion") IF (INDEX(array(i) (21:39), "Torsion") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3684,8 +3702,9 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) & + ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) THEN found = .TRUE. + END IF CASE ("Improper") IF (INDEX(array(i) (21:39), "Improper") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3701,8 +3720,9 @@ CONTAINS ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm2)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm3)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) & + ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) THEN found = .TRUE. + END IF CASE ("Out of plane bend") IF (INDEX(array(i) (21:39), "Out of plane bend") == 0) CYCLE @@ -3715,8 +3735,9 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) & + ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) THEN found = .TRUE. + END IF CASE ("Charge") IF (INDEX(array(i) (21:39), "Charge") == 0) CYCLE diff --git a/src/force_fields_input.F b/src/force_fields_input.F index 28fccce750..1df71ce40d 100644 --- a/src/force_fields_input.F +++ b/src/force_fields_input.F @@ -69,7 +69,7 @@ MODULE force_fields_input USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, deepmd_type, do_potential_single_allocation, & ea_type, eam_pot_type, ft_pot_type, ft_type, ftd_type, gal21_type, gal_type, gp_type, & - gw_type, ip_type, ipbv_pot_type, lj_charmm_type, nequip_pot_type, nequip_type, & + gw_type, ip_type, ipbv_pot_type, lj_charmm_type, mace_type, nequip_pot_type, nequip_type, & no_potential_single_allocation, pair_potential_p_type, pair_potential_reallocate, & potential_single_allocation, siepmann_type, tab_pot_type, tab_type, tersoff_type, wl_type USE shell_potential_types, ONLY: shell_p_create,& @@ -109,8 +109,8 @@ CONTAINS CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: atm_names INTEGER :: nace, nb4, nbends, nbm, nbmhft, nbmhftd, nbonds, nchg, ndeepmd, neam, ngal, & - ngal21, ngd, ngp, nimpr, nipbv, nlj, nnequip, nopbend, nshell, nsiepmann, ntab, ntersoff, & - ntors, ntot, nubs, nwl + ngal21, ngd, ngp, nimpr, nipbv, nlj, nmace, nnequip, nopbend, nshell, nsiepmann, ntab, & + ntersoff, ntors, ntot, nubs, nwl LOGICAL :: explicit, unique_spline REAL(KIND=dp) :: min_eps_spline_allowed TYPE(input_info_type), POINTER :: inp_info @@ -135,8 +135,11 @@ CONTAINS SELECT CASE (ff_type%ff_type) CASE (do_ff_charmm, do_ff_amber, do_ff_g96, do_ff_g87) CALL section_vals_val_get(ff_section, "PARM_FILE_NAME", c_val=ff_type%ff_file_name) - IF (TRIM(ff_type%ff_file_name) == "") & + + IF (TRIM(ff_type%ff_file_name) == "") THEN CPABORT("Force Field Parameter's filename is empty! Please check your input file.") + END IF + CASE (do_ff_undef) ! Do Nothing CASE DEFAULT @@ -325,6 +328,19 @@ CONTAINS CALL read_ace_section(inp_info%nonbonded, tmp_section2, ntot) END IF + tmp_section2 => section_vals_get_subs_vals(tmp_section, "MACE") + CALL section_vals_get(tmp_section2, explicit=explicit, n_repetition=nmace) + ntot = nlj + nwl + neam + ngd + nipbv + nbmhft + nbmhftd + nb4 + nbm + ngp + ntersoff + & + ngal + ngal21 + nsiepmann + nnequip + ntab + ndeepmd + nace + IF (explicit) THEN + ! avoid repeating the mace section for each pair + CALL section_vals_val_get(tmp_section2, "ATOMS", c_vals=atm_names) + nmace = nmace - 1 + SIZE(atm_names) + (SIZE(atm_names)*SIZE(atm_names) - SIZE(atm_names))/2 + ! MACE reuses the nequip_pot_type storage (set%nequip), hence nequip=.TRUE. here + CALL pair_potential_reallocate(inp_info%nonbonded, 1, ntot + nmace, nequip=.TRUE.) + CALL read_mace_section(inp_info%nonbonded, tmp_section2, ntot) + END IF + END IF tmp_section => section_vals_get_subs_vals(ff_section, "NONBONDED14") @@ -538,8 +554,9 @@ CONTAINS ipbv%a(13) = 8756947519.029_dp ipbv%a(14) = 15793297761.67_dp ipbv%a(15) = 12917180227.21_dp - ELSEIF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & - ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN + ELSE IF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & + ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN + ipbv%rcore = 2.95_dp ! a.u. ipbv%m = -0.004025691139759147_dp ! Hartree/a.u. @@ -559,7 +576,7 @@ CONTAINS ipbv%a(13) = -4224406093.918E0_dp ipbv%a(14) = 217192386506.5E0_dp ipbv%a(15) = -157581228915.5_dp - ELSEIF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN + ELSE IF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN ipbv%rcore = 3.165_dp ! a.u. ipbv%m = 0.002639704108787555_dp ! Hartree/a.u. ipbv%b = -0.2735482611857583_dp ! Hartree @@ -599,12 +616,13 @@ CONTAINS ft%a = cp_unit_to_cp2k(424.097_dp, "eV") ft%c = cp_unit_to_cp2k(1.05_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(0.499_dp, "eV*angstrom^8") - ELSEIF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & - ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN + ELSE IF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & + ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN + ft%a = cp_unit_to_cp2k(1256.31_dp, "eV") ft%c = cp_unit_to_cp2k(7.00_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(8.676_dp, "eV*angstrom^8") - ELSEIF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN + ELSE IF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN ft%a = cp_unit_to_cp2k(3488.998_dp, "eV") ft%c = cp_unit_to_cp2k(72.50_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(145.427_dp, "eV*angstrom^8") @@ -825,6 +843,54 @@ CONTAINS END SUBROUTINE read_nequip_section +! ************************************************************************************************** +!> \brief Reads the MACE section +!> \param nonbonded ... +!> \param section ... +!> \param start ... +!> \author Xinyue Sun +! ************************************************************************************************** + SUBROUTINE read_mace_section(nonbonded, section, start) + TYPE(pair_potential_p_type), POINTER :: nonbonded + TYPE(section_vals_type), POINTER :: section + INTEGER, INTENT(IN) :: start + + CHARACTER(LEN=default_string_length) :: pot_file_name + CHARACTER(LEN=default_string_length), & + DIMENSION(:), POINTER :: atm_names + INTEGER :: isec, jsec, n_items + TYPE(nequip_pot_type) :: mace + + n_items = 1 + isec = 1 + n_items = isec*n_items + CALL section_vals_val_get(section, "ATOMS", c_vals=atm_names) + CALL section_vals_val_get(section, "POT_FILE_NAME", c_val=pot_file_name) + + mace%pot_file_name = discover_file(pot_file_name) + ! MACE models use standardized units: Angstrom, eV and eV/Angstrom + mace%unit_length = "angstrom" + mace%unit_energy = "eV" + mace%unit_forces = "eV/Angstrom" + ! MACE models are exported to speak the same metadata/tensor dialect as NequIP + CALL read_nequip_data(mace) + CALL check_cp2k_atom_names_in_torch(atm_names, mace%type_names_torch) + + DO isec = 1, SIZE(atm_names) + DO jsec = isec, SIZE(atm_names) + nonbonded%pot(start + n_items)%pot%type = mace_type + nonbonded%pot(start + n_items)%pot%at1 = atm_names(isec) + nonbonded%pot(start + n_items)%pot%at2 = atm_names(jsec) + CALL uppercase(nonbonded%pot(start + n_items)%pot%at1) + CALL uppercase(nonbonded%pot(start + n_items)%pot%at2) + nonbonded%pot(start + n_items)%pot%set(1)%nequip = mace + nonbonded%pot(start + n_items)%pot%rcutsq = mace%rcutsq + n_items = n_items + 1 + END DO + END DO + + END SUBROUTINE read_mace_section + ! ************************************************************************************************** !> \brief Reads the LJ section !> \param nonbonded ... @@ -1271,10 +1337,13 @@ CONTAINS ! Calculate p_inv the inverse of the matrix p p_inv(:, :) = 0.0_dp CALL invert_matrix(p, p_inv, eval_error) - IF (eval_error >= 1.0E-8_dp) & + + IF (eval_error >= 1.0E-8_dp) THEN CALL cp_warn(__LOCATION__, & "The polynomial fit for the BUCK4RANGES potential is only accurate to "// & TRIM(cp_to_string(eval_error))) + END IF + ! Get the 6 coefficients of the 5th-order polynomial -> x(1:6) ! and the 4 coefficients of the 3rd-order polynomial -> x(7:10) x(:) = MATMUL(p_inv(:, :), v(:)) diff --git a/src/global_types.F b/src/global_types.F index 9d076d7514..6ce57fe286 100644 --- a/src/global_types.F +++ b/src/global_types.F @@ -139,8 +139,9 @@ CONTAINS CPASSERT(globenv%ref_count > 0) globenv%ref_count = globenv%ref_count - 1 IF (globenv%ref_count == 0) THEN - IF (ALLOCATED(globenv%gaussian_rng_stream)) & + IF (ALLOCATED(globenv%gaussian_rng_stream)) THEN DEALLOCATE (globenv%gaussian_rng_stream) + END IF DEALLOCATE (globenv) END IF END IF diff --git a/src/graphcon.F b/src/graphcon.F index 7a06c59b4e..e2ecc59f35 100644 --- a/src/graphcon.F +++ b/src/graphcon.F @@ -547,7 +547,7 @@ CONTAINS IF (q(k) == k) THEN q(k) = n ELSE - go to 1 + GOTO 1 END IF END DO first = .TRUE. diff --git a/src/grid/grid_api.F b/src/grid/grid_api.F index f93b6072be..3868fa9a47 100644 --- a/src/grid/grid_api.F +++ b/src/grid/grid_api.F @@ -474,14 +474,18 @@ CONTAINS hadb=hadb_cptr, & a_hdab=a_hdab_cptr) - IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) & + IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) THEN force_a = force_a + forces(:, 1) - IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) & + END IF + IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) THEN force_b = force_b + forces(:, 2) - IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) & + END IF + IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) THEN my_virial_a = my_virial_a + virials(:, :, 1) - IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) & + END IF + IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) THEN my_virial_b = my_virial_b + virials(:, :, 2) + END IF END SUBROUTINE integrate_pgf_product diff --git a/src/grpp/libgrpp.F b/src/grpp/libgrpp.F index 820b585bca..07b19227b7 100644 --- a/src/grpp/libgrpp.F +++ b/src/grpp/libgrpp.F @@ -16,6 +16,10 @@ MODULE libgrpp USE ISO_C_BINDING, ONLY: C_DOUBLE,& C_INT32_T + IMPLICIT NONE + + PRIVATE + INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_DIRAC = 0 INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_TURBOMOLE = 1 @@ -26,6 +30,12 @@ MODULE libgrpp INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_FERMI_BUBBLE = 4 INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_POINT_CHARGE_NUMERICAL = 5 + PUBLIC :: libgrpp_init + PUBLIC :: libgrpp_type1_integrals + PUBLIC :: libgrpp_type1_integrals_gradient + PUBLIC :: libgrpp_type2_integrals + PUBLIC :: libgrpp_type2_integrals_gradient + INTERFACE SUBROUTINE libgrpp_init() diff --git a/src/gw_integrals.F b/src/gw_integrals.F index 30582ab92c..9036627e7d 100644 --- a/src/gw_integrals.F +++ b/src/gw_integrals.F @@ -128,7 +128,7 @@ CONTAINS IF (ctx%op_ij == do_potential_truncated .OR. ctx%op_ij == do_potential_short) THEN ctx%dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor ctx%dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (ctx%op_ij == do_potential_coulomb) THEN + ELSE IF (ctx%op_ij == do_potential_coulomb) THEN ctx%dr_ij = 1000000.0_dp ctx%dr_ik = 1000000.0_dp END IF diff --git a/src/gw_large_cell_gamma_ri_rs.F b/src/gw_large_cell_gamma_ri_rs.F index 5dda82c272..d80730fb64 100644 --- a/src/gw_large_cell_gamma_ri_rs.F +++ b/src/gw_large_cell_gamma_ri_rs.F @@ -395,9 +395,28 @@ CONTAINS IF (.NOT. ASSOCIATED(orb_basis_set)) RETURN - IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0; END IF - IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0; END IF - IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0; END IF + IF (cell%perd(1) == 1) THEN + ix_min = -1 + ix_max = 1 + ELSE + ix_min = 0 + ix_max = 0 + END IF + IF (cell%perd(2) == 1) THEN + iy_min = -1 + iy_max = 1 + ELSE + iy_min = 0 + iy_max = 0 + END IF + + IF (cell%perd(3) == 1) THEN + iz_min = -1 + iz_max = 1 + ELSE + iz_min = 0 + iz_max = 0 + END IF r_atom = particle_set(iatom)%r @@ -952,9 +971,27 @@ CONTAINS natom = SIZE(bs_env%i_ao_start_from_atom) - IF (cell%perd(1) == 1) THEN; ix_min = -1; ix_max = 1; ELSE; ix_min = 0; ix_max = 0; END IF - IF (cell%perd(2) == 1) THEN; iy_min = -1; iy_max = 1; ELSE; iy_min = 0; iy_max = 0; END IF - IF (cell%perd(3) == 1) THEN; iz_min = -1; iz_max = 1; ELSE; iz_min = 0; iz_max = 0; END IF + IF (cell%perd(1) == 1) THEN + ix_min = -1 + ix_max = 1 + ELSE + ix_min = 0 + ix_max = 0 + END IF + IF (cell%perd(2) == 1) THEN + iy_min = -1 + iy_max = 1 + ELSE + iy_min = 0 + iy_max = 0 + END IF + IF (cell%perd(3) == 1) THEN + iz_min = -1 + iz_max = 1 + ELSE + iz_min = 0 + iz_max = 0 + END IF !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(bs_env, ctx, phi_val, d_lp, n_grid_total, n_loc_ri, atom_P, max_ao_size, & diff --git a/src/gw_non_periodic_ri_rs.F b/src/gw_non_periodic_ri_rs.F index 7c0cea6568..0cf7dfc5ef 100644 --- a/src/gw_non_periodic_ri_rs.F +++ b/src/gw_non_periodic_ri_rs.F @@ -258,14 +258,16 @@ CONTAINS DO i = 1, SIZE(zet_ao, 1) DO j = 1, SIZE(zet_ao, 2) - IF (zet_ao(i, j) > 1.0E-3_dp) & + IF (zet_ao(i, j) > 1.0E-3_dp) THEN alpha_min_ao_kind(ikind) = MIN(alpha_min_ao_kind(ikind), zet_ao(i, j)) + END IF END DO END DO DO i = 1, SIZE(zet_ri, 1) DO j = 1, SIZE(zet_ri, 2) - IF (zet_ri(i, j) > 1.0E-3_dp) & + IF (zet_ri(i, j) > 1.0E-3_dp) THEN alpha_min_ri_kind(ikind) = MIN(alpha_min_ri_kind(ikind), zet_ri(i, j)) + END IF END DO END DO END DO diff --git a/src/gw_utils.F b/src/gw_utils.F index e1f635b340..a4206cac50 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -1401,8 +1401,9 @@ CONTAINS num_pe = para_env%num_pe ! if not already set, use all processors for the group (for large-cell GW, performance ! seems to be best for a single group with all MPI processes per group) - IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) & + IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) THEN bs_env%group_size_tensor = num_pe + END IF ! group_size_tensor must divide num_pe without rest; otherwise everything will be complicated IF (MODULO(num_pe, bs_env%group_size_tensor) /= 0) THEN @@ -2052,15 +2053,17 @@ CONTAINS DO i = 1, SIZE(exp_RI, 1) DO j = 1, SIZE(exp_RI, 2) IF (exp_RI(i, j) < exp_min_RI .AND. exp_RI(i, j) > 1E-3_dp) exp_min_RI = exp_RI(i, j) - IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) & + IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) THEN exp_RI_kind(ikind) = exp_RI(i, j) + END IF END DO END DO DO i = 1, SIZE(exp_ao, 1) DO j = 1, SIZE(exp_ao, 2) IF (exp_ao(i, j) < exp_min_ao .AND. exp_ao(i, j) > 1E-3_dp) exp_min_ao = exp_ao(i, j) - IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) & + IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) THEN exp_ao_kind(ikind) = exp_ao(i, j) + END IF END DO END DO radius_ao_kind(ikind) = SQRT(-LOG(eps)/exp_ao_kind(ikind)) diff --git a/src/gx_ac_unittest.F b/src/gx_ac_unittest.F index edbb4a1617..d962c3e789 100644 --- a/src/gx_ac_unittest.F +++ b/src/gx_ac_unittest.F @@ -11,17 +11,21 @@ ! ************************************************************************************************** PROGRAM gx_ac_unittest #include "base/base_uses.f90" -#if !defined(__GREENX) - ! Abort and inform that GreenX was not included in the compilation - ! Ideally, this will be avoided in testing by the conditional tests - CPABORT("CP2K not compiled with GreenX library.") -#else +#if defined(__GREENX) USE kinds, ONLY: dp USE gx_ac, ONLY: create_thiele_pade, & evaluate_thiele_pade_at, & free_params, & params +#endif + IMPLICIT NONE + +#if !defined(__GREENX) + ! Abort and inform that GreenX was not included in the compilation + ! Ideally, this will be avoided in testing by the conditional tests + CPABORT("CP2K not compiled with GreenX library.") +#else ! Create the dataset containing the fitting data ! Two Lorentzian peaks with some overlap COMPLEX(kind=dp) :: damp_one = (2, 0), & diff --git a/src/hartree_local_methods.F b/src/hartree_local_methods.F index 78f4033388..44e58782e8 100644 --- a/src/hartree_local_methods.F +++ b/src/hartree_local_methods.F @@ -329,8 +329,9 @@ CONTAINS basis_set=basis_1c, basis_type="GAPW_1C") cneo = ASSOCIATED(cneo_potential) - IF (cneo .AND. tddft) & + IF (cneo .AND. tddft) THEN CPABORT("Electronic TDDFT with CNEO quantum nuclei is not implemented.") + END IF NULLIFY (nuc_basis) max_iso_not0_nuc = 0 @@ -372,8 +373,9 @@ CONTAINS END IF nchan_0 = nsoset(lmax0) - IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) & + IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) THEN CPABORT("channels for rho0 > # max of spherical harmonics") + END IF NULLIFY (Vh1_h, Vh1_s) ALLOCATE (Vh1_h(nr, max_iso_not0)) diff --git a/src/hdf5_wrapper.F b/src/hdf5_wrapper.F index 24a9388303..d80bd6b9cc 100644 --- a/src/hdf5_wrapper.F +++ b/src/hdf5_wrapper.F @@ -35,9 +35,16 @@ MODULE hdf5_wrapper IMPLICIT NONE + PRIVATE + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'hdf5_wrapper' #ifdef __HDF5 INTEGER, PARAMETER, PUBLIC :: hdf5_id = hid_t + + PUBLIC :: h5aread_double_scalar, h5awrite_boolean, h5awrite_double_scalar, h5awrite_double_simple + PUBLIC :: h5awrite_fixlen_string, h5awrite_integer_scalar, h5awrite_integer_simple + PUBLIC :: h5awrite_string_simple, h5close, h5dread_double_simple, h5dwrite_double_simple, h5fclose + PUBLIC :: h5fcreate, h5fopen, h5gclose, h5gcreate, h5gopen, h5open #endif CONTAINS diff --git a/src/hfx_ace_methods.F b/src/hfx_ace_methods.F index 501997a8ef..e095b59ca0 100644 --- a/src/hfx_ace_methods.F +++ b/src/hfx_ace_methods.F @@ -182,15 +182,17 @@ CONTAINS nspins = dft_control%nspins IF (n_rep_hf /= 1) CPABORT("ACE: only one &HF section is supported.") - IF (dft_control%nimages /= 1) & + IF (dft_control%nimages /= 1) THEN CPABORT("ACE: k-points / multiple images are not implemented.") + END IF ! ACE requires explicit MO coefficients (C_occ) which are only available ! with diagonalization-based SCF. OT never constructs mo_coeff during ! the SCF, so the ACE projector build loop would silently get garbage. CALL get_qs_env(qs_env, scf_control=scf_control) - IF (scf_control%use_ot) & + IF (scf_control%use_ot) THEN CPABORT("ACE: OT doesn't work, use diagonalization-based SCF.") + END IF rebuild_freq = MAX(1, ace_rebuild_frequency) @@ -198,8 +200,9 @@ CONTAINS ! Bypass A: energy-only call ! ------------------------------------------------------------------ IF (just_energy) THEN - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T2,A)') 'ACE | just_energy=T: full HFX (no matrix update)' + END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -211,8 +214,9 @@ CONTAINS ! Bypass B: ionic forces requested ! ------------------------------------------------------------------ IF (calculate_forces) THEN - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T2,A)') 'ACE | calculate_forces=T: full HFX for exact forces' + END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -271,13 +275,15 @@ CONTAINS IF (ace_built_now) THEN ace_is_built = .TRUE. ace_step_counter = 1 - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'ACE | W built. Projector live from next step.' + END IF ELSE ace_is_built = .FALSE. ace_step_counter = 0 - IF (DBG_ROUTING .AND. iw > 0) & + IF (DBG_ROUTING .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'ACE | Build deferred (C_occ=0). Full HFX in ks_matrix.' + END IF END IF ELSE @@ -409,8 +415,9 @@ CONTAINS v_rspace_new, v_tau_rspace, ext_xc_section) ehfx_full = energy%ex - IF (DBG_BUILD .AND. iw > 0) & + IF (DBG_BUILD .AND. iw > 0) THEN WRITE (iw, '(/,T2,A,F20.10)') 'ACE BUILD | E_x(full HFX) = ', ehfx_full + END IF ! Allocate / resize module storage IF (ALLOCATED(ace_W)) THEN @@ -426,9 +433,10 @@ CONTAINS ! ---------------------------------------------------------------- DO ispin = 1, nspins - IF (mos_for_ace(ispin)%use_mo_coeff_b) & + IF (mos_for_ace(ispin)%use_mo_coeff_b) THEN CALL copy_dbcsr_to_fm(mos_for_ace(ispin)%mo_coeff_b, & mos_for_ace(ispin)%mo_coeff) + END IF CALL get_mo_set(mos_for_ace(ispin), mo_coeff=mo_coeff, & nao=nao, nmo=nmo, homo=nocc, & @@ -450,8 +458,9 @@ CONTAINS END IF IF (frob < 1.0e-20_dp) THEN - IF (DBG_BUILD .AND. iw > 0) & + IF (DBG_BUILD .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'mo_coeff=0: build deferred to next step.' + END IF CALL timestop(handle) RETURN END IF @@ -530,12 +539,14 @@ CONTAINS CPABORT("ACE: Cholesky of -M failed (not positive definite).") END IF - IF (DBG_BUILD .AND. iw > 0) & + IF (DBG_BUILD .AND. iw > 0) THEN WRITE (iw, '(T4,A)') 'Cholesky OK (info=0).' + END IF ! Step 7: W = xi * U^{-1} - IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) & + IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) THEN CALL cp_fm_release(ace_W(1, ispin)) + END IF CALL cp_fm_create(ace_W(1, ispin), xi_fm%matrix_struct, name="W_ACE") CALL cp_fm_to_fm(xi_fm, ace_W(1, ispin)) @@ -735,9 +746,10 @@ CONTAINS CALL cp_fm_release(P_fm) CALL cp_fm_release(PW_fm) - IF (DBG_ENERGY .AND. iw > 0) & + IF (DBG_ENERGY .AND. iw > 0) THEN WRITE (iw, '(T4,A,I4,A,F20.10)') & - 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val + 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val + END IF END DO energy%ex = ehfx_ace @@ -776,15 +788,17 @@ CONTAINS IF (do_admm) THEN CALL get_admm_env(admm_env, mos_aux_fit=mos_aux_diag) - IF (mos_aux_diag(ispin)%use_mo_coeff_b) & + IF (mos_aux_diag(ispin)%use_mo_coeff_b) THEN CALL copy_dbcsr_to_fm(mos_aux_diag(ispin)%mo_coeff_b, & mos_aux_diag(ispin)%mo_coeff) + END IF CALL get_mo_set(mos_aux_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) ELSE - IF (mos_diag(ispin)%use_mo_coeff_b) & + IF (mos_diag(ispin)%use_mo_coeff_b) THEN CALL copy_dbcsr_to_fm(mos_diag(ispin)%mo_coeff_b, & mos_diag(ispin)%mo_coeff) + END IF CALL get_mo_set(mos_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) END IF diff --git a/src/hfx_admm_utils.F b/src/hfx_admm_utils.F index 95aa6eb99c..502353ae25 100644 --- a/src/hfx_admm_utils.F +++ b/src/hfx_admm_utils.F @@ -213,8 +213,9 @@ CONTAINS IF (PRESENT(ext_xc_section)) hfx_sections => section_vals_get_subs_vals(ext_xc_section, "HF") CALL section_vals_get(hfx_sections, n_repetition=n_rep_hf) - IF (n_rep_hf > 1) & + IF (n_rep_hf > 1) THEN CPABORT("ADMM can handle only one HF section.") + END IF IF (.NOT. ASSOCIATED(admm_env)) THEN ! setup admm environment @@ -228,8 +229,9 @@ CONTAINS admm_env=admm_env) ! Initialize the GAPW data types - IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) & + IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN CALL init_admm_gapw(qs_env) + END IF ! ADMM neighbor lists and overlap matrices CALL admm_init_hamiltonians(admm_env, qs_env, "AUX_FIT") @@ -304,11 +306,13 @@ CONTAINS CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) !Test combinations of input values. So far, only ADMM2 is availavle - IF (.NOT. admm_env%purification_method == do_admm_purify_none) & + IF (.NOT. admm_env%purification_method == do_admm_purify_none) THEN CPABORT("Only ADMM_PURIFICATION_METHOD NONE implemeted for ADMM K-points") + END IF IF (.NOT. (dft_control%admm_control%method == do_admm_basis_projection & - .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) & + .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) THEN CPABORT("Only BASIS_PROJECTION and CHARGE_CONSTRAINED_PROJECTION implemented for KP") + END IF IF (admm_env%do_admms .OR. admm_env%do_admmp .OR. admm_env%do_admmq) THEN IF (use_real_wfn) CPABORT("Only KP-HFX ADMM2 is implemented with REAL wavefunctions") END IF @@ -637,7 +641,7 @@ CONTAINS mic = molecule_only IF (kpoints%nkp > 0) THEN mic = .FALSE. - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN mic = .TRUE. END IF @@ -1239,8 +1243,9 @@ CONTAINS ! Remember: Vhfx is added, energy is calclulated from total Vhfx, ! so energy of last iteration is correct - IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) & + IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) THEN CPABORT("HFX_TREAT_LSD_IN_CORE not implemented for adiabatically rescaled hybrids") + END IF ! everything is calculated with adiabatic rescaling but the potential is not added in a first step distribute_fock_matrix = .NOT. do_adiabatic_rescaling diff --git a/src/hfx_compression_methods.F b/src/hfx_compression_methods.F index d6d0df4ae7..6b9e07e456 100644 --- a/src/hfx_compression_methods.F +++ b/src/hfx_compression_methods.F @@ -225,7 +225,9 @@ CONTAINS !! This happens in case a container has fully been filled in the compression step !! but no other was needed for the current bit size !! Therefore we can safely igonore an eof error + ! We still need to ask for it to read the data correctly, so we mark it as used READ (container%unit, IOSTAT=stat) container%current%data + MARK_USED(stat) memory_usage = memory_usage + 1 container%file_counter = container%file_counter + 1 ELSE diff --git a/src/hfx_energy_potential.F b/src/hfx_energy_potential.F index 679a821530..eec9821017 100644 --- a/src/hfx_energy_potential.F +++ b/src/hfx_energy_potential.F @@ -3123,12 +3123,13 @@ CONTAINS DO mb = 1, mb_max DO ma = 1, ma_max iint = iint + 1 - IF (ABS(prim(iint)) > 0.0000000000001) & + IF (ABS(prim(iint)) > 0.0000000000001) THEN WRITE (99, *) atom_offsets(i, 1) + ma + set_offsets(iset, 1, i, 1) - 1, & - atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & - atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & - atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & - prim(iint) + atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & + atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & + atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & + prim(iint) + END IF END DO END DO END DO diff --git a/src/hfx_exx.F b/src/hfx_exx.F index 4116db4143..c083d86131 100644 --- a/src/hfx_exx.F +++ b/src/hfx_exx.F @@ -567,7 +567,7 @@ CONTAINS xc_section_aux => qs_env%mp2_env%ri_rpa%xc_section_aux xc_section_primary => qs_env%mp2_env%ri_rpa%xc_section_primary END IF - ELSEIF (qs_env%energy_correction) THEN + ELSE IF (qs_env%energy_correction) THEN IF (ASSOCIATED(qs_env%ec_env%xc_section_aux) .AND. & ASSOCIATED(qs_env%ec_env%xc_section_primary)) THEN xc_section_aux => qs_env%ec_env%xc_section_aux diff --git a/src/hfx_load_balance_methods.F b/src/hfx_load_balance_methods.F index 5b13c6a164..38f34ce1e0 100644 --- a/src/hfx_load_balance_methods.F +++ b/src/hfx_load_balance_methods.F @@ -1860,9 +1860,10 @@ CONTAINS ! it also avoids degenerate cases where thousands of zero sized tasks ! are assigned to the same (least loaded) cpu ! - IF (do_randomize) & + IF (do_randomize) THEN rng_stream = rng_stream_type(name="uniform_rng", & distribution_type=UNIFORM) + END IF DO i = total_number_of_bins, 1, -nstep tmp_cpu_cost = my_cost_cpu diff --git a/src/hfx_pw_methods.F b/src/hfx_pw_methods.F index 8551fc0b85..f4a1e7ca5b 100644 --- a/src/hfx_pw_methods.F +++ b/src/hfx_pw_methods.F @@ -147,7 +147,7 @@ CONTAINS END IF IF (potential_type == do_potential_coulomb) THEN CALL pw_copy(poisson_env%green_fft%influence_fn, greenfn) - ELSEIF (potential_type == do_potential_truncated) THEN + ELSE IF (potential_type == do_potential_truncated) THEN CALL section_vals_val_get(ip_section, "CUTOFF_RADIUS", r_val=rcut) grid => poisson_env%green_fft%influence_fn%pw_grid DO ig = grid%first_gne0, grid%ngpts_cut_local @@ -156,9 +156,10 @@ CONTAINS g3d = fourpi/g2 greenfn%array(ig) = g3d*(1.0_dp - COS(rcut*gg)) END DO - IF (grid%have_g0) & + IF (grid%have_g0) THEN greenfn%array(1) = 0.5_dp*fourpi*rcut*rcut - ELSEIF (potential_type == do_potential_short) THEN + END IF + ELSE IF (potential_type == do_potential_short) THEN CALL section_vals_val_get(ip_section, "OMEGA", r_val=omega) IF (omega > 0.0_dp) omega = 0.25_dp/(omega*omega) grid => poisson_env%green_fft%influence_fn%pw_grid diff --git a/src/hfx_ri.F b/src/hfx_ri.F index 23675f8016..087348e6b3 100644 --- a/src/hfx_ri.F +++ b/src/hfx_ri.F @@ -3708,9 +3708,10 @@ CONTAINS CALL get_RI_density_coeffs(density_coeffs, rho_ao, 1, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) - IF (nspins == 2) & + IF (nspins == 2) THEN CALL get_RI_density_coeffs(density_coeffs_2, rho_ao, 2, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) + END IF unit_nr = cp_print_key_unit_nr(logger, input, "DFT%XC%HF%RI%PRINT%RI_DENSITY_COEFFS", & extension=".dat", file_status="REPLACE", & diff --git a/src/hfx_ri_kp.F b/src/hfx_ri_kp.F index 238d2f9b50..2093e39aad 100644 --- a/src/hfx_ri_kp.F +++ b/src/hfx_ri_kp.F @@ -250,8 +250,9 @@ CONTAINS !We do all the checks on what we allow in this initial implementation IF (ri_data%flavor /= ri_pmat) CPABORT("K-points RI-HFX only with RHO flavor") IF (ri_data%same_op) ri_data%same_op = .FALSE. !force the full calculation with RI metric - IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) & + IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) THEN CPABORT("RI%EPS_PGF_ORB and QS%EPS_PGF_ORB must be identical for RI-HFX k-points") + END IF CALL get_kp_and_ri_images(ri_data, qs_env) nimg = ri_data%nimg @@ -3637,8 +3638,9 @@ CONTAINS DO i_img = 1, nimg DO i_spin = 1, nspins - IF (.NOT. (i_img == 1 .AND. i_spin == 1)) & + IF (.NOT. (i_img == 1 .AND. i_spin == 1)) THEN CALL dbt_create(rho_ao_t_sub(1, 1), rho_ao_t_sub(i_spin, i_img)) + END IF CALL copy_2c_to_subgroup(rho_ao_t_sub(i_spin, i_img), rho_ao_t(i_spin, i_img), & group_size, ngroups, para_env) CALL dbt_destroy(rho_ao_t(i_spin, i_img)) @@ -4398,8 +4400,9 @@ CONTAINS CALL neighbor_list_iterator_release(nl_iterator) CALL release_neighbor_list_sets(nl_2c) CALL para_env%max(ri_data%nimg) - IF (ri_data%nimg > nimg) & + IF (ri_data%nimg > nimg) THEN CPABORT("Make sure the smallest exponent of the RI-HFX basis is larger than that of the ORB basis.") + END IF !Keep track of which images will not contribute, so that can be ignored before calculation CALL para_env%sum(present_img) diff --git a/src/hfx_types.F b/src/hfx_types.F index 1c11cc9d77..d81fd2de0e 100644 --- a/src/hfx_types.F +++ b/src/hfx_types.F @@ -778,8 +778,9 @@ CONTAINS actual_x_data%load_balance_parameter%do_randomize = logic_val actual_x_data%load_balance_parameter%rtp_redistribute = .FALSE. - IF (ASSOCIATED(dft_control%rtp_control)) & + IF (ASSOCIATED(dft_control%rtp_control)) THEN actual_x_data%load_balance_parameter%rtp_redistribute = dft_control%rtp_control%hfx_redistribute + END IF CALL section_vals_val_get(hf_sub_section, "BLOCK_SIZE", i_val=int_val) ! negative values ask for a computed default @@ -1044,11 +1045,13 @@ CONTAINS ! Sanity checks IF (actual_x_data%use_ace) THEN ! ACE requires HFX to be meaningful - IF (actual_x_data%general_parameter%fraction <= 0.0_dp) & + IF (actual_x_data%general_parameter%fraction <= 0.0_dp) THEN CPABORT("ACE requires FRACTION > 0.") + END IF ! If frequency is 1, it is full HFX - IF (actual_x_data%ace_rebuild_freq < 1) & + IF (actual_x_data%ace_rebuild_freq < 1) THEN CPABORT("ACE: REBUILD_FREQUENCY must be >= 1") + END IF END IF END IF END DO @@ -1216,8 +1219,9 @@ CONTAINS ri_metric%scale_longrange = hfx_pot%scale_longrange END IF - IF (ri_metric%potential_type == do_potential_short) & + IF (ri_metric%potential_type == do_potential_short) THEN CALL erfc_cutoff(ri_data%eps_schwarz, ri_metric%omega, ri_metric%cutoff_radius) + END IF IF (ri_metric%potential_type == do_potential_id) ri_metric%cutoff_radius = 0.0_dp END ASSOCIATE @@ -1432,7 +1436,7 @@ CONTAINS DEALLOCATE (dist1, dist2) CALL dbt_create(ri_data%ks_t(1, 1), ri_data%ks_t(2, 1)) - ELSEIF (ri_data%flavor == ri_mo) THEN + ELSE IF (ri_data%flavor == ri_mo) THEN ALLOCATE (ri_data%t_2c_int(2, 1)) CALL create_2c_tensor(ri_data%t_2c_int(1, 1), dist1, dist2, ri_data%pgrid_2d, & @@ -1622,7 +1626,7 @@ CONTAINS DEALLOCATE (ri_data%blk_indices) DEALLOCATE (ri_data%store_3c) - ELSEIF (ri_data%flavor == ri_mo) THEN + ELSE IF (ri_data%flavor == ri_mo) THEN CALL dbt_destroy(ri_data%t_3c_int_ctr_1(1, 1)) CALL dbt_destroy(ri_data%t_3c_int_ctr_2(1, 1)) DEALLOCATE (ri_data%t_3c_int_ctr_1) diff --git a/src/hfxbase/hfx_compression_core_methods.F b/src/hfxbase/hfx_compression_core_methods.F index 302e5b90b6..bdb6ca7c6a 100644 --- a/src/hfxbase/hfx_compression_core_methods.F +++ b/src/hfxbase/hfx_compression_core_methods.F @@ -21,38 +21,38 @@ MODULE hfx_compression_core_methods ! masks the corresponding number of bits from the right INTEGER(kind=int_8), PARAMETER :: mask_right(0:63) = & - (/0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & + [0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & 1023_int_8, 2047_int_8, 4095_int_8, 8191_int_8, 16383_int_8, 32767_int_8, 65535_int_8, 131071_int_8, & 262143_int_8, 524287_int_8, 1048575_int_8, 2097151_int_8, 4194303_int_8, 8388607_int_8, 16777215_int_8, & 33554431_int_8, 67108863_int_8, 134217727_int_8, 268435455_int_8, 536870911_int_8, 1073741823_int_8, & - 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & + 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & 68719476735_int_8, 137438953471_int_8, 274877906943_int_8, 549755813887_int_8, 1099511627775_int_8, & - 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & - 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & + 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & + 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & 562949953421311_int_8, 1125899906842623_int_8, 2251799813685247_int_8, 4503599627370495_int_8, & 9007199254740991_int_8, 18014398509481983_int_8, 36028797018963967_int_8, 72057594037927935_int_8, & - 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & - 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & - 9223372036854775807_int_8/) + 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & + 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & + 9223372036854775807_int_8] ! masks the corresponding number of bits from the left ! use ishft to avoid explicitly writing -HUGE-1, and keep it out of the array a work-around for a bug in pgi 6.1-1 INTEGER(kind=int_8), PARAMETER :: ugly_duck = ISHFT(1_int_8, 63) INTEGER(kind=int_8), PARAMETER :: mask_left(0:63) = & - (/0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & - -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & - -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & + [0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & + -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & + -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & -18014398509481984_int_8, -9007199254740992_int_8, -4503599627370496_int_8, -2251799813685248_int_8, & -1125899906842624_int_8, -562949953421312_int_8, -281474976710656_int_8, -140737488355328_int_8, & - -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & - -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & + -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & + -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & -274877906944_int_8, -137438953472_int_8, -68719476736_int_8, -34359738368_int_8, -17179869184_int_8, & -8589934592_int_8, -4294967296_int_8, -2147483648_int_8, -1073741824_int_8, -536870912_int_8, & - -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & + -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & -8388608_int_8, -4194304_int_8, -2097152_int_8, -1048576_int_8, -524288_int_8, -262144_int_8, & -131072_int_8, -65536_int_8, -32768_int_8, -16384_int_8, -8192_int_8, -4096_int_8, -2048_int_8, & -1024_int_8, -512_int_8, -256_int_8, -128_int_8, -64_int_8, -32_int_8, -16_int_8, -8_int_8, -4_int_8, & - -2_int_8/) + -2_int_8] PUBLIC :: bits2ints_specific, ints2bits_specific @@ -70,7 +70,7 @@ CONTAINS INTEGER(KIND=int_8), INTENT(OUT) :: full_data(*) full_data(1:Ndata) = packed_data(1:Ndata) - END SUBROUTINE + END SUBROUTINE ints2ints ! Nbits : number of relevant bits per int in the bit stream (this includes all bits) ! Ndata : number of ints that need to be extracted from the bit stream @@ -160,22 +160,30 @@ CONTAINS idata = idata + 1 IF (ibits_remaining >= Nbits) THEN data_tmp = full_data(idata) - data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left - pack_tmp = IOR(pack_tmp, data_tmp) ! add to the packed data + ! put bits on the left + data_tmp = ISHFT(data_tmp, 64 - Nbits) + ! add to the packed data + pack_tmp = IOR(pack_tmp, data_tmp) ibits_remaining = ibits_remaining - Nbits - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! and shift to the right to make place for the next + ! and shift to the right to make place for the next + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ELSE i_odd_bits = ibits_remaining data_tmp = full_data(idata) - data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left - data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) ! restrict to those bits for which we still have space + ! put bits on the left + data_tmp = ISHFT(data_tmp, 64 - Nbits) + ! restrict to those bits for which we still have space + data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) pack_tmp = IOR(pack_tmp, data_tmp) ! add them to the packed bits ipack = ipack + 1 - packed_data(ipack) = pack_tmp ! store the full packed data away and start with a new one + ! store the full packed data away and start with a new one + packed_data(ipack) = pack_tmp data_tmp = full_data(idata) - pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) ! put the missing bits on the left if pack_tmp + ! put the missing bits on the left if pack_tmp + pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) ibits_remaining = 64 - Nbits + i_odd_bits - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! shift to make place, but not more than the number of available bits + ! shift to make place, but not more than the number of available bits + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) END IF END DO diff --git a/src/hirshfeld_methods.F b/src/hirshfeld_methods.F index d045ff0a39..f4dbc0691a 100644 --- a/src/hirshfeld_methods.F +++ b/src/hirshfeld_methods.F @@ -220,16 +220,18 @@ CONTAINS IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) & + IF (hirshfeld_env%use_bohr) THEN rco = cp_unit_to_cp2k(rco, "angstrom") + END IF END IF CASE (radius_covalent) CALL get_ptable_info(symbol=esym, covalent_radius=rco, found=found) IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) & + IF (hirshfeld_env%use_bohr) THEN rco = cp_unit_to_cp2k(rco, "angstrom") + END IF END IF CASE (radius_single) CPASSERT(PRESENT(radius)) diff --git a/src/iao_analysis.F b/src/iao_analysis.F index 0e658efcd6..080d92ca5c 100644 --- a/src/iao_analysis.F +++ b/src/iao_analysis.F @@ -1179,7 +1179,7 @@ CONTAINS WRITE (filename, '(A18,I1.1)') "IBO_CENTERS_SPREAD" iw = cp_print_key_unit_nr(logger, print_section, "", extension=".csp", & middle_name=TRIM(filename), file_position="REWIND", log_filename=.FALSE.) - ELSEIF (PRESENT(iounit)) THEN + ELSE IF (PRESENT(iounit)) THEN iw = iounit ELSE iw = -1 @@ -1702,7 +1702,7 @@ CONTAINS IF (order == 2) THEN aij = aij + 4._dp*mij**2 - (mii - mjj)**2 bij = bij + 4._dp*mij*(mii - mjj) - ELSEIF (order == 4) THEN + ELSE IF (order == 4) THEN aij = aij - mii**4 - mjj**4 + 6._dp*(mii**2 + mjj**2)*mij**2 + & mii**3*mjj + mii*mjj**3 bij = bij + 4._dp*mij*(mii**3 - mjj**3) diff --git a/src/iao_types.F b/src/iao_types.F index ce837e271c..27fa24a883 100644 --- a/src/iao_types.F +++ b/src/iao_types.F @@ -239,8 +239,9 @@ CONTAINS nfrags = 0 DO ii = 1, SIZE(particle_set) - IF (nfrags < particle_set(ii)%fragment_index) & + IF (nfrags < particle_set(ii)%fragment_index) THEN nfrags = particle_set(ii)%fragment_index + END IF END DO logger => cp_get_default_logger() @@ -269,13 +270,13 @@ CONTAINS IF (particle_set(iatom)%fragment_index == jj) THEN totalcol = totalcol + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcoljj = .FALSE. - ELSEIF (lfirstcoljj) THEN + ELSE IF (lfirstcoljj) THEN colskip = colskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF IF (particle_set(iatom)%fragment_index == ii) THEN totalrow = totalrow + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcol = .FALSE. - ELSEIF (lfirstcol) THEN + ELSE IF (lfirstcol) THEN rowskip = rowskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF rowfrag = rowfrag + orb_basis_set_list(ikind)%gto_basis_set%nsgf diff --git a/src/input/cp_output_handling.F b/src/input/cp_output_handling.F index 8abac352bf..ca7c1fb19e 100644 --- a/src/input/cp_output_handling.F +++ b/src/input/cp_output_handling.F @@ -981,33 +981,38 @@ CONTAINS filename_bak_2 = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(i - 1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Moving file "//TRIM(filename_bak_2)// & - " into file "//TRIM(filename_bak_1)//"." + " into file "//TRIM(filename_bak_1)//"." + END IF END IF INQUIRE (FILE=filename_bak_2, EXIST=found) IF (.NOT. found) THEN IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "File "//TRIM(filename_bak_2)//" not existing.." + END IF END IF ELSE ! Shared file: rotate on the source rank only; per-task ! (my_local) files are per-rank, rotated by their owner. - IF (my_local .OR. logger%para_env%is_source()) & + IF (my_local .OR. logger%para_env%is_source()) THEN CALL m_mov(TRIM(filename_bak_2), TRIM(filename_bak_1)) + END IF END IF END DO ! The last backup is always the one with index 1 filename_bak = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Moving file "//TRIM(filename)//" into file "//TRIM(filename_bak)//"." + END IF END IF - IF (my_local .OR. logger%para_env%is_source()) & + IF (my_local .OR. logger%para_env%is_source()) THEN CALL m_mov(TRIM(filename), TRIM(filename_bak)) + END IF ELSE ! Zero the backup history for this new iteration level.. print_key%ibackup(my_backup_level) = 0 @@ -1028,10 +1033,11 @@ CONTAINS END IF IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Writing "//TRIM(print_key%section%name)//" "// & - TRIM(cp_iter_string(logger%iter_info))//" to "// & - TRIM(filename) + TRIM(cp_iter_string(logger%iter_info))//" to "// & + TRIM(filename) + END IF END IF END IF ELSE diff --git a/src/input/cp_parser_ilist_methods.F b/src/input/cp_parser_ilist_methods.F index bb8b41979c..6b178f7ab2 100644 --- a/src/input/cp_parser_ilist_methods.F +++ b/src/input/cp_parser_ilist_methods.F @@ -44,11 +44,12 @@ CONTAINS ind = INDEX(token, "..") READ (UNIT=token(:ind - 1), FMT=*) ilist%istart READ (UNIT=token(ind + 2:), FMT=*) ilist%iend - IF (ilist%istart > ilist%iend) & + IF (ilist%istart > ilist%iend) THEN CALL cp_abort(__LOCATION__, & "Invalid list range specified: "// & TRIM(ADJUSTL(cp_to_string(ilist%istart)))//".."// & TRIM(ADJUSTL(cp_to_string(ilist%iend)))) + END IF ilist%nel_list = ilist%iend - ilist%istart + 1 ilist%ipresent = ilist%istart ilist%in_use = .TRUE. diff --git a/src/input/cp_parser_inpp_methods.F b/src/input/cp_parser_inpp_methods.F index dd2d552f06..1ba2e7f5dc 100644 --- a/src/input/cp_parser_inpp_methods.F +++ b/src/input/cp_parser_inpp_methods.F @@ -53,15 +53,18 @@ CONTAINS is_valid_varname = .FALSE. - IF (LEN(str) == 0) & + IF (LEN(str) == 0) then RETURN + end if - IF (INDEX(alpha, str(1:1)) == 0) & + IF (INDEX(alpha, str(1:1)) == 0) then RETURN + end if DO idx = 2, LEN(str) - IF (INDEX(alphanum, str(idx:idx)) == 0) & + IF (INDEX(alphanum, str(idx:idx)) == 0) then RETURN + end if END DO is_valid_varname = .TRUE. @@ -592,8 +595,9 @@ CONTAINS CPABORT(TRIM(message)) END IF - IF (idx > 0) & + IF (idx > 0) then var_value = TRIM(inpp%variable_value(idx)) + end if newline = input_line(1:pos1 - 3)//var_value//input_line(pos2 + 2:) input_line = newline @@ -605,8 +609,9 @@ CONTAINS pos1 = pos1 + 1 ! move to the start of the variable name pos2 = INDEX(input_line(pos1:), ' ') - IF (pos2 == 0) & + IF (pos2 == 0) then pos2 = LEN_TRIM(input_line(pos1:)) + 1 + end if pos2 = pos1 + pos2 - 2 ! end of the variable name, minus the separating whitespace var_name = input_line(pos1:pos2) diff --git a/src/input/cp_parser_methods.F b/src/input/cp_parser_methods.F index a57066f206..8b9b1bbbc7 100644 --- a/src/input/cp_parser_methods.F +++ b/src/input/cp_parser_methods.F @@ -548,8 +548,9 @@ CONTAINS ! Read input string of fixed length (single line) ! Check for EOF - IF (parser%icol == -1) & + IF (parser%icol == -1) THEN CPABORT("Unexpectetly reached EOF"//TRIM(parser_location(parser))) + END IF length = MIN(len_trim_inputline - parser%icol1 + 1, length) parser%icol1 = parser%icol + 1 diff --git a/src/input/cp_parser_types.F b/src/input/cp_parser_types.F index d4fec0975d..f8a4340268 100644 --- a/src/input/cp_parser_types.F +++ b/src/input/cp_parser_types.F @@ -196,8 +196,9 @@ CONTAINS parser%input_unit = unit_nr IF (PRESENT(file_name)) parser%input_file_name = TRIM(ADJUSTL(file_name)) ELSE - IF (.NOT. PRESENT(file_name)) & + IF (.NOT. PRESENT(file_name)) THEN CPABORT("at least one of filename and unit_nr must be present") + END IF CALL open_file(file_name=TRIM(ADJUSTL(file_name)), & unit_number=parser%input_unit) parser%input_file_name = TRIM(ADJUSTL(file_name)) diff --git a/src/input/input_enumeration_types.F b/src/input/input_enumeration_types.F index 112b8b49ae..ca21d04940 100644 --- a/src/input/input_enumeration_types.F +++ b/src/input/input_enumeration_types.F @@ -175,8 +175,9 @@ CONTAINS END DO PRINT *, enum%i_vals END IF - IF (enum%strict) & + IF (enum%strict) THEN CPABORT("invalid value for enumeration:"//cp_to_string(i)) + END IF res = ADJUSTL(cp_to_string(i)) END IF END FUNCTION enum_i2c @@ -211,11 +212,13 @@ CONTAINS END DO IF (.NOT. found) THEN - IF (enum%strict) & + IF (enum%strict) THEN CPABORT("invalid value for enumeration:"//TRIM(c)) + END IF READ (c, "(i10)", iostat=iostat) res - IF (iostat /= 0) & + IF (iostat /= 0) THEN CPABORT("invalid value for enumeration2:"//TRIM(c)) + END IF END IF END FUNCTION enum_c2i diff --git a/src/input/input_keyword_types.F b/src/input/input_keyword_types.F index 1665d10024..8f33f0b1bd 100644 --- a/src/input/input_keyword_types.F +++ b/src/input/input_keyword_types.F @@ -274,8 +274,9 @@ CONTAINS IF (PRESENT(default_l_val) .OR. PRESENT(default_l_vals) .OR. & PRESENT(default_i_val) .OR. PRESENT(default_i_vals) .OR. & PRESENT(default_r_val) .OR. PRESENT(default_r_vals) .OR. & - PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) & + PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) THEN CPABORT("you should pass either default_val or a default value, not both") + END IF keyword%default_value => default_val IF (ASSOCIATED(default_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN @@ -310,10 +311,11 @@ CONTAINS " assumed undefined type by default") END IF ELSE IF (PRESENT(type_of_var)) THEN - IF (keyword%type_of_var /= type_of_var) & + IF (keyword%type_of_var /= type_of_var) THEN CALL cp_abort(__LOCATION__, & "keyword "//TRIM(keyword%names(1))// & " has a type different from the type of the default_value") + END IF keyword%type_of_var = type_of_var END IF @@ -325,15 +327,17 @@ CONTAINS IF (PRESENT(lone_keyword_l_val) .OR. PRESENT(lone_keyword_l_vals) .OR. & PRESENT(lone_keyword_i_val) .OR. PRESENT(lone_keyword_i_vals) .OR. & PRESENT(lone_keyword_r_val) .OR. PRESENT(lone_keyword_r_vals) .OR. & - PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) & + PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) THEN CALL cp_abort(__LOCATION__, & "you should pass either lone_keyword_val or a lone_keyword value, not both") + END IF keyword%lone_keyword_value => lone_keyword_val CALL val_retain(lone_keyword_val) IF (ASSOCIATED(lone_keyword_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN - IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) & + IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) THEN CPABORT("keyword%enum/=lone_keyword_val%enum") + END IF ELSE IF (ASSOCIATED(keyword%lone_keyword_value)) THEN CPABORT(".NOT. ASSOCIATED(keyword%lone_keyword_value)") @@ -355,8 +359,9 @@ CONTAINS IF (keyword%lone_keyword_value%type_of_var == no_t) THEN CALL val_release(keyword%lone_keyword_value) ELSE - IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) & + IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) THEN CPABORT("lone_keyword_value type incompatible with keyword type") + END IF ! lc_val cannot have lone_keyword_value! IF (keyword%type_of_var == enum_t) THEN IF (keyword%enum%strict) THEN @@ -364,8 +369,9 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) & + IF (.NOT. check) THEN CPABORT("default value not in enumeration : "//keyword%names(1)) + END IF END IF END IF END IF @@ -384,8 +390,9 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) & + IF (.NOT. check) THEN CPABORT("default value not in enumeration : "//keyword%names(1)) + END IF END IF keyword%n_var = SIZE(keyword%default_value%i_val) CASE (real_t) @@ -401,8 +408,9 @@ CONTAINS END SELECT END IF IF (PRESENT(n_var)) keyword%n_var = n_var - IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) & + IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) THEN CPABORT("arrays of lchar_t not supported : "//keyword%names(1)) + END IF IF (PRESENT(unit_str)) THEN ALLOCATE (keyword%unit) @@ -760,10 +768,11 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(keyword%description))) & //"" - IF (ALLOCATED(keyword%deprecation_notice)) & + IF (ALLOCATED(keyword%deprecation_notice)) THEN WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & - //"" + TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & + //"" + END IF IF (ASSOCIATED(keyword%default_value) .AND. & (keyword%type_of_var /= no_t)) THEN diff --git a/src/input/input_parsing.F b/src/input/input_parsing.F index dab4ca7b6b..332e6791ef 100644 --- a/src/input/input_parsing.F +++ b/src/input/input_parsing.F @@ -93,22 +93,25 @@ CONTAINS output_unit = cp_logger_get_default_io_unit() CPASSERT(section_vals%ref_count > 0) - IF (root_sect .AND. parser%icol1 > parser%icol2) & + IF (root_sect .AND. parser%icol1 > parser%icol2) THEN CALL cp_abort(__LOCATION__, & "Error 1: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) + END IF section => section_vals%section IF (root_sect) THEN token = TRIM(ADJUSTL(parser%input_line(parser%icol1:parser%icol2))) ! Ignore leading or trailing blanks CALL uppercase(token) - IF (token /= parser%section_character//section%name) & + IF (token /= parser%section_character//section%name) THEN CALL cp_abort(__LOCATION__, & "Error 2: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) + END IF END IF - IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) & + IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) THEN CALL cp_abort(__LOCATION__, "Section "//TRIM(section%name)// & " should not repeat "//TRIM(parser_location(parser))) + END IF CALL section_vals_add_values(section_vals) irs = SIZE(section_vals%values, 2) @@ -138,10 +141,11 @@ CONTAINS lower_to_upper=.TRUE., at_end=at_end) token = TRIM(ADJUSTL(token)) ! Ignore leading or trailing blanks IF (at_end) THEN - IF (root_sect) & + IF (root_sect) THEN CALL cp_abort(__LOCATION__, & "unexpected end of file while parsing section "// & TRIM(section%name)//" "//TRIM(parser_location(parser))) + END IF EXIT END IF IF (token(1:1) == parser%section_character) THEN @@ -269,15 +273,17 @@ CONTAINS END IF END IF - IF (ALLOCATED(keyword%deprecation_notice)) & + IF (ALLOCATED(keyword%deprecation_notice)) THEN CALL cp_warn(__LOCATION__, & "The specified keyword '"//TRIM(token)// & "' is deprecated and may be removed in a future version: "// & keyword%deprecation_notice) + END IF NULLIFY (el) - IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) & + IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) THEN CALL parser_skip_space(parser) + END IF CALL val_create_parsing(el, type_of_var=keyword%type_of_var, & n_var=keyword%n_var, default_value=keyword%lone_keyword_value, & enum=keyword%enum, unit=keyword%unit, & @@ -289,10 +295,11 @@ CONTAINS IF (.NOT. ASSOCIATED(last_val)) THEN section_vals%values(ik, irs)%list => new_val ELSE - IF (.NOT. keyword%repeats) & + IF (.NOT. keyword%repeats) THEN CALL cp_abort(__LOCATION__, & "Keyword "//TRIM(token)// & " in section "//TRIM(section%name)//" should not repeat.") + END IF IF (ASSOCIATED(last_val, previous_list)) THEN last_val => previous_last ELSE @@ -524,16 +531,18 @@ CONTAINS END IF END IF CASE (lchar_t) - IF (ASSOCIATED(default_value)) & + IF (ASSOCIATED(default_value)) THEN CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot have a lone keyword attribute,"// & " no value is interpreted as empty string"// & TRIM(parser_location(parser))) - IF (n_var /= 1) & + END IF + IF (n_var /= 1) THEN CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot be repeated,"// & " one always represent a whole line, till the end"// & TRIM(parser_location(parser))) + END IF IF (parser_test_next_token(parser) == "EOL") THEN ALLOCATE (c_val_p(1)) c_val_p(1) = ' ' @@ -677,11 +686,12 @@ CONTAINS my_unit => unit END IF END IF - IF (.NOT. cp_unit_compatible(unit, my_unit)) & + IF (.NOT. cp_unit_compatible(unit, my_unit)) THEN CALL cp_abort(__LOCATION__, & "Incompatible units. Defined as ("// & TRIM(cp_unit_desc(unit))//") specified in input as ("// & TRIM(cp_unit_desc(my_unit))//"). These units are incompatible!") + END IF END IF CALL parser_get_object(parser, r_val) IF (ASSOCIATED(unit)) THEN diff --git a/src/input/input_section_types.F b/src/input/input_section_types.F index 917c8edeb1..44662e9ed1 100644 --- a/src/input/input_section_types.F +++ b/src/input/input_section_types.F @@ -326,8 +326,9 @@ CONTAINS IF (ASSOCIATED(section)) THEN CPASSERT(section%ref_count > 0) - IF (.NOT. my_hide_root) & + IF (.NOT. my_hide_root) THEN WRITE (UNIT=unit_nr, FMT="('*** section &',A,' ***')") TRIM(ADJUSTL(section%name)) + END IF IF (level > 1) THEN message = get_section_info(section) CALL print_message(TRIM(a2s(section%description))//TRIM(message), unit_nr, 0, 0, 0) @@ -347,8 +348,9 @@ CONTAINS END DO END IF IF (section%n_subsections > 0 .AND. my_recurse >= 0) THEN - IF (.NOT. my_hide_root) & + IF (.NOT. my_hide_root) THEN WRITE (UNIT=unit_nr, FMT="('** subsections **')") + END IF DO isub = 1, section%n_subsections IF (my_recurse > 0) THEN CALL section_describe(section%subsections(isub)%section, unit_nr, & @@ -358,8 +360,9 @@ CONTAINS END IF END DO END IF - IF (.NOT. my_hide_root) & + IF (.NOT. my_hide_root) THEN WRITE (UNIT=unit_nr, FMT="('*** &end section ',A,' ***')") TRIM(ADJUSTL(section%name)) + END IF ELSE WRITE (unit_nr, "(a)") '
' END IF @@ -586,11 +589,12 @@ CONTAINS section%subsections => new_subsections END IF DO i = 1, section%n_subsections - IF (subsection%name == section%subsections(i)%section%name) & + IF (subsection%name == section%subsections(i)%section%name) THEN CALL cp_abort(__LOCATION__, & "trying to add a subsection with a name ("// & TRIM(subsection%name)//") that was already used in section " & //TRIM(section%name)) + END IF END DO CALL section_retain(subsection) section%n_subsections = section%n_subsections + 1 @@ -761,10 +765,11 @@ CONTAINS isection = section_get_subsection_index(section_vals%section, subsection_name(1:my_index)) IF (isection > 0) res => section_vals%subs_vals(isection, irep)%section_vals - IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) & + IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) THEN CALL cp_abort(__LOCATION__, & "could not find subsection "//TRIM(subsection_name(1:my_index))//" in section "// & TRIM(section_vals%section%name)//" at ") + END IF IF (is_path .AND. ASSOCIATED(res)) THEN res => section_vals_get_subs_vals(res, subsection_name(my_index + 2:LEN_TRIM(subsection_name)), & i_rep_section, can_return_null) @@ -1096,16 +1101,18 @@ CONTAINS PRESENT(c_val) .OR. PRESENT(l_vals) .OR. PRESENT(i_vals) .OR. & PRESENT(r_vals) .OR. PRESENT(c_vals) ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) + END IF keyword => section%keywords(ik)%keyword - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF NULLIFY (my_val) IF (PRESENT(n_rep_val)) n_rep_val = 0 IF (irs <= SIZE(s_vals%values, 2)) THEN ! the section was parsed @@ -1128,11 +1135,12 @@ CONTAINS END IF IF (PRESENT(val)) val => my_val IF (valRequested) THEN - IF (.NOT. ASSOCIATED(my_val)) & + IF (.NOT. ASSOCIATED(my_val)) THEN CALL cp_abort(__LOCATION__, & "Value requested, but no value set getting value from "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF CALL val_get(my_val, l_val=l_val, i_val=i_val, r_val=r_val, & c_val=c_val, l_vals=l_vals, i_vals=i_vals, r_vals=r_vals, & c_vals=c_vals) @@ -1183,15 +1191,17 @@ CONTAINS IF (PRESENT(i_rep_section)) irs = i_rep_section section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + END IF + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF list => s_vals%values(ik, irs)%list END SUBROUTINE section_vals_list_get @@ -1266,20 +1276,22 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) + END IF ! Add values.. DO IF (irs <= SIZE(s_vals%values, 2)) EXIT CALL section_vals_add_values(s_vals) END DO - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF keyword => s_vals%section%keywords(ik)%keyword NULLIFY (my_val) IF (PRESENT(val)) my_val => val @@ -1288,18 +1300,20 @@ CONTAINS PRESENT(r_vals_ptr) .OR. PRESENT(c_vals_ptr) IF (ASSOCIATED(my_val)) THEN ! check better? - IF (valSet) & + IF (valSet) THEN CALL cp_abort(__LOCATION__, & " both val and values present, in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF ELSE ! ignore ? - IF (.NOT. valSet) & + IF (.NOT. valSet) THEN CALL cp_abort(__LOCATION__, & " empty value in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF CPASSERT(valSet) IF (keyword%type_of_var == lchar_t) THEN CALL val_create(my_val, lc_val=c_val, lc_vals_ptr=c_vals_ptr) @@ -1316,11 +1330,12 @@ CONTAINS IF (irk == -1) THEN CALL cp_sll_val_insert_el_at(vals, my_val, index=-1) ELSE IF (irk <= cp_sll_val_get_length(vals)) THEN - IF (irk <= 0) & + IF (irk <= 0) THEN CALL cp_abort(__LOCATION__, & "invalid irk "//TRIM(ADJUSTL(cp_to_string(irk)))// & " in keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) + END IF old_val => cp_sll_val_get_el_at(vals, index=irk) CALL val_release(old_val) CALL cp_sll_val_set_el_at(vals, value=my_val, index=irk) @@ -1386,17 +1401,19 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) + END IF ! ignore unset of non set values IF (irs <= SIZE(s_vals%values, 2)) THEN - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") + END IF IF (irk == -1) THEN pos => cp_sll_val_get_rest(s_vals%values(ik, irs)%list, iter=-1) ELSE @@ -1589,10 +1606,11 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(section%description))) & //"" - IF (ALLOCATED(section%deprecation_notice)) & + IF (ALLOCATED(section%deprecation_notice)) THEN WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & - //"" + TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & + //"" + END IF IF (ASSOCIATED(section%citations)) THEN DO i = 1, SIZE(section%citations, 1) @@ -1735,10 +1753,11 @@ CONTAINS CPASSERT(irep <= SIZE(s_vals%subs_vals, 2)) isection = section_get_subsection_index(s_vals%section, subsection_name(my_index:LEN_TRIM(subsection_name))) - IF (isection <= 0) & + IF (isection <= 0) THEN CALL cp_abort(__LOCATION__, & "could not find subsection "//subsection_name(my_index:LEN_TRIM(subsection_name))//" in section "// & TRIM(section_vals%section%name)//" at ") + END IF CALL section_vals_retain(new_section_vals) CALL section_vals_release(s_vals%subs_vals(isection, irep)%section_vals) s_vals%subs_vals(isection, irep)%section_vals => new_section_vals @@ -1813,10 +1832,12 @@ CONTAINS END DO END DO IF (.NOT. PRESENT(i_rep_low) .AND. (.NOT. PRESENT(i_rep_high))) THEN - IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) & + IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) THEN CPABORT("Incompatible sizes of values between input and output") - IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) & + END IF + IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) THEN CPABORT("Incompatible sizes of subsections between input and output") + END IF END IF iend = SIZE(section_vals_in%subs_vals, 2) IF (PRESENT(i_rep_high)) iend = i_rep_high diff --git a/src/input/input_val_types.F b/src/input/input_val_types.F index 9ac7220f12..83580f89e0 100644 --- a/src/input/input_val_types.F +++ b/src/input/input_val_types.F @@ -399,23 +399,26 @@ CONTAINS IF (val%type_of_var == lchar_t) THEN l_in = default_string_length*(SIZE(val%c_val) - 1) + & LEN_TRIM(val%c_val(SIZE(val%c_val))) - IF (l_out < l_in) & + IF (l_out < l_in) THEN CALL cp_warn(__LOCATION__, & "val_get will truncate value, value beginning with '"// & TRIM(val%c_val(1))//"' is too long for variable") + END IF DO i = 1, SIZE(val%c_val) c_val((i - 1)*default_string_length + 1:MIN(l_out, i*default_string_length)) = & val%c_val(i) (1:MIN(80, l_out - (i - 1)*default_string_length)) IF (l_out <= i*default_string_length) EXIT END DO - IF (l_out > SIZE(val%c_val)*default_string_length) & + IF (l_out > SIZE(val%c_val)*default_string_length) THEN c_val(SIZE(val%c_val)*default_string_length + 1:l_out) = "" + END IF ELSE l_in = LEN_TRIM(val%c_val(1)) - IF (l_out < l_in) & + IF (l_out < l_in) THEN CALL cp_warn(__LOCATION__, & "val_get will truncate value, value '"// & TRIM(val%c_val(1))//"' is too long for variable") + END IF c_val = val%c_val(1) END IF ELSE diff --git a/src/input_cp2k_check.F b/src/input_cp2k_check.F index 273e17ad76..87a01c5aaf 100644 --- a/src/input_cp2k_check.F +++ b/src/input_cp2k_check.F @@ -80,8 +80,9 @@ CONTAINS CPASSERT(ASSOCIATED(input_file)) CPASSERT(input_file%ref_count > 0) ! ext_restart - IF (PRESENT(output_unit)) & + IF (PRESENT(output_unit)) THEN CALL handle_ext_restart(input_declaration, input_file, para_env, output_unit) + END IF ! checks on force_eval section sections => section_vals_get_subs_vals(input_file, "FORCE_EVAL") @@ -146,13 +147,15 @@ CONTAINS ! do not allow the use of external potential section => section_vals_get_subs_vals(sections, "DFT%EXTERNAL_POTENTIAL") CALL section_vals_get(section, explicit=apply_ext_potential) - IF (apply_ext_potential) & + IF (apply_ext_potential) THEN CPABORT("The EXTERNAL_POTENTIAL section is not allowed for the MiMiC runtype.") + END IF ! force eval methods supported with MiMiC CALL section_vals_val_get(sections, "METHOD", i_val=force_eval_method) - IF (force_eval_method /= do_qs) & + IF (force_eval_method /= do_qs) THEN CPABORT("At the moment, only Quickstep method is supported with MiMiC.") + END IF END IF CALL timestop(handle) @@ -431,29 +434,33 @@ CONTAINS IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_COORD") CALL section_vals_set_subs_vals(section2, "SHELL_COORD", section) - IF (check_restart(section1, section2, "SHELL_COORD")) & + IF (check_restart(section1, section2, "SHELL_COORD")) THEN CALL set_restart_info("SHELL COORDINATES", restarted_infos) + END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_POS", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_COORD") CALL section_vals_set_subs_vals(section2, "CORE_COORD", section) - IF (check_restart(section1, section2, "CORE_COORD")) & + IF (check_restart(section1, section2, "CORE_COORD")) THEN CALL set_restart_info("CORE COORDINATES", restarted_infos) + END IF END IF CALL section_vals_val_get(r_section, "RESTART_SHELL_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_VELOCITY") CALL section_vals_set_subs_vals(section2, "SHELL_VELOCITY", section) - IF (check_restart(section1, section2, "SHELL_VELOCITY")) & + IF (check_restart(section1, section2, "SHELL_VELOCITY")) THEN CALL set_restart_info("SHELL VELOCITIES", restarted_infos) + END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_VELOCITY") CALL section_vals_set_subs_vals(section2, "CORE_VELOCITY", section) - IF (check_restart(section1, section2, "CORE_VELOCITY")) & + IF (check_restart(section1, section2, "CORE_VELOCITY")) THEN CALL set_restart_info("CORE VELOCITIES", restarted_infos) + END IF END IF END IF ELSE @@ -977,18 +984,20 @@ CONTAINS CALL section_vals_set_subs_vals(input_file, TRIM(path)//"%AD_LANGEVIN%MASS", section) END SELECT ELSE - IF (input_type /= restart_type) & + IF (input_type /= restart_type) THEN CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of thermostat! Restarting is not possible! "// & "Thermostat will not be restarted! ") - IF (input_region /= restart_region) & + END IF + IF (input_region /= restart_region) THEN CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of REGION! Restarting is not possible! "// & "Thermostat will not be restarted! ") + END IF END IF END IF END SUBROUTINE restart_thermostat diff --git a/src/input_cp2k_dft.F b/src/input_cp2k_dft.F index 082cc27f4b..74c65fff9f 100644 --- a/src/input_cp2k_dft.F +++ b/src/input_cp2k_dft.F @@ -250,8 +250,14 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify size of automatically generated auxiliary (RI) basis sets: "// & - "Options={small,medium,large,huge}", & + description="Specify type and size of automatically generated auxiliary "// & + "(RI) basis sets. Exactly two arguments are required for this option. "// & + "The first argument of basis type should be one of the following: "// & + "`RI_AUX`, `AUX_FIT`, `LRI_AUX`, `P_LRI_AUX`, `RI_HXC`, `RI_XAS`, or "// & + "`RI_HFX`. The second argument of basis size should be one of the "// & + "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & + "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & + "as written here).", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) diff --git a/src/input_cp2k_mm.F b/src/input_cp2k_mm.F index aeb0be36a1..4938f9cfea 100644 --- a/src/input_cp2k_mm.F +++ b/src/input_cp2k_mm.F @@ -15,9 +15,9 @@ ! ************************************************************************************************** MODULE input_cp2k_mm USE bibliography, ONLY: & - Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, Drautz2019, & - Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, Tan2025, & - Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 + Batatia2022, Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, & + Drautz2019, Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, & + Tan2025, Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 USE cp_output_handling, ONLY: cp_print_key_section_create,& debug_print_level,& high_print_level,& @@ -1185,6 +1185,10 @@ CONTAINS CALL section_add_subsection(section, subsection) CALL section_release(subsection) + CALL create_MACE_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + CALL create_DEEPMD_section(subsection) CALL section_add_subsection(section, subsection) CALL section_release(subsection) @@ -1483,6 +1487,48 @@ CONTAINS END SUBROUTINE create_NEQUIP_section +! ************************************************************************************************** +!> \brief This section specifies the input parameters for MACE potential type +!> \param section the section to create +!> \author Xinyue Sun +! ************************************************************************************************** + SUBROUTINE create_MACE_section(section) + TYPE(section_type), POINTER :: section + + TYPE(keyword_type), POINTER :: keyword + + CPASSERT(.NOT. ASSOCIATED(section)) + CALL section_create(section, __LOCATION__, name="MACE", & + description="This section specifies the input parameters for MACE potential type, "// & + "a higher-order equivariant message-passing neural network. "// & + "The MACE model must be exported to a TorchScript file that takes a single "// & + "dictionary argument (see the create_cp2k_model.py helper). "// & + "Requires linking with libtorch library from .", & + citations=[Batatia2022], n_keywords=1, n_subsections=0, repeats=.FALSE.) + + NULLIFY (keyword) + + CALL keyword_create(keyword, __LOCATION__, name="ATOMS", & + description="Defines the atomic kinds involved in the MACE potential. "// & + "Provide a list of each element, making sure that the mapping from the ATOMS list "// & + "to MACE atom types is correct. This mapping should also be consistent for the "// & + "atomic coordinates as specified in the sections COORDS or TOPOLOGY.", & + usage="ATOMS {KIND 1} {KIND 2} .. {KIND N}", type_of_var=char_t, & + n_var=-1) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, __LOCATION__, name="POT_FILE_NAME", & + variants=["MODEL_FILE_NAME"], & + description="Specifies the filename that contains the exported MACE model. "// & + "MACE models use standardized units (Angstrom for length, eV for energy, "// & + "eV/Angstrom for forces), so no unit keywords are required.", & + usage="POT_FILE_NAME {FILENAME}", default_lc_val=" ") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + END SUBROUTINE create_MACE_section + ! ************************************************************************************************** !> \brief This section specifies the input parameters for ACE potential type !> \param section the section to create diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index e120efee04..68a5a348e7 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -1803,8 +1803,13 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify size of automatically generated auxiliary basis sets: "// & - "Options={small,medium,large,huge}", & + description="Specify type and size of automatically generated auxiliary "// & + "(RI) basis sets. Exactly two arguments are required for this option. "// & + "The first argument of basis type should be one of the following: "// & + "`P_LRI_AUX`. The second argument of basis size should be one of the "// & + "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & + "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & + "as written here).", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) diff --git a/src/input_cp2k_restarts_util.F b/src/input_cp2k_restarts_util.F index 2411d815ec..c281e5f8b7 100644 --- a/src/input_cp2k_restarts_util.F +++ b/src/input_cp2k_restarts_util.F @@ -62,10 +62,11 @@ CONTAINS CPASSERT(velocity_section%ref_count > 0) section => velocity_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF ! At least one of the two arguments must be present.. check = PRESENT(particles) .NEQV. PRESENT(velocity) diff --git a/src/input_restart_force_eval.F b/src/input_restart_force_eval.F index 77181ca694..e333517e4b 100644 --- a/src/input_restart_force_eval.F +++ b/src/input_restart_force_eval.F @@ -555,10 +555,11 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT @@ -689,10 +690,11 @@ CONTAINS CPASSERT(dipoles_section%ref_count > 0) section => dipoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF ! At least one of the two arguments must be present.. nloop = SIZE(dipoles, 2) @@ -766,10 +768,11 @@ CONTAINS CPASSERT(quadrupoles_section%ref_count > 0) section => quadrupoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF ! At least one of the two arguments must be present.. nloop = SIZE(quadrupoles, 2) diff --git a/src/input_restart_rng.F b/src/input_restart_rng.F index 51913f61cf..ea236ff010 100644 --- a/src/input_restart_rng.F +++ b/src/input_restart_rng.F @@ -61,10 +61,11 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(rng_section%values, 2) == 1) EXIT diff --git a/src/ipi_driver.F b/src/ipi_driver.F index ea8b57b9a3..19404bd82f 100644 --- a/src/ipi_driver.F +++ b/src/ipi_driver.F @@ -212,8 +212,9 @@ CONTAINS CALL para_env%bcast(combuf) CALL force_env_get(force_env, subsys=subsys) - IF (nat /= subsys%particles%n_els) & + IF (nat /= subsys%particles%n_els) THEN CPABORT("@DRIVER MODE: Uh-oh! Particle number mismatch between i-PI and cp2k input!") + END IF ii = 0 DO ip = 1, subsys%particles%n_els DO idir = 1, 3 diff --git a/src/ipi_server.F b/src/ipi_server.F index 8cb6ac0d66..488e5a19b4 100644 --- a/src/ipi_server.F +++ b/src/ipi_server.F @@ -179,16 +179,18 @@ CONTAINS ! Step 1: See if the client is ready CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "READY") & + IF (TRIM(msgbuffer) /= "READY") THEN CPABORT("i–PI: Expected READY header but recieved "//TRIM(msgbuffer)) + END IF ! Step 2: Send cell and position data to client CALL send_posdata(comm_socket, subsys=ipi_env%subsys) ! Step 3: Ask for status, should be done now CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "HAVEDATA") & + IF (TRIM(msgbuffer) /= "HAVEDATA") THEN CPABORT("i–PI: Expected HAVEDATA header but recieved "//TRIM(msgbuffer)) + END IF ! Step 4: Ask for data ALLOCATE (forces(3, nAtom)) @@ -267,8 +269,9 @@ CONTAINS ! Exchange headers CALL writebuffer(sockfd, msg, msglength) CALL get_header(sockfd, msgbuffer) - IF (TRIM(msgbuffer) /= "FORCEREADY") & + IF (TRIM(msgbuffer) /= "FORCEREADY") THEN CPABORT("i–PI: Expected FORCEREADY header but recieved "//TRIM(msgbuffer)) + END IF ! Recieve data CALL readbuffer(sockfd, energy) diff --git a/src/iterate_matrix.F b/src/iterate_matrix.F index d78f5a3191..4a6b4b3a88 100644 --- a/src/iterate_matrix.F +++ b/src/iterate_matrix.F @@ -1177,8 +1177,9 @@ CONTAINS END IF END DO - IF (.NOT. converged) & + IF (.NOT. converged) THEN CPABORT("dense_matrix_sign_Newton_Schulz did not converge within 100 iterations") + END IF DEALLOCATE (tmp1) DEALLOCATE (tmp2) @@ -1807,8 +1808,9 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) & + IF (abnormal_value(conv)) THEN CPABORT("conv is an abnormal value (NaN/Inf).") + END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN @@ -2028,8 +2030,9 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) & + IF (abnormal_value(conv)) THEN CPABORT("conv is an abnormal value (NaN/Inf).") + END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN diff --git a/src/kg_correction.F b/src/kg_correction.F index ab870ac90a..3377337cde 100644 --- a/src/kg_correction.F +++ b/src/kg_correction.F @@ -309,8 +309,9 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) & + IF (ASSOCIATED(vxc_tau)) THEN ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) + END IF END DO END IF END IF @@ -409,8 +410,9 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) & + IF (ASSOCIATED(vxc_tau)) THEN ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) + END IF END DO END IF END IF diff --git a/src/kg_vertex_coloring_methods.F b/src/kg_vertex_coloring_methods.F index bf437d443f..d95ccc533a 100644 --- a/src/kg_vertex_coloring_methods.F +++ b/src/kg_vertex_coloring_methods.F @@ -667,8 +667,9 @@ CONTAINS valid = .FALSE. CALL check_coloring(graph, valid) - IF (.NOT. valid) & + IF (.NOT. valid) THEN CPABORT("Coloring not valid.") + END IF nnodes = SIZE(kg_env%molecule_set) diff --git a/src/kpoint_io.F b/src/kpoint_io.F index e7e544a0a0..a7e2ee483c 100644 --- a/src/kpoint_io.F +++ b/src/kpoint_io.F @@ -231,7 +231,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -266,7 +266,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 diff --git a/src/kpoint_methods.F b/src/kpoint_methods.F index 1c579b7dac..6abad3f2a7 100644 --- a/src/kpoint_methods.F +++ b/src/kpoint_methods.F @@ -2299,14 +2299,14 @@ CONTAINS CALL dbcsr_iterator_next_block(iter, irow, icol, rblock) IF (.NOT. ALLOCATED(rwork)) THEN ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSEIF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN + ELSE IF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (rwork) ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF IF (.NOT. real_only) THEN IF (.NOT. ALLOCATED(cwork)) THEN ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSEIF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN + ELSE IF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (cwork) ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF diff --git a/src/kpoint_mo_symmetry_methods.F b/src/kpoint_mo_symmetry_methods.F new file mode 100644 index 0000000000..3483dc7889 --- /dev/null +++ b/src/kpoint_mo_symmetry_methods.F @@ -0,0 +1,238 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2026 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Utilities for transforming k-point MO coefficients under symmetry operations +! ************************************************************************************************** +MODULE kpoint_mo_symmetry_methods + USE cp_fm_types, ONLY: cp_fm_copy_general,& + cp_fm_get_info,& + cp_fm_get_submatrix,& + cp_fm_set_submatrix,& + cp_fm_type + USE kinds, ONLY: dp + USE kpoint_types, ONLY: kind_rotmat_type,& + kpoint_sym_type,& + kpoint_type + USE mathconstants, ONLY: twopi + USE message_passing, ONLY: mp_para_env_type +#include "./base/base_uses.f90" + + IMPLICIT NONE + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'kpoint_mo_symmetry_methods' + + PUBLIC :: kpoint_same_periodic, & + kpoint_transform_scf_mo + +CONTAINS + +! ************************************************************************************************** +!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. +!> \param xkp_a first k-point +!> \param xkp_b second k-point +!> \return true if the k-points are equivalent +! ************************************************************************************************** + LOGICAL FUNCTION kpoint_same_periodic(xkp_a, xkp_b) RESULT(same) + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b + + REAL(KIND=dp), DIMENSION(3) :: diff + + diff(1:3) = xkp_a(1:3) - xkp_b(1:3) + diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) + same = SUM(ABS(diff(1:3))) < 1.0e-8_dp + + END FUNCTION kpoint_same_periodic + +! ************************************************************************************************** +!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. +!> \param src_real real part of source MO coefficients +!> \param src_imag imaginary part of source MO coefficients +!> \param dst_real real part of transformed MO coefficients +!> \param dst_imag imaginary part of transformed MO coefficients +!> \param qs_kpoint SCF k-point object containing symmetry operations +!> \param ikred representative k-point index +!> \param isym symmetry operation index; 0 direct copy, -1 time reversal +!> \param para_env global parallel environment +!> \param success true if the transformation was performed +!> \param reason diagnostic message +! ************************************************************************************************** + SUBROUTINE kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & + isym, para_env, success, reason) + TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: ikred, isym + TYPE(mp_para_env_type), POINTER :: para_env + LOGICAL, INTENT(OUT) :: success + CHARACTER(LEN=*), INTENT(OUT) :: reason + + INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & + nmo, rot_slot, source_atom, source_dim, target_atom, target_dim + INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start + LOGICAL :: reverse_phase, time_reversal + REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & + phase_imag, phase_real, sinkl + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r + REAL(KIND=dp), DIMENSION(3) :: xkp_phase + REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat + TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot + TYPE(kpoint_sym_type), POINTER :: kpsym + + success = .FALSE. + reason = "" + IF (isym == 0) THEN + CALL cp_fm_copy_general(src_real, dst_real, para_env) + CALL cp_fm_copy_general(src_imag, dst_imag, para_env) + success = .TRUE. + RETURN + END IF + + CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) + ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) + CALL cp_fm_get_submatrix(src_real, src_r) + CALL cp_fm_get_submatrix(src_imag, src_i) + dst_r(:, :) = 0.0_dp + dst_i(:, :) = 0.0_dp + + IF (isym == -1) THEN + dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) + dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i) + success = .TRUE. + RETURN + END IF + + IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN + reason = "SCF symmetry operation data are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym + IF (.NOT. ASSOCIATED(kpsym)) THEN + reason = "SCF k-point symmetry operation is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (isym > kpsym%nwred) THEN + reason = "SCF k-point symmetry operation index is out of range" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN + reason = "SCF atom mappings or basis rotation matrices are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + + rot_slot = find_kpoint_rotation_slot(qs_kpoint, kpsym%rotp(isym)) + IF (rot_slot == 0) THEN + reason = "could not match the SCF symmetry operation to a basis rotation" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) + natom = SIZE(qs_kpoint%atype) + ALLOCATE (ao_start(natom), ao_size(natom)) + irow = 1 + DO iatom = 1, natom + ikind = qs_kpoint%atype(iatom) + IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN + reason = "a required basis rotation matrix is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + ao_start(iatom) = irow + ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) + irow = irow + ao_size(iatom) + END DO + IF (irow - 1 /= nao) THEN + reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + + time_reversal = kpsym%rotp(isym) < 0 + reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) + IF (ASSOCIATED(kpsym%phase_mode)) THEN + IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 + END IF + xkp_phase(1:3) = kpsym%xkp(1:3, isym) + DO iatom = 1, natom + source_atom = iatom + target_atom = kpsym%f0(iatom, isym) + ikind = qs_kpoint%atype(source_atom) + rotmat => kind_rot(ikind)%rmat + source_dim = ao_size(source_atom) + target_dim = ao_size(target_atom) + IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN + reason = "basis rotation dimensions do not match the atom/AO symmetry transform" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & + REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & + REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) + IF (ASSOCIATED(kpsym%kgphase)) THEN + arg = arg + kpsym%kgphase(source_atom, isym) + END IF + IF (reverse_phase) arg = -arg + coskl = COS(twopi*arg) + sinkl = SIN(twopi*arg) + DO imo = 1, nmo + DO irow_work = 1, source_dim + irow_source = ao_start(source_atom) + irow_work - 1 + coeff_real = src_r(irow_source, imo) + coeff_imag = src_i(irow_source, imo) + IF (time_reversal) coeff_imag = -coeff_imag + phase_real = coskl*coeff_real - sinkl*coeff_imag + phase_imag = sinkl*coeff_real + coskl*coeff_imag + DO iao = 1, target_dim + irow_target = ao_start(target_atom) + iao - 1 + dst_r(irow_target, imo) = dst_r(irow_target, imo) + & + rotmat(iao, irow_work)*phase_real + dst_i(irow_target, imo) = dst_i(irow_target, imo) + & + rotmat(iao, irow_work)*phase_imag + END DO + END DO + END DO + END DO + + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + success = .TRUE. + + END SUBROUTINE kpoint_transform_scf_mo + +! ************************************************************************************************** +!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. +!> \param qs_kpoint SCF k-point object +!> \param rotp signed operation identifier +!> \return rotation slot, or zero when no slot matches +! ************************************************************************************************** + INTEGER FUNCTION find_kpoint_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: rotp + + INTEGER :: irot, rot_abs + + rot_slot = 0 + rot_abs = ABS(rotp) + IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN + DO irot = 1, SIZE(qs_kpoint%ibrot) + IF (rot_abs == qs_kpoint%ibrot(irot)) THEN + rot_slot = irot + RETURN + END IF + END DO + + END FUNCTION find_kpoint_rotation_slot + +END MODULE kpoint_mo_symmetry_methods diff --git a/src/kpoint_transitional.F b/src/kpoint_transitional.F index fba771ac76..3a0ca3aa07 100644 --- a/src/kpoint_transitional.F +++ b/src/kpoint_transitional.F @@ -47,8 +47,9 @@ CONTAINS TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: res IF (ASSOCIATED(this%ptr_1d)) THEN - IF (SIZE(this%ptr_2d, 2) /= 1) & + IF (SIZE(this%ptr_2d, 2) /= 1) THEN CPABORT("Method not implemented for k-points") + END IF END IF res => this%ptr_1d diff --git a/src/kpoint_types.F b/src/kpoint_types.F index 2f949201c3..10a0dd0c05 100644 --- a/src/kpoint_types.F +++ b/src/kpoint_types.F @@ -566,8 +566,9 @@ CONTAINS IF (PRESENT(full_grid)) full_grid = kpoint%full_grid IF (PRESENT(inversion_symmetry_only)) inversion_symmetry_only = kpoint%inversion_symmetry_only IF (PRESENT(symmetry_backend)) symmetry_backend = kpoint%symmetry_backend - IF (PRESENT(symmetry_reduction_method)) & + IF (PRESENT(symmetry_reduction_method)) THEN symmetry_reduction_method = kpoint%symmetry_reduction_method + END IF IF (PRESENT(use_real_wfn)) use_real_wfn = kpoint%use_real_wfn IF (PRESENT(eps_geo)) eps_geo = kpoint%eps_geo IF (PRESENT(parallel_group_size)) parallel_group_size = kpoint%parallel_group_size @@ -681,8 +682,9 @@ CONTAINS IF (PRESENT(full_grid)) kpoint%full_grid = full_grid IF (PRESENT(inversion_symmetry_only)) kpoint%inversion_symmetry_only = inversion_symmetry_only IF (PRESENT(symmetry_backend)) kpoint%symmetry_backend = symmetry_backend - IF (PRESENT(symmetry_reduction_method)) & + IF (PRESENT(symmetry_reduction_method)) THEN kpoint%symmetry_reduction_method = symmetry_reduction_method + END IF IF (PRESENT(use_real_wfn)) kpoint%use_real_wfn = use_real_wfn IF (PRESENT(eps_geo)) kpoint%eps_geo = eps_geo IF (PRESENT(parallel_group_size)) kpoint%parallel_group_size = parallel_group_size diff --git a/src/kpsym.F b/src/kpsym.F index 170c44e613..4342c92f8b 100644 --- a/src/kpsym.F +++ b/src/kpsym.F @@ -188,10 +188,12 @@ CONTAINS a02(i) = a2(i)/alat a03(i) = a3(i)/alat END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| NUMBER OF ATOMS (STRUCT):",I6)') nat - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",10X,"K TYPE",14X,"X(K)")') + END IF itype = 0 DO i = 1, nat ! Assign an atomic type (for internal purposes) @@ -206,19 +208,22 @@ CONTAINS END IF itype = itype + 1 IF (itype > nsp) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,I4,")")') & - ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & - nsp - IF (iout > 0) & + ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & + nsp + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| THE ARRAY TY IS:",/,9(1X,10I7,/))') & - (ty(j), j=1, nat) + (ty(j), j=1, nat) + END IF CALL stopgm('K290', 'FATAL ERROR') END IF 178 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",6X,I5,I6,3F10.5)') & - i, ty(i), (xkapa(j, i), j=1, 3) + i, ty(i), (xkapa(j, i), j=1, 3) + END IF END DO ! ==--------------------------------------------------------------== ! IS THE STRAIN SIGNIFICANT ? @@ -264,11 +269,12 @@ CONTAINS ! ==--------------------------------------------------------------== invadd = 0 IF (li == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,A,/,A)') & - ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & - ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & - ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' + ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & + ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & + ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' + END IF invadd = 1 END IF ! ==--------------------------------------------------------------== @@ -283,101 +289,125 @@ CONTAINS ! ==--------------------------------------------------------------== ! == GROUP-THEORETICAL INFORMATION == ! ==--------------------------------------------------------------== - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM| GROUP-THEORETICAL INFORMATION:")') + END IF ! IHG .... Point group of the primitive lattice, holohedral - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(" KPSYM| POINT GROUP OF THE PRIMITIVE LATTICE: ",A," SYSTEM")') & - icst(ihg) + icst(ihg) + END IF ! IHC .... Code distinguishing between hexagonal and cubic groups ! ISY .... Code indicating whether the space group is symmorphic IF (isy == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP")') - ELSEIF (isy == 1) THEN - IF (iout > 0) & + END IF + ELSE IF (isy == 1) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP")') - ELSEIF (isy == -1) THEN - IF (iout > 0) & + END IF + ELSE IF (isy == -1) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP WITH NON-STANDARD ORIGIN")') - ELSEIF (isy == -2) THEN - IF (iout > 0) & + END IF + ELSE IF (isy == -2) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP???")') + END IF END IF ! LI ..... Inversions symmetry IF (li == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"NO INVERSION SYMMETRY")') - ELSEIF (li > 0) THEN - IF (iout > 0) & + END IF + ELSE IF (li > 0) THEN + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"INVERSION SYMMETRY")') + END IF END IF ! NC ..... Total number of elements in the point group - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(" KPSYM|",4X,"TOTAL NUMBER OF ELEMENTS IN THE POINT GROUP:",I3)') nc - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM|",4X,"TO SUM UP: (",I1,5I3,")")') & - ihg, ihc, isy, li, nc, indpg + ihg, ihc, isy, li, nc, indpg + END IF ! IB ..... List of the rotations constituting the point group - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE ROTATIONS:")') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(7X,12I4)') (ib(i), i=1, nc) + END IF ! V ...... Nonprimitive translations (for nonsymmorphic groups) IF (isy <= 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",4X,"NONPRIMITIVE TRANSLATIONS:")') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,A)') & - ' ROT V IN THE BASIS A1, A2, A3 ', & - 'V IN CARTESIAN COORDINATES' + ' ROT V IN THE BASIS A1, A2, A3 ', & + 'V IN CARTESIAN COORDINATES' + END IF ! Cartesian components of nonprimitive translation. DO i = 1, nc DO j = 1, 3 vv0(j) = v(1, i)*a1(j) + v(2, i)*a2(j) + v(3, i)*a3(j) END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(1X,I3,3F10.5,3X,3F10.5)') & - ib(i), (v(j, i), j=1, 3), vv0 + ib(i), (v(j, i), j=1, 3), vv0 + END IF END DO END IF ! F0 ..... The function defined in Maradudin, Ipatova by ! eq. (3.2.12): atom transformation table. - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(/," KPSYM|",4X,"ATOM TRANSFORMATION TABLE (MARADUDIN,VOSKO):")') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(5(4X,"R AT->AT"))') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(I5," [Identity]")') 1 + END IF DO k = 2, nc DO j = 1, nat - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(I5,2I4)', advance="no") ib(k), j, f0(k, j) - IF ((MOD(j, 5) == 0) .AND. iout > 0) & + END IF + IF ((MOD(j, 5) == 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END DO ! R ...... List of the 3 x 3 rotation matrices - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE 3 X 3 ROTATION MATRICES:")') + END IF IF (ihc == 0) THEN DO k = 1, nc - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(4X,I3," (",I2,": ",A11,")",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + END IF END DO ELSE DO k = 1, nc - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, & '(4X,I3," (",I2,": ",A10,") ",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) + END IF END DO END IF ! ==--------------------------------------------------------------== @@ -391,34 +421,42 @@ CONTAINS ! (cubic/hexagonal) will apply to the crystal as well as the Bravais ! lattice. ! ==--------------------------------------------------------------== - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/,1X,19("*"),A,25("*"))') & - ' GENERATION OF SPECIAL POINTS ' + ' GENERATION OF SPECIAL POINTS ' + END IF ! Parameter Q of Monkhorst and Pack, generalized for 3 axes B1,2,3 - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,1X,3I5)') & - ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & - iq1, iq2, iq3 + ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & + iq1, iq2, iq3 + END IF ! WVK0 is the shift of the whole mesh (see Macdonald) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,1X,3F10.5)') & - ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 - IF (iabs(iq1) + iabs(iq2) + iabs(iq3) == 0) GOTO 710 + ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 + END IF + IF (ABS(iq1) + ABS(iq2) + ABS(iq3) == 0) GOTO 710 IF (ABS(istriz) /= 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz + END IF CALL stopgm('K290', 'ISTRIZ WRONG ARGUMENT') END IF - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" KPSYM| SYMMETRIZATION SWITCH: ",I3)', advance="no") istriz + END IF IF (istriz == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" (SYMMETRIZATION OF MONKHORST-PACK MESH)")') + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" (NO SYMMETRIZATION OF MONKHORST-PACK MESH)")') + END IF END IF ! Set to 0. DO i = 1, nkpoint @@ -433,12 +471,15 @@ CONTAINS ! rotations than Bravais lattice. ! We use only the rotations for Bravais lattices IF (ntvec == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR BRAVAIS LATTICE', nc0 - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR CRYSTAL LATTICE', nc - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) ' KPSYM| NO DUPLICATION FOUND' + END IF CALL stopgm('ERROR', & 'SOMETHING IS WRONG IN GROUP DETERMINATION') END IF @@ -446,19 +487,24 @@ CONTAINS DO i = 1, nc0 ib(i) = ib0(i) END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/,1X,20("! "),"WARNING",20("!"))') - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' - IF (iout > 0) & + ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' + END IF + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' - IF (iout > 0) & + ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' + END IF + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' - IF (iout > 0) & + ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' + END IF + IF (iout > 0) THEN WRITE (iout, '(1X,20("! "),"WARNING",20("!"),/)') + END IF END IF CALL sppt2(iout, iq1, iq2, iq3, wvk0, nkpoint, & a01, a02, a03, b01, b02, b03, & @@ -467,16 +513,18 @@ CONTAINS ! ==--------------------------------------------------------------== ! == Check on error signals == ! ==--------------------------------------------------------------== - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/," KPSYM|",1X,I5," SPECIAL POINTS GENERATED")') ntot + END IF IF (ntot == 0) THEN GOTO 710 ELSE IF (ntot < 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,I5,/,A,/,A)') ' KPSYM| DIMENSION NKPOINT =', nkpoint, & - ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & - ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' - ntot = iabs(ntot) + ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & + ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' + END IF + ntot = ABS(ntot) END IF ! Before using the list WVKL as wave vectors, they have to be ! multiplied by 2*Pi @@ -485,9 +533,10 @@ CONTAINS DO i = 1, ntot iswght = iswght + lwght(i) END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(8X,A,T33,A,4X,A)') & - 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' + 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' + END IF ! Set near-zeroes equal to zero: DO l = 1, ntot DO i = 1, 3 @@ -508,17 +557,20 @@ CONTAINS END DO END IF lmax = lwght(l) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, fmt='(1X,I5,3F8.4,I8,T42,12I3)') & - l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) + l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) + END IF DO j = 13, lmax, 12 - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, fmt='(T42,12I3)') & - (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) + (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) + END IF END DO END DO - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(24X,"TOTAL:",I8)') iswght + END IF ! ==--------------------------------------------------------------== 710 CONTINUE ! ==--------------------------------------------------------------== @@ -723,12 +775,14 @@ CONTAINS IF (iout > 0) THEN IF (li > 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(1X,A)') & - 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' + 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' + END IF END IF - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) + END IF END IF END SUBROUTINE group1s @@ -1300,138 +1354,139 @@ CONTAINS ! (Thierry Deutsch - 1998 [Maybe not complete!!]) IF (ihg < 6) THEN IF (nc == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC + END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSEIF (nc == 1) THEN + ELSE IF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSEIF (nc == 2 .AND. ib(2) == 25) THEN + ELSE IF (nc == 2 .AND. ib(2) == 25) THEN ! IB=125 indpg = 2 ! <1>(ci) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 4 .OR. & ! 2[001] - ib(2) == 2 .OR. & ! 2[100] - ib(2) == 3)) THEN ! 2[010] + ELSE IF (nc == 2 .AND. ( & + ib(2) == 4 .OR. & ! 2[001] + ib(2) == 2 .OR. & ! 2[100] + ib(2) == 3)) THEN ! 2[010] ! Monoclinic system ! IB=14 (z-axis) OR ! IB=12 (x-axis) OR ! IB=13 (y-axis) indpg = 3 ! 2 (c2) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 28 .OR. & - ib(2) == 26 .OR. & - ib(2) == 27)) THEN + ELSE IF (nc == 2 .AND. ( & + ib(2) == 28 .OR. & + ib(2) == 26 .OR. & + ib(2) == 27)) THEN ! IB=128 (z-axis) OR ! IB=126 (x-axis) OR ! IB=127 (y-axis) indpg = 4 ! m (c1h) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 28 .OR. & ! 2[001] - ib(4) == 27 .OR. & ! 2[010] - ib(4) == 26 .OR. & ! 2[100] - ib(4) == 37 .OR. & ! -2[-110] - ib(4) == 40)) THEN ! 2[110] + ELSE IF (nc == 4 .AND. ( & + ib(4) == 28 .OR. & ! 2[001] + ib(4) == 27 .OR. & ! 2[010] + ib(4) == 26 .OR. & ! 2[100] + ib(4) == 37 .OR. & ! -2[-110] + ib(4) == 40)) THEN ! 2[110] ! IB=1 425 28 (z-axis) OR ! IB=1 225 26 (x-axis) OR ! IB=1 325 27 (y-axis) OR ! IB=113 2537 (-xy-axis)OR ! IB=116 2540 (xy-axis) indpg = 5 ! 2/m(c2h) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 15 .OR. & - ib(4) == 20 .OR. & - ib(4) == 24)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 15 .OR. & + ib(4) == 20 .OR. & + ib(4) == 24)) THEN ! Tetragonal system ! IB=14 1415 (z-axis) OR ! IB=12 1920 (x-axis) OR ! IB=13 2224 (y-axis) indpg = 11 ! 4 (c4) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 39 .OR. & - ib(4) == 44 .OR. & - ib(4) == 48)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 39 .OR. & + ib(4) == 44 .OR. & + ib(4) == 48)) THEN ! IB=14 3839 (z-axis) OR ! IB=12 4344 (x-axis) OR ! IB=13 4648 (y-axis) indpg = 12 ! <4>(s4) - ELSEIF (nc == 8 .AND. ( & - (ib(3) == 14 .AND. ib(8) == 39) .OR. & - (ib(3) == 19 .AND. ib(8) == 44) .OR. & - (ib(3) == 22 .AND. ib(8) == 48))) THEN + ELSE IF (nc == 8 .AND. ( & + (ib(3) == 14 .AND. ib(8) == 39) .OR. & + (ib(3) == 19 .AND. ib(8) == 44) .OR. & + (ib(3) == 22 .AND. ib(8) == 48))) THEN ! IB=14 1415 2825 3839 (z-axis) OR ! IB=12 1920 2625 4344 (x-axis) OR ! IB=13 2224 2725 4648 (y-axis) indpg = 13 ! 422(d4) - ELSEIF (nc == 8 .AND. ib(4) == 4 .AND. ( & - ib(8) == 16 .OR. & - ib(8) == 20 .OR. & - ib(8) == 24)) THEN + ELSE IF (nc == 8 .AND. ib(4) == 4 .AND. ( & + ib(8) == 16 .OR. & + ib(8) == 20 .OR. & + ib(8) == 24)) THEN ! IB=12 3 413 1415 16 (z-axis) OR ! IB=12 3 417 1920 18 (x-axis) OR ! IB=12 3 421 2224 23 (y-axis) indpg = 14 ! 4/m(c4h) - ELSEIF (nc == 8 .AND. ( & - ib(8) == 40 .OR. & - ib(8) == 42 .OR. & - ib(8) == 47)) THEN + ELSE IF (nc == 8 .AND. ( & + ib(8) == 40 .OR. & + ib(8) == 42 .OR. & + ib(8) == 47)) THEN ! IB=14 1415 2627 3740 (z-axis) OR ! IB=12 1920 2827 4142 (x-axis) OR ! IB=13 2224 2628 4547 (y-axis) indpg = 15 ! 4mm(c4v) - ELSEIF (nc == 8 .AND. ( & - (ib(3) == 13 .AND. ib(8) == 39) .OR. & - (ib(3) == 17 .AND. ib(8) == 44) .OR. & - (ib(3) == 21 .AND. ib(8) == 48))) THEN + ELSE IF (nc == 8 .AND. ( & + (ib(3) == 13 .AND. ib(8) == 39) .OR. & + (ib(3) == 17 .AND. ib(8) == 44) .OR. & + (ib(3) == 21 .AND. ib(8) == 48))) THEN ! IB=14 1316 2627 3839 (z-axis) OR ! IB=12 1718 2827 4344 (x-axis) OR ! IB=13 2123 2628 4648 (y-axis) indpg = 16 ! <4>2m(d2d) - ELSEIF (nc == 16 .AND. ( & - ib(16) == 40 .OR. & - ib(16) == 44 .OR. & - ib(16) == 48)) THEN + ELSE IF (nc == 16 .AND. ( & + ib(16) == 40 .OR. & + ib(16) == 44 .OR. & + ib(16) == 48)) THEN ! IB=12 3 413 1415 1625 2627 2837 3839 40 (z-axis) OR ! IB=12 3 417 1920 1825 2627 2841 4344 42 (x-axis) OR ! IB=12 3 421 2224 2325 2627 2845 4648 47 (y-axis) indpg = 17 ! 4/mmm(d4h) - ELSEIF (nc == 4 .AND. (ib(4) == 4)) THEN + ELSE IF (nc == 4 .AND. (ib(4) == 4)) THEN ! Orthorhombic system ! IB=12 3 4 indpg = 25 ! 222(d2) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 27 .OR. & - ib(4) == 28)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 27 .OR. & + ib(4) == 28)) THEN ! IB=13 2627 (z-axis) OR ! IB=12 2728 (x-axis) OR ! IB=14 2628 (y-axis) OR indpg = 26 ! mm2(c2v) - ELSEIF (nc == 8) THEN + ELSE IF (nc == 8) THEN ! IB=12 3 425 2627 28 indpg = 27 ! mmm(d2h) - ELSEIF (nc == 12 .AND. ( & - ib(12) == 12 .OR. & - ib(12) == 47 .OR. & - ib(12) == 45)) THEN + ELSE IF (nc == 12 .AND. ( & + ib(12) == 12 .OR. & + ib(12) == 47 .OR. & + ib(12) == 45)) THEN ! Cubic system ! IB=12 3 4 5 6 7 8 910 1112 OR ! IB=15 1113 1823 2530 3537 4247 OR ! IB=18 1016 1821 2532 3440 4245 indpg = 28 ! 23 (t) - ELSEIF (nc == 24 .AND. ib(24) == 36) THEN + ELSE IF (nc == 24 .AND. ib(24) == 36) THEN ! IB= 1 2 3 4 5 6 7 8 910 1112 ! 2526 2728 2930 3132 3334 3536 indpg = 29 ! m3 (th) - ELSEIF (nc == 24 .AND. ib(24) == 24) THEN + ELSE IF (nc == 24 .AND. ib(24) == 24) THEN ! IB=12 3 45 6 78 9 1011 12 ! 1314 1516 1718 1920 2122 2324 indpg = 30 ! 432 (o) - ELSEIF (nc == 24 .AND. ib(24) == 48) THEN + ELSE IF (nc == 24 .AND. ib(24) == 48) THEN ! IB=12 3 45 6 78 9 1011 12 ! 3738 3940 4142 4345 4647 48 indpg = 31 ! <4>3m(td) - ELSEIF (nc == 48) THEN + ELSE IF (nc == 48) THEN ! IB=1..48 indpg = 32 ! m3m(oh) ELSE @@ -1441,69 +1496,70 @@ CONTAINS ! Probably a sub-group of 32 indpg = -32 END IF - ELSEIF (ihg >= 6) THEN + ELSE IF (ihg >= 6) THEN IF (nc == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC + END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSEIF (nc == 1) THEN + ELSE IF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSEIF (nc == 2 .AND. ib(2) == 13) THEN + ELSE IF (nc == 2 .AND. ib(2) == 13) THEN ! IB=113 indpg = 2 ! <1>(ci) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 4)) THEN ! 2[001] + ELSE IF (nc == 2 .AND. ( & + ib(2) == 4)) THEN ! 2[001] ! Monoclinic system ! IB=1 4 indpg = 3 ! 2 (c2) - ELSEIF (nc == 2 .AND. ( & - ib(2) == 16)) THEN + ELSE IF (nc == 2 .AND. ( & + ib(2) == 16)) THEN ! IB=116 indpg = 4 ! m (c1h) - ELSEIF (nc == 4 .AND. ( & - ib(4) == 24 .OR. & - ib(4) == 20)) THEN + ELSE IF (nc == 4 .AND. ( & + ib(4) == 24 .OR. & + ib(4) == 20)) THEN ! IB=112 1324 OR ! IB=1 813 20 indpg = 5 ! 2/m(c2h) - ELSEIF (nc == 3 .AND. ib(3) == 5) THEN + ELSE IF (nc == 3 .AND. ib(3) == 5) THEN ! Trigonal system ! IB=13 5 indpg = 6 ! 3 (c3) - ELSEIF (nc == 6 .AND. ib(6) == 17) THEN + ELSE IF (nc == 6 .AND. ib(6) == 17) THEN ! IB=113 1517 35 indpg = 7 ! <3>(c3i) - ELSEIF (nc == 6 .AND. ib(6) == 11) THEN + ELSE IF (nc == 6 .AND. ib(6) == 11) THEN ! IB=17 9 1135 indpg = 8 ! 32 (d3) - ELSEIF (nc == 6 .AND. ib(6) == 23) THEN + ELSE IF (nc == 6 .AND. ib(6) == 23) THEN ! IB=13 5 1921 23 indpg = 9 ! 3m (c3v) - ELSEIF (nc == 12 .AND. ib(12) == 23) THEN + ELSE IF (nc == 12 .AND. ib(12) == 23) THEN ! IB=13 5 79 1113 1517 1921 23 indpg = 10 ! <3>m(d3d) - ELSEIF (nc == 6 .AND. ib(6) == 6) THEN + ELSE IF (nc == 6 .AND. ib(6) == 6) THEN ! Hexagonal system ! IB=12 3 45 6 indpg = 18 ! 6 (c6) - ELSEIF (nc == 6 .AND. ib(6) == 18) THEN + ELSE IF (nc == 6 .AND. ib(6) == 18) THEN ! IB=13 5 1416 18 indpg = 19 ! <6>(c3h) - ELSEIF (nc == 12 .AND. ib(12) == 18) THEN + ELSE IF (nc == 12 .AND. ib(12) == 18) THEN ! IB=12 3 45 6 1314 1516 1718 indpg = 20 ! 6/m(c6h) - ELSEIF (nc == 12 .AND. ib(12) == 12) THEN + ELSE IF (nc == 12 .AND. ib(12) == 12) THEN ! IB=12 3 45 6 78 9 1011 12 indpg = 21 ! 622(d6) - ELSEIF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN + ELSE IF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN ! IB=12 3 45 6 1920 2122 2324 indpg = 22 ! 6mm(c6v) - ELSEIF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN + ELSE IF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN ! IB=13 5 79 1114 1618 2022 24 indpg = 23 ! <6>m2(d3h) - ELSEIF (nc == 24) THEN + ELSE IF (nc == 24) THEN ! IB=1..24 indpg = 24 ! 6/mmm(d6h) ELSE @@ -1540,7 +1596,7 @@ CONTAINS xb(i) = a(i, 1)*origin(1) + a(i, 2)*origin(2) + a(i, 3)*origin(3) END DO isy = -1 - ELSEIF (info == 0) THEN + ELSE IF (info == 0) THEN isy = 0 ELSE isy = -2 @@ -1554,83 +1610,98 @@ CONTAINS ! == Output == ! ==--------------------------------------------------------------== IF (iout > 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) + END IF CALL xstring(icst(ihg), i, j) IF ((ihg == 7 .AND. nc == 24) .OR. & (ihg == 5 .AND. nc == 48)) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,A,A)') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & - icst(ihg) (i:j), & - ' GROUP' + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & + icst(ihg) (i:j), & + ' GROUP' + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,A,A,I2,A)') & - ' KPSYM| THE CRYSTAL SYSTEM IS ', & - icst(ihg) (i:j), & - ' WITH ', nc, ' OPERATIONS:' + ' KPSYM| THE CRYSTAL SYSTEM IS ', & + icst(ihg) (i:j), & + ' WITH ', nc, ' OPERATIONS:' + END IF IF (ihc == 0) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '( 5(5(A13),/))') (rname_hexai(ib(i)), i=1, nc) + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(10(5(A13),/))') (rname_cubic(ib(i)), i=1, nc) + END IF END IF END IF ! ==------------------------------------------------------------== IF (isy == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - ELSEIF (isy == -1) THEN - IF (iout > 0) & + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + END IF + ELSE IF (isy == -1) THEN + IF (iout > 0) THEN WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - IF (iout > 0) & + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + END IF + IF (iout > 0) THEN WRITE (iout, '(A,A,/,T3,3F10.6,3X,3F10.6)') & - ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & - '[CARTESIAN] [CRYSTAL]', xb, origin - ELSEIF (isy == 0) THEN - IF (iout > 0) & + ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & + '[CARTESIAN] [CRYSTAL]', xb, origin + END IF + ELSE IF (isy == 0) THEN + IF (iout > 0) THEN WRITE (iout, '(A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' (SUM OF TRANSLATION VECTORS=', vs, ')' - ELSEIF (isy == -2) THEN - IF (iout > 0) & + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' (SUM OF TRANSLATION VECTORS=', vs, ')' + END IF + ELSE IF (isy == -2) THEN + IF (iout > 0) THEN WRITE (iout, '(A,A)') & - ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & - ' SYMMORPHIC OR NOT' - IF (iout > 0) & + ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & + ' SYMMORPHIC OR NOT' + END IF + IF (iout > 0) THEN WRITE (iout, '(A,/,A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & - ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & + ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' + END IF END IF IF (indpg > 0) THEN CALL xstring(pgrp(indpg), i, j) CALL xstring(pgrd(indpg), k, l) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & - pgrd(indpg) (k:l), indpg + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & + pgrd(indpg) (k:l), indpg + END IF ELSE CALL xstring(pgrp(-indpg), i, j) CALL xstring(pgrd(-indpg), k, l) - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,I2,A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & - ' SUBGROUP OF ', pgrp(-indpg) (i:j), & - pgrd(-indpg) (k:l), -indpg + ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & + ' SUBGROUP OF ', pgrp(-indpg) (i:j), & + pgrd(-indpg) (k:l), -indpg + END IF END IF IF (ntvec == 1) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec + ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec + END IF ELSE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec + ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec + END IF END IF END IF @@ -2403,11 +2474,12 @@ CONTAINS 280 CONTINUE END DO END DO - IF (iremov > 0 .AND. iout > 0) & + IF (iremov > 0 .AND. iout > 0) THEN WRITE (iout, '(A,A,/,A,1X,I6,A,/)') & - ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & - 'TRANSLATION VECTORS', & - ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' + ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & + 'TRANSLATION VECTORS', & + ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' + END IF END IF ! ==--------------------------------------------------------------== ! == IN THE MESH OF WAVEVECTORS, NOW SEARCH FOR EQUIVALENT POINTS:== @@ -2500,59 +2572,72 @@ CONTAINS ! == THE LIST OF WEIGHTS LWGHT IS NOT NORMALIZED == ! ==--------------------------------------------------------------== IF (ntot > nkpoint) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, *) 'IN SPPT2 NUMBER OF SPECIAL POINTS = ', ntot - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) 'BUT NKPOINT = ', nkpoint + END IF ntot = -1 END IF IF (iout > 0) THEN ! Write the index table relating k points in the mesh ! with special k points - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(/,A,4X,A)') & - ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' - IF (iout > 0) & + ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' + END IF + IF (iout > 0) THEN WRITE (iout, '(5(4X,"IK -> SK"))') + END IF DO i = 1, imesh iplace = includ(i)/2 - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(1X,I5,1X,I5)', advance="no") i, iplace - IF ((MOD(i, 5) == 0) .AND. iout > 0) & + END IF + IF ((MOD(i, 5) == 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN WRITE (iout, *) + END IF END IF RETURN ! ==--------------------------------------------------------------== ! == ERROR MESSAGES == ! ==--------------------------------------------------------------== 450 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' + END IF CALL stopgm('SPPT2', 'VECTOR OUTSIDE THE 1BZ') ! ==--------------------------------------------------------------== 470 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, *) 'MESH SIZE EXCEEDS NKPOINT=', nkpoint + END IF CALL stopgm('SPPT2', 'MESH SIZE EXCEEDED') ! ==--------------------------------------------------------------== 490 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' + END IF CALL stopgm('SPPT2', 'VECTOR NOT IN THE LIST') ! ==--------------------------------------------------------------== RETURN @@ -2615,7 +2700,7 @@ CONTAINS igarbg = 0 RETURN ! ==--------------------------------------------------------------== - ELSEIF ((iplace > -2) .AND. (iplace <= 0)) THEN + ELSE IF ((iplace > -2) .AND. (iplace <= 0)) THEN ! The particular HASH function used in this case: rhash = 0.7890_dp*wvk(1) & + 0.6810_dp*wvk(2) & @@ -2639,10 +2724,11 @@ CONTAINS ipoint = list(ihash) END DO ! List too long - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(2A,/,A)') & - ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & - ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' + ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & + ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' + END IF CALL stopgm('MESH', 'WARNING') ! WVK was not found 130 CONTINUE @@ -2654,12 +2740,14 @@ CONTAINS ! IPLACE=0: add WVK to the list list(ihash) = istore IF (istore > nmesh) THEN - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A)') 'SUBROUTINE MESH *** FATAL ERROR ***' - IF (iout > 0) & + END IF + IF (iout > 0) THEN WRITE (iout, '(A,I10,A,/,A,3F10.5)') & - ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & - ' WVK = ', wvk + ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & + ' WVK = ', wvk + END IF CALL stopgm('MESH', 'WARNING') END IF list(istore) = nil @@ -2691,11 +2779,12 @@ CONTAINS ! == Error - beyond list == ! ==--------------------------------------------------------------== 190 CONTINUE - IF (iout > 0) & + IF (iout > 0) THEN WRITE (iout, '(A,/,A,I5,A,/)') & - ' SUBROUTINE MESH *** WARNING ***', & - ' IPLACE = ', iplace, & - ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' + ' SUBROUTINE MESH *** WARNING ***', & + ' IPLACE = ', iplace, & + ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' + END IF DO i = 1, 3 wvk(i) = 1.0e38_dp END DO diff --git a/src/libint_2c_3c.F b/src/libint_2c_3c.F index e7698ae20d..1fa20a7fd6 100644 --- a/src/libint_2c_3c.F +++ b/src/libint_2c_3c.F @@ -147,7 +147,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op == do_potential_coulomb) THEN + ELSE IF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -515,7 +515,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op == do_potential_coulomb) THEN + ELSE IF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -885,7 +885,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF @@ -1135,7 +1135,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF diff --git a/src/libint_wrapper.F b/src/libint_wrapper.F index edebee3a87..93e9f7b84c 100644 --- a/src/libint_wrapper.F +++ b/src/libint_wrapper.F @@ -120,9 +120,10 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) & + IF (${m_max}$ <= m_max) THEN libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & - = F(${m_max}$+1) + = F(${m_max}$+1) + END IF #endif #:endfor @@ -215,9 +216,10 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) & + IF (${m_max}$ <= m_max) THEN libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) + = F(${m_max}$+1) + END IF #endif #:endfor @@ -287,9 +289,10 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) & + IF (${m_max}$ <= m_max) THEN libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) + = F(${m_max}$+1) + END IF #endif #:endfor diff --git a/src/library_tests.F b/src/library_tests.F index b1f2cbd5b5..0c64f82e17 100644 --- a/src/library_tests.F +++ b/src/library_tests.F @@ -287,7 +287,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env INTEGER :: iw - INTEGER :: i, ierr, j, len, ntim, siz + INTEGER :: i, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: ca, cb @@ -298,10 +298,8 @@ CONTAINS DO i = 6, 24 len = 2**i IF (8.0_dp*REAL(len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ca(len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (cb(len), STAT=ierr) - IF (ierr /= 0) EXIT + ALLOCATE (ca(len)) + ALLOCATE (cb(len)) CALL RANDOM_NUMBER(ca) ntim = NINT(1.e7_dp/REAL(len, KIND=dp)) @@ -348,7 +346,7 @@ CONTAINS LOGICAL :: test_matmul, test_dgemm INTEGER :: iw - INTEGER :: i, ierr, j, len, ntim, siz + INTEGER :: i, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart, xdum REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: ma, mb, mc @@ -360,12 +358,9 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mb(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mc(len, len), STAT=ierr) - IF (ierr /= 0) EXIT + ALLOCATE (ma(len, len)) + ALLOCATE (mb(len, len)) + ALLOCATE (mc(len, len)) mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -454,12 +449,9 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mb(len, len), STAT=ierr) - IF (ierr /= 0) EXIT - ALLOCATE (mc(len, len), STAT=ierr) - IF (ierr /= 0) EXIT + ALLOCATE (ma(len, len)) + ALLOCATE (mb(len, len)) + ALLOCATE (mc(len, len)) mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -566,8 +558,8 @@ CONTAINS INTEGER, PARAMETER :: ndate(3) = [12, 48, 96] - INTEGER :: iall, ierr, it, j, len, n(3), ntim, & - radix_in, radix_out, siz, stat + INTEGER :: iall, it, j, len, n(3), ntim, radix_in, & + radix_out, siz, stat COMPLEX(KIND=dp), DIMENSION(4, 4, 4) :: zz COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: ca, cb, cc CHARACTER(LEN=7) :: method @@ -605,8 +597,8 @@ CONTAINS len = radix_out n = len IF (16.0_dp*REAL(len*len*len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ra(len, len, len), STAT=ierr) - ALLOCATE (ca(len, len, len), STAT=ierr) + ALLOCATE (ra(len, len, len)) + ALLOCATE (ca(len, len, len)) CALL RANDOM_NUMBER(ra) ca(:, :, :) = ra CALL RANDOM_NUMBER(ra) @@ -652,25 +644,29 @@ CONTAINS CALL fft3d(FWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is changed in out-of-place FFT !" + " Input array is changed in out-of-place FFT !" + END IF ELSE - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is not changed in out-of-place FFT !" + " Input array is not changed in out-of-place FFT !" + END IF END IF ca(:, :, :) = cc CALL fft3d(BWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is changed in out-of-place FFT !" + " Input array is changed in out-of-place FFT !" + END IF ELSE - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is not changed in out-of-place FFT !" + " Input array is not changed in out-of-place FFT !" + END IF END IF IF (para_env%is_source()) WRITE (iw, *) diff --git a/src/linesearch.F b/src/linesearch.F index 3d9977d78f..8948e11682 100644 --- a/src/linesearch.F +++ b/src/linesearch.F @@ -610,8 +610,9 @@ CONTAINS is_done = .FALSE. - IF (this%gave_up) & + IF (this%gave_up) THEN CPABORT("had to give up, should not be called again") + END IF IF (.NOT. this%have_left) THEN this%left_x = 0.0_dp @@ -685,8 +686,9 @@ CONTAINS IF (this%have_left .AND. this%have_middle .AND. this%have_right) THEN a = this%middle_x - this%left_x b = this%right_x - this%middle_x - IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) & + IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) THEN CPABORT("golden-ratio gone") + END IF IF (a < b) THEN step_size = this%middle_x + a/phi diff --git a/src/local_gemm_api.F b/src/local_gemm_api.F index 7812c45cc1..e45895578f 100644 --- a/src/local_gemm_api.F +++ b/src/local_gemm_api.F @@ -8,6 +8,7 @@ MODULE local_gemm_api USE ISO_C_BINDING, ONLY: C_NULL_PTR, & C_PTR + USE kinds, ONLY: dp #if defined(__SPLA) && defined(__OFFLOAD_GEMM) USE input_constants, ONLY: do_dgemm_spla USE ISO_C_BINDING, ONLY: C_ASSOCIATED, & @@ -83,25 +84,25 @@ CONTAINS INTEGER, INTENT(in) :: m INTEGER, INTENT(in) :: n INTEGER, INTENT(in) :: k - REAL(8), INTENT(in) :: alpha + REAL(KIND=dp), INTENT(in) :: alpha #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(8), DIMENSION(*), INTENT(in), TARGET :: A + REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: A #else - REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: A + REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: A #endif INTEGER, INTENT(in) :: lda #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(8), DIMENSION(*), INTENT(in), TARGET :: B + REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: B #else - REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: B + REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: B #endif INTEGER, INTENT(in) :: ldb - REAL(8), INTENT(in) :: beta + REAL(KIND=dp), INTENT(in) :: beta #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(8), DIMENSION(*), INTENT(inout), TARGET ::C + REAL(KIND=dp), DIMENSION(*), INTENT(inout), TARGET ::C #else - REAL(8), DIMENSION(:, :), INTENT(inout), TARGET :: C + REAL(KIND=dp), DIMENSION(:, :), INTENT(inout), TARGET :: C #endif INTEGER, INTENT(in) :: ldc CLASS(local_gemm_ctxt_type), INTENT(inout) :: ctx diff --git a/src/localization_tb.F b/src/localization_tb.F index 417e0fa0f7..866e1d491f 100644 --- a/src/localization_tb.F +++ b/src/localization_tb.F @@ -147,7 +147,7 @@ CONTAINS IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSEIF (dft_control%restricted) THEN + ELSE IF (dft_control%restricted) THEN IF (iounit > 0) WRITE (iounit, *) & " Unclear how we define MOs / localization in the restricted case ... skipping" ELSE diff --git a/src/localized_moments.F b/src/localized_moments.F index 7f6782fb0e..6a82b95e68 100644 --- a/src/localized_moments.F +++ b/src/localized_moments.F @@ -737,9 +737,10 @@ CONTAINS DO idir = 1, 3 CALL dbcsr_get_readonly_block_p(moments_der(i, idir)%matrix, & iatom, jatom, oblock, found) - IF (found) & + IF (found) THEN qupole_der((i - 1)*3 + idir) = & - qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) + qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) + END IF END DO END DO END IF diff --git a/src/lri_optimize_ri_basis_types.F b/src/lri_optimize_ri_basis_types.F index 41bf462a06..4a79d3914a 100644 --- a/src/lri_optimize_ri_basis_types.F +++ b/src/lri_optimize_ri_basis_types.F @@ -227,8 +227,7 @@ CONTAINS END DO DO ishell = 1, gto_basis_set%nshell(iset) - gcc(:, ishell, iset) = gcc(:, ishell, iset)/ & - SQRT(DOT_PRODUCT(gcc(:, ishell, iset), gcc(:, ishell, iset))) + gcc(:, ishell, iset) = gcc(:, ishell, iset)/NORM2(gcc(:, ishell, iset)) END DO END DO diff --git a/src/manybody_nequip.F b/src/manybody_e3nn.F similarity index 94% rename from src/manybody_nequip.F rename to src/manybody_e3nn.F index adff300a10..58e5dc64c6 100644 --- a/src/manybody_nequip.F +++ b/src/manybody_e3nn.F @@ -6,13 +6,16 @@ !--------------------------------------------------------------------------------------------------! ! ************************************************************************************************** +!> \brief Shared TorchScript evaluation path for e3nn-based equivariant message-passing +!> potentials (NequIP, Allegro and MACE). !> \par History !> Implementation of NequIP and Allegro potentials - [gtocci] 2022 !> Index mapping of atoms from .xyz to Allegro config.yaml file - [mbilichenko] 2024 !> Refactoring and update to NequIP version >= v0.7.0 - [gtocci] 2026 +!> Renamed manybody_nequip -> manybody_e3nn as it now also serves MACE - [xysun] 2026 !> \author Gabriele Tocci ! ************************************************************************************************** -MODULE manybody_nequip +MODULE manybody_e3nn USE atomic_kind_types, ONLY: atomic_kind_type USE cell_types, ONLY: cell_type @@ -28,7 +31,8 @@ MODULE manybody_nequip dp,& int_8 USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: nequip_pot_type,& + USE pair_potential_types, ONLY: mace_type,& + nequip_pot_type,& nequip_type,& pair_potential_pp_type,& pair_potential_single_type @@ -43,10 +47,10 @@ MODULE manybody_nequip IMPLICIT NONE PRIVATE - PUBLIC :: nequip_energy_store_force_virial, & - nequip_add_force_virial + PUBLIC :: e3nn_energy_store_force_virial, & + e3nn_add_force_virial - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_nequip' + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_e3nn' TYPE, PRIVATE :: nequip_work_type INTEGER :: target_pot_type @@ -89,10 +93,10 @@ CONTAINS !> Refactoring and unifying NequIP and Allegro - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_total, fist_nonbond_env, para_env, use_virial, & - target_pot_type) + SUBROUTINE e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_total, fist_nonbond_env, para_env, use_virial, & + target_pot_type) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(particle_type), POINTER :: particle_set(:) @@ -107,7 +111,7 @@ CONTAINS LOGICAL, INTENT(IN) :: use_virial INTEGER, INTENT(IN) :: target_pot_type - CHARACTER(LEN=*), PARAMETER :: routineN = 'nequip_energy_store_force_virial' + CHARACTER(LEN=*), PARAMETER :: routineN = 'e3nn_energy_store_force_virial' INTEGER :: handle TYPE(nequip_data_type), POINTER :: neq_data @@ -132,7 +136,8 @@ CONTAINS CALL setup_neq_data(fist_nonbond_env, neq_data, neq_pot, nequip_work) - IF (nequip_work%target_pot_type == nequip_type) THEN + IF (nequip_work%target_pot_type == nequip_type .OR. & + nequip_work%target_pot_type == mace_type) THEN CALL prepare_edges_shifts_nequip(nequip_work) ELSE CALL prepare_edges_shifts_allegro(nequip_work) @@ -146,7 +151,7 @@ CONTAINS CALL release_nequip_work(nequip_work) CALL timestop(handle) - END SUBROUTINE nequip_energy_store_force_virial + END SUBROUTINE e3nn_energy_store_force_virial ! ************************************************************************************************** !> \brief ... @@ -468,8 +473,9 @@ CONTAINS END IF IF (ASSOCIATED(neq_data%force)) THEN - IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) & + IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) THEN DEALLOCATE (neq_data%force, neq_data%use_indices) + END IF END IF IF (.NOT. ASSOCIATED(neq_data%force)) THEN @@ -563,7 +569,8 @@ CONTAINS n_atoms = SIZE(nequip_work%particle_set) ! for allegro ensure ghost atoms are included in the evaluation - IF (nequip_work%target_pot_type /= nequip_type) THEN + IF (nequip_work%target_pot_type /= nequip_type .AND. & + nequip_work%target_pot_type /= mace_type) THEN ! label atoms in the local edges DO i = 1, SIZE(nequip_work%local_edges, 2) atom_a = INT(nequip_work%local_edges(1, i)) @@ -707,7 +714,8 @@ CONTAINS DO iat_use = 1, SIZE(neq_data%use_indices) iat = neq_data%use_indices(iat_use) ! Only apply the local mask for Allegro models - IF (nequip_work%target_pot_type /= nequip_type) THEN + IF (nequip_work%target_pot_type /= nequip_type .AND. & + nequip_work%target_pot_type /= mace_type) THEN IF (.NOT. nequip_work%sum_energy(iat)) CYCLE END IF @@ -716,7 +724,8 @@ CONTAINS CALL torch_tensor_release(t_energy) pot_total = pot_total*pot%unit_energy_val - IF (nequip_work%target_pot_type == nequip_type) THEN + IF (nequip_work%target_pot_type == nequip_type .OR. & + nequip_work%target_pot_type == mace_type) THEN neq_data%force = neq_data%force/REAL(nequip_work%para_env%num_pe, dp) pot_total = pot_total/REAL(nequip_work%para_env%num_pe, dp) END IF @@ -727,7 +736,8 @@ CONTAINS neq_data%virial(:, :) = RESHAPE(v_ptr, [3, 3])*pot%unit_energy_val CALL torch_tensor_release(t_virial) - IF (nequip_work%target_pot_type == nequip_type) THEN + IF (nequip_work%target_pot_type == nequip_type .OR. & + nequip_work%target_pot_type == mace_type) THEN neq_data%virial = neq_data%virial/REAL(nequip_work%para_env%num_pe, dp) END IF END IF @@ -744,7 +754,7 @@ CONTAINS !> Sum forces, virial to nonbond - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + SUBROUTINE e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: f_nonbond, pv_nonbond LOGICAL, INTENT(IN) :: use_virial @@ -763,6 +773,6 @@ CONTAINS f_nonbond(1:3, iat) = f_nonbond(1:3, iat) + neq_data%force(1:3, iat_use) END DO - END SUBROUTINE nequip_add_force_virial + END SUBROUTINE e3nn_add_force_virial -END MODULE manybody_nequip +END MODULE manybody_e3nn diff --git a/src/manybody_eam.F b/src/manybody_eam.F index 0819359be8..38cc5ba35b 100644 --- a/src/manybody_eam.F +++ b/src/manybody_eam.F @@ -186,7 +186,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) @@ -196,7 +196,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -233,7 +233,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -247,7 +247,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) diff --git a/src/manybody_gal.F b/src/manybody_gal.F index 8c72d24322..cb57bcddd6 100644 --- a/src/manybody_gal.F +++ b/src/manybody_gal.F @@ -81,7 +81,8 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair - rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) !Vector in pbc from j to i + !Vector in pbc from j to i + rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only ALLOCATE (gal%n_vectors(3, SIZE(particle_set))) @@ -98,7 +99,8 @@ CONTAINS Vang = 0.0_dp IF (gcn_weight2 /= 0.0) THEN - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, only the first time + ! that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -106,13 +108,14 @@ CONTAINS particle_set, cell) END IF - nvec(:) = gal%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen + !Else, retrive it, should not have moved sinc metal is supposed to be frozen + nvec(:) = gal%n_vectors(:, jparticle) !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) + weight = EXP(-NORM2(rji)/gal%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = angular(gal, r_last_update_pbc, iparticle, cell, particle_set, nvec, & @@ -223,12 +226,13 @@ CONTAINS IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) drjk2 = DOT_PRODUCT(rjk, rjk) - IF (drjk2 > gal%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + IF (drjk2 > gal%rcutsq) CYCLE normale(:) = normale(:) - rjk(:) !Build the normal, vector by vector END DO ! Normalisation of the vector - normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) + normale(:) = normale(:)/NORM2(normale) END FUNCTION normale @@ -264,9 +268,11 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (element_symbol_k == gal%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r1) !Build the sum of the exponential weights - IF (element_symbol_k == gal%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r2) !Build the sum of the exponential weights + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal%rcutsq) CYCLE + !Build the sum of the exponential weights + IF (element_symbol_k == gal%met1) somme = somme + EXP(-NORM2(rki)/gal%r1) + IF (element_symbol_k == gal%met2) somme = somme + EXP(-NORM2(rki)/gal%r2) END DO END FUNCTION somme @@ -317,11 +323,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -335,7 +341,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -390,7 +396,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only @@ -407,7 +413,8 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% IF (gcn_weight2 /= 0.0) THEN - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, only the first time + ! that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -524,7 +531,7 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) + weight_rji = EXP(-NORM2(rji)/gal%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system @@ -532,11 +539,13 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - drki = SQRT(DOT_PRODUCT(rki, rki)) + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal%rcutsq) CYCLE + drki = NORM2(rki) rki_hat(:) = rki(:)/drki - IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) !Build the sum of derivativs + !Build the sum of derivativs + IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) IF (element_symbol_k == gal%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r2)*EXP(-drki/gal%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -587,11 +596,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -603,14 +612,15 @@ CONTAINS END IF rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole + rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector + ! Theta is the angle between the normal to the surface and the dipole + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -618,7 +628,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*gal%a1*SIN(theta) - gal%a2*2.0_dp*SIN(2.0_dp*theta) - & gal%a3*3.0_dp*SIN(3.0_dp*theta) - gal%a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term diff --git a/src/manybody_gal21.F b/src/manybody_gal21.F index c31ac17f5c..7604fe379c 100644 --- a/src/manybody_gal21.F +++ b/src/manybody_gal21.F @@ -105,7 +105,8 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Vang = 0.0_dp - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, + ! only the first time that an interaction with the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -113,13 +114,14 @@ CONTAINS particle_set, cell) END IF - nvec(:) = gal21%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen + ! Else, retrive it, should not have moved sinc metal is supposed to be frozen + nvec(:) = gal21%n_vectors(:, jparticle) !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal21, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) + weight = EXP(-NORM2(rji)/gal21%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = 0.0_dp @@ -229,15 +231,18 @@ CONTAINS IF (kparticle == jparticle) CYCLE !Avoid the principal Me atom (j) in the counting CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals + !Keep only metals + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) - drjk = SQRT(DOT_PRODUCT(rjk, rjk)) - IF (drjk > gal21%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair - normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) !Build the normal, vector by vector + drjk = NORM2(rjk) + !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + IF (drjk > gal21%rcutsq) CYCLE + !Build the normal, vector by vector + normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) END DO ! Normalisation of the vector - normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) + normale(:) = normale(:)/NORM2(normale) END FUNCTION normale @@ -269,11 +274,14 @@ CONTAINS DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals + !Keep only metals + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (element_symbol_k == gal21%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r1) !Build the sum of the exponential weights - IF (element_symbol_k == gal21%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r2) !Build the sum of the exponential weights + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal21%rcutsq) CYCLE + !Build the sum of the exponential weights + IF (element_symbol_k == gal21%met1) somme = somme + EXP(-NORM2(rki)/gal21%r1) + IF (element_symbol_k == gal21%met2) somme = somme + EXP(-NORM2(rki)/gal21%r2) END DO END FUNCTION somme @@ -325,11 +333,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -348,7 +356,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -359,8 +367,7 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) - VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & - EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) + VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*NORM2(rjh1)) + EXP(-BH*NORM2(rjh2))) ! For fit purpose IF (gal21%express .AND. energy) THEN @@ -370,9 +377,8 @@ CONTAINS IF (index_outfile > 0) WRITE (index_outfile, *) "Fourier", costheta, COS(2.0_dp*theta), COS(3.0_dp*theta), & COS(4.0_dp*theta) !, theta - IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & - EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2))) - !IF (index_outfile > 0) WRITE (index_outfile, *) "H_r6", -1/DOT_PRODUCT(rjh1,rjh1)**3 -1/DOT_PRODUCT(rjh2,rjh2)**3 + IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*NORM2(rjh1)) + & + EXP(-BH*NORM2(rjh2)) CALL cp_print_key_finished_output(index_outfile, logger, mm_section, & "PRINT%PROGRAM_RUN_INFO") @@ -415,7 +421,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal21%n_vectors)) THEN !First calling of the forcefield only @@ -430,7 +436,8 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated + ! Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with + ! the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -566,19 +573,22 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) + weight_rji = EXP(-NORM2(rji)/gal21%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals + !Keep only metals + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - drki = SQRT(DOT_PRODUCT(rki, rki)) + !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (NORM2(rki) > gal21%rcutsq) CYCLE + drki = NORM2(rki) rki_hat(:) = rki(:)/drki - IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) !Build the sum of derivativs + !Build the sum of derivativs + IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) IF (element_symbol_k == gal21%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r2)*EXP(-drki/gal21%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -641,11 +651,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -662,14 +672,14 @@ CONTAINS a4 = gal21%a41 + gal21%a42*gal21%gcn(jparticle) + gal21%a43*gal21%gcn(jparticle)*gal21%gcn(jparticle) rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector - costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole + rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector + costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) ! Theta is the angle between the normal to the surface and the dipole IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -677,7 +687,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*a1*SIN(theta) - a2*2.0_dp*SIN(2.0_dp*theta) - & a3*3.0_dp*SIN(3.0_dp*theta) - a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term @@ -695,35 +705,35 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) f_nonbond(1:3, index_h1) = f_nonbond(1:3, index_h1) + (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))*rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))*rjh1(:)/NORM2(rjh1) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh1(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & - *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))) & + *rjh1(:)/NORM2(rjh1) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh1(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & - *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))) & + *rjh1(:)/NORM2(rjh1) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh1(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & - *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) + BH*EXP(-BH*NORM2(rjh1))) & + *rjh1(:)/NORM2(rjh1) END IF rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) f_nonbond(1:3, index_h2) = f_nonbond(1:3, index_h2) + ((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh2(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh2(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh2(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & - *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) + BH*EXP(-BH*NORM2(rjh2))) & + *rjh2(:)/NORM2(rjh2) END IF END SUBROUTINE angular_d diff --git a/src/manybody_potential.F b/src/manybody_potential.F index 16b5faec93..a3a706a7f1 100644 --- a/src/manybody_potential.F +++ b/src/manybody_potential.F @@ -30,6 +30,8 @@ MODULE manybody_potential ace_energy_store_force_virial USE manybody_deepmd, ONLY: deepmd_add_force_virial,& deepmd_energy_store_force_virial + USE manybody_e3nn, ONLY: e3nn_add_force_virial,& + e3nn_energy_store_force_virial USE manybody_eam, ONLY: get_force_eam USE manybody_gal, ONLY: destroy_gal_arrays,& gal_energy,& @@ -39,8 +41,6 @@ MODULE manybody_potential gal21_energy,& gal21_forces,& setup_gal21_arrays - USE manybody_nequip, ONLY: nequip_add_force_virial,& - nequip_energy_store_force_virial USE manybody_siepmann, ONLY: destroy_siepmann_arrays,& print_nr_ions_siepmann,& setup_siepmann_arrays,& @@ -54,8 +54,9 @@ MODULE manybody_potential USE message_passing, ONLY: mp_para_env_type USE pair_potential_types, ONLY: & ace_type, allegro_type, deepmd_type, ea_type, eam_pot_type, gal21_pot_type, gal21_type, & - gal_pot_type, gal_type, nequip_type, pair_potential_pp_type, pair_potential_single_type, & - siepmann_pot_type, siepmann_type, tersoff_pot_type, tersoff_type + gal_pot_type, gal_type, mace_type, nequip_type, pair_potential_pp_type, & + pair_potential_single_type, siepmann_pot_type, siepmann_type, tersoff_pot_type, & + tersoff_type USE particle_types, ONLY: particle_type USE util, ONLY: sort #include "./base/base_uses.f90" @@ -105,11 +106,11 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_nequip, & - any_siepmann, any_tersoff + any_gal, any_gal21, any_mace, & + any_nequip, any_siepmann, any_tersoff REAL(KIND=dp) :: drij, embed, pot_ace, pot_allegro, & - pot_deepmd, pot_loc, pot_nequip, qr, & - rab2_max, rij(3) + pot_deepmd, pot_loc, pot_mace, & + pot_nequip, qr, rab2_max, rij(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v REAL(KIND=dp), POINTER :: fembed(:) @@ -132,6 +133,7 @@ CONTAINS any_gal21 = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. + any_mace = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. CALL timeset(routineN, handle) @@ -177,6 +179,7 @@ CONTAINS pot => potparm%pot(ikind, jkind)%pot any_tersoff = any_tersoff .OR. ANY(pot%type == tersoff_type) any_nequip = any_nequip .OR. ANY(pot%type == nequip_type) + any_mace = any_mace .OR. ANY(pot%type == mace_type) any_ace = any_ace .OR. ANY(pot%type == ace_type) any_allegro = any_allegro .OR. ANY(pot%type == allegro_type) any_deepmd = any_deepmd .OR. ANY(pot%type == deepmd_type) @@ -189,21 +192,30 @@ CONTAINS ! NEQUIP IF (any_nequip) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_nequip, fist_nonbond_env, & - para_env, use_virial, nequip_type) + CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_nequip, fist_nonbond_env, & + para_env, use_virial, nequip_type) pot_manybody = pot_manybody + pot_nequip END IF ! ALLEGRO IF (any_allegro) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_allegro, fist_nonbond_env, & - para_env, use_virial, allegro_type) + CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_allegro, fist_nonbond_env, & + para_env, use_virial, allegro_type) pot_manybody = pot_manybody + pot_allegro END IF + ! MACE (reuses the NequIP message-passing evaluation path) + IF (any_mace) THEN + NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) + CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_mace, fist_nonbond_env, & + para_env, use_virial, mace_type) + pot_manybody = pot_manybody + pot_mace + END IF ! ACE IF (any_ace) THEN CALL ace_energy_store_force_virial(particle_set, cell, atomic_kind_set, potparm, & @@ -578,8 +590,8 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_nequip, & - any_siepmann, any_tersoff + any_gal, any_gal21, any_mace, & + any_nequip, any_siepmann, any_tersoff REAL(KIND=dp) :: f_eam, fac, fr(3), ptens11, ptens12, ptens13, ptens21, ptens22, ptens23, & ptens31, ptens32, ptens33, rab(3), rab2, rab2_max, rtmp(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi @@ -599,6 +611,7 @@ CONTAINS any_tersoff = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. + any_mace = .FALSE. any_siepmann = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. @@ -639,8 +652,9 @@ CONTAINS END DO END DO ! ACE - IF (any_ace) & + IF (any_ace) THEN CALL ace_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + END IF DO ikind = 1, nkinds DO jkind = ikind, nkinds @@ -648,8 +662,9 @@ CONTAINS END DO END DO ! DEEPMD - IF (any_deepmd) & + IF (any_deepmd) THEN CALL deepmd_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + END IF ! NEQUIP DO ikind = 1, nkinds @@ -658,7 +673,7 @@ CONTAINS END DO END DO IF (any_nequip) THEN - CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! ALLEGRO @@ -668,7 +683,17 @@ CONTAINS END DO END DO IF (any_allegro) THEN - CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + END IF + + ! MACE (reuses the NequIP force/virial accumulation) + DO ikind = 1, nkinds + DO jkind = ikind, nkinds + any_mace = any_mace .OR. ANY(potparm%pot(ikind, jkind)%pot%type == mace_type) + END DO + END DO + IF (any_mace) THEN + CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! starting the force loop diff --git a/src/manybody_siepmann.F b/src/manybody_siepmann.F index 42c619b843..09e29c1ef7 100644 --- a/src/manybody_siepmann.F +++ b/src/manybody_siepmann.F @@ -185,7 +185,7 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) IF (kparticle == jparticle) CYCLE @@ -243,7 +243,7 @@ CONTAINS F = siepmann%F rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji nparticle = SIZE(r_last_update_pbc) @@ -339,19 +339,19 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) DO iatom = 1, natom CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = SQRT(DOT_PRODUCT(rih, rih)) + drih = NORM2(rih) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -363,21 +363,21 @@ CONTAINS ELSE CPABORT("No H atoms for O found") END IF - ELSEIF (count_h == 1) THEN + ELSE IF (count_h == 1) THEN IF (siepmann%allow_oh_formation) THEN IF (PRESENT(nr_oh)) nr_oh = nr_oh + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Only one H atom of O atom found") END IF - ELSEIF (count_h == 3) THEN + ELSE IF (count_h == 3) THEN IF (siepmann%allow_h3o_formation) THEN IF (PRESENT(nr_h3o)) nr_h3o = nr_h3o + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Three H atoms for O atom found") END IF - ELSEIF (count_h > 3) THEN + ELSE IF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -386,7 +386,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = SQRT(DOT_PRODUCT(rix, rix)) + drix = NORM2(rix) cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp IF (cosphi > +1.0_dp) cosphi = +1.0_dp @@ -441,7 +441,7 @@ CONTAINS cell_v, cell, rcutsq, & particle_set) rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji DO iatom = 1, natom @@ -449,23 +449,23 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = SQRT(DOT_PRODUCT(rih, rih)) + drih = NORM2(rih) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSEIF (count_h == 2) THEN + ELSE IF (count_h == 2) THEN index_h2 = iatom END IF END DO IF (count_h == 0 .AND. .NOT. siepmann%allow_o_formation) THEN CPABORT("No H atoms for O found") - ELSEIF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN + ELSE IF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN CPABORT("Only one H atom for O atom found") - ELSEIF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN + ELSE IF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN CPABORT("Three H atoms for O atom found") - ELSEIF (count_h > 3) THEN + ELSE IF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -474,7 +474,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = SQRT(DOT_PRODUCT(rix, rix)) + drix = NORM2(rix) rix_hat(:) = rix(:)/drix cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp @@ -561,7 +561,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) rji_hat(:) = rji(:)/drji fac = -1.0_dp !gradient to force @@ -646,7 +646,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = SQRT(DOT_PRODUCT(rji, rji)) + drji = NORM2(rji) fac = -1.0_dp Phi_ij = siep_Phi_ij(siepmann, r_last_update_pbc, iparticle, jparticle, & diff --git a/src/manybody_tersoff.F b/src/manybody_tersoff.F index 9f86baecab..719e662a37 100644 --- a/src/manybody_tersoff.F +++ b/src/manybody_tersoff.F @@ -346,7 +346,7 @@ CONTAINS lambda3 = tersoff%lambda3 rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = SQRT(DOT_PRODUCT(rij, rij)) + drij = NORM2(rij) ter_zeta_ij = 0.0_dp DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) @@ -413,7 +413,7 @@ CONTAINS rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = SQRT(DOT_PRODUCT(rij, rij)) + drij = NORM2(rij) rij_hat(:) = rij(:)/drij nparticle = SIZE(r_last_update_pbc) @@ -576,7 +576,7 @@ CONTAINS CALL timeset(routineN, handle) rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = SQRT(DOT_PRODUCT(rij, rij)) + drij = NORM2(rij) rij_hat(:) = rij(:)/drij fac = -0.5_dp diff --git a/src/mao_basis.F b/src/mao_basis.F index ed28ab101b..6234629519 100644 --- a/src/mao_basis.F +++ b/src/mao_basis.F @@ -261,8 +261,9 @@ CONTAINS ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) & + IF (col_blk_sizes(iab) < 0) THEN CPABORT("Minimum number of MAOs has to be specified in KIND section for all elements") + END IF END DO DO ispin = 1, nspin ! coefficients diff --git a/src/mao_io.F b/src/mao_io.F index 53728ce974..1b300ea47e 100644 --- a/src/mao_io.F +++ b/src/mao_io.F @@ -122,8 +122,10 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) & ! catch corner-case + IF (SIZE(local_block) > 0) THEN + ! catch corner-case mpi_buffer(:, :) = local_block(:, :) + END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/mao_wfn_analysis.F b/src/mao_wfn_analysis.F index ba7f41bdc2..d0d7132444 100644 --- a/src/mao_wfn_analysis.F +++ b/src/mao_wfn_analysis.F @@ -243,8 +243,9 @@ CONTAINS CALL get_particle_set(particle_set, qs_kind_set, nmao=col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) & + IF (col_blk_sizes(iab) < 0) THEN CPABORT("Number of MAOs has to be specified in KIND section for all elements") + END IF END DO DO ispin = 1, nspin ! coeficients diff --git a/src/metadyn_tools/graph.F b/src/metadyn_tools/graph.F index 92444bd6da..62eb7713ea 100644 --- a/src/metadyn_tools/graph.F +++ b/src/metadyn_tools/graph.F @@ -200,8 +200,9 @@ PROGRAM graph END IF END DO - IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) & + IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) THEN CPABORT("Error! You've to specify either ORAC, CP2K or CPMD!") + END IF ! For CPMD move filename to colvar_mtd IF (l_cpmd) THEN @@ -358,9 +359,10 @@ PROGRAM graph END IF END DO - IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) & + IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) THEN CALL cp_abort(__LOCATION__, & "-find-path requires the specification of -point-a and -point-b !") + END IF ELSE ALLOCATE (mep_input_data%minima(0, 0)) END IF @@ -647,7 +649,7 @@ PROGRAM graph IF (.NOT. lstride .AND. MOD(it, nwr) == 0) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" - ELSEIF (.NOT. lstride .AND. it == nt) THEN + ELSE IF (.NOT. lstride .AND. it == nt) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" END IF END DO Hills @@ -663,7 +665,7 @@ PROGRAM graph IF (ncount < 10) THEN WRITE (out3_stride, '(A,i1)') TRIM(out3), ncount - ELSEIF (ncount < 100) THEN + ELSE IF (ncount < 100) THEN WRITE (out3_stride, '(A,i2)') TRIM(out3), ncount ELSE WRITE (out3_stride, '(A,i3)') TRIM(out3), ncount diff --git a/src/metadyn_tools/graph_methods.F b/src/metadyn_tools/graph_methods.F index 739fd093e7..8ec364e70e 100644 --- a/src/metadyn_tools/graph_methods.F +++ b/src/metadyn_tools/graph_methods.F @@ -323,7 +323,7 @@ CONTAINS fes_old = fes_now !WRITE(10+j,'(10f20.10)')(xx(id),id=ndim,1,-1),-fes(pnt) - norm_dx = SQRT(DOT_PRODUCT(dx, dx)) + norm_dx = NORM2(dx) IF (norm_dx == 0.0_dp) EXIT ! It is in a really flat region xx = xx - MIN(0.1_dp, norm_dx)*dx/norm_dx ! Re-evaluating pos @@ -448,7 +448,7 @@ CONTAINS ! compute average length (distance 1) DO irep = 2, nreplica xx = pos(:, irep) - pos(:, irep - 1) - avg1 = avg1 + SQRT(DOT_PRODUCT(xx, xx)) + avg1 = avg1 + NORM2(xx) END DO avg1 = avg1/REAL(nreplica - 1, KIND=dp) @@ -456,7 +456,7 @@ CONTAINS ! compute average length (distance 2) DO irep = 3, nreplica xx = pos(:, irep) - pos(:, irep - 2) - avg2 = avg2 + SQRT(DOT_PRODUCT(xx, xx)) + avg2 = avg2 + NORM2(xx) END DO avg2 = avg2/REAL(nreplica - 2, KIND=dp) @@ -478,7 +478,7 @@ CONTAINS davg2 = 0.0_dp IF (irep < nf - 1) THEN xx = pos(:, irep) - pos(:, irep + 2) - xx0 = SQRT(DOT_PRODUCT(xx, xx)) + xx0 = NORM2(xx) dxx = 1.0_dp/xx0*xx ene = ene + 0.25_dp*mep_input_data%kb*(xx0 - avg2)**2 davg2 = davg2 + dxx @@ -486,7 +486,7 @@ CONTAINS IF (irep > ns + 1) THEN xx = pos(:, irep) - pos(:, irep - 2) - yy0 = SQRT(DOT_PRODUCT(xx, xx)) + yy0 = NORM2(xx) dyy = 1.0_dp/yy0*xx davg2 = davg2 + dyy END IF @@ -503,11 +503,11 @@ CONTAINS ! Evaluation of the elastic term ! ------------------------------------------------------------- xx = pos(:, irep) - pos(:, irep + 1) - yy0 = SQRT(DOT_PRODUCT(xx, xx)) + yy0 = NORM2(xx) dyy = 1.0_dp/yy0*xx xx = pos(:, irep) - pos(:, irep - 1) - xx0 = SQRT(DOT_PRODUCT(xx, xx)) + xx0 = NORM2(xx) dxx = 1.0_dp/xx0*xx davg1 = (dxx + dyy)/REAL(nreplica - 1, KIND=dp) @@ -517,11 +517,11 @@ CONTAINS ! Evaluate the tangent xx = pos(:, irep + 1) - pos(:, irep) - xx = xx/SQRT(DOT_PRODUCT(xx, xx)) + xx = xx/NORM2(xx) yy = pos(:, irep) - pos(:, irep - 1) - yy = yy/SQRT(DOT_PRODUCT(yy, yy)) + yy = yy/NORM2(yy) tang = xx + yy - tang = tang/SQRT(DOT_PRODUCT(tang, tang)) + tang = tang/NORM2(tang) xx = derivative(fes, ipos, iperd, ndim, ngrid, dp_grid) dx(:, irep) = DOT_PRODUCT(dx(:, irep), tang)*tang + & @@ -536,7 +536,7 @@ CONTAINS ene = ene + fes_rep(irep) IF ((irep == 1) .OR. (irep == nreplica)) CYCLE - norm_dx = SQRT(DOT_PRODUCT(dx(:, irep), dx(:, irep))) + norm_dx = NORM2(dx(:, irep)) IF (norm_dx /= 0.0_dp) THEN pos(:, irep) = pos(:, irep) - MIN(0.1_dp, norm_dx)*dx(:, irep)/norm_dx END IF diff --git a/src/metadynamics_types.F b/src/metadynamics_types.F index a299e450b9..985188607a 100644 --- a/src/metadynamics_types.F +++ b/src/metadynamics_types.F @@ -272,8 +272,9 @@ CONTAINS END IF ! Langevin on COLVARS - IF (meta_env%langevin) & + IF (meta_env%langevin) THEN DEALLOCATE (meta_env%rng) + END IF NULLIFY (meta_env%time) NULLIFY (meta_env%metadyn_section) diff --git a/src/metadynamics_utils.F b/src/metadynamics_utils.F index 91b33ff467..72834021df 100644 --- a/src/metadynamics_utils.F +++ b/src/metadynamics_utils.F @@ -157,9 +157,10 @@ CONTAINS "Overriding input specification!") END IF check = meta_env%hills_env%nt_hills >= meta_env%hills_env%min_nt_hills - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "MIN_NT_HILLS must have a value smaller or equal to NT_HILLS! "// & "Cross check with the input reference!") + END IF !RG Adaptive hills CALL section_vals_val_get(metadyn_section, "MIN_DISP", r_val=meta_env%hills_env%min_disp) CALL section_vals_val_get(metadyn_section, "OLD_HILL_NUMBER", i_val=meta_env%hills_env%old_hill_number) @@ -189,15 +190,18 @@ CONTAINS IF (meta_env%well_tempered) THEN meta_env%hills_env%wtcontrol = meta_env%hills_env%wtcontrol .OR. check check = meta_env%hills_env%wtcontrol - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "When using Well-Tempered metadynamics, "// & "DELTA_T (or WTGAMMA) should be explicitly specified.") - IF (meta_env%extended_lagrange) & + END IF + IF (meta_env%extended_lagrange) THEN CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with extended-lagrangian formulation.") - IF (meta_env%hills_env%min_disp > 0.0_dp) & + END IF + IF (meta_env%hills_env%min_disp > 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with Adaptive hills.") + END IF END IF CALL section_vals_val_get(metadyn_section, "COLVAR_AVG_TEMPERATURE_RESTART", & @@ -207,12 +211,13 @@ CONTAINS CALL metavar_read(meta_env%metavar(i), meta_env%extended_lagrange, & meta_env%langevin, i, metavar_section) check = (meta_env%metavar(i)%icolvar <= number_allocated_colvars) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "An error occurred in the specification of COLVAR for METAVAR. "// & "Specified COLVAR #("//TRIM(ADJUSTL(cp_to_string(meta_env%metavar(i)%icolvar)))//") "// & "is larger than the maximum number of COLVARS defined in the SUBSYS ("// & TRIM(ADJUSTL(cp_to_string(number_allocated_colvars)))//") !") + END IF END DO ! Parsing the Multiple Walkers Info @@ -235,12 +240,13 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(walkers_section, "WALKERS_STATUS", i_vals=walkers_status) check = (SIZE(walkers_status) == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "size of the WALKERS_STATUS. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") + END IF meta_env%multiple_walkers%walkers_status = walkers_status ELSE meta_env%multiple_walkers%walkers_status = 0 @@ -251,12 +257,13 @@ CONTAINS CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & n_rep_val=n_rep) check = (n_rep == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "number of Walkers File names provided. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") + END IF DO i = 1, n_rep CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & i_rep_val=i, c_val=walkers_file_name) diff --git a/src/minbas_methods.F b/src/minbas_methods.F index 57411747cf..96f1c421df 100644 --- a/src/minbas_methods.F +++ b/src/minbas_methods.F @@ -138,8 +138,9 @@ CONTAINS nmao = SUM(col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) & + IF (col_blk_sizes(iab) < 0) THEN CPABORT("Number of MAOs has to be specified in KIND section for all elements") + END IF END DO CALL get_mo_set(mo_set=mos(1), nao=nao, nmo=nmo) @@ -167,7 +168,7 @@ CONTAINS WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' END IF do_minbas = .FALSE. - ELSEIF (nmo /= nmx) THEN + ELSE IF (nmo /= nmx) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A)') 'Different Number of Alpha and Beta MOs' WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' diff --git a/src/minbas_wfn_analysis.F b/src/minbas_wfn_analysis.F index bd4c617ca7..3c501d3076 100644 --- a/src/minbas_wfn_analysis.F +++ b/src/minbas_wfn_analysis.F @@ -424,9 +424,9 @@ CONTAINS wij = ABS(SUM(qblock*sblock))/REAL(n, KIND=dp) IF (wij > 0.1_dp) THEN ecount(jatom, 1) = ecount(jatom, 1) + 1 - ELSEIF (wij > 0.01_dp) THEN + ELSE IF (wij > 0.01_dp) THEN ecount(jatom, 2) = ecount(jatom, 2) + 1 - ELSEIF (wij > 0.001_dp) THEN + ELSE IF (wij > 0.001_dp) THEN ecount(jatom, 3) = ecount(jatom, 3) + 1 END IF END IF diff --git a/src/minimax/minimax_exp.F b/src/minimax/minimax_exp.F index af4d922b38..2d9554e462 100644 --- a/src/minimax/minimax_exp.F +++ b/src/minimax/minimax_exp.F @@ -142,7 +142,7 @@ CONTAINS CALL get_minimax_coeff_k15(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k15 END IF - ELSEIF (k <= 53) THEN + ELSE IF (k <= 53) THEN CALL get_minimax_coeff_k53(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k53 ELSE diff --git a/src/minimax/minimax_rpa.F b/src/minimax/minimax_rpa.F index 869a85a9e8..9d89e943ed 100644 --- a/src/minimax/minimax_rpa.F +++ b/src/minimax/minimax_rpa.F @@ -155,7 +155,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 2) :: fit_coef - REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = (/8.4569134345088148E-01_dp, & + REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = [8.4569134345088148E-01_dp, & -2.3864746901255809E-01_dp, -1.1361819501552294E-01_dp, 6.7690505100738471E-02_dp, & 5.3985186361341728E-03_dp, -1.9612317325166117E-02_dp, 7.3513074383591715E-03_dp, & 1.9996243815975012E-03_dp, -3.1205386442664557E-03_dp, 6.2573451848435199E-04_dp, & @@ -172,8 +172,8 @@ CONTAINS -3.6844989012010113E-06_dp, -7.8361514387479545E+00_dp, -3.6112788486477720E+00_dp, & 9.5851351388967405E+00_dp, 7.2698001012821694E+00_dp, -1.1403856909523945E+01_dp, & -1.7651082087203267E+01_dp, 3.2669706643838275E+01_dp, -5.4176678145626020E+00_dp, & - -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp/) - REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 2, 2/)) + -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp] + REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE([c01], [13, 2, 2]) INTEGER :: irange @@ -205,7 +205,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 4) :: fit_coef - REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = (/4.9649110596357299E-01_dp, & + REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = [4.9649110596357299E-01_dp, & -1.8397680763708085E-01_dp, -2.6764777836094898E-02_dp, 1.4685597048762128E-02_dp, & 3.8551475599549168E-03_dp, -6.6371384965829621E-04_dp, -8.2857349546675376E-04_dp, & 3.7111617653054724E-05_dp, 1.2814660801267966E-04_dp, 6.1538340479780230E-06_dp, & @@ -257,8 +257,8 @@ CONTAINS -4.9301857791232557E+01_dp, 3.1465928358831281E+00_dp, 7.7404606802819202E+01_dp, & -3.3013072565887242E+01_dp, -1.2019494685884978E+02_dp, 1.5486223363142261E+02_dp, & 3.2337501402758228E+01_dp, -1.8488455295931200E+02_dp, 5.0234562973130487E+01_dp, & - 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp/) - REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 4, 3/)) + 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp] + REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 4, 3]) INTEGER :: irange @@ -295,7 +295,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 6) :: fit_coef - REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = (/4.7223379816403283E-01_dp, & + REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = [4.7223379816403283E-01_dp, & -2.2042504935487547E-01_dp, -1.0700855642800766E-01_dp, 2.9282041797865813E-02_dp, & 3.3026836310057026E-02_dp, 1.1386996102844459E-02_dp, -1.2818345627763791E-02_dp, & -4.0229827105483680E-03_dp, 5.2714678853526230E-03_dp, -5.7896018199156346E-03_dp, & @@ -373,8 +373,8 @@ CONTAINS -1.7804086701584447E+02_dp, 5.3879411878296139E+01_dp, 2.5019726837316304E+02_dp, & -2.4632876610675547E+02_dp, -2.3728096521661567E+02_dp, 7.2832435058031899E+02_dp, & -6.3406381009820018E+02_dp, 7.2166814993792187E+01_dp, 2.2865645970566064E+02_dp, & - -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp/) - REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 6, 3/)) + -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp] + REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 6, 3]) INTEGER :: irange @@ -411,7 +411,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 8) :: fit_coef - REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = (/4.0437679455062153E-01_dp, & + REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = [4.0437679455062153E-01_dp, & -1.9968645981826424E-01_dp, -9.6669556285432015E-02_dp, 2.6839132012201752E-02_dp, & 3.6190132805626725E-02_dp, 4.1166010414531336E-03_dp, -1.0769456290470580E-02_dp, & -8.7529874160434775E-05_dp, 5.7309585756926467E-03_dp, -1.0860752534826048E-02_dp, & @@ -515,8 +515,8 @@ CONTAINS -6.8223088256704716E+02_dp, 3.4708903230411840E+02_dp, 1.0990846081358511E+03_dp, & -1.7164437218305100E+03_dp, -5.1026413431245879E+02_dp, 4.8843366036040652E+03_dp, & -7.6063698448775094E+03_dp, 5.5268501397810141E+03_dp, -6.4043799549226162E+02_dp, & - -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp/) - REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 8, 3/)) + -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp] + REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 8, 3]) INTEGER :: irange @@ -553,7 +553,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 10) :: fit_coef - REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = (/-4.8858613834160547E-01_dp, & + REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = [-4.8858613834160547E-01_dp, & 3.4033685149450971E-01_dp, -1.0142642654121627E-01_dp, 1.8656576613307461E+00_dp, & -2.2611249862234847E-07_dp, -4.2139600757794465E-01_dp, 2.7923611356976985E-01_dp, & 4.7524652113269663E-03_dp, -5.0664309914469052E-01_dp, 9.4151166751519222E-01_dp, & @@ -593,8 +593,8 @@ CONTAINS -2.0215919999407249E+03_dp, 1.3397278899112848E+03_dp, 3.2785602402023524E+03_dp, & -6.7015638377241066E+03_dp, 8.2607523725594240E+02_dp, 1.7011468237133256E+04_dp, & -3.7898634628790373E+04_dp, 4.6113041763967398E+04_dp, -3.4882603781213867E+04_dp, & - 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6550926316288959E-01_dp, & + 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6550926316288959E-01_dp, & -1.4194808279243129E-01_dp, -1.8340243943233556E-02_dp, 1.5594859644926301E-02_dp, & 6.5213609288545414E-03_dp, -7.2580394496045918E-04_dp, -1.4367869259991610E-03_dp, & -5.1441935266499043E-04_dp, 1.1018516863846910E-04_dp, 1.3857094404802231E-04_dp, & @@ -727,9 +727,8 @@ CONTAINS -9.5025460048391619E+02_dp, 1.8084927413816368E+02_dp, 4.5372254459206868E-01_dp, & -3.2706671239427972E-08_dp, -6.0956447616697843E-02_dp, 4.0392497654627497E-02_dp, & -5.9611390145588245E-03_dp, -6.4482812112108656E-02_dp, 1.3285507045769324E-01_dp, & - -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp/) - REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02/), (/13, 10, 4/)) + -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp] + REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 10, 4]) INTEGER :: irange @@ -771,7 +770,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 12) :: fit_coef - REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = (/-2.1886099081761100E-02_dp, & + REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = [-2.1886099081761100E-02_dp, & 1.6493591518278907E-03_dp, 1.1789604920345118E-03_dp, 6.4862232853117350E+00_dp, & -1.7754848782963699E+00_dp, -1.3982954414549702E+00_dp, 8.0870739791892121E-01_dp, & -3.2912209721480506E-01_dp, 6.6541689936850468E-01_dp, -7.1706760669376735E-01_dp, & @@ -846,8 +845,8 @@ CONTAINS 4.8176388108956071E+03_dp, 1.0175276953355078E+04_dp, -2.6714845272387549E+04_dp, & 1.3141868511851815E+04_dp, 5.7600064337445598E+04_dp, -1.7044732018512717E+05_dp, & 2.5361567867653081E+05_dp, -2.3362423558935185E+05_dp, 1.2691185251979054E+05_dp, & - -3.1278542676771558E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.3880318322659616E-01_dp, & + -3.1278542676771558E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.3880318322659616E-01_dp, & -1.3504254699048457E-01_dp, -1.8598173825632135E-02_dp, 1.5951626606880761E-02_dp, & 7.2684956676590529E-03_dp, -5.7141087071240480E-04_dp, -1.5395949213734461E-03_dp, & -7.1572363929054415E-04_dp, 3.6877254806601694E-05_dp, 5.4320682223059976E-06_dp, & @@ -980,9 +979,8 @@ CONTAINS -1.0634490523999061E+02_dp, 2.1350371455168180E+01_dp, 3.4511581153937105E+00_dp, & -4.6074986504725718E-01_dp, -4.1793306232973060E-01_dp, 1.1447565909224683E-01_dp, & -9.1392964448968397E-02_dp, 1.8219557370192899E-01_dp, -1.6634354182093192E-01_dp, & - 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp/) - REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02/), (/13, 12, 4/)) + 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp] + REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 12, 4]) INTEGER :: irange @@ -1024,7 +1022,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 14) :: fit_coef - REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = (/-4.1754731782680632E-02_dp, & + REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = [-4.1754731782680632E-02_dp, & 6.9637423606893978E-03_dp, 9.8317123038661812E-04_dp, 9.3141247748056060E+00_dp, & -3.3034187378384154E+00_dp, -2.3099777024265484E+00_dp, 1.9795050912537626E+00_dp, & -8.5251482053787397E-01_dp, 1.2153039011546896E+00_dp, -1.4541564892554977E+00_dp, & @@ -1133,8 +1131,8 @@ CONTAINS -6.0796509451681840E-03_dp, -1.2729055327721569E+04_dp, 1.1355442435730931E+04_dp, & 1.9420434975201191E+04_dp, -5.7157101053784776E+04_dp, 4.1961441009360387E+04_dp, & 8.2301170473632315E+04_dp, -2.9848869860082364E+05_dp, 4.7636758440468600E+05_dp, & - -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6444089699692058E-01_dp, & + -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6444089699692058E-01_dp, & -1.5470504999202458E-01_dp, -4.6856578935403119E-02_dp, 2.5042624726789489E-02_dp, & 1.9131665599864848E-02_dp, -2.9696778036559586E-03_dp, -3.7556543742271655E-03_dp, & 1.6266657874186815E-04_dp, 4.6360340975112090E-03_dp, -7.8332396642386976E-03_dp, & @@ -1267,9 +1265,8 @@ CONTAINS 1.3457500127744759E-03_dp, 3.1573603989801897E-04_dp, 3.6037055399201039E+00_dp, & -8.0542869559173069E-01_dp, -6.3866068626924610E-01_dp, 3.6581611775536099E-01_dp, & -1.8032325305523136E-01_dp, 3.1726528871551424E-01_dp, -3.4024223010999666E-01_dp, & - 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp/) - REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02/), (/13, 14, 4/)) + 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp] + REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 14, 4]) INTEGER :: irange @@ -1311,7 +1308,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 16) :: fit_coef - REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = (/-8.9013840273255062E+02_dp, & + REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = [-8.9013840273255062E+02_dp, & 4.4450456221108550E+02_dp, 5.3174323393059228E+02_dp, -1.2592882857295644E+03_dp, & 1.0557554278716216E+03_dp, -3.5046238641220043E+02_dp, 1.2930757301899466E+03_dp, & 1.1516939780618657E-03_dp, -1.6608759395740256E+03_dp, 1.4462154462223984E+03_dp, & @@ -1322,8 +1319,8 @@ CONTAINS 1.9619149559132464E+04_dp, 2.5759373028729122E+04_dp, -7.7020575840804217E+04_dp, & 6.3201727988014049E+04_dp, 6.8163632238120859E+04_dp, -2.9053341169350612E+05_dp, & 4.7359098571404989E+05_dp, -4.6694609866564447E+05_dp, 2.7229709401159501E+05_dp, & - -7.2557173401722219E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7310961221813451E-01_dp, & + -7.2557173401722219E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7310961221813451E-01_dp, & -9.5711109831144323E-02_dp, -2.5960297888544426E-02_dp, 7.7258590328211849E-03_dp, & 5.1368496261163018E-03_dp, -1.1234374052788891E-03_dp, -1.0608869644587510E-03_dp, & 4.0213920388401469E-04_dp, 3.0775150301006290E-04_dp, -5.8915574825377335E-05_dp, & @@ -1456,8 +1453,8 @@ CONTAINS -1.6811781491598083E+01_dp, 4.2614301447710945E+00_dp, 4.2182283329260298E+02_dp, & -9.0232374730691106E+02_dp, 7.1913307941971050E+02_dp, 6.5788926678577425E+01_dp, & -5.6847305624230580E+02_dp, 3.2522974861279704E+02_dp, 1.3143394779042333E+02_dp, & - -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.8863592203480596E+02_dp, & + -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.8863592203480596E+02_dp, & 1.0528430973221714E+02_dp, -1.5857007223981109E+01_dp, 1.8276946029107571E+03_dp, & -4.8112032981737193E+03_dp, 6.1258592600600687E+03_dp, -4.0381542724034271E+03_dp, & 3.2440486268768652E+01_dp, 2.9756759864086989E+03_dp, -3.5826087401832801E+03_dp, & @@ -1590,9 +1587,9 @@ CONTAINS 1.4478597281785360E+02_dp, 1.1301880394535623E+01_dp, -1.5313609799645960E+02_dp, & 1.5075591149117258E+02_dp, -5.3325987923237058E+01_dp, 2.9560124699329253E+02_dp, & 1.7113342586626282E-04_dp, -2.4662390250801528E+02_dp, 2.1474962274139023E+02_dp, & - -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp/) + -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp] REAL(KIND=dp), DIMENSION(13, 16, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03/), (/13, 16, 4/)) + coefdata = RESHAPE([c01, c02, c03], [13, 16, 4]) INTEGER :: irange @@ -1634,7 +1631,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 18) :: fit_coef - REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = (/-8.4609670938814907E+02_dp, & + REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = [-8.4609670938814907E+02_dp, & 5.2521889455815938E+02_dp, -1.8158803681882837E+01_dp, -1.9195843056246903E+02_dp, & 4.7038182235191250E+01_dp, 4.4962618821808661E+01_dp, 2.3952550076762327E+03_dp, & 7.3919658606953450E-04_dp, -3.3678854403725500E+03_dp, 2.7630103823335253E+03_dp, & @@ -1679,8 +1676,8 @@ CONTAINS 7.9756724721310873E-03_dp, -3.6633955682749525E+04_dp, 3.0054168139170702E+04_dp, & 3.0244619250697619E+04_dp, -8.9553753522321902E+04_dp, 7.9875735584514681E+04_dp, & 1.7524458945017868E+04_dp, -1.3188240705569120E+05_dp, 1.3592402872600380E+05_dp, & - -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7491556688515650E-01_dp, & + -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7491556688515650E-01_dp, & -1.0138397977284885E-01_dp, -3.9049726894672010E-02_dp, 1.2625689412991524E-02_dp, & 1.2491380414983764E-02_dp, -3.7765616302317911E-03_dp, -5.1175283467075521E-03_dp, & 1.4632298825565039E-03_dp, 3.6642955364173022E-03_dp, -2.0156097072982762E-03_dp, & @@ -1813,8 +1810,8 @@ CONTAINS 2.9781052441439151E-02_dp, -1.4527696704126849E-02_dp, 1.7339641636383043E+01_dp, & -1.1465395481325789E+01_dp, -2.7302697069655961E+00_dp, 4.4629359221611402E+00_dp, & 7.1614646223286882E-01_dp, -1.4605259953560206E+00_dp, -1.0335490616197762E+00_dp, & - 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/8.6574572823904627E-01_dp, & + 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [8.6574572823904627E-01_dp, & -1.6889080712338411E-01_dp, -3.8729713566779244E-03_dp, 4.1076303571384891E+01_dp, & -3.6684994925539350E+01_dp, -3.4268355391161074E+00_dp, 1.6994010089726881E+01_dp, & -1.2988970233372894E+00_dp, -6.3669393876591824E+00_dp, -1.4789915209996456E+00_dp, & @@ -1947,9 +1944,9 @@ CONTAINS 1.3132457381744328E+02_dp, -3.8713782602971918E+01_dp, -3.5040157951924371E+01_dp, & 3.7792017841024283E+01_dp, -1.0016991740016113E+01_dp, 4.5777593919577163E+02_dp, & 8.1637641969554641E-05_dp, -3.6580205008674420E+02_dp, 3.0011032726156765E+02_dp, & - -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp/) + -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp] REAL(KIND=dp), DIMENSION(13, 18, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03/), (/13, 18, 4/)) + coefdata = RESHAPE([c01, c02, c03], [13, 18, 4]) INTEGER :: irange @@ -1991,7 +1988,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 20) :: fit_coef - REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = (/-6.3360994610628929E-01_dp, & + REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = [-6.3360994610628929E-01_dp, & 9.7649518951989356E-01_dp, -1.0559988395317237E+00_dp, 7.8078414899977844E-01_dp, & -3.5500159005989329E-01_dp, 7.4673135592582374E-02_dp, 2.6285615412587124E+00_dp, & 1.5860173767897436E-07_dp, -3.6913389708324101E-01_dp, 3.7465972064134995E-01_dp, & @@ -2071,8 +2068,8 @@ CONTAINS -1.0102666755386532E+05_dp, 1.0253508247597031E+05_dp, 1.0602636418265585E+05_dp, & -4.0728952867028292E+05_dp, 4.6976444940836332E+05_dp, 5.8500781101532266E+04_dp, & -1.2055500949944141E+06_dp, 2.3598896259778733E+06_dp, -2.5585975849316372E+06_dp, & - 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.5561005851553148E-01_dp, & + 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.5561005851553148E-01_dp, & -9.8727639373792656E-02_dp, -3.5824853081321391E-02_dp, 1.3639809429163310E-02_dp, & 1.2140312218587666E-02_dp, -4.6051578600266093E-03_dp, -5.2440292404026837E-03_dp, & 1.6141788048728977E-03_dp, 4.9068438183985687E-03_dp, -3.8643109440260576E-03_dp, & @@ -2205,8 +2202,8 @@ CONTAINS 1.4996446737543528E+02_dp, -3.0374236420884017E+01_dp, 2.5318787052609042E+00_dp, & -4.5232522380132079E-01_dp, -2.4894203765998704E-01_dp, 3.7844517569960621E-02_dp, & 6.7481113092261444E-02_dp, -1.8350883302710324E-03_dp, -3.7893183999051401E-02_dp, & - 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.4867222607997398E-03_dp, & + 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.4867222607997398E-03_dp, & 7.4160230219779905E-03_dp, -1.8338341118192985E-03_dp, 3.6656246502838239E+00_dp, & -1.0862821007061922E+00_dp, -4.7299838594788851E-01_dp, 2.1791529395255307E-01_dp, & 1.6235258776392880E-01_dp, -5.9164629917823931E-02_dp, -1.0182204867540855E-01_dp, & @@ -2339,9 +2336,9 @@ CONTAINS 2.0849621635227758E-01_dp, -2.2855126470711301E-01_dp, 1.7151231132777350E-01_dp, & -7.9338970506037887E-02_dp, 1.7034794798258115E-02_dp, 1.1561315825459209E+00_dp, & 4.6876842564306299E-08_dp, -1.0903099661435091E-01_dp, 1.1066333209885304E-01_dp, & - -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp/) + -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp] REAL(KIND=dp), DIMENSION(13, 20, 4), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03/), (/13, 20, 4/)) + coefdata = RESHAPE([c01, c02, c03], [13, 20, 4]) INTEGER :: irange @@ -2383,7 +2380,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 22) :: fit_coef - REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = (/-2.5319035989384675E+00_dp, & + REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = [-2.5319035989384675E+00_dp, & -3.1868909327109335E-01_dp, 7.3902114944100665E+00_dp, -1.8431274144078589E+01_dp, & 2.9378426424405447E+01_dp, -3.3161724592145767E+01_dp, 2.5816413812770147E+01_dp, & -1.2469330304705172E+01_dp, 2.8128079338690761E+00_dp, 2.4584353206019742E+01_dp, & @@ -2460,8 +2457,8 @@ CONTAINS 2.1221227425035721E+05_dp, 1.9513181165124831E+05_dp, -8.3228931356148690E+05_dp, & 1.0686042433396007E+06_dp, -1.6890882361242565E+05_dp, -2.0275393275062682E+06_dp, & 4.3886071943292571E+06_dp, -4.9464312502375301E+06_dp, 3.1275647455199584E+06_dp, & - -8.7618952854779735E+05_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.9140383852290629E-01_dp, & + -8.7618952854779735E+05_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.9140383852290629E-01_dp, & -6.8714312208041611E-02_dp, -9.1979524758077930E-03_dp, 4.0542016308222793E-03_dp, & 1.3043896673939879E-03_dp, -3.3077626826676678E-04_dp, -1.1713733973944338E-04_dp, & 7.6096932007647678E-05_dp, 1.6862094749663900E-05_dp, -1.8859482112709049E-05_dp, & @@ -2594,8 +2591,8 @@ CONTAINS -3.8649136037865522E-01_dp, 2.2567746326676860E-01_dp, 7.4213954026122252E+01_dp, & -1.4804950267684572E+02_dp, 1.2495507784125873E+02_dp, -2.4776264817547396E+01_dp, & -4.2930419560902017E+01_dp, 2.9472395507465627E+01_dp, 1.0097402469676231E+01_dp, & - -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.4561539999459816E+01_dp, & + -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.4561539999459816E+01_dp, & 4.8544787554718685E+00_dp, -6.3387746031848102E-01_dp, 1.5731981998839461E+02_dp, & -3.7106120150889751E+02_dp, 4.0538316285381757E+02_dp, -1.9862435563464234E+02_dp, & -4.2159595434504858E+01_dp, 1.1123116084380190E+02_dp, -3.2616679588589356E+01_dp, & @@ -2728,8 +2725,8 @@ CONTAINS 2.4122252521897924E+00_dp, -9.7999682646599489E+00_dp, 7.9639626818274714E+00_dp, & -2.9529703827741800E+00_dp, 4.3437020501980872E-01_dp, 1.3418598639315178E+02_dp, & -1.4639064170062176E+02_dp, 7.9688822975923612E+00_dp, 6.9963146941480773E+01_dp, & - -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2105999150585166E+01_dp, & + -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2105999150585166E+01_dp, & -2.2551854693657698E+00_dp, -3.0252257829864192E+01_dp, 3.2690274416605568E+01_dp, & -1.5006475584487145E+01_dp, 2.7494470603903425E+00_dp, 3.4045498207568971E+02_dp, & -4.7133760448357106E+02_dp, 1.1327780050673924E+02_dp, 2.2523014020490135E+02_dp, & @@ -2862,9 +2859,9 @@ CONTAINS -1.1263108188627524E-02_dp, 2.3148160729056904E+00_dp, -5.9940875579716151E+00_dp, & 9.7525037514957766E+00_dp, -1.1202621964616382E+01_dp, 8.8723971586232349E+00_dp, & -4.3615551235670349E+00_dp, 1.0019327026030862E+00_dp, 1.0890417035686898E+01_dp, & - -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp/) + -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp] REAL(KIND=dp), DIMENSION(13, 22, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 22, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04], [13, 22, 5]) INTEGER :: irange @@ -2911,7 +2908,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 24) :: fit_coef - REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = (/-3.4185637511153556E+02_dp, & + REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = [-3.4185637511153556E+02_dp, & 3.0668182445881496E+02_dp, -4.1209664021967029E+02_dp, 3.7330789502174974E+02_dp, & -2.3245333897278655E+02_dp, 1.3019687281058577E+02_dp, -7.4166370900253412E+01_dp, & 3.1434861912054572E+01_dp, -6.1992398402862987E+00_dp, 3.3062345634073872E+03_dp, & @@ -3031,8 +3028,8 @@ CONTAINS -3.7306629896332178E+05_dp, 4.1394566251683736E+05_dp, 3.3744969046701316E+05_dp, & -1.5791948214027057E+06_dp, 2.1917044569001873E+06_dp, -7.9115467427151953E+05_dp, & -3.0601023356753197E+06_dp, 7.4427363873937679E+06_dp, -8.7248223821029570E+06_dp, & - 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8031277973538481E-01_dp, & + 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8031277973538481E-01_dp, & -6.7333985536224536E-02_dp, -8.9222590966419636E-03_dp, 4.3313443199331000E-03_dp, & 1.3612994231258369E-03_dp, -4.2134528860866431E-04_dp, -1.3958926498276367E-04_dp, & 1.0459985085575114E-04_dp, 2.4321788489287324E-05_dp, -2.5628407616984446E-05_dp, & @@ -3165,8 +3162,8 @@ CONTAINS -3.8414425007098330E-01_dp, 7.5502828561301874E-02_dp, 1.5429572442140103E+01_dp, & -1.9205543991334537E+01_dp, 7.1837956925844102E+00_dp, 4.1527008022568523E+00_dp, & -3.9604373888031548E+00_dp, -1.2184620720634423E+00_dp, 2.1268242758491254E+00_dp, & - 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/1.1553671463453488E+00_dp, & + 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [1.1553671463453488E+00_dp, & -7.6780781804979914E-01_dp, 1.7390307652239254E-01_dp, 2.8165264234356147E+01_dp, & -4.2781018965163859E+01_dp, 2.3179056548048951E+01_dp, 5.2439089413556950E+00_dp, & -1.1643001503346785E+01_dp, 4.5770373921564939E-01_dp, 5.5851597940226441E+00_dp, & @@ -3299,8 +3296,8 @@ CONTAINS 1.9287416985295423E-02_dp, -9.7735471490287135E-03_dp, -5.4153420961059818E-03_dp, & 6.2996178645704911E-03_dp, -1.6741808988248179E-03_dp, 3.2323307090443092E+00_dp, & -7.5868899537917556E-01_dp, -3.6403112314198777E-01_dp, 1.3638032105863709E-01_dp, & - 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.5411208403973456E-02_dp, & + 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.5411208403973456E-02_dp, & 5.7808629859203861E-02_dp, -5.0196351778645114E-02_dp, 5.2149034144752344E-03_dp, & 9.5271530622531974E-03_dp, -3.3982153227889275E-03_dp, 5.4948218832066447E+00_dp, & -1.9768544283573861E+00_dp, -7.8540931963005123E-01_dp, 5.1224166160961682E-01_dp, & @@ -3433,9 +3430,9 @@ CONTAINS 8.6197068058446064E+01_dp, -1.1457176948523994E+02_dp, 1.0089516510941472E+02_dp, & -7.0493679332727382E+01_dp, 4.8625058388200841E+01_dp, -2.9732088584351676E+01_dp, & 1.1947228503152537E+01_dp, -2.1840920197937304E+00_dp, 1.0166774272757106E+03_dp, & - -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp/) + -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp] REAL(KIND=dp), DIMENSION(13, 24, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 24, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04], [13, 24, 5]) INTEGER :: irange @@ -3482,7 +3479,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 26) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8838771004380783E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8838771004380783E-01_dp, & -7.8098504554216852E-02_dp, -1.5170263296839995E-02_dp, 8.2399169935392508E-03_dp, & 3.5286892847422469E-03_dp, -1.8215194066877041E-03_dp, -9.0884305814463765E-04_dp, & 6.8756727909990219E-04_dp, 3.7413977081317160E-04_dp, -2.6705465221031334E-04_dp, & @@ -3615,8 +3612,8 @@ CONTAINS -3.7209893008122726E-02_dp, 4.6211560443511707E-03_dp, 4.9425542029764467E+00_dp, & -3.3299793049425701E+00_dp, -1.5240471603939173E-02_dp, 9.6617116551502813E-01_dp, & -5.4487412666999822E-02_dp, -4.4981543663568441E-01_dp, 5.4235895382646740E-02_dp, & - 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/3.5632823078643500E-01_dp, & + 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [3.5632823078643500E-01_dp, & -1.4001776162509430E-01_dp, 2.2286666712875530E-02_dp, 8.7125285885676789E+00_dp, & -7.4679426200738366E+00_dp, 8.3805209926335500E-01_dp, 2.2477163058559704E+00_dp, & -6.0060735276290700E-01_dp, -1.0331040612400506E+00_dp, 3.9698448728282515E-01_dp, & @@ -3749,8 +3746,8 @@ CONTAINS -1.5690448976060742E+00_dp, -1.4469520844727743E+01_dp, 1.5229016181347497E+01_dp, & -6.7413191274813640E+00_dp, 1.1871712862612187E+00_dp, 2.8292219949744720E+02_dp, & -3.3466585644002333E+02_dp, 6.5399374381441106E+01_dp, 1.3547954808764075E+02_dp, & - -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.1951406154569082E+01_dp, & + -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.1951406154569082E+01_dp, & -2.7863833003973856E+01_dp, -2.4615790099798474E+01_dp, 4.4154903132889864E+01_dp, & -2.4321043128719936E+01_dp, 5.0336537486842516E+00_dp, 7.0657858026784504E+02_dp, & -1.0528573743078830E+03_dp, 4.1625512279061735E+02_dp, 3.6427444425345516E+02_dp, & @@ -3883,8 +3880,8 @@ CONTAINS 5.9384272779209310E-02_dp, -6.6034549944533560E-02_dp, 6.3165197301667780E-02_dp, & -5.8533667022985264E-02_dp, 4.7080124186021241E-02_dp, -2.8040678094242519E-02_dp, & 1.0590404330460124E-02_dp, -1.8887168866975497E-03_dp, 3.2950022547352660E+00_dp, & - -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-7.8836509708512373E-02_dp, & + -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-7.8836509708512373E-02_dp, & 1.3178061660818258E-01_dp, -1.4891101086305505E-01_dp, 1.4038052557472530E-01_dp, & -1.2827505792189706E-01_dp, 1.0306674552536969E-01_dp, -6.1520533848826123E-02_dp, & 2.3216931723502306E-02_dp, -4.1222161991565217E-03_dp, 5.6592328962619902E+00_dp, & @@ -4017,8 +4014,8 @@ CONTAINS -1.7064535222921169E+01_dp, 1.9476350353952395E+01_dp, -1.8590436540559089E+01_dp, & 3.1925275522724674E+00_dp, 4.1158324783342913E+01_dp, -1.1921515605115852E+02_dp, & 2.0979218330367425E+02_dp, -2.5985281813994447E+02_dp, 2.2199832068654112E+02_dp, & - -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp/) - REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = (/-2.7907357414271074E-05_dp, & + -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp] + REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = [-2.7907357414271074E-05_dp, & -4.8826106427338516E+01_dp, 5.5726828156877396E+01_dp, -5.0511477178292488E+01_dp, & 2.9783692652581260E+00_dp, 1.2761594545085276E+02_dp, -3.5194583503612256E+02_dp, & 6.0567238480576850E+02_dp, -7.3810346857458831E+02_dp, 6.2201716742048916E+02_dp, & @@ -4048,9 +4045,9 @@ CONTAINS -6.7753046300068102E+05_dp, 7.7323771401862660E+05_dp, 5.5823523395335092E+05_dp, & -2.8474678682125942E+06_dp, 4.1915016169727501E+06_dp, -2.1435582467267131E+06_dp, & -4.2583193954617819E+06_dp, 1.1939190162504816E+07_dp, -1.4588866431316955E+07_dp, & - 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp/) + 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp] REAL(KIND=dp), DIMENSION(13, 26, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 26, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 26, 5]) INTEGER :: irange @@ -4097,7 +4094,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 28) :: fit_coef - REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = (/-4.9474578762585689E-04_dp, & + REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = [-4.9474578762585689E-04_dp, & -2.5939403957639643E+03_dp, 3.0352874416549189E+03_dp, -1.9742442806612846E+03_dp, & -1.5969761709828460E+03_dp, 9.5497831811419619E+03_dp, -2.1791219784053799E+04_dp, & 3.4007167063977518E+04_dp, -3.8426789298450683E+04_dp, 3.0290020612758195E+04_dp, & @@ -4170,8 +4167,8 @@ CONTAINS -2.4363178639415667E-01_dp, -1.2048752475226286E+06_dp, 1.4098050382019044E+06_dp, & 9.0383108002498816E+05_dp, -5.0245780711403918E+06_dp, 7.7751430360333202E+06_dp, & -4.9183263330898508E+06_dp, -5.5122178990547452E+06_dp, 1.8712359903900910E+07_dp, & - -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8855631887642382E-01_dp, & + -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8855631887642382E-01_dp, & -8.1829231046632769E-02_dp, -1.8950903102790816E-02_dp, 1.1349898287774197E-02_dp, & 5.7338935886024562E-03_dp, -3.6475885523936957E-03_dp, -2.1458998142384776E-03_dp, & 1.4787405505064602E-03_dp, 1.8498537181843471E-03_dp, -1.9614757255708645E-03_dp, & @@ -4304,8 +4301,8 @@ CONTAINS 1.1382083100254657E-03_dp, -3.9779179490065093E-04_dp, 1.4924251913695632E+00_dp, & -5.1831019334185813E-01_dp, -1.0671352469554986E-01_dp, 9.3839903685068102E-02_dp, & 3.2490232771881414E-02_dp, -3.4916436688308940E-02_dp, -1.3379509563995902E-02_dp, & - 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/7.7725039723149673E-03_dp, & + 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [7.7725039723149673E-03_dp, & 1.1145706792479703E-04_dp, -5.6097890673260616E-04_dp, 2.6197138414537928E+00_dp, & -1.1878855591113402E+00_dp, -1.3669541461047707E-01_dp, 2.5880924857422194E-01_dp, & 3.9410663226141771E-02_dp, -1.0161291074659663E-01_dp, -1.4845376770825033E-02_dp, & @@ -4438,8 +4435,8 @@ CONTAINS 1.8202124035828973E-01_dp, -2.3777194345333863E-01_dp, 9.8820369139971026E-02_dp, & -6.2744671316908003E-03_dp, -4.3699523495120468E-03_dp, 1.1856221271082283E+01_dp, & -5.2568207235502564E+00_dp, -1.5969164750173954E+00_dp, 1.6461069205315015E+00_dp, & - 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.7852818456494469E-01_dp, & + 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.7852818456494469E-01_dp, & 4.8067555347683755E-01_dp, -7.7452581263261322E-01_dp, 4.1934407249887440E-01_dp, & -8.9234614648328783E-02_dp, 1.6775465007990663E-03_dp, 2.2972132228999541E+01_dp, & -1.2898901071815617E+01_dp, -2.9797860863789967E+00_dp, 4.6560435611069622E+00_dp, & @@ -4572,8 +4569,8 @@ CONTAINS 8.7770738779350062E+00_dp, -1.1095172356986756E+01_dp, 1.0314862293028543E+01_dp, & -8.8233143705921826E+00_dp, 7.0699089843034164E+00_dp, -4.4024286308950149E+00_dp, & 1.7350313146222107E+00_dp, -3.1699935067362639E-01_dp, 1.3246229877703036E+02_dp, & - -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-1.7228109793468004E+01_dp, & + -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-1.7228109793468004E+01_dp, & 2.4108285826088757E+01_dp, -3.1362122687167119E+01_dp, 2.9105748579791722E+01_dp, & -2.4011018345543842E+01_dp, 1.8874442598138845E+01_dp, -1.1844908362658735E+01_dp, & 4.7389221341553531E+00_dp, -8.7620232886140437E-01_dp, 3.1319177678658934E+02_dp, & @@ -4706,9 +4703,9 @@ CONTAINS -6.6016663782193780E+02_dp, 7.7249587755502171E+02_dp, -6.0564642881603584E+02_dp, & -1.6334533603788654E+02_dp, 2.0809169575290675E+03_dp, -5.2520819705711947E+03_dp, & 8.7142803953445527E+03_dp, -1.0381449011333283E+04_dp, 8.6066748064158692E+03_dp, & - -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp/) + -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp] REAL(KIND=dp), DIMENSION(13, 28, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 28, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 28, 5]) INTEGER :: irange @@ -4755,7 +4752,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 30) :: fit_coef - REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = (/-3.0692468631051978E-08_dp, & + REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = [-3.0692468631051978E-08_dp, & -3.9609383383921665E-01_dp, 4.7587580740675417E-01_dp, -5.5706375318965173E-01_dp, & 3.4546263714113901E-01_dp, 5.4776062905207357E-01_dp, -2.4141552540426781E+00_dp, & 4.9577847041515470E+00_dp, -6.8295343742172383E+00_dp, 6.3573367557181761E+00_dp, & @@ -4872,8 +4869,8 @@ CONTAINS 2.5461696440140237E+06_dp, 1.4577959403430095E+06_dp, -8.8776723555507679E+06_dp, & 1.4429270679797074E+07_dp, -1.0764718275979346E+07_dp, -6.0081024069717359E+06_dp, & 2.8423455083762139E+07_dp, -3.8351286309245549E+07_dp, 2.6572649225598279E+07_dp, & - -7.9000536567775914E+06_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8728308171438685E-01_dp, & + -7.9000536567775914E+06_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8728308171438685E-01_dp, & -7.4958225804522882E-02_dp, -1.7654418697317781E-02_dp, 1.0337296188123402E-02_dp, & 5.3074367941912289E-03_dp, -3.4737735619981940E-03_dp, -2.0980081422520588E-03_dp, & 1.3332352270175691E-03_dp, 1.8928638178553657E-03_dp, -2.0371064972525598E-03_dp, & @@ -5006,8 +5003,8 @@ CONTAINS 3.0587066325522777E+01_dp, -9.7246696807779784E+00_dp, 2.3046596783109666E-01_dp, & -5.0266863054748409E-02_dp, -1.7179737588739360E-02_dp, 5.4654515693096711E-03_dp, & 4.7852361622912525E-03_dp, -1.7421101769864551E-03_dp, -1.9440310548800761E-03_dp, & - 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.3785652584517211E-04_dp, & + 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.3785652584517211E-04_dp, & 4.0415260781371566E-04_dp, -1.1566827381466792E-04_dp, 7.4614843698202982E-01_dp, & -1.8831297390879426E-01_dp, -5.5307781300718430E-02_dp, 2.5755321163507486E-02_dp, & 1.6130804272204945E-02_dp, -8.8949071784985307E-03_dp, -6.6594057854666763E-03_dp, & @@ -5140,8 +5137,8 @@ CONTAINS 1.6273475095842586E-03_dp, -8.9025885910407965E-04_dp, -3.6671922956720823E-04_dp, & 4.8507440460371750E-04_dp, -1.3211072877791544E-04_dp, 8.5654480285554591E-01_dp, & -1.1200920153309295E-01_dp, -6.0375651330303620E-02_dp, 1.2480943363126322E-02_dp, & - 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2061351968797813E-03_dp, & + 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2061351968797813E-03_dp, & 7.2651800654771788E-03_dp, -4.9666091131882828E-03_dp, -6.0509045722459322E-04_dp, & 1.7074706793122701E-03_dp, -5.0886032182887841E-04_dp, 1.7258143200373688E+00_dp, & -2.9884323352649256E-01_dp, -1.4775030321223576E-01_dp, 4.7248271588260116E-02_dp, & @@ -5274,8 +5271,8 @@ CONTAINS 2.2562073529423785E-02_dp, -2.5951410486921640E-02_dp, 2.5567379426983138E-02_dp, & -2.4333781051323347E-02_dp, 2.0151995146635144E-02_dp, -1.2400482709093779E-02_dp, & 4.8452373650168124E-03_dp, -8.9294844328912499E-04_dp, 1.8352119311378547E+00_dp, & - -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-3.6931298185134437E-02_dp, & + -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-3.6931298185134437E-02_dp, & 6.2239013775737956E-02_dp, -7.2288174936489244E-02_dp, 7.0693666064322772E-02_dp, & -6.6776211112181863E-02_dp, 5.5274684972707100E-02_dp, -3.4069532004586962E-02_dp, & 1.3318163740503416E-02_dp, -2.4516852040202333E-03_dp, 3.4526910112953169E+00_dp, & @@ -5408,9 +5405,9 @@ CONTAINS -1.5296272228579366E-01_dp, 1.8377288757765206E-01_dp, -2.1880198683428151E-01_dp, & 1.4228504563245828E-01_dp, 1.9523650997654252E-01_dp, -9.0945729598550951E-01_dp, & 1.8916140218456958E+00_dp, -2.6232469600311217E+00_dp, 2.4527671312473118E+00_dp, & - -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp/) + -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp] REAL(KIND=dp), DIMENSION(13, 30, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 30, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 30, 5]) INTEGER :: irange @@ -5457,7 +5454,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 32) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8440983439459679E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8440983439459679E-01_dp, & -7.0479249003300562E-02_dp, -1.6832381157590469E-02_dp, 9.9837323526780937E-03_dp, & 5.1989041899428937E-03_dp, -3.5423416042951205E-03_dp, -2.1543663571483209E-03_dp, & 1.3096125508292179E-03_dp, 2.2049401312140603E-03_dp, -2.5023058617921153E-03_dp, & @@ -5590,8 +5587,8 @@ CONTAINS 9.8497860011119158E+00_dp, -3.3639190612129344E+00_dp, 5.9487274112930379E+02_dp, & -1.7978611801015538E+03_dp, 2.7622843520701335E+03_dp, -2.5880461605405826E+03_dp, & 1.4022414211295804E+03_dp, -2.0359258628022113E+02_dp, -2.6091417556034258E+02_dp, & - 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/2.9539145031653501E+01_dp, & + 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [2.9539145031653501E+01_dp, & 4.7715049407002184E+00_dp, -3.2712144543127324E+00_dp, 2.2264348078485641E+03_dp, & -6.6288008445597088E+03_dp, 1.0084012629385183E+04_dp, -9.4383385665132246E+03_dp, & 5.2647790264708256E+03_dp, -1.0875754774918837E+03_dp, -5.8837187049175338E+02_dp, & @@ -5724,8 +5721,8 @@ CONTAINS -1.7628434198318345E+01_dp, 3.9655688909902926E+02_dp, -3.7408946589251713E+02_dp, & 1.5787812785698458E+02_dp, -2.7089362134634474E+01_dp, 2.0614418378112468E+03_dp, & -5.6578757894510300E+03_dp, 7.1620850676558530E+03_dp, -4.4041308675995369E+03_dp, & - -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.5703600920047631E+02_dp, & + -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.5703600920047631E+02_dp, & 6.8515562434659739E+02_dp, 1.8173876061092901E+02_dp, -5.6990417291447488E+02_dp, & 3.3635689037567329E+02_dp, -7.1542971828322536E+01_dp, 4.8609029109261082E+03_dp, & -1.4519102949367327E+04_dp, 2.1140422991455973E+04_dp, -1.7456530345889521E+04_dp, & @@ -5858,8 +5855,8 @@ CONTAINS -6.5694865280062390E+02_dp, 5.9368339749825054E+02_dp, 7.7692645932202890E+02_dp, & -1.0697937873179803E+03_dp, 3.8548984201540087E+01_dp, 6.7608544747530505E+02_dp, & -4.8167622236142665E+02_dp, 1.1263022376557032E+02_dp, 4.9024755081192952E+03_dp, & - -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-4.7874743699806668E+03_dp, & + -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-4.7874743699806668E+03_dp, & -8.5329386064550408E+02_dp, 2.7526945075798449E+03_dp, 1.9553980517436300E+03_dp, & -5.9289564226732664E+03_dp, 4.4771348003328458E+03_dp, -1.0901273950898408E+03_dp, & -3.0130386512273043E+02_dp, 1.6238769196873562E+02_dp, 1.3563319365162426E+04_dp, & @@ -5992,8 +5989,8 @@ CONTAINS -3.7066724475406403E+02_dp, 4.4339421427221095E+02_dp, -2.5185768559746347E+02_dp, & 3.0387188886435422E+02_dp, -4.1221355071839258E+02_dp, 3.9500349025307065E+02_dp, & -3.1942180687176204E+02_dp, 2.4606495659517455E+02_dp, -1.5690263401286234E+02_dp, & - 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.8663851312283325E+03_dp, & + 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.8663851312283325E+03_dp, & -1.0423380612707174E+03_dp, 1.5483806206375675E+03_dp, -9.0806872083263704E+02_dp, & 9.4017350130709883E+02_dp, -1.2957349086372242E+03_dp, 1.2616460034642841E+03_dp, & -9.6943667338306091E+02_dp, 7.0087846283955878E+02_dp, -4.4162263728305550E+02_dp, & @@ -6126,8 +6123,8 @@ CONTAINS 2.6878483032699012E+02_dp, 5.8309882443897629E+02_dp, 6.7807520171925752E-05_dp, & -3.0064117576976992E+02_dp, 3.6682509804999006E+02_dp, -3.7040717157728307E+02_dp, & 1.3406424149107912E+02_dp, 6.4428398410363116E+02_dp, -2.1519786183493156E+03_dp, & - 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp/) - REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = (/-2.7780629763055545E+03_dp, & + 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp] + REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = [-2.7780629763055545E+03_dp, & 7.2394748688135314E+02_dp, 1.4141872703259592E+03_dp, 1.9924393057961005E-04_dp, & -8.8514298674834572E+02_dp, 1.0799982553752052E+03_dp, -1.0299886964497700E+03_dp, & 2.4613962885626509E+02_dp, 2.1496502911088132E+03_dp, -6.6513723885247055E+03_dp, & @@ -6154,9 +6151,9 @@ CONTAINS 4.3939694879051335E+06_dp, 2.2270474259830317E+06_dp, -1.4748142024036435E+07_dp, & 2.4772021603756029E+07_dp, -2.0427694973111704E+07_dp, -5.1425641553283399E+06_dp, & 4.1035528362137891E+07_dp, -5.8536317653180525E+07_dp, 4.1604269769282125E+07_dp, & - -1.2580153353393231E+07_dp/) + -1.2580153353393231E+07_dp] REAL(KIND=dp), DIMENSION(13, 32, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 32, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 32, 5]) INTEGER :: irange @@ -6203,7 +6200,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 34) :: fit_coef - REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = (/1.8370815219029825E+05_dp, & + REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = [1.8370815219029825E+05_dp, & -2.2571407833669311E+05_dp, 1.9425009817913763E+05_dp, -1.0472915274294355E+05_dp, & 2.6504347685948280E+04_dp, 4.7817002324082285E+04_dp, 2.5450661362359097E-02_dp, & -6.6225824542394374E+04_dp, 8.1048394804074065E+04_dp, -4.3435260565217926E+04_dp, & @@ -6287,8 +6284,8 @@ CONTAINS -5.8978754757524757E+06_dp, 7.2176798918735152E+06_dp, 3.1998615207433747E+06_dp, & -2.2851538821395889E+07_dp, 3.8978847055747673E+07_dp, -3.3766691905692071E+07_dp, & -3.6817494449235639E+06_dp, 5.8417659409558006E+07_dp, -8.7460434017794341E+07_dp, & - 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.3076079314075767E-01_dp, & + 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.3076079314075767E-01_dp, & -3.1204465976027999E-02_dp, -1.7122144125202067E-03_dp, 7.1244719472004776E-04_dp, & 9.7914036643084913E-05_dp, -1.6905608998459976E-05_dp, -7.4913349592830019E-05_dp, & 3.9524844540922514E-04_dp, -1.3207548101866621E-03_dp, 2.4893343556511901E-03_dp, & @@ -6421,8 +6418,8 @@ CONTAINS -7.2938082345320598E-01_dp, 1.1849370069427336E+00_dp, 3.0981138444088945E+01_dp, & -3.2826924199015650E+01_dp, 1.8061271201881183E+01_dp, -5.9402359654032049E+00_dp, & 1.0560336370860732E+00_dp, -1.3076665170325774E-03_dp, -9.1952845171647243E-02_dp, & - 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.2901998665259486E+00_dp, & + 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.2901998665259486E+00_dp, & -1.1234438324718303E+00_dp, 1.8249388295785653E+00_dp, 5.3052663877251987E+01_dp, & -5.6300287553126552E+01_dp, 3.1510803678504963E+01_dp, -1.0839542135686512E+01_dp, & 2.1894315183922908E+00_dp, -1.2602122478496375E-01_dp, -1.3889457312206924E-01_dp, & @@ -6555,8 +6552,8 @@ CONTAINS -2.5103650595979259E+00_dp, 4.0981205243496870E+00_dp, -1.9744886540859123E+00_dp, & 2.7900551212540414E-01_dp, 3.9609099066905094E-02_dp, 4.9480572244963817E+01_dp, & -1.0554295952164991E+02_dp, 9.7784802913758284E+01_dp, -3.3609900633466118E+01_dp, & - -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.8292295875978279E+00_dp, & + -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.8292295875978279E+00_dp, & -2.5859581635928466E+00_dp, 8.2643295812249669E+00_dp, -5.7320634779870945E+00_dp, & 1.7650956249120218E+00_dp, -1.9567508222089966E-01_dp, 7.7834138139689216E+01_dp, & -1.8267266020330240E+02_dp, 1.9349073152056008E+02_dp, -9.1481588588459843E+01_dp, & @@ -6689,8 +6686,8 @@ CONTAINS -2.8967923413102912E+00_dp, 1.3681886836307373E+00_dp, 1.3955776856915574E+00_dp, & -1.5897239290899864E-01_dp, -2.5212216600023445E+00_dp, 2.8219668706971945E+00_dp, & -1.3307700093912902E+00_dp, 2.4913514170866757E-01_dp, 3.6963550418790938E+01_dp, & - -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-6.7963494820353745E+00_dp, & + -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-6.7963494820353745E+00_dp, & -5.2037548606327730E+00_dp, 4.1015955423288375E+00_dp, 2.6719939603737344E+00_dp, & -2.0314435192987417E+00_dp, -3.5279015440942261E+00_dp, 5.3011832033957269E+00_dp, & -2.8122613024625087E+00_dp, 5.6915484145040629E-01_dp, 6.4926664043803811E+01_dp, & @@ -6823,8 +6820,8 @@ CONTAINS -8.6651521700026635E-01_dp, 4.9374292598778025E-01_dp, 3.4952603809371302E-01_dp, & -1.7396151407323862E-01_dp, -2.5934913691469813E-01_dp, 9.2007238929733004E-02_dp, & 3.3903391371774966E-01_dp, -4.2381412446029582E-01_dp, 2.1088118199107522E-01_dp, & - -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.2539604263036663E+00_dp, & + -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.2539604263036663E+00_dp, & -1.7332279212896191E+00_dp, 1.2863899425408518E+00_dp, 7.2978346101421798E-01_dp, & -5.0542068060802536E-01_dp, -5.6453129220842824E-01_dp, 2.6844891959416117E-01_dp, & 8.2065620557106000E-01_dp, -1.1421990003730462E+00_dp, 6.4148861901481036E-01_dp, & @@ -6957,8 +6954,8 @@ CONTAINS 1.8297112165331673E+04_dp, 2.0796368651156318E+00_dp, -7.1211773323306998E-02_dp, & -6.5222594833814318E-02_dp, 2.4758880150403027E-02_dp, -2.6172471480240402E-02_dp, & 4.2607134478414486E-02_dp, -4.9952200375915141E-02_dp, 5.1244059328384543E-02_dp, & - -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/1.0378429926308540E-02_dp, & + -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [1.0378429926308540E-02_dp, & -1.9521878957809889E-03_dp, 2.6944073713370376E+00_dp, -1.3634250253884062E-01_dp, & -1.2248962009310110E-01_dp, 5.1739894797576326E-02_dp, -4.9861795300424228E-02_dp, & 8.1764747263490686E-02_dp, -9.6628896510658951E-02_dp, 9.8409054684497427E-02_dp, & @@ -7091,9 +7088,9 @@ CONTAINS -6.0517025375512349E+04_dp, 5.4074356432769353E+04_dp, -3.0109150792826324E+04_dp, & 7.8344472467430223E+03_dp, 1.3254579477277694E+04_dp, 5.1532479271565908E-03_dp, & -1.3351228791461199E+04_dp, 1.6339623735533780E+04_dp, -1.2301930953556473E+04_dp, & - -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp/) + -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp] REAL(KIND=dp), DIMENSION(13, 34, 6), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07/), (/13, 34, 6/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07], [13, 34, 6]) INTEGER :: irange @@ -7145,7 +7142,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 36) :: fit_coef - REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = (/-4.2209902072425757E+02_dp, & + REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = [-4.2209902072425757E+02_dp, & 1.1367036683435998E+02_dp, 2.4004100563047302E+02_dp, 2.6442809338541683E-05_dp, & -9.2920139462935452E+01_dp, 1.1857226657184384E+02_dp, -1.3712334751086243E+02_dp, & 8.9614212066663356E+01_dp, 1.2954531399327851E+02_dp, -6.1204117014894439E+02_dp, & @@ -7258,8 +7255,8 @@ CONTAINS 2.7482124839381648E+00_dp, -1.0319720350104814E+07_dp, 1.3167559540232308E+07_dp, & 5.3141307787938649E+06_dp, -4.2806172437992170E+07_dp, 7.7700737994820118E+07_dp, & -7.6880123309893116E+07_dp, 1.7343391064140473E+07_dp, 7.7860350009209916E+07_dp, & - -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8104907156518354E-01_dp, & + -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8104907156518354E-01_dp, & -6.1817005353024562E-02_dp, -1.5365071642354823E-02_dp, 9.1489217818269322E-03_dp, & 4.9967787273344161E-03_dp, -3.5367914652488903E-03_dp, -2.2075007488833458E-03_dp, & 1.2029276142200300E-03_dp, 2.8328851353903797E-03_dp, -3.4438772536686739E-03_dp, & @@ -7392,8 +7389,8 @@ CONTAINS 1.0488104966880156E+01_dp, -1.6444555466331974E+00_dp, 1.2763045722861104E+02_dp, & -3.2766564765272250E+02_dp, 3.7973217630740623E+02_dp, -1.9781100978811261E+02_dp, & -3.0157621574998899E+01_dp, 9.3237621383503154E+01_dp, -1.4664555123007290E+01_dp, & - -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-5.0683586321199940E+01_dp, & + -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-5.0683586321199940E+01_dp, & 2.2685614985361322E+01_dp, -4.0911306259362732E+00_dp, 2.0692715444769155E+02_dp, & -5.7784708851700361E+02_dp, 7.5313473849594516E+02_dp, -4.9591356082585395E+02_dp, & 4.6934746915158954E+01_dp, 1.7278593891248715E+02_dp, -7.9461883488471031E+01_dp, & @@ -7526,8 +7523,8 @@ CONTAINS 1.7192575597177209E-01_dp, -1.9796532433429683E+00_dp, 1.9593380309152029E+00_dp, & -8.5836023264597161E-01_dp, 1.5125817632192159E-01_dp, 3.3681131542986975E+01_dp, & -3.4585438137019239E+01_dp, 6.9509291872553263E+00_dp, 9.6987345107099117E+00_dp, & - -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.0123022827718544E+00_dp, & + -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.0123022827718544E+00_dp, & -5.8064769221536761E-01_dp, -3.3561931133425400E+00_dp, 3.9944119179735149E+00_dp, & -1.9296809249289084E+00_dp, 3.6684710023030970E-01_dp, 5.8314392583364203E+01_dp, & -6.9071915064420764E+01_dp, 2.0273316780786242E+01_dp, 1.8091276263426014E+01_dp, & @@ -7660,8 +7657,8 @@ CONTAINS -1.2172815962913154E-02_dp, -4.0308427219634048E-02_dp, 7.7287143244938123E-03_dp, & 4.0019771312533585E-02_dp, -3.7854821497454338E-02_dp, 1.0769335283667015E-02_dp, & 1.9476127553671263E-03_dp, -1.2801087884499606E-03_dp, 3.6694426304025538E+00_dp, & - -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/1.3124621600522313E-01_dp, & + -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [1.3124621600522313E-01_dp, & -4.3574928379419176E-02_dp, -8.9899230702256708E-02_dp, 2.4290637640954200E-02_dp, & 9.8569915866746516E-02_dp, -1.0636170473106374E-01_dp, 4.0918764154109298E-02_dp, & -1.9272580657675622E-03_dp, -1.9052149763963443E-03_dp, 5.9890800326505680E+00_dp, & @@ -7794,8 +7791,8 @@ CONTAINS -1.9257015318780568E+03_dp, 3.2472036360073544E+03_dp, -1.9642544031850207E+03_dp, & 1.8422466462758632E+03_dp, -2.5561629910519391E+03_dp, 2.5895289445906710E+03_dp, & -2.0116564542023402E+03_dp, 1.4283611462124322E+03_dp, -8.9489172870925711E+02_dp, & - 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.4073380941871266E+04_dp, & + 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.4073380941871266E+04_dp, & -5.4884212128021491E+03_dp, 1.3338114839397269E+04_dp, -9.1704389994968824E+03_dp, & 6.9234192947715492E+03_dp, -8.9848495511906458E+03_dp, 9.4904838722939803E+03_dp, & -7.0131996973248588E+03_dp, 4.2053129160131894E+03_dp, -2.2892321189981762E+03_dp, & @@ -7928,9 +7925,9 @@ CONTAINS 4.8018190809835360E+01_dp, 1.1735957000719010E+02_dp, 1.0796734300526574E-05_dp, & -3.7912420090540877E+01_dp, 4.8378813528148328E+01_dp, -5.7435863659353501E+01_dp, & 4.0377808851989506E+01_dp, 4.5658311276489918E+01_dp, -2.3911739347016501E+02_dp, & - 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp/) + 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp] REAL(KIND=dp), DIMENSION(13, 36, 5), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 36, 5/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 36, 5]) INTEGER :: irange @@ -7977,7 +7974,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 38) :: fit_coef - REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = (/1.0499223216920694E+01_dp, & + REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = [1.0499223216920694E+01_dp, & 4.4951728164305678E+00_dp, -4.0844623976889828E+01_dp, 9.6469089733765301E+01_dp, & -1.4457308237433509E+02_dp, 1.4358591897299843E+02_dp, -8.6337055270254567E+01_dp, & 2.3772804326078404E+01_dp, 6.6359118115924133E+01_dp, -2.8591296818375736E-06_dp, & @@ -8032,8 +8029,8 @@ CONTAINS 2.1377543596431356E+07_dp, 7.5558560062402077E+06_dp, -6.6595246625963897E+07_dp, & 1.2300183044218574E+08_dp, -1.2663664724774376E+08_dp, 4.1031313200280927E+07_dp, & 1.0283971430652012E+08_dp, -1.9310895904024291E+08_dp, 1.5058167673706385E+08_dp, & - -4.7897275226966202E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4159553890012480E-01_dp, & + -4.7897275226966202E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4159553890012480E-01_dp, & -3.2212259532342614E-02_dp, -2.5211569112270739E-03_dp, 1.0259263161798598E-03_dp, & 1.7009451604343799E-04_dp, -7.4233588848268952E-05_dp, -1.4091849072407304E-05_dp, & 8.9792205912272354E-06_dp, -6.1068721080120308E-07_dp, 2.3673956901460579E-06_dp, & @@ -8166,8 +8163,8 @@ CONTAINS -9.8650715039269197E-04_dp, 8.4812423349403076E-04_dp, 1.9235334619586016E+01_dp, & -2.1430578544580889E+01_dp, 1.0935348023770239E+01_dp, -2.5703290931021043E+00_dp, & -9.3684439339661404E-02_dp, 1.9608483863631485E-01_dp, -1.2873315513389102E-02_dp, & - -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.1899012855183456E-04_dp, & + -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.1899012855183456E-04_dp, & -1.3697632531141069E-03_dp, 1.2268039489488590E-03_dp, 2.6982367118180953E+01_dp, & -3.2203467268313922E+01_dp, 1.8094671738936693E+01_dp, -5.1291575498824864E+00_dp, & 2.2721945369117036E-01_dp, 3.0848319451415068E-01_dp, -5.4944705448018556E-02_dp, & @@ -8300,8 +8297,8 @@ CONTAINS 3.2103644959620231E-02_dp, -1.4486824002301485E-01_dp, 1.2355203927413878E-01_dp, & -4.8092052541477776E-02_dp, 7.5259001655546970E-03_dp, 4.4383894095260246E+00_dp, & -3.5679718788094252E+00_dp, 5.1476908985660208E-01_dp, 8.0172648142794001E-01_dp, & - -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4079316176694362E-01_dp, & + -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4079316176694362E-01_dp, & 1.0204817722398823E-02_dp, -2.5165636141352937E-01_dp, 2.5091425850523480E-01_dp, & -1.0907652615992168E-01_dp, 1.8995561214566335E-02_dp, 6.6017064494743369E+00_dp, & -6.3396206574849705E+00_dp, 1.4645915581906761E+00_dp, 1.3567138102239846E+00_dp, & @@ -8434,8 +8431,8 @@ CONTAINS 4.7301818737714882E+02_dp, 1.3863635256023798E+02_dp, -2.1631236718932931E+02_dp, & -9.4803921196274686E+01_dp, 2.5426811844807858E+02_dp, -1.6576110763951490E+02_dp, & 4.7407189814529652E+01_dp, -4.5099294020295337E+00_dp, 2.9586882462973167E+03_dp, & - -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-9.1855299569510419E+02_dp, & + -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-9.1855299569510419E+02_dp, & 1.5086598025400613E+03_dp, -1.6982251398122094E+02_dp, -5.5006675710728985E+02_dp, & 8.6766882152744344E+01_dp, 4.7256010495026828E+02_dp, -4.6889366551390941E+02_dp, & 1.9581559031410015E+02_dp, -3.2716661828879559E+01_dp, 6.2548032409521911E+03_dp, & @@ -8568,8 +8565,8 @@ CONTAINS -5.9070868285783193E+00_dp, 7.0462234223485760E+00_dp, 2.3163307108458544E+00_dp, & -3.1353286429629565E+00_dp, -1.8613396596490337E+00_dp, 1.7553943424387961E+00_dp, & 3.1455571650317942E+00_dp, -5.5222826187397756E+00_dp, 3.6478129213769028E+00_dp, & - -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.3207068963149325E+01_dp, & + -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.3207068963149325E+01_dp, & -1.0554104925448858E+01_dp, 1.6886407464491334E+01_dp, 3.8180534827516577E+00_dp, & -7.9351781128404237E+00_dp, -3.3784899123822600E+00_dp, 4.6319521704833901E+00_dp, & 6.7239240450100590E+00_dp, -1.3642372104076109E+01_dp, 9.8589344031369794E+00_dp, & @@ -8702,8 +8699,8 @@ CONTAINS -2.0360724244160395E-04_dp, 7.8600093766184087E-01_dp, -2.7552722482330382E-02_dp, & -2.4320818015224920E-02_dp, 9.3274629486534248E-03_dp, -9.2079352354389778E-03_dp, & 1.5452692636155842E-02_dp, -1.8450575101340298E-02_dp, 1.9063757888167280E-02_dp, & - -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/4.0992188628857576E-03_dp, & + -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [4.0992188628857576E-03_dp, & -7.7827564716362676E-04_dp, 1.5427835617899610E+00_dp, -6.9505394993586406E-02_dp, & -6.0594885888198051E-02_dp, 2.4860739271249380E-02_dp, -2.3168221093078572E-02_dp, & 3.9027511015698728E-02_dp, -4.6867833756562442E-02_dp, 4.8230445510777237E-02_dp, & @@ -8836,8 +8833,8 @@ CONTAINS 5.4224742270029606E+02_dp, -3.5283793388597093E+02_dp, 1.4803941533425319E+02_dp, & -2.8871200173717554E+01_dp, 5.6772385530114016E+03_dp, -2.9062895360890998E+03_dp, & -1.7148517487548181E+03_dp, 2.2947989851698503E+03_dp, -1.3525758366401831E+03_dp, & - 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-1.8635835707916260E+03_dp, & + 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-1.8635835707916260E+03_dp, & 1.4615094004676805E+03_dp, -9.4860776301801513E+02_dp, 4.0324630910185732E+02_dp, & -7.9802696400978931E+01_dp, 1.4580340019039370E+04_dp, -8.9648221759975659E+03_dp, & -4.7160531127075310E+03_dp, 7.7970756952852253E+03_dp, -4.7953125668139064E+03_dp, & @@ -8970,9 +8967,9 @@ CONTAINS 1.6548760224475922E+00_dp, -1.7934154017551453E+01_dp, 4.3051248399276048E+01_dp, & -6.4961623842017133E+01_dp, 6.4774151275958900E+01_dp, -3.9049982184732009E+01_dp, & 1.0772159604979572E+01_dp, 3.5239797671962883E+01_dp, -1.2791831843911305E-06_dp, & - -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp/) + -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp] REAL(KIND=dp), DIMENSION(13, 38, 6), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 38, 6/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 38, 6]) INTEGER :: irange @@ -9024,7 +9021,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 40) :: fit_coef - REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = (/3.4482542694423209E+03_dp, & + REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = [3.4482542694423209E+03_dp, & 9.3380638606834109E+03_dp, -3.6141948437832449E+04_dp, 7.3811576243227406E+04_dp, & -1.0360614380245237E+05_dp, 9.9273882530972987E+04_dp, -5.8503038150581720E+04_dp, & 1.5941507970166829E+04_dp, 1.9245609411100908E+04_dp, 1.5758311389454111E-03_dp, & @@ -9131,8 +9128,8 @@ CONTAINS 3.4369174208174527E+07_dp, 1.0603207649981629E+07_dp, -1.0297545596222048E+08_dp, & 1.9337680822524059E+08_dp, -2.0606965563558266E+08_dp, 8.3351497204227954E+07_dp, & 1.3400532965008634E+08_dp, -2.7949474181137478E+08_dp, 2.2551932538988832E+08_dp, & - -7.3358489823807165E+07_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4818427186393188E-01_dp, & + -7.3358489823807165E+07_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4818427186393188E-01_dp, & -3.9684125490741781E-02_dp, -4.5544691512272280E-03_dp, 2.2868531356116861E-03_dp, & 5.4988095348367525E-04_dp, -3.2090841260734175E-04_dp, -9.2010045248866118E-05_dp, & 6.1214638366653809E-05_dp, 2.2665438652455234E-05_dp, -1.8900573386763588E-05_dp, & @@ -9265,8 +9262,8 @@ CONTAINS -5.9740661993351847E-03_dp, 1.4691884865455198E-03_dp, 1.7073926981017319E+01_dp, & -2.1963630226832553E+01_dp, 1.2134829552891802E+01_dp, -2.2528424944623944E+00_dp, & -9.3240764730384440E-01_dp, 4.6660358949448766E-01_dp, 1.0216844176487623E-01_dp, & - -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/5.9915911031709962E-03_dp, & + -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [5.9915911031709962E-03_dp, & -8.6423694074923528E-03_dp, 2.4291300518560965E-03_dp, 2.4071366084770816E+01_dp, & -3.3716515170389293E+01_dp, 2.0906788438349480E+01_dp, -5.2492585742829574E+00_dp, & -1.0597221453010373E+00_dp, 9.1826115756590143E-01_dp, 5.3116568030487622E-02_dp, & @@ -9399,8 +9396,8 @@ CONTAINS 1.2466570600707088E-02_dp, -1.3874197741980808E-02_dp, 4.1907856070478042E-03_dp, & 7.5271368574731106E-04_dp, -5.1647877466666774E-04_dp, 1.7444005611942730E+00_dp, & -5.6824316669549102E-01_dp, -9.5567270387908632E-02_dp, 9.5953975937291464E-02_dp, & - 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4012464467116794E-02_dp, & + 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4012464467116794E-02_dp, & 1.7870937744543961E-02_dp, -2.8284778305657239E-02_dp, 1.4614940139686226E-02_dp, & -2.7014027690474133E-03_dp, -7.8952988099918739E-05_dp, 2.2522270551584125E+00_dp, & -9.9237513069804251E-01_dp, -7.1665511461607434E-02_dp, 1.9968203248776958E-01_dp, & @@ -9533,8 +9530,8 @@ CONTAINS -1.7263628579210469E+01_dp, 1.2547672408466081E+01_dp, 8.4591865266308197E+00_dp, & -5.6249151706448863E+00_dp, -1.1592672327907211E+01_dp, 1.6508808139297699E+01_dp, & -8.5771693846067460E+00_dp, 1.7125060439946929E+00_dp, 2.3966601282404417E+02_dp, & - -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-5.7499561390798192E+01_dp, & + -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-5.7499561390798192E+01_dp, & -2.8667295698939792E+01_dp, 3.3623712254987076E+01_dp, 1.4613232172192909E+01_dp, & -2.2425748408516260E+01_dp, -1.0625183610714041E+01_dp, 2.7811282349984850E+01_dp, & -1.6721270864181005E+01_dp, 3.6190172602275243E+00_dp, 4.3864077011236401E+02_dp, & @@ -9667,8 +9664,8 @@ CONTAINS -7.3049415971812165E-02_dp, 1.6928103093679515E-02_dp, 1.8417725387954376E-02_dp, & -1.9453592218161570E-03_dp, -1.1634328023640639E-02_dp, 3.4714019819061617E-03_dp, & 5.3490931351907831E-03_dp, -3.1907950343243647E-03_dp, -1.4616713023815479E-03_dp, & - 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-3.2389785098025670E-01_dp, & + 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-3.2389785098025670E-01_dp, & -1.5588421416935677E-01_dp, 4.6469218783312088E-02_dp, 4.1557942308222309E-02_dp, & -7.5142092188104671E-03_dp, -2.6806031107589168E-02_dp, 9.2275566818059377E-03_dp, & 1.3149892067901462E-02_dp, -9.4462212865469193E-03_dp, -1.9880182010796601E-03_dp, & @@ -9801,8 +9798,8 @@ CONTAINS 1.1110268324191310E+01_dp, 2.6853251507125306E+03_dp, -2.6690269182691513E+03_dp, & 7.2463711925762794E+01_dp, 1.2014230806845137E+03_dp, -2.9322356189139873E+02_dp, & -4.8871486180307096E+02_dp, 8.0189444854946785E+01_dp, 3.5253998447998373E+02_dp, & - -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/-2.2712994716763473E+02_dp, & + -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [-2.2712994716763473E+02_dp, & 4.0385181038065113E+01_dp, 6.0197819306524152E+03_dp, -6.9664015206915119E+03_dp, & 8.8000828312450119E+02_dp, 3.2181044508507798E+03_dp, -1.3451011011345620E+03_dp, & -1.2427951210535916E+03_dp, 5.4994829125785282E+02_dp, 9.7855377199584927E+02_dp, & @@ -9935,8 +9932,8 @@ CONTAINS 1.6768202331832444E-01_dp, -1.0515504828494937E-01_dp, 4.2563447502959498E-02_dp, & -8.2219895159869709E-03_dp, 9.5923398264069970E+00_dp, -9.1351432511338171E-01_dp, & -7.2002060302993121E-01_dp, 3.4478262562537942E-01_dp, -2.6236445928893765E-01_dp, & - 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp/) - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-4.3224032563729953E-01_dp, & + 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp] + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-4.3224032563729953E-01_dp, & 3.5758483946236974E-01_dp, -2.2431923396808751E-01_dp, 9.0777959192790053E-02_dp, & -1.7518061809443625E-02_dp, 1.6725498665042689E+01_dp, -1.9435939058523524E+00_dp, & -1.5082483802542699E+00_dp, 7.7123067496772879E-01_dp, -5.6050187357065773E-01_dp, & @@ -10069,9 +10066,9 @@ CONTAINS 2.5970516090366850E+03_dp, -1.1583854023864891E+04_dp, 2.4553873694398699E+04_dp, & -3.5160886963347439E+04_dp, 3.4138635891960170E+04_dp, -2.0309554368209294E+04_dp, & 5.5733463618645619E+03_dp, 7.3092031064017010E+03_dp, 4.9005183646288716E-04_dp, & - -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp/) + -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp] REAL(KIND=dp), DIMENSION(13, 40, 6), PARAMETER :: & - coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 40, 6/)) + coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 40, 6]) INTEGER :: irange @@ -10166,7 +10163,7 @@ CONTAINS E_ratio = 1.0_dp END IF aw(:) = aw(:)/E_ratio - END SUBROUTINE + END SUBROUTINE rescale_grid ! ************************************************************************************************** !> \brief ... @@ -10184,7 +10181,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 799.0_dp) THEN E_ratio = 799.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13642311899920728_dp, & 0.4200545572769177_dp, & 0.7370807753440111_dp, & @@ -10236,9 +10233,9 @@ CONTAINS 175.19453971323657_dp, & 301.19411259128674_dp, & 645.6383267719649_dp, & - 2472.504957810595_dp/) + 2472.504957810595_dp] ELSE IF (E_range < 995.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13925292153649474_dp, & 0.4292451559612877_dp, & 0.7548554587233549_dp, & @@ -10290,9 +10287,9 @@ CONTAINS 211.68822580031673_dp, & 364.5832859080767_dp, & 780.7919711700442_dp, & - 2983.4784258039044_dp/) + 2983.4784258039044_dp] ELSE IF (E_range < 1293.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14255313239112444_dp, & 0.44000221057671707_dp, & 0.7757923584694003_dp, & @@ -10344,9 +10341,9 @@ CONTAINS 265.33605383413214_dp, & 458.1910477032067_dp, & 980.4158381921823_dp, & - 3736.258588894085_dp/) + 3736.258588894085_dp] ELSE IF (E_range < 1738.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1461752355773306_dp, & 0.45185762356828396_dp, & 0.7990360544025357_dp, & @@ -10398,9 +10395,9 @@ CONTAINS 342.31559687568875_dp, & 593.3221880856304_dp, & 1268.7961696472178_dp, & - 4820.528614472729_dp/) + 4820.528614472729_dp] ELSE IF (E_range < 2238.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1491837006061548_dp, & 0.46174475862674996_dp, & 0.8185592742668346_dp, & @@ -10452,9 +10449,9 @@ CONTAINS 425.4335136047249_dp, & 740.2128400786926_dp, & 1582.657563073928_dp, & - 5997.255668095278_dp/) + 5997.255668095278_dp] ELSE IF (E_range < 3009.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15260234927102537_dp, & 0.47302539641929003_dp, & 0.840991102837249_dp, & @@ -10506,9 +10503,9 @@ CONTAINS 548.3643432689413_dp, & 959.1555990081102_dp, & 2051.35284281865_dp, & - 7749.544195896773_dp/) + 7749.544195896773_dp] ELSE IF (E_range < 4377.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15677016271388225_dp, & 0.4868453590049744_dp, & 0.8687054372436632_dp, & @@ -10560,9 +10557,9 @@ CONTAINS 755.1838770980437_dp, & 1331.5355795873638_dp, & 2851.124163900499_dp, & - 10729.678598478598_dp/) + 10729.678598478598_dp] ELSE IF (E_range < 6256.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16057542542593983_dp, & 0.49952962028824754_dp, & 0.8943731123892699_dp, & @@ -10614,9 +10611,9 @@ CONTAINS 1022.6891506041642_dp, & 1819.6861630933722_dp, & 3904.600906393468_dp, & - 14642.034530501202_dp/) + 14642.034530501202_dp] ELSE IF (E_range < 9034.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16432089011213946_dp, & 0.5120783448939726_dp, & 0.9199886972681118_dp, & @@ -10668,9 +10665,9 @@ CONTAINS 1393.996082618058_dp, & 2507.6502273684464_dp, & 5398.730047404666_dp, & - 20174.243482162154_dp/) + 20174.243482162154_dp] ELSE IF (E_range < 15564.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16955168876185606_dp, & 0.5297128492681893_dp, & 0.9563682595025127_dp, & @@ -10722,9 +10719,9 @@ CONTAINS 2193.7537015644107_dp, & 4023.287609783773_dp, & 8726.293698066565_dp, & - 32456.229019326278_dp/) + 32456.229019326278_dp] ELSE IF (E_range < 19500.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17161078656390408_dp, & 0.5366905364814994_dp, & 0.97088881076514_dp, & @@ -10776,9 +10773,9 @@ CONTAINS 2641.8070030495096_dp, & 4889.503800534578_dp, & 10648.322208945656_dp, & - 39537.49857015622_dp/) + 39537.49857015622_dp] ELSE IF (E_range < 22300.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1728061198835349_dp, & 0.5407506981101403_dp, & 0.9793714038026303_dp, & @@ -10830,9 +10827,9 @@ CONTAINS 2948.8741403686568_dp, & 5489.390378606207_dp, & 11987.379922744534_dp, & - 44468.08958434164_dp/) + 44468.08958434164_dp] ELSE IF (E_range < 24783.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1737308948597355_dp, & 0.5438966877521114_dp, & 0.9859610380912929_dp, & @@ -10884,9 +10881,9 @@ CONTAINS 3214.1964330189876_dp, & 6011.5393853613305_dp, & 13158.00196550311_dp, & - 48777.36298097777_dp/) + 48777.36298097777_dp] ELSE IF (E_range < 41198.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17799130240706984_dp, & 0.558445410809649_dp, & 1.0166297309491044_dp, & @@ -10938,9 +10935,9 @@ CONTAINS 4842.950527196566_dp, & 9285.588160319077_dp, & 20597.325965171356_dp, & - 76161.8596274348_dp/) + 76161.8596274348_dp] ELSE IF (E_range < 94407.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18427327646299554_dp, & 0.5800678142111884_dp, & 1.062813174396542_dp, & @@ -10992,9 +10989,9 @@ CONTAINS 9266.732583950343_dp, & 18647.213606093355_dp, & 42656.46566405554_dp, & - 157660.6216097217_dp/) + 157660.6216097217_dp] ELSE IF (E_range < 189080.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1889166187549335_dp, & 0.5961850834729495_dp, & 1.097718788260886_dp, & @@ -11046,9 +11043,9 @@ CONTAINS 15593.849284273198_dp, & 32917.0364973997_dp, & 78051.06376348506_dp, & - 289942.76429117593_dp/) + 289942.76429117593_dp] ELSE IF (E_range < 457444.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.194043824675455_dp, & 0.6141201650984125_dp, & 1.137056339966442_dp, & @@ -11100,9 +11097,9 @@ CONTAINS 29125.998944110084_dp, & 65928.95446339808_dp, & 166172.86831676983_dp, & - 628359.6031461136_dp/) + 628359.6031461136_dp] ELSE IF (E_range < 2101965.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.20097761439605452_dp, & 0.6386142361636943_dp, & 1.1916436123207983_dp, & @@ -11154,9 +11151,9 @@ CONTAINS 75639.29476513214_dp, & 196582.0757874882_dp, & 575257.5915715584_dp, & - 2362446.5347060743_dp/) + 2362446.5347060743_dp] ELSE IF (E_range < 14140999.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.20658002404396444_dp, & 0.6586140986839257_dp, & 1.2369737792708104_dp, & @@ -11208,9 +11205,9 @@ CONTAINS 186203.45469776812_dp, & 576894.7309753906_dp, & 2152261.8479348915_dp, & - 11566361.80487531_dp/) + 11566361.80487531_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.20878089337233605_dp, & 0.6665236543193817_dp, & 1.2550931614146674_dp, & @@ -11262,9 +11259,9 @@ CONTAINS 277390.3096379278_dp, & 946568.3924295901_dp, & 4140822.150621181_dp, & - 30376446.323901277_dp/) + 30376446.323901277_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_26 ! ************************************************************************************************** !> \brief ... @@ -11282,7 +11279,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 1545.0_dp) THEN E_ratio = 1545.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13575757270404953_dp, & 0.4178973639556045_dp, & 0.7329236428021971_dp, & @@ -11338,9 +11335,9 @@ CONTAINS 333.52874619054023_dp, & 573.9031161499247_dp, & 1229.5973040920514_dp, & - 4703.444164101694_dp/) + 4703.444164101694_dp] ELSE IF (E_range < 2002.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13875490228933057_dp, & 0.4276255171652803_dp, & 0.7517156037290086_dp, & @@ -11396,9 +11393,9 @@ CONTAINS 417.7474719630637_dp, & 720.4456660885186_dp, & 1542.1360738637661_dp, & - 5884.200372654236_dp/) + 5884.200372654236_dp] ELSE IF (E_range < 2600.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14170133198228974_dp, & 0.4372217263238123_dp, & 0.7703667410153948_dp, & @@ -11454,9 +11451,9 @@ CONTAINS 524.1575321727823_dp, & 906.5045080905089_dp, & 1939.0883159241562_dp, & - 7379.912745615771_dp/) + 7379.912745615771_dp] ELSE IF (E_range < 3300.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1443213439813841_dp, & 0.4457831750819166_dp, & 0.7871040955754438_dp, & @@ -11512,9 +11509,9 @@ CONTAINS 644.5187891323013_dp, & 1118.0760747835973_dp, & 2390.794104288915_dp, & - 9077.664025334678_dp/) + 9077.664025334678_dp] ELSE IF (E_range < 4000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14638817647917096_dp, & 0.4525562304919969_dp, & 0.8004113661058508_dp, & @@ -11570,9 +11567,9 @@ CONTAINS 761.3056079394062_dp, & 1324.411398249371_dp, & 2831.738972704671_dp, & - 10731.431828374814_dp/) + 10731.431828374814_dp] ELSE IF (E_range < 5000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14873276811274175_dp, & 0.4602604435552678_dp, & 0.8156202251610892_dp, & @@ -11628,9 +11625,9 @@ CONTAINS 923.1971063861915_dp, & 1612.0060664213056_dp, & 3447.1144071775916_dp, & - 13034.665823606138_dp/) + 13034.665823606138_dp] ELSE IF (E_range < 5800.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1502608626762777_dp, & 0.46529381929136415_dp, & 0.8255984287192656_dp, & @@ -11686,9 +11683,9 @@ CONTAINS 1049.2452864243335_dp, & 1837.0994387864066_dp, & 3929.4241467171732_dp, & - 14836.654624922767_dp/) + 14836.654624922767_dp] ELSE IF (E_range < 7000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15216067096721872_dp, & 0.471565223326128_dp, & 0.8380780093696487_dp, & @@ -11744,9 +11741,9 @@ CONTAINS 1233.5478315642981_dp, & 2167.935258865102_dp, & 4639.411026254049_dp, & - 17485.041970829057_dp/) + 17485.041970829057_dp] ELSE IF (E_range < 8500.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1540799216139811_dp, & 0.47791627634651673_dp, & 0.850769563354445_dp, & @@ -11802,9 +11799,9 @@ CONTAINS 1457.1994566202313_dp, & 2571.939694554795_dp, & 5508.2172091289185_dp, & - 20720.162172438253_dp/) + 20720.162172438253_dp] ELSE IF (E_range < 11000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15656226451877622_dp, & 0.4861541997731515_dp, & 0.8673131850431656_dp, & @@ -11860,9 +11857,9 @@ CONTAINS 1816.6489638049509_dp, & 3226.5521973584873_dp, & 6920.118346610322_dp, & - 25967.01374573565_dp/) + 25967.01374573565_dp] ELSE IF (E_range < 14000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15881564616129193_dp, & 0.4936556598653273_dp, & 0.8824588841815081_dp, & @@ -11918,9 +11915,9 @@ CONTAINS 2230.6304097502575_dp, & 3987.780431784136_dp, & 8568.294988757902_dp, & - 32079.26783423429_dp/) + 32079.26783423429_dp] ELSE IF (E_range < 18000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1610939781339949_dp, & 0.5012631407780889_dp, & 0.8978984268667602_dp, & @@ -11976,9 +11973,9 @@ CONTAINS 2759.7196504068343_dp, & 4970.842422998521_dp, & 10706.437123051388_dp, & - 39993.678157447954_dp/) + 39993.678157447954_dp] ELSE IF (E_range < 22000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16286202517738316_dp, & 0.5071829401058993_dp, & 0.9099691167949224_dp, & @@ -12034,9 +12031,9 @@ CONTAINS 3268.0690080523195_dp, & 5925.0502577809875_dp, & 12791.74491637296_dp, & - 47700.6553314684_dp/) + 47700.6553314684_dp] ELSE IF (E_range < 30000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16550588765942553_dp, & 0.516062009336416_dp, & 0.9281674926129342_dp, & @@ -12092,9 +12089,9 @@ CONTAINS 4236.78509184323_dp, & 7766.730019457065_dp, & 16842.450828736164_dp, & - 62648.76273159001_dp/) + 62648.76273159001_dp] ELSE IF (E_range < 40000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1678624984386396_dp, & 0.5240039277065677_dp, & 0.9445413343768262_dp, & @@ -12150,9 +12147,9 @@ CONTAINS 5379.192173747507_dp, & 9973.306180469173_dp, & 21737.4521360814_dp, & - 80688.08263620315_dp/) + 80688.08263620315_dp] ELSE IF (E_range < 55000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17036496307430077_dp, & 0.5324663182632273_dp, & 0.9620895318113227_dp, & @@ -12208,9 +12205,9 @@ CONTAINS 6988.303443289154_dp, & 13136.528535241805_dp, & 28826.90535778617_dp, & - 106792.5668680263_dp/) + 106792.5668680263_dp] ELSE IF (E_range < 75000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17269556592412857_dp, & 0.5403748964029321_dp, & 0.9785852679690707_dp, & @@ -12266,9 +12263,9 @@ CONTAINS 8991.001468037319_dp, & 17151.64888313862_dp, & 37936.68288424044_dp, & - 140330.3757792011_dp/) + 140330.3757792011_dp] ELSE IF (E_range < 100000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17476493191141415_dp, & 0.5474193940515534_dp, & 0.9933573948794411_dp, & @@ -12324,9 +12321,9 @@ CONTAINS 11326.739601304256_dp, & 21929.575378095506_dp, & 48923.087093047834_dp, & - 180801.94440922138_dp/) + 180801.94440922138_dp] ELSE IF (E_range < 140000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17707349703529857_dp, & 0.5553034658173043_dp, & 1.0099791730991756_dp, & @@ -12382,9 +12379,9 @@ CONTAINS 14783.538737749648_dp, & 29163.479733223845_dp, & 65827.4645722146_dp, & - 243179.26518144744_dp/) + 243179.26518144744_dp] ELSE IF (E_range < 200000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17939121623291196_dp, & 0.5632460962554191_dp, & 1.0268207360191903_dp, & @@ -12440,9 +12437,9 @@ CONTAINS 19511.673781213012_dp, & 39328.72129742758_dp, & 90071.79118231079_dp, & - 332938.41349157074_dp/) + 332938.41349157074_dp] ELSE IF (E_range < 280000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18145787532761345_dp, & 0.5703516980411364_dp, & 1.041969987100468_dp, & @@ -12498,9 +12495,9 @@ CONTAINS 25223.35236302233_dp, & 51966.7592745666_dp, & 120920.32428947231_dp, & - 447736.17541344964_dp/) + 447736.17541344964_dp] ELSE IF (E_range < 400000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18352365749998711_dp, & 0.5774767415391759_dp, & 1.0572402465072317_dp, & @@ -12556,9 +12553,9 @@ CONTAINS 32921.61554906603_dp, & 69533.14758216766_dp, & 164947.39394785516_dp, & - 612800.2731138045_dp/) + 612800.2731138045_dp] ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1865127174002091_dp, & 0.5878264119237888_dp, & 1.0795642254870847_dp, & @@ -12614,9 +12611,9 @@ CONTAINS 49336.106221828624_dp, & 108694.3328979675_dp, & 267237.7291173849_dp, & - 1002021.1700926761_dp/) + 1002021.1700926761_dp] ELSE IF (E_range < 1200000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18910898992309827_dp, & 0.5968553778314455_dp, & 1.099179600396227_dp, & @@ -12672,9 +12669,9 @@ CONTAINS 71590.44785506214_dp, & 164831.2803483035_dp, & 422312.83970923733_dp, & - 1607194.846517409_dp/) + 1607194.846517409_dp] ELSE IF (E_range < 2000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19132297837375925_dp, & 0.6045842212401715_dp, & 1.116075239909931_dp, & @@ -12730,9 +12727,9 @@ CONTAINS 100098.51304747425_dp, & 240936.64519318528_dp, & 645993.0255202315_dp, & - 2511145.760363479_dp/) + 2511145.760363479_dp] ELSE IF (E_range < 4500000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19436594608582472_dp, & 0.6152519388154075_dp, & 1.1395565637382394_dp, & @@ -12788,9 +12785,9 @@ CONTAINS 163720.9776403595_dp, & 424479.54068993696_dp, & 1238540.16298379_dp, & - 5075528.538071685_dp/) + 5075528.538071685_dp] ELSE IF (E_range < 10000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19682681061058516_dp, & 0.6239175967168831_dp, & 1.1587697829037367_dp, & @@ -12846,9 +12843,9 @@ CONTAINS 251532.47511127745_dp, & 702946.2892638468_dp, & 2257925.6950304266_dp, & - 10050972.42119658_dp/) + 10050972.42119658_dp] ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.20028753559878754_dp, & 0.636163845466183_dp, & 1.1861370761903154_dp, & @@ -12904,9 +12901,9 @@ CONTAINS 488713.1004068534_dp, & 1569108.161138_dp, & 6194788.779558858_dp, & - 36612022.104547605_dp/) + 36612022.104547605_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.20148359962188625_dp, & 0.6404126846191118_dp, & 1.1956914499421463_dp, & @@ -12962,9 +12959,9 @@ CONTAINS 627349.5338890508_dp, & 2140772.611660053_dp, & 9364952.860952146_dp, & - 68700022.28914484_dp/) + 68700022.28914484_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_28 ! ************************************************************************************************** !> \brief ... @@ -12983,7 +12980,7 @@ CONTAINS IF (E_range < 2906.0_dp) THEN E_ratio = 2906.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13472077973006066_dp, & 0.41454012407362284_dp, & 0.7264650127115554_dp, & @@ -13043,9 +13040,9 @@ CONTAINS 619.9912456625073_dp, & 1067.5959324975324_dp, & 2286.544806677275_dp, & - 8738.901002766614_dp/) + 8738.901002766614_dp] ELSE IF (E_range < 3236.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13585569926755156_dp, & 0.41821529920891193_dp, & 0.7335359382994969_dp, & @@ -13105,9 +13102,9 @@ CONTAINS 681.1401603164769_dp, & 1173.9561106510982_dp, & 2513.427330670278_dp, & - 9596.45252078042_dp/) + 9596.45252078042_dp] ELSE IF (E_range < 3810.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1375558839742156_dp, & 0.4237299246561157_dp, & 0.7441765936480988_dp, & @@ -13167,9 +13164,9 @@ CONTAINS 785.6426382482606_dp, & 1356.1465778665718_dp, & 2902.1064912290262_dp, & - 11063.595563099649_dp/) + 11063.595563099649_dp] ELSE IF (E_range < 4405.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13904406912216055_dp, & 0.4285658262322887_dp, & 0.7535381269110286_dp, & @@ -13229,9 +13226,9 @@ CONTAINS 891.8325474154066_dp, & 1541.8004917177743_dp, & 3298.2637895129933_dp, & - 12556.72637834854_dp/) + 12556.72637834854_dp] ELSE IF (E_range < 5400.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1410960680209205_dp, & 0.43524771510986004_dp, & 0.7665207024486466_dp, & @@ -13291,9 +13288,9 @@ CONTAINS 1065.3146704916662_dp, & 1846.16967438266_dp, & 3948.0236905716197_dp, & - 15001.510222225108_dp/) + 15001.510222225108_dp] ELSE IF (E_range < 6800.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1433674220737173_dp, & 0.4426628898148459_dp, & 0.7809932553639084_dp, & @@ -13353,9 +13350,9 @@ CONTAINS 1302.3421015152915_dp, & 2264.016465253404_dp, & 4840.7455216590715_dp, & - 18353.395351716823_dp/) + 18353.395351716823_dp] ELSE IF (E_range < 8400.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14540131106958792_dp, & 0.4493201231807535_dp, & 0.7940459513320671_dp, & @@ -13415,9 +13412,9 @@ CONTAINS 1565.1330028308446_dp, & 2729.7495636084445_dp, & 5836.893913938098_dp, & - 22085.748007810864_dp/) + 22085.748007810864_dp] ELSE IF (E_range < 10000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14704498509396693_dp, & 0.4547122051327194_dp, & 0.8046596707087634_dp, & @@ -13477,9 +13474,9 @@ CONTAINS 1820.9007070932764_dp, & 3185.3327939434785_dp, & 6812.567149441103_dp, & - 25734.79348292465_dp/) + 25734.79348292465_dp] ELSE IF (E_range < 12000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14873028953425532_dp, & 0.46025228447257244_dp, & 0.815604068464183_dp, & @@ -13539,9 +13536,9 @@ CONTAINS 2132.484724545273_dp, & 3743.164994620193_dp, & 8008.935958082978_dp, & - 30201.87390773344_dp/) + 30201.87390773344_dp] ELSE IF (E_range < 15000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15074658869167354_dp, & 0.4668958035836203_dp, & 0.8287813045866178_dp, & @@ -13601,9 +13598,9 @@ CONTAINS 2585.9493214732233_dp, & 4560.104639212192_dp, & 9764.47140618184_dp, & - 36744.78826999934_dp/) + 36744.78826999934_dp] ELSE IF (E_range < 20000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15327074211168326_dp, & 0.47523666558201105_dp, & 0.8454081293698346_dp, & @@ -13663,9 +13660,9 @@ CONTAINS 3312.4890760215126_dp, & 5880.358930845362_dp, & 12610.246229383727_dp, & - 47327.426186591925_dp/) + 47327.426186591925_dp] ELSE IF (E_range < 28000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15611582449200168_dp, & 0.484670676531795_dp, & 0.864327133672447_dp, & @@ -13725,9 +13722,9 @@ CONTAINS 4418.177298699454_dp, & 7913.127380453787_dp, & 17012.044780129974_dp, & - 63654.92138377425_dp/) + 63654.92138377425_dp] ELSE IF (E_range < 38000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1585986414808211_dp, & 0.49293227874864953_dp, & 0.8809949627642996_dp, & @@ -13787,9 +13784,9 @@ CONTAINS 5728.411572233089_dp, & 10353.785071731596_dp, & 22327.676016416055_dp, & - 83326.1396670659_dp/) + 83326.1396670659_dp] ELSE IF (E_range < 50000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16074983925508995_dp, & 0.5001125329781305_dp, & 0.895558007331798_dp, & @@ -13849,9 +13846,9 @@ CONTAINS 7222.917612404246_dp, & 13174.2778180717_dp, & 28509.267725054422_dp, & - 106160.2639173599_dp/) + 106160.2639173599_dp] ELSE IF (E_range < 64000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16262039381403579_dp, & 0.5063730793021797_dp, & 0.9083149017898943_dp, & @@ -13911,9 +13908,9 @@ CONTAINS 8885.07671917959_dp, & 16351.40165928286_dp, & 35518.56312434257_dp, & - 132016.67889946306_dp/) + 132016.67889946306_dp] ELSE IF (E_range < 84000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16461121992013572_dp, & 0.5130537467027886_dp, & 0.9219891409850267_dp, & @@ -13973,9 +13970,9 @@ CONTAINS 11143.129516033901_dp, & 20727.354533996564_dp, & 45246.467731381585_dp, & - 167864.82966862986_dp/) + 167864.82966862986_dp] ELSE IF (E_range < 110000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16651351865477473_dp, & 0.519454577907408_dp, & 0.9351507515667731_dp, & @@ -14035,9 +14032,9 @@ CONTAINS 13921.767968244894_dp, & 26195.561124088643_dp, & 57512.80156760765_dp, & - 213037.54770361463_dp/) + 213037.54770361463_dp] ELSE IF (E_range < 160000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1690396225959909_dp, & 0.527980783630836_dp, & 0.9527749551685267_dp, & @@ -14097,9 +14094,9 @@ CONTAINS 18902.03087469423_dp, & 36195.04534310194_dp, & 80228.85952678222_dp, & - 296685.58400527935_dp/) + 296685.58400527935_dp] ELSE IF (E_range < 220000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17108080746256005_dp, & 0.5348926066785868_dp, & 0.9671403722271738_dp, & @@ -14159,9 +14156,9 @@ CONTAINS 24425.382905474227_dp, & 47540.939727448866_dp, & 106401.9838008185_dp, & - 393145.5653859997_dp/) + 393145.5653859997_dp] ELSE IF (E_range < 370000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.174208015078396_dp, & 0.5455214527091232_dp, & 0.9893700986809595_dp, & @@ -14221,9 +14218,9 @@ CONTAINS 36827.67063798521_dp, & 73825.92204301585_dp, & 168436.45444117606_dp, & - 622444.873239739_dp/) + 622444.873239739_dp] ELSE IF (E_range < 520000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1761202582043389_dp, & 0.5520447609872519_dp, & 1.0030974507555772_dp, & @@ -14283,9 +14280,9 @@ CONTAINS 47901.44750228873_dp, & 98085.01445426073_dp, & 227192.3617986822_dp, & - 840731.2172617969_dp/) + 840731.2172617969_dp] ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1777047921517639_dp, & 0.5574641492548221_dp, & 1.0145511230139452_dp, & @@ -14345,9 +14342,9 @@ CONTAINS 60011.99599547493_dp, & 125336.8664775516_dp, & 294698.3519483209_dp, & - 1092989.8333233916_dp/) + 1092989.8333233916_dp] ELSE IF (E_range < 1100000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1799647702096782_dp, & 0.5652158330702483_dp, & 1.0310122635781176_dp, & @@ -14407,9 +14404,9 @@ CONTAINS 83848.098471279_dp, & 180849.87459593892_dp, & 436512.7424947387_dp, & - 1628215.5545881148_dp/) + 1628215.5545881148_dp] ELSE IF (E_range < 1800000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1822263529525982_dp, & 0.5729996377421059_dp, & 1.047635792810745_dp, & @@ -14469,9 +14466,9 @@ CONTAINS 119209.6009779448_dp, & 267043.87988619285_dp, & 666555.4805450162_dp, & - 2511681.1233505663_dp/) + 2511681.1233505663_dp] ELSE IF (E_range < 3300000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1847328901237733_dp, & 0.5816579181920506_dp, & 1.06623831659397_dp, & @@ -14531,9 +14528,9 @@ CONTAINS 180141.95260617262_dp, & 424305.6328571203_dp, & 1112162.6633453001_dp, & - 4275158.808925236_dp/) + 4275158.808925236_dp] ELSE IF (E_range < 6000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18691650786522696_dp, & 0.5892282516421157_dp, & 1.082601142199495_dp, & @@ -14593,9 +14590,9 @@ CONTAINS 264080.7768830504_dp, & 655640.4058250692_dp, & 1818602.1997626221_dp, & - 7205611.5064693205_dp/) + 7205611.5064693205_dp] ELSE IF (E_range < 18000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19022370155321527_dp, & 0.600743360402157_dp, & 1.1076668599949147_dp, & @@ -14655,9 +14652,9 @@ CONTAINS 494979.5222323457_dp, & 1359946.1830275727_dp, & 4269995.133188314_dp, & - 18594665.56920044_dp/) + 18594665.56920044_dp] ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.19253210390672987_dp, & 0.6088167991143922_dp, & 1.1253694421581641_dp, & @@ -14717,9 +14714,9 @@ CONTAINS 801312.2270425739_dp, & 2415145.5599759216_dp, & 8639654.807896439_dp, & - 43666635.56753933_dp/) + 43666635.56753933_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.1949107095730563_dp, & 0.6171672239307736_dp, & 1.143792172436484_dp, & @@ -14779,9 +14776,9 @@ CONTAINS 1380639.0831843547_dp, & 4711303.6808049455_dp, & 20609904.76278654_dp, & - 151191206.84136662_dp/) + 151191206.84136662_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_30 ! ************************************************************************************************** !> \brief ... @@ -14799,7 +14796,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 4862.0_dp) THEN E_ratio = 4862.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13254275519610229_dp, & 0.4075002434334006_dp, & 0.7129653611128071_dp, & @@ -14863,9 +14860,9 @@ CONTAINS 1039.6543728256195_dp, & 1789.9748349736915_dp, & 3833.9681364720745_dp, & - 14655.44632366239_dp/) + 14655.44632366239_dp] ELSE IF (E_range < 5846.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1343248849882633_dp, & 0.4132592119099152_dp, & 0.7240043390799359_dp, & @@ -14929,9 +14926,9 @@ CONTAINS 1222.611932252175_dp, & 2108.162233431274_dp, & 4512.831122628449_dp, & - 17222.120678400817_dp/) + 17222.120678400817_dp] ELSE IF (E_range < 6665.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13557338601660668_dp, & 0.41730065260389615_dp, & 0.7317746815552322_dp, & @@ -14995,9 +14992,9 @@ CONTAINS 1371.947991018934_dp, & 2368.536327804507_dp, & 5068.399861166353_dp, & - 19319.551508880766_dp/) + 19319.551508880766_dp] ELSE IF (E_range < 7800.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1370499857872464_dp, & 0.422087838650514_dp, & 0.7410040914005517_dp, & @@ -15061,9 +15058,9 @@ CONTAINS 1575.1576866889702_dp, & 2723.745097867967_dp, & 5826.475195617796_dp, & - 22177.608473258828_dp/) + 22177.608473258828_dp] ELSE IF (E_range < 10044.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1393751435556022_dp, & 0.4296428076126454_dp, & 0.7556269118458908_dp, & @@ -15127,9 +15124,9 @@ CONTAINS 1966.3786822155184_dp, & 3410.3262356194664_dp, & 7292.46886903304_dp, & - 27693.855354838164_dp/) + 27693.855354838164_dp] ELSE IF (E_range < 14058.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14237486453944107_dp, & 0.4394200534952092_dp, & 0.7746555330683098_dp, & @@ -15193,9 +15190,9 @@ CONTAINS 2639.3168711629464_dp, & 4598.936377351543_dp, & 9833.306219117254_dp, & - 37228.01191754706_dp/) + 37228.01191754706_dp] ELSE IF (E_range < 19114.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14502370796551703_dp, & 0.4480829010539378_dp, & 0.7916157981286331_dp, & @@ -15259,9 +15256,9 @@ CONTAINS 3450.91828637881_dp, & 6043.794023233803_dp, & 12927.644737686549_dp, & - 48805.08862191054_dp/) + 48805.08862191054_dp] ELSE IF (E_range < 25870.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14754727473790832_dp, & 0.4563621690490255_dp, & 0.8079150128057052_dp, & @@ -15325,9 +15322,9 @@ CONTAINS 4489.970449108518_dp, & 7909.344598672393_dp, & 16932.78473977757_dp, & - 63749.23270457554_dp/) + 63749.23270457554_dp] ELSE IF (E_range < 35180.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15002348519433922_dp, & 0.46451130342750646_dp, & 0.824045021042684_dp, & @@ -15391,9 +15388,9 @@ CONTAINS 5859.209649832797_dp, & 10391.307380953114_dp, & 22278.529118569048_dp, & - 83643.6346001724_dp/) + 83643.6346001724_dp] ELSE IF (E_range < 58986.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15399032986872938_dp, & 0.4776194738561411_dp, & 0.8501753043803365_dp, & @@ -15457,9 +15454,9 @@ CONTAINS 9137.412009720016_dp, & 16424.470778988587_dp, & 35351.12874442453_dp, & - 132131.62635064372_dp/) + 132131.62635064372_dp] ELSE IF (E_range < 85052.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15665201491118563_dp, & 0.48645255086696204_dp, & 0.8679140908633145_dp, & @@ -15523,9 +15520,9 @@ CONTAINS 12481.117979830125_dp, & 22687.396569080272_dp, & 49029.27213151443_dp, & - 182714.99577064996_dp/) + 182714.99577064996_dp] ELSE IF (E_range < 126612.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15940855323823325_dp, & 0.4956331404107984_dp, & 0.8864643437510178_dp, & @@ -15589,9 +15586,9 @@ CONTAINS 17463.261532301312_dp, & 32186.387908159864_dp, & 69962.03966745277_dp, & - 259964.04274551442_dp/) + 259964.04274551442_dp] ELSE IF (E_range < 247709.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16373958436697705_dp, & 0.5101264978608379_dp, & 0.9159896069529507_dp, & @@ -15655,9 +15652,9 @@ CONTAINS 30505.194880449075_dp, & 57794.75930208428_dp, & 127350.9867284555_dp, & - 471374.61882211326_dp/) + 471374.61882211326_dp] ELSE IF (E_range < 452410.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16729345587752817_dp, & 0.5220837915443625_dp, & 0.9405741148525995_dp, & @@ -15721,9 +15718,9 @@ CONTAINS 49765.1843652489_dp, & 97101.2613405646_dp, & 217655.43736295513_dp, & - 804161.4023302288_dp/) + 804161.4023302288_dp] ELSE IF (E_range < 1104308.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17199827765823103_dp, & 0.5380059294727404_dp, & 0.9736341997615289_dp, & @@ -15787,9 +15784,9 @@ CONTAINS 100319.89810256775_dp, & 206207.35016280194_dp, & 478990.19443877833_dp, & - 1773158.149536881_dp/) + 1773158.149536881_dp] ELSE IF (E_range < 2582180.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.17588045499160682_dp, & 0.5512257021498627_dp, & 1.0013703118630188_dp, & @@ -15853,9 +15850,9 @@ CONTAINS 189213.13598878586_dp, & 412506.46573426365_dp, & 1004859.506854019_dp, & - 3757500.169762731_dp/) + 3757500.169762731_dp] ELSE IF (E_range < 10786426.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.18118431919794764_dp, & 0.569409896731795_dp, & 1.0399575954447753_dp, & @@ -15919,9 +15916,9 @@ CONTAINS 501508.5608275271_dp, & 1228961.4319415095_dp, & 3359678.97519788_dp, & - 13198823.17240385_dp/) + 13198823.17240385_dp] ELSE IF (E_range < 72565710.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.1860758083606257_dp, & 0.5863105731285033_dp, & 1.0762838189916888_dp, & @@ -15985,9 +15982,9 @@ CONTAINS 1439654.5954696422_dp, & 4195690.360297783_dp, & 14287820.480068853_dp, & - 67797329.79665162_dp/) + 67797329.79665162_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.18894944364096963_dp, & 0.5962994473518639_dp, & 1.0979679811546372_dp, & @@ -16051,9 +16048,9 @@ CONTAINS 2964362.2649549907_dp, & 10115616.277159294_dp, & 44251495.17814687_dp, & - 324622278.5292175_dp/) + 324622278.5292175_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_32 ! ************************************************************************************************** !> \brief ... @@ -16071,7 +16068,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 9649.0_dp) THEN E_ratio = 9649.0_dp/E_range - aw(:) = (/ & + aw(:) = [ & 0.13207515772844727_dp, & 0.405991108403864_dp, & 0.7100791180957539_dp, & @@ -16139,9 +16136,9 @@ CONTAINS 2025.283801158086_dp, & 3491.3059333297665_dp, & 7474.317631875756_dp, & - 28531.55532533201_dp/) + 28531.55532533201_dp] ELSE IF (E_range < 15161.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.13599210879419024_dp, & 0.41865733842571035_dp, & 0.734387462880487_dp, & @@ -16209,9 +16206,9 @@ CONTAINS 3017.958277485201_dp, & 5225.5076295652025_dp, & 11175.8295539236_dp, & - 42493.69287150706_dp/) + 42493.69287150706_dp] ELSE IF (E_range < 29986.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14157456993085618_dp, & 0.43680814305293825_dp, & 0.7695603918544728_dp, & @@ -16279,9 +16276,9 @@ CONTAINS 5497.180237430633_dp, & 9607.611108068526_dp, & 20546.39934902344_dp, & - 77652.80170951472_dp/) + 77652.80170951472_dp] ELSE IF (E_range < 49196.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.14537972365704172_dp, & 0.44924937732846576_dp, & 0.7939069438582139_dp, & @@ -16349,9 +16346,9 @@ CONTAINS 8473.557800314775_dp, & 14944.543756287507_dp, & 32001.381350595566_dp, & - 120417.37064242488_dp/) + 120417.37064242488_dp] ELSE IF (E_range < 109833.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15111478683237578_dp, & 0.46811081455805653_dp, & 0.8311975658154092_dp, & @@ -16419,9 +16416,9 @@ CONTAINS 16981.74160635827_dp, & 30536.056841551963_dp, & 65732.37502124789_dp, & - 245660.71368655932_dp/) + 245660.71368655932_dp] ELSE IF (E_range < 276208.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.15704353232796245_dp, & 0.4877544479660704_dp, & 0.8705376156017336_dp, & @@ -16489,9 +16486,9 @@ CONTAINS 37197.937321555175_dp, & 68943.1032010462_dp, & 150241.71258102785_dp, & - 557720.3208697784_dp/) + 557720.3208697784_dp] ELSE IF (E_range < 852991.0_dp) THEN - aw(:) = (/ & + aw(:) = [ & 0.16336922513552726_dp, & 0.5088837963863347_dp, & 0.9134464251208241_dp, & @@ -16559,9 +16556,9 @@ CONTAINS 94285.04834791286_dp, & 183730.02847568074_dp, & 411506.64532360405_dp, & - 1520426.766419325_dp/) + 1520426.766419325_dp] ELSE - aw(:) = (/ & + aw(:) = [ & 0.1835103101234003_dp, & 0.5774305061474206_dp, & 1.057140472868453_dp, & @@ -16629,8 +16626,8 @@ CONTAINS 6223266.011027118_dp, & 21236461.045184538_dp, & 92901077.9747871_dp, & - 681507114.6255051_dp/) + 681507114.6255051_dp] END IF - END SUBROUTINE + END SUBROUTINE get_coeff_34 END MODULE minimax_rpa diff --git a/src/mixed_cdft_methods.F b/src/mixed_cdft_methods.F index 74f7a80279..d5e1d7c4cc 100644 --- a/src/mixed_cdft_methods.F +++ b/src/mixed_cdft_methods.F @@ -122,6 +122,21 @@ MODULE mixed_cdft_methods CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mixed_cdft_methods' LOGICAL, PARAMETER, PRIVATE :: debug_this_module = .FALSE. + TYPE buffers_idx_irr + INTEGER :: imap(6) = 0 + INTEGER, DIMENSION(:), & + POINTER :: iv => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :) :: r3 => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :, :) :: r4 => null() + END TYPE buffers_idx_irr + + TYPE buffers_bi + LOGICAL, POINTER, DIMENSION(:) :: bv => NULL() + INTEGER, POINTER, DIMENSION(:) :: iv => NULL() + END TYPE buffers_bi + PUBLIC :: mixed_cdft_init, & mixed_cdft_build_weight, & mixed_cdft_calculate_coupling @@ -180,14 +195,16 @@ CONTAINS mixed_env%do_mixed_cdft = .TRUE. IF (mixed_env%do_mixed_cdft) THEN ! Sanity check - IF (nforce_eval < 2) & + IF (nforce_eval < 2) THEN CALL cp_abort(__LOCATION__, & "Mixed CDFT calculation requires at least 2 force_evals.") + END IF mapping_section => section_vals_get_subs_vals(mixed_section, "MAPPING") CALL section_vals_get(mapping_section, explicit=explicit) ! The sub_force_envs must share the same geometrical structure - IF (explicit) & + IF (explicit) THEN CPABORT("Please disable section &MAPPING for mixed CDFT calculations") + END IF CALL section_vals_val_get(mixed_section, "MIXED_CDFT%COUPLING", i_val=et_freq) IF (et_freq < 0) THEN mixed_env%do_mixed_et = .FALSE. @@ -244,9 +261,10 @@ CONTAINS IF (is_parallel) THEN ! Treat states in parallel, build weight function and gradients in parallel before SCF process mixed_cdft%run_type = mixed_cdft_parallel - IF (.NOT. nforce_eval == 2) & + IF (.NOT. nforce_eval == 2) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT calculation supports only 2 force_evals.") + END IF ELSE ! Treat states in parallel, but each states builds its own weight function and gradients mixed_cdft%run_type = mixed_cdft_parallel_nobuild @@ -299,8 +317,9 @@ CONTAINS END IF ! Inversion method CALL section_vals_val_get(mixed_section, "MIXED_CDFT%EPS_SVD", r_val=mixed_cdft%eps_svd) - IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) & + IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) THEN CPABORT("Illegal value for EPS_SVD. Value must be between 0.0 and 1.0.") + END IF ! MD related settings CALL force_env_get(force_env, root_section=root_section) md_section => section_vals_get_subs_vals(root_section, "MOTION%MD") @@ -446,6 +465,7 @@ CONTAINS INTEGER, DIMENSION(2, 3) :: bo INTEGER, DIMENSION(:), POINTER :: lb, sendbuffer_i, ub REAL(KIND=dp) :: t1, t2 + TYPE(buffers_idx_irr), DIMENSION(:), POINTER :: recvbuffer TYPE(cdft_control_type), POINTER :: cdft_control, cdft_control_target TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys_mix @@ -460,17 +480,6 @@ CONTAINS TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: force_env_section, print_section - TYPE buffers - INTEGER :: imap(6) - INTEGER, DIMENSION(:), & - POINTER :: iv => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :) :: r3 => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :, :) :: r4 => null() - END TYPE buffers - TYPE(buffers), DIMENSION(:), POINTER :: recvbuffer - NULLIFY (subsys_mix, force_env_qs, particles_mix, force_env_section, print_section, & mixed_env, mixed_cdft, pw_env, auxbas_pw_pool, mixed_auxbas_pw_pool, & qs_env, dft_control, sendbuffer_i, lb, ub, req_total, recvbuffer, & @@ -609,8 +618,9 @@ CONTAINS IF (mixed_cdft%dlb_control%recv_work_repl(1) .OR. mixed_cdft%dlb_control%recv_work_repl(2)) THEN DO j = 1, 2 recv_offset = 0 - IF (mixed_cdft%dlb_control%recv_work_repl(j)) & + IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN recv_offset = SUM(mixed_cdft%dlb_control%recv_info(j)%target_list(2, :)) + END IF IF (mixed_cdft%is_pencil) THEN recvbuffer(j)%imap(1) = recvbuffer(j)%imap(1) + recv_offset ELSE @@ -812,15 +822,17 @@ CONTAINS IF (ANY(mixed_cdft%dlb_control%recv_work_repl)) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%recv_work_repl) IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN - IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) THEN DEALLOCATE (mixed_cdft%dlb_control%recv_info(j)%target_list) + END IF DEALLOCATE (mixed_cdft%dlb_control%recvbuff(j)%buffs) END IF END DO DEALLOCATE (mixed_cdft%dlb_control%recv_info, mixed_cdft%dlb_control%recvbuff) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) THEN DEALLOCATE (mixed_cdft%dlb_control%target_list) + END IF DEALLOCATE (mixed_cdft%dlb_control%recv_work_repl) END IF DEALLOCATE (recvbuffer) @@ -982,8 +994,9 @@ CONTAINS END IF ! Atomic weight functions needed for CDFT charges IF (cdft_control_source%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control_target%charge)) & + IF (.NOT. ASSOCIATED(cdft_control_target%charge)) THEN ALLOCATE (cdft_control_target%charge(cdft_control_target%natoms)) + END IF DO iatom = 1, cdft_control_target%natoms CALL auxbas_pw_pool_target%create_pw(cdft_control_target%charge(iatom)) CALL pw_copy(cdft_control_source%charge(iatom), cdft_control_target%charge(iatom)) @@ -1232,12 +1245,14 @@ CONTAINS CALL cp_fm_get_info(mixed_mo_coeff(1, ispin), ncol_global=check_mo(1), nrow_global=check_ao(1)) DO iforce_eval = 2, nforce_eval CALL cp_fm_get_info(mixed_mo_coeff(iforce_eval, ispin), ncol_global=check_mo(2), nrow_global=check_ao(2)) - IF (check_ao(1) /= check_ao(2)) & + IF (check_ao(1) /= check_ao(2)) THEN CALL cp_abort(__LOCATION__, & "The number of atomic orbitals must be the same in every CDFT state.") - IF (check_mo(1) /= check_mo(2)) & + END IF + IF (check_mo(1) /= check_mo(2)) THEN CALL cp_abort(__LOCATION__, & "The number of molecular orbitals must be the same in every CDFT state.") + END IF END DO END DO ! Allocate work @@ -1266,13 +1281,15 @@ CONTAINS ALLOCATE (homo(nforce_eval, nspins)) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL section_vals_val_get(mixed_cdft_section, "EPS_OCCUPIED", r_val=eps_occupied) - IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) & + IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Keyword EPS_OCCUPIED only accepts values between 0.0 and 1.0") - IF (mixed_cdft%eps_svd == 0.0_dp) & + END IF + IF (mixed_cdft%eps_svd == 0.0_dp) THEN CALL cp_warn(__LOCATION__, & "The usage of SVD based matrix inversions with fractionally occupied "// & "orbitals is strongly recommended to screen nearly orthogonal states.") + END IF CALL section_vals_val_get(mixed_cdft_section, "SCALE_WITH_OCCUPATION_NUMBERS", l_val=should_scale) END IF ! Start the actual calculation @@ -1304,8 +1321,9 @@ CONTAINS nelectron_mismatch = .FALSE. nelectron_tot = SUM(mixed_cdft%occupations(1, ispin)%array(1:nmo)) DO istate = 2, nforce_eval - IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) & + IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) THEN nelectron_mismatch = .TRUE. + END IF END DO IF (ANY(homo(:, ispin) /= nmo)) THEN IF (ispin == 1) THEN @@ -1368,9 +1386,10 @@ CONTAINS name="MO_COEFF_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_" & //TRIM(ADJUSTL(cp_to_string(ispin)))//"_MATRIX") CALL cp_fm_to_fm(tmp2, mixed_mo_coeff(iforce_eval, ispin)) - IF (should_scale) & + IF (should_scale) THEN CALL cp_fm_column_scale(mixed_mo_coeff(iforce_eval, ispin), & mixed_cdft%occupations(iforce_eval, ispin)%array(1:nmo)) + END IF DEALLOCATE (mixed_cdft%occupations(iforce_eval, ispin)%array) END DO END IF @@ -1384,12 +1403,13 @@ CONTAINS CALL parallel_gemm('T', 'N', nmo, nmo, nao, 1.0_dp, & mixed_mo_coeff(jstate, ispin), & tmp2, 0.0_dp, mo_overlap(ipermutation)) - IF (print_mo) & + IF (print_mo) THEN CALL cp_fm_write_formatted(mo_overlap(ipermutation), mounit, & "# MO overlap matrix (step "//TRIM(ADJUSTL(cp_to_string(mixed_cdft%sim_step)))// & "): CDFT states "//TRIM(ADJUSTL(cp_to_string(istate)))//" and "// & TRIM(ADJUSTL(cp_to_string(jstate)))//" (spin "// & TRIM(ADJUSTL(cp_to_string(ispin)))//")") + END IF END DO END DO ! calculate the MO-representations of the restraint matrices of all CDFT states @@ -1489,9 +1509,10 @@ CONTAINS END SELECT END DO ! Compute density matrix difference P = P_j - P_i - IF (mixed_cdft%calculate_metric) & + IF (mixed_cdft%calculate_metric) THEN CALL dbcsr_add(density_matrix_diff(ipermutation, ispin)%matrix, & density_matrix(jstate, ispin)%matrix, -1.0_dp, 1.0_dp) + END IF ! CALL force_env%para_env%sum(a(ispin, :, ipermutation)) CALL force_env%para_env%sum(b(ispin, :, ipermutation)) @@ -1518,12 +1539,14 @@ CONTAINS DEALLOCATE (homo) DEALLOCATE (mixed_cdft%occupations) END IF - IF (print_mo) & + IF (print_mo) THEN CALL cp_print_key_finished_output(mounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) - IF (print_mo_eigval) & + END IF + IF (print_mo_eigval) THEN CALL cp_print_key_finished_output(moeigvalunit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) + END IF ! solve eigenstates for the projector matrix ALLOCATE (Wda(nvar, npermutations)) ALLOCATE (Sda(npermutations)) @@ -1649,9 +1672,10 @@ CONTAINS ! Compute coupling also with the wavefunction overlap method, see Migliore2009 ! Requires the unconstrained KS ground state wavefunction as input IF (mixed_cdft%wfn_overlap_method) THEN - IF (.NOT. uniform_occupation) & + IF (.NOT. uniform_occupation) THEN CALL cp_abort(__LOCATION__, & "Wavefunction overlap method supports only uniformly occupied MOs.") + END IF CALL mixed_cdft_wfn_overlap_method(force_env, mixed_cdft, ncol_mo, nrow_mo) END IF ! Release remaining work @@ -1958,9 +1982,10 @@ CONTAINS END DO DEALLOCATE (H_block, S_block, eigenvalues, blocks) END DO ! recursion - IF (iounit > 0) & + IF (iounit > 0) THEN WRITE (iounit, '(T3,A)') & - '------------------------------------------------------------------------------' + '------------------------------------------------------------------------------' + END IF CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -2001,8 +2026,9 @@ CONTAINS ALLOCATE (evals(ncol_mo(ispin))) DO ipermutation = 1, npermutations ! Take into account doubly occupied orbitals without LSD - IF (nspins == 1) & + IF (nspins == 1) THEN CALL dbcsr_scale(density_matrix_diff(ipermutation, 1)%matrix, alpha_scalar=0.5_dp) + END IF ! Diagonalize difference density matrix CALL cp_dbcsr_syevd(density_matrix_diff(ipermutation, ispin)%matrix, e_vectors, evals, & para_env=force_env%para_env, blacs_env=mixed_cdft%blacs_env) @@ -2093,31 +2119,35 @@ CONTAINS ALLOCATE (mo_set(ispin)%occupation_numbers(nmo)) END DO ! Read wfn file (note we assume that the basis set is the same) - IF (force_env%mixed_env%do_mixed_qmmm_cdft) & + IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN ! This really shouldnt be a problem? CALL cp_abort(__LOCATION__, & "QMMM + wavefunction overlap method not supported.") + END IF CALL force_env_get(force_env=force_env, subsys=subsys_mix) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL cp_subsys_get(subsys_mix, atomic_kind_set=atomic_kind_set, particle_set=particle_set) CPASSERT(ASSOCIATED(mixed_cdft%qs_kind_set)) - IF (force_env%para_env%is_source()) & + IF (force_env%para_env%is_source()) THEN CALL wfn_restart_file_name(file_name, exist, mixed_cdft_section, logger) + END IF CALL force_env%para_env%bcast(exist) CALL force_env%para_env%bcast(file_name) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CALL cp_abort(__LOCATION__, & "User requested to restart the wavefunction from the file named: "// & TRIM(file_name)//". This file does not exist. Please check the existence of"// & " the file or change properly the value of the keyword WFN_RESTART_FILE_NAME in"// & " section FORCE_EVAL\MIXED\MIXED_CDFT.") + END IF CALL read_mo_set_from_restart(mo_array=mo_set, qs_kind_set=mixed_cdft%qs_kind_set, particle_set=particle_set, & para_env=force_env%para_env, id_nr=0, multiplicity=mixed_cdft%multiplicity, & dft_section=mixed_cdft_section, natom_mismatch=natom_mismatch, & cdft=.TRUE.) - IF (natom_mismatch) & + IF (natom_mismatch) THEN CALL cp_abort(__LOCATION__, & "Restart wfn file has a wrong number of atoms") + END IF ! Orthonormalize wfn DO ispin = 1, nspins IF (mixed_cdft%has_unit_metric) THEN @@ -2350,10 +2380,11 @@ CONTAINS CASE (becke_cutoff_global) cdft_control%becke_control%cutoffs(:) = cdft_control%becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) THEN CALL cp_abort(__LOCATION__, & "Size of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does "// & "not match number of atomic kinds in the input coordinate file.") + END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -2379,20 +2410,23 @@ CONTAINS is_constraint = .FALSE. END IF in_memory = calculate_forces .AND. cdft_control%becke_control%in_memory - IF (in_memory .NEQV. calculate_forces) & + IF (in_memory .NEQV. calculate_forces) THEN CALL cp_abort(__LOCATION__, & "The flag BECKE_CONSTRAINT\IN_MEMORY must be activated "// & "for the calculation of mixed CDFT forces") + END IF IF (in_memory .OR. mixed_cdft%first_iteration) ALLOCATE (coefficients(natom)) DO i = 1, cdft_control%natoms catom(i) = cdft_control%atoms(i) IF (cdft_control%save_pot .OR. & cdft_control%becke_control%cavity_confine .OR. & cdft_control%becke_control%should_skip .OR. & - mixed_cdft%first_iteration) & + mixed_cdft%first_iteration) THEN is_constraint(catom(i)) = .TRUE. - IF (in_memory .OR. mixed_cdft%first_iteration) & + END IF + IF (in_memory .OR. mixed_cdft%first_iteration) THEN coefficients(catom(i)) = cdft_control%group(1)%coeff(i) + END IF END DO CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_pw_pool=auxbas_pw_pool) bo = auxbas_pw_pool%pw_grid%bounds_local @@ -2424,7 +2458,7 @@ CONTAINS pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + R12(iatom, jatom) = NORM2(dist_vec) R12(jatom, iatom) = R12(iatom, jatom) IF (build) THEN CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & @@ -2521,8 +2555,9 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=cdft_control%becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) & + IF (ASSOCIATED(radii_list)) THEN DEALLOCATE (radii_list) + END IF END IF NULLIFY (rs_cavity) CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_rs_grid=rs_cavity, & @@ -2622,9 +2657,10 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (force_env%para_env%is_source() .AND. unit_nr < 1) & + IF (force_env%para_env%is_source() .AND. unit_nr < 1) THEN CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") + END IF CALL cp_pw_to_cube(cdft_control%becke_control%cavity, & unit_nr, "CAVITY", particles=particles, & stride=stride, mpi_io=mpi_io) @@ -2633,17 +2669,20 @@ CONTAINS END IF END IF bo_conf = bo - IF (cdft_control%becke_control%cavity_confine) & + IF (cdft_control%becke_control%cavity_confine) THEN bo_conf(:, 3) = cdft_control%becke_control%confine_bounds + END IF ! Load balance - IF (mixed_cdft%dlb) & + IF (mixed_cdft%dlb) THEN CALL mixed_becke_constraint_dlb(force_env, mixed_cdft, my_work, & my_work_size, natom, bo, bo_conf) + END IF ! The bounds have been finalized => time to allocate storage for working matrices offset_dlb = 0 IF (mixed_cdft%dlb) THEN - IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) & + IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) THEN offset_dlb = SUM(mixed_cdft%dlb_control%target_list(2, :)) + END IF END IF IF (cdft_control%becke_control%cavity_confine) THEN ! Get rid of the zero part of the confinement cavity (cr3d -> real(:,:,:)) @@ -2733,6 +2772,7 @@ CONTAINS INTEGER, PARAMETER :: should_deallocate = 7000, & uninitialized = -7000 + CHARACTER(len=2) :: dummy INTEGER :: actually_sent, exhausted_work, handle, i, ind, iounit, ispecial, j, max_targets, & more_work, my_pos, my_special_work, my_target, no_overloaded, no_underloaded, nsend, & nsend_limit, nsend_max, offset, offset_proc, offset_special, send_total, tags(2) @@ -2744,19 +2784,13 @@ CONTAINS REAL(kind=dp) :: average_work, load_scale, & very_overloaded, work_factor REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: cavity + TYPE(buffers_bi), DIMENSION(:), POINTER :: recvbuffer, sbuff TYPE(cdft_control_type), POINTER :: cdft_control TYPE(cp_logger_type), POINTER :: logger TYPE(mp_request_type), DIMENSION(4) :: req TYPE(mp_request_type), DIMENSION(:), POINTER :: req_recv, req_total TYPE(section_vals_type), POINTER :: force_env_section, print_section - TYPE buffers - LOGICAL, POINTER, DIMENSION(:) :: bv - INTEGER, POINTER, DIMENSION(:) :: iv - END TYPE buffers - TYPE(buffers), POINTER, DIMENSION(:) :: recvbuffer, sbuff - CHARACTER(len=2) :: dummy - logger => cp_get_default_logger() CALL timeset(routineN, handle) mixed_cdft%dlb_control%recv_work = .FALSE. @@ -2821,8 +2855,9 @@ CONTAINS ! We store the unsorted expected work to refine the estimate on subsequent calls to this routine mixed_cdft%dlb_control%expected_work = expected_work ! Take into account the prediction error of the last step - IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN expected_work = expected_work - mixed_cdft%dlb_control%prediction_error + END IF ! average_work = REAL(SUM(expected_work), dp)/REAL(force_env%para_env%num_pe, dp) ALLOCATE (work_index(force_env%para_env%num_pe), & @@ -2924,8 +2959,9 @@ CONTAINS ! Prevent over redistribution: leave at least (1-work_factor)*nsend_limit slices to my_pos IF (nsend > NINT(work_factor*nsend_limit - send_total)) THEN nsend = NINT(work_factor*nsend_limit - send_total) - IF (debug_this_module) & + IF (debug_this_module) THEN should_warn(force_env%para_env%mepos + 1) = 1 + END IF END IF mixed_cdft%dlb_control%target_list(1, i) = work_index(my_target) - 1 ! This is the actual processor rank IF (mixed_cdft%is_special) THEN @@ -2968,9 +3004,10 @@ CONTAINS EXIT END IF i = i + 1 - IF (i > max_targets) & + IF (i > max_targets) THEN CALL cp_abort(__LOCATION__, & "Load balancing error: increase max_targets") + END IF END DO IF (.NOT. mixed_cdft%is_special) THEN CALL reallocate(mixed_cdft%dlb_control%target_list, 1, 3, 1, i) @@ -2993,11 +3030,12 @@ CONTAINS CALL force_env%para_env%sum(targets) IF (debug_this_module) THEN CALL force_env%para_env%sum(should_warn) - IF (ANY(should_warn == 1)) & + IF (ANY(should_warn == 1)) THEN CALL cp_warn(__LOCATION__, & "MIXED_CDFT DLB: Attempted to redistribute more array"// & " slices than actually available. Leaving a fraction of the total"// & " slices on the overloaded processor. Perhaps you have set LOAD_SCALE too high?") + END IF DEALLOCATE (should_warn) END IF ! check that there is one-to-one mapping between over- and underloaded processors @@ -3236,11 +3274,12 @@ CONTAINS CALL force_env%para_env%irecv(msgout=recvbuffer(i)%bv, & source=mixed_cdft%source_list(i), & request=req_total(i), tag=1) - IF (mixed_cdft%is_special) & + IF (mixed_cdft%is_special) THEN CALL force_env%para_env%irecv(msgout=recvbuffer(i)%iv, & source=mixed_cdft%source_list(i), & request=req_total(i + SIZE(mixed_cdft%source_list)), & tag=2) + END IF END DO DO i = 1, my_special_work DO j = 1, SIZE(mixed_cdft%dest_list) @@ -3258,8 +3297,9 @@ CONTAINS IF (touched(j)) THEN nsend = 0 DO ispecial = 1, SIZE(mixed_cdft%dlb_control%target_list, 2) - IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) & + IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) THEN nsend = nsend + 1 + END IF END DO sbuff(j)%iv(3) = nsend nsend_proc(j) = nsend @@ -3271,10 +3311,11 @@ CONTAINS CALL force_env%para_env%isend(msgin=sbuff(j)%bv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind), tag=1) - IF (mixed_cdft%is_special) & + IF (mixed_cdft%is_special) THEN CALL force_env%para_env%isend(msgin=sbuff(j)%iv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind + 2*SIZE(mixed_cdft%dest_list)), tag=2) + END IF END DO END DO CALL mp_waitall(req_total) @@ -3349,8 +3390,9 @@ CONTAINS IF (mixed_cdft%dlb_control%send_work) THEN ind = COUNT(mixed_cdft%dlb_control%recv_work_repl) + 1 DO i = 1, 2 - IF (i == 2) & + IF (i == 2) THEN mixed_cdft%dlb_control%target_list(3, :) = mixed_cdft%dlb_control%target_list(3, :) + 3*max_targets + END IF CALL force_env%para_env%isend(msgin=mixed_cdft%dlb_control%target_list, & dest=mixed_cdft%dest_list(i), & request=req_total(ind)) @@ -3846,8 +3888,9 @@ CONTAINS END DO END IF ! Poll to prevent starvation - IF (ASSOCIATED(req_recv)) & + IF (ASSOCIATED(req_recv)) THEN completed_recv = mp_testall(req_recv) + END IF ! DO i = LBOUND(weight, 3), UBOUND(weight, 3) IF (cdft_control%becke_control%cavity_confine) THEN @@ -3885,7 +3928,7 @@ CONTAINS IF (distances(iatom) == 0.0_dp) THEN r = position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) distance_vecs(:, iatom) = dist_vec distances(iatom) = dist1 ELSE @@ -3898,7 +3941,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -3914,7 +3957,7 @@ CONTAINS IF (distances(jatom) == 0.0_dp) THEN r1 = position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) distance_vecs(:, jatom) = dist_vec distances(jatom) = dist2 ELSE @@ -3927,7 +3970,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) END IF IF (in_memory) THEN IF (store_vectors) THEN @@ -3990,27 +4033,30 @@ CONTAINS IF (in_memory) THEN dP_i_dRi(:, iatom) = cell_functions(iatom)*dP_i_dRi(:, iatom) d_sum_Pm_dR(:, iatom) = d_sum_Pm_dR(:, iatom) + dP_i_dRi(:, iatom) - IF (is_constraint(iatom)) & + IF (is_constraint(iatom)) THEN d_sum_const_dR(:, iatom) = d_sum_const_dR(:, iatom) + dP_i_dRi(:, iatom)* & coefficients(iatom) + END IF DO jatom = 1, natom IF (jatom /= iatom) THEN IF (jatom < iatom) THEN IF (.NOT. skip_me(jatom)) THEN dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) & + IF (is_constraint(iatom)) THEN d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + & dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) + END IF CYCLE END IF END IF dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) & + IF (is_constraint(iatom)) THEN d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) + END IF END IF END DO END IF @@ -4050,8 +4096,9 @@ CONTAINS END IF END DO END IF - IF (ABS(sum_cell_f_all) > 0.000001) & + IF (ABS(sum_cell_f_all) > 0.000001) THEN weight(k, j, i) = sum_cell_f_constr/sum_cell_f_all + END IF END DO ! i END DO ! j END DO ! k @@ -4114,20 +4161,26 @@ CONTAINS END DO CALL mp_waitall(req_total) DEALLOCATE (req_total) - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%gradients) + END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) + END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4136,20 +4189,26 @@ CONTAINS IF (should_communicate) THEN CALL mp_waitall(req_send) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%gradients) + END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & + END IF + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) + END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4162,8 +4221,9 @@ CONTAINS IF (mixed_cdft%dlb) THEN CALL force_env%para_env%sum(work) CALL force_env%para_env%sum(work_dlb) - IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & + IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN ALLOCATE (mixed_cdft%dlb_control%prediction_error(force_env%para_env%num_pe)) + END IF mixed_cdft%dlb_control%prediction_error = mixed_cdft%dlb_control%expected_work - work IF (debug_this_module .AND. iounit > 0) THEN DO i = 1, SIZE(work, 1) @@ -4174,8 +4234,9 @@ CONTAINS DEALLOCATE (work, work_dlb, mixed_cdft%dlb_control%expected_work) END IF NULLIFY (gradients, weight, cavity) - IF (ALLOCATED(coefficients)) & + IF (ALLOCATED(coefficients)) THEN DEALLOCATE (coefficients) + END IF IF (in_memory) THEN DEALLOCATE (ds_dR_j) DEALLOCATE (ds_dR_i) @@ -4189,25 +4250,30 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) & + IF (ALLOCATED(is_constraint)) THEN DEALLOCATE (is_constraint) + END IF DEALLOCATE (catom) DEALLOCATE (R12) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) - IF (ALLOCATED(completed)) & + IF (ALLOCATED(completed)) THEN DEALLOCATE (completed) - IF (ASSOCIATED(nsent)) & + END IF + IF (ASSOCIATED(nsent)) THEN DEALLOCATE (nsent) + END IF IF (store_vectors) THEN DEALLOCATE (distances) DEALLOCATE (distance_vecs) DEALLOCATE (position_vecs) END IF - IF (ASSOCIATED(req_send)) & + IF (ASSOCIATED(req_send)) THEN DEALLOCATE (req_send) - IF (ASSOCIATED(req_recv)) & + END IF + IF (ASSOCIATED(req_recv)) THEN DEALLOCATE (req_recv) + END IF CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) diff --git a/src/mixed_cdft_types.F b/src/mixed_cdft_types.F index 5a05d67a39..1fa57726d9 100644 --- a/src/mixed_cdft_types.F +++ b/src/mixed_cdft_types.F @@ -310,41 +310,55 @@ CONTAINS INTEGER :: i, j CALL pw_env_release(cdft_control%pw_env) - IF (ASSOCIATED(cdft_control%dest_list)) & + IF (ASSOCIATED(cdft_control%dest_list)) THEN DEALLOCATE (cdft_control%dest_list) - IF (ASSOCIATED(cdft_control%dest_list_save)) & + END IF + IF (ASSOCIATED(cdft_control%dest_list_save)) THEN DEALLOCATE (cdft_control%dest_list_save) - IF (ASSOCIATED(cdft_control%dest_list_bo)) & + END IF + IF (ASSOCIATED(cdft_control%dest_list_bo)) THEN DEALLOCATE (cdft_control%dest_list_bo) - IF (ASSOCIATED(cdft_control%dest_bo_save)) & + END IF + IF (ASSOCIATED(cdft_control%dest_bo_save)) THEN DEALLOCATE (cdft_control%dest_bo_save) - IF (ASSOCIATED(cdft_control%source_list)) & + END IF + IF (ASSOCIATED(cdft_control%source_list)) THEN DEALLOCATE (cdft_control%source_list) - IF (ASSOCIATED(cdft_control%source_list_save)) & + END IF + IF (ASSOCIATED(cdft_control%source_list_save)) THEN DEALLOCATE (cdft_control%source_list_save) - IF (ASSOCIATED(cdft_control%source_list_bo)) & + END IF + IF (ASSOCIATED(cdft_control%source_list_bo)) THEN DEALLOCATE (cdft_control%source_list_bo) - IF (ASSOCIATED(cdft_control%source_bo_save)) & + END IF + IF (ASSOCIATED(cdft_control%source_bo_save)) THEN DEALLOCATE (cdft_control%source_bo_save) - IF (ASSOCIATED(cdft_control%recv_bo)) & + END IF + IF (ASSOCIATED(cdft_control%recv_bo)) THEN DEALLOCATE (cdft_control%recv_bo) - IF (ASSOCIATED(cdft_control%weight)) & + END IF + IF (ASSOCIATED(cdft_control%weight)) THEN DEALLOCATE (cdft_control%weight) - IF (ASSOCIATED(cdft_control%cavity)) & + END IF + IF (ASSOCIATED(cdft_control%cavity)) THEN DEALLOCATE (cdft_control%cavity) - IF (ALLOCATED(cdft_control%constraint_type)) & + END IF + IF (ALLOCATED(cdft_control%constraint_type)) THEN DEALLOCATE (cdft_control%constraint_type) + END IF IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations, 1) DO j = 1, SIZE(cdft_control%occupations, 2) - IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) & + IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) THEN DEALLOCATE (cdft_control%occupations(i, j)%array) + END IF END DO END DO DEALLOCATE (cdft_control%occupations) END IF - IF (ASSOCIATED(cdft_control%dlb_control)) & + IF (ASSOCIATED(cdft_control%dlb_control)) THEN CALL mixed_cdft_dlb_release(cdft_control%dlb_control) + END IF IF (ASSOCIATED(cdft_control%sendbuff)) THEN DO i = 1, SIZE(cdft_control%sendbuff) CALL mixed_cdft_buffers_release(cdft_control%sendbuff(i)) @@ -355,10 +369,12 @@ CONTAINS CALL cdft_control_release(cdft_control%cdft_control) DEALLOCATE (cdft_control%cdft_control) END IF - IF (ASSOCIATED(cdft_control%blacs_env)) & + IF (ASSOCIATED(cdft_control%blacs_env)) THEN CALL cp_blacs_env_release(cdft_control%blacs_env) - IF (ASSOCIATED(cdft_control%qs_kind_set)) & + END IF + IF (ASSOCIATED(cdft_control%qs_kind_set)) THEN CALL deallocate_qs_kind_set(cdft_control%qs_kind_set) + END IF IF (ASSOCIATED(cdft_control%sub_logger)) THEN DO i = 1, SIZE(cdft_control%sub_logger) CALL cp_logger_release(cdft_control%sub_logger(i)%p) @@ -381,8 +397,9 @@ CONTAINS INTEGER :: i - IF (ASSOCIATED(dlb_control%recv_work_repl)) & + IF (ASSOCIATED(dlb_control%recv_work_repl)) THEN DEALLOCATE (dlb_control%recv_work_repl) + END IF IF (ASSOCIATED(dlb_control%sendbuff)) THEN DO i = 1, SIZE(dlb_control%sendbuff) CALL mixed_cdft_buffers_release(dlb_control%sendbuff(i)) @@ -397,27 +414,36 @@ CONTAINS END IF IF (ASSOCIATED(dlb_control%recv_info)) THEN DO i = 1, SIZE(dlb_control%recv_info) - IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) & + IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) THEN DEALLOCATE (dlb_control%recv_info(i)%matrix_info) - IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) & + END IF + IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) THEN DEALLOCATE (dlb_control%recv_info(i)%target_list) + END IF END DO DEALLOCATE (dlb_control%recv_info) END IF - IF (ASSOCIATED(dlb_control%bo)) & + IF (ASSOCIATED(dlb_control%bo)) THEN DEALLOCATE (dlb_control%bo) - IF (ASSOCIATED(dlb_control%expected_work)) & + END IF + IF (ASSOCIATED(dlb_control%expected_work)) THEN DEALLOCATE (dlb_control%expected_work) - IF (ASSOCIATED(dlb_control%prediction_error)) & + END IF + IF (ASSOCIATED(dlb_control%prediction_error)) THEN DEALLOCATE (dlb_control%prediction_error) - IF (ASSOCIATED(dlb_control%target_list)) & + END IF + IF (ASSOCIATED(dlb_control%target_list)) THEN DEALLOCATE (dlb_control%target_list) - IF (ASSOCIATED(dlb_control%cavity)) & + END IF + IF (ASSOCIATED(dlb_control%cavity)) THEN DEALLOCATE (dlb_control%cavity) - IF (ASSOCIATED(dlb_control%weight)) & + END IF + IF (ASSOCIATED(dlb_control%weight)) THEN DEALLOCATE (dlb_control%weight) - IF (ASSOCIATED(dlb_control%gradients)) & + END IF + IF (ASSOCIATED(dlb_control%gradients)) THEN DEALLOCATE (dlb_control%gradients) + END IF DEALLOCATE (dlb_control) END SUBROUTINE mixed_cdft_dlb_release @@ -430,12 +456,15 @@ CONTAINS SUBROUTINE mixed_cdft_buffers_release(buffer) TYPE(buffers) :: buffer - IF (ASSOCIATED(buffer%cavity)) & + IF (ASSOCIATED(buffer%cavity)) THEN DEALLOCATE (buffer%cavity) - IF (ASSOCIATED(buffer%weight)) & + END IF + IF (ASSOCIATED(buffer%weight)) THEN DEALLOCATE (buffer%weight) - IF (ASSOCIATED(buffer%gradients)) & + END IF + IF (ASSOCIATED(buffer%gradients)) THEN DEALLOCATE (buffer%gradients) + END IF END SUBROUTINE mixed_cdft_buffers_release diff --git a/src/mixed_cdft_utils.F b/src/mixed_cdft_utils.F index 89fcedfe23..cba3f032cf 100644 --- a/src/mixed_cdft_utils.F +++ b/src/mixed_cdft_utils.F @@ -209,10 +209,11 @@ CONTAINS CALL force_env_get(force_env_qs, qs_env=qs_env) END IF CALL get_qs_env(qs_env, pw_env=pw_env, dft_control=dft_control) - IF (.NOT. dft_control%qs_control%cdft) & + IF (.NOT. dft_control%qs_control%cdft) THEN CALL cp_abort(__LOCATION__, & "A mixed CDFT simulation with multiple force_evals was requested, "// & "but CDFT constraints were not active in the QS section of all force_evals!") + END IF cdft_control => dft_control%qs_control%cdft_control CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) settings%bo = auxbas_pw_pool%pw_grid%bounds_local @@ -227,13 +228,15 @@ CONTAINS settings%rs_dims(:, iforce_eval) = auxbas_pw_pool%pw_grid%para%group%num_pe_cart IF (auxbas_pw_pool%pw_grid%grid_span == HALFSPACE) settings%odd(iforce_eval) = 1 ! Becke constraint atoms/coeffs - IF (cdft_control%natoms > SIZE(settings%atoms, 1)) & + IF (cdft_control%natoms > SIZE(settings%atoms, 1)) THEN CALL cp_abort(__LOCATION__, & "More CDFT constraint atoms than defined in mixed section. "// & "Use default values for MIXED\MAPPING.") + END IF settings%atoms(1:cdft_control%natoms, iforce_eval) = cdft_control%atoms - IF (mixed_cdft%run_type == mixed_cdft_parallel) & + IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN settings%coeffs(1:cdft_control%natoms, iforce_eval) = cdft_control%group(1)%coeff + END IF ! Integer type settings IF (cdft_control%type == outer_scf_becke_constraint) THEN settings%si(1, iforce_eval) = cdft_control%becke_control%cutoff_type @@ -274,41 +277,46 @@ CONTAINS IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN nkinds = SIZE(cdft_control%becke_control%cutoffs_tmp) - IF (nkinds > settings%max_nkinds) & + IF (nkinds > settings%max_nkinds) THEN CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ELEMENT_CUTOFF. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") + END IF settings%cutoffs(1:nkinds, iforce_eval) = cdft_control%becke_control%cutoffs_tmp(:) END IF IF (cdft_control%becke_control%adjust) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF nkinds = SIZE(cdft_control%becke_control%radii_tmp) - IF (nkinds > settings%max_nkinds) & + IF (nkinds > settings%max_nkinds) THEN CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ATOMIC_RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") + END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%becke_control%radii_tmp(:) END IF END IF IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN IF (ASSOCIATED(cdft_control%hirshfeld_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT&RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF nkinds = SIZE(cdft_control%hirshfeld_control%radii) - IF (nkinds > settings%max_nkinds) & + IF (nkinds > settings%max_nkinds) THEN CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in HIRSHFELD_CONSTRAINT&RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") + END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%hirshfeld_control%radii(:) END IF END IF @@ -333,15 +341,17 @@ CONTAINS is_match = is_match .AND. (settings%rs_dims(2, 1) == settings%rs_dims(2, iforce_eval)) is_match = is_match .AND. (settings%odd(1) == settings%odd(iforce_eval)) END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &MGRID settings of the CDFT force_evals.") + END IF IF (settings%spherical(1) == 1) settings%is_spherical = .TRUE. IF (settings%odd(1) == 1) settings%is_odd = .TRUE. ! Make sure CDFT settings are consistent CALL force_env%para_env%sum(settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) & + IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN CALL force_env%para_env%sum(settings%coeffs) + END IF settings%ncdft = 0 DO i = 1, SIZE(settings%atoms, 1) DO iforce_eval = 2, nforce_eval @@ -352,12 +362,13 @@ CONTAINS END DO IF (settings%atoms(i, 1) /= 0) settings%ncdft = settings%ncdft + 1 END DO - IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) & + IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT section of the CDFT force_evals. "// & "Parallel mode mixed CDFT requires identical constraint definitions in both CDFT states. "// & "Switch to serial mode or disable keyword PARALLEL_BUILD if you "// & "want to use nonidentical constraint definitions.") + END IF CALL force_env%para_env%sum(settings%si) CALL force_env%para_env%sum(settings%sr) DO i = 1, SIZE(settings%sb, 1) @@ -377,13 +388,15 @@ CONTAINS IF (settings%sr(i, 1) /= settings%sr(i, iforce_eval)) is_match = .FALSE. END DO END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT settings of the CDFT force_evals.") + END IF ! Some CDFT features are currently disabled for mixed calculations: check that these features were not requested - IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) & + IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT load balancing requires Gaussian cavity confinement.") + END IF ! Check for identical constraints in case of run type serial/parallel_nobuild IF (mixed_cdft%run_type /= mixed_cdft_parallel) THEN ! Get array sizes @@ -409,8 +422,9 @@ CONTAINS ! Sum up array sizes and check consistency CALL force_env%para_env%sum(array_sizes) IF (ANY(array_sizes(:, :, 1) /= array_sizes(1, 1, 1)) .OR. & - ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) & + ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) THEN mixed_cdft%identical_constraints = .FALSE. + END IF ! Check constraint definitions IF (mixed_cdft%identical_constraints) THEN ! Prepare temporary storage @@ -454,14 +468,17 @@ CONTAINS END DO DO iforce_eval = 2, nforce_eval DO iatom = 1, SIZE(atoms(1, i)%array) - IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) & + IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) THEN mixed_cdft%identical_constraints = .FALSE. - IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) & + END IF + IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) THEN mixed_cdft%identical_constraints = .FALSE. + END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO - IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) & + IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) THEN mixed_cdft%identical_constraints = .FALSE. + END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO IF (.NOT. mixed_cdft%identical_constraints) EXIT @@ -509,12 +526,15 @@ CONTAINS END DO IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (.NOT. cdft_control%atomic_charges) DEALLOCATE (cdft_control%atoms) - IF (cdft_control%becke_control%cavity_confine) & + IF (cdft_control%becke_control%cavity_confine) THEN CALL release_hirshfeld_type(cdft_control%becke_control%cavity_env) - IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) & + END IF + IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN DEALLOCATE (cdft_control%becke_control%cutoffs_tmp) - IF (cdft_control%becke_control%adjust) & + END IF + IF (cdft_control%becke_control%adjust) THEN DEALLOCATE (cdft_control%becke_control%radii_tmp) + END IF END IF END IF END DO @@ -549,16 +569,19 @@ CONTAINS settings%radius = settings%sr(5, 1) ! Transfer settings only needed if the constraint should be built in parallel IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN - IF (settings%sb(6, 1)) & + IF (settings%sb(6, 1)) THEN CALL cp_abort(__LOCATION__, & "Calculation of atomic Becke charges not supported with parallel mode mixed CDFT") - IF (mixed_cdft%nconstraint /= 1) & + END IF + IF (mixed_cdft%nconstraint /= 1) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not yet support multiple constraints.") + END IF - IF (settings%si(5, 1) /= outer_scf_becke_constraint) & + IF (settings%si(5, 1) /= outer_scf_becke_constraint) THEN CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not support Hirshfeld constraints.") + END IF ALLOCATE (mixed_cdft%cdft_control) CALL cdft_control_create(mixed_cdft%cdft_control) @@ -593,10 +616,11 @@ CONTAINS IF (settings%cutoffs(i, 1) /= settings%cutoffs(i, 2)) is_match = .FALSE. IF (settings%cutoffs(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ELEMENT_CUTOFF settings of the two force_evals.") + END IF ALLOCATE (cdft_control%becke_control%cutoffs_tmp(nkinds)) cdft_control%becke_control%cutoffs_tmp = settings%cutoffs(1:nkinds, 1) END IF @@ -607,10 +631,11 @@ CONTAINS IF (settings%radii(i, 1) /= settings%radii(i, 2)) is_match = .FALSE. IF (settings%radii(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ATOMIC_RADII settings of the two force_evals.") + END IF ALLOCATE (cdft_control%becke_control%radii(nkinds)) cdft_control%becke_control%radii = settings%radii(1:nkinds, 1) END IF @@ -706,8 +731,9 @@ CONTAINS mixed_cdft%is_special = .FALSE. ! Flag to control the last mapping ! With xc smoothing, the grid is always (ncpu/2,1) distributed ! and correct behavior cannot be guaranteed for ncpu/2 > nx, so we abort... - IF (ncpu/2 > settings%npts(1, 1)) & + IF (ncpu/2 > settings%npts(1, 1)) THEN CPABORT("ncpu/2 => nx: decrease ncpu or disable xc_smoothing") + END IF ! ALLOCATE (mixed_rs_dims(2)) IF (settings%rs_dims(2, 1) /= 1) mixed_cdft%is_pencil = .TRUE. @@ -740,11 +766,12 @@ CONTAINS ELSE IF (.NOT. pw_grid%para%group%num_pe_cart(2) == 1) is_match = .FALSE. END IF - IF (.NOT. is_match) & + IF (.NOT. is_match) THEN CALL cp_abort(__LOCATION__, & "Unable to create a suitable grid distribution "// & "for mixed CDFT calculations. Try decreasing the total number "// & "of processors or disabling xc_smoothing.") + END IF DEALLOCATE (mixed_rs_dims) ! Create the pool bo_mixed = pw_grid%bounds_local @@ -1010,8 +1037,9 @@ CONTAINS DEALLOCATE (settings%rs_dims) DEALLOCATE (settings%odd) DEALLOCATE (settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) & + IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN DEALLOCATE (settings%coeffs) + END IF DEALLOCATE (settings%cutoffs) DEALLOCATE (settings%radii) DEALLOCATE (settings%si) @@ -1088,15 +1116,17 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) CPASSERT(ASSOCIATED(dft_control)) nspins = dft_control%nspins - IF (force_env_qs%para_env%is_source()) & + IF (force_env_qs%para_env%is_source()) THEN has_occupation_numbers(iforce_eval) = ALLOCATED(dft_control%qs_control%cdft_control%occupations) + END IF END DO CALL force_env%para_env%sum(has_occupation_numbers(1)) DO iforce_eval = 2, nforce_eval CALL force_env%para_env%sum(has_occupation_numbers(iforce_eval)) - IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) & + IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) THEN CALL cp_abort(__LOCATION__, & "Mixing of uniform and non-uniform occupations is not allowed.") + END IF END DO uniform_occupation = .NOT. has_occupation_numbers(1) DEALLOCATE (has_occupation_numbers) @@ -1154,8 +1184,9 @@ CONTAINS ! Valgrind 3.12/gfortran 4.8.4 oddly complains here (unconditional jump) ! if mixed_cdft%calculate_metric = .FALSE. and the need to null the array ! is queried with IF (mixed_cdft%calculate_metric) & - IF (.NOT. uniform_occupation) & + IF (.NOT. uniform_occupation) THEN NULLIFY (occno_tmp(iforce_eval, ispin)%array) + END IF END DO IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE ! From this point onward, we access data local to the sub_force_envs @@ -1228,8 +1259,9 @@ CONTAINS ! Occupation numbers IF (.NOT. uniform_occupation) THEN DO ispin = 1, nspins - IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) & + IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) THEN CPABORT("Array dimensions dont match.") + END IF IF (force_env_qs%para_env%is_source()) THEN ALLOCATE (occno_tmp(iforce_eval, ispin)%array(ncol_mo(ispin))) occno_tmp(iforce_eval, ispin)%array = dft_control%qs_control%cdft_control%occupations(ispin)%array @@ -1248,8 +1280,9 @@ CONTAINS ! We use this method for the serial case (mixed_cdft%run_type == mixed_cdft_serial) as well to move the arrays to the ! correct blacs_env, which is impossible using a simple copy of the arrays ALLOCATE (mixed_wmat_tmp(nforce_eval, nvar)) - IF (mixed_cdft%calculate_metric) & + IF (mixed_cdft%calculate_metric) THEN ALLOCATE (mixed_matrix_p_tmp(nforce_eval, nspins)) + END IF DO iforce_eval = 1, nforce_eval ! MO coefficients DO ispin = 1, nspins @@ -1381,8 +1414,9 @@ CONTAINS WRITE (iounit, '(T3,A,I3,A,I3,A)') '###### CDFT states I =', istate, ' and J = ', jstate, ' ######' WRITE (iounit, '(T3,A)') REPEAT('#', 44) DO ivar = 1, nvar - IF (ivar > 1) & + IF (ivar > 1) THEN WRITE (iounit, '(A)') '' + END IF WRITE (iounit, '(T3,A,T60,(3X,I18))') 'Atomic group:', ivar WRITE (iounit, '(T3,A,T60,(3X,F18.12))') & 'Strength of constraint I:', mixed_cdft%results%strength(ivar, istate) @@ -1491,8 +1525,9 @@ CONTAINS INTEGER :: kcol, kpermutation, krow, npermutations npermutations = n*(n - 1)/2 ! Size of upper triangular part - IF (ipermutation > npermutations) & + IF (ipermutation > npermutations) THEN CPABORT("Permutation index out of bounds") + END IF kpermutation = 0 DO krow = 1, n DO kcol = krow + 1, n @@ -1610,18 +1645,20 @@ CONTAINS block_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT%BLOCK_DIAGONALIZE") CALL section_vals_get(block_section, explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CALL cp_abort(__LOCATION__, & "Block diagonalization of CDFT Hamiltonian was requested, but the "// & "corresponding input section is missing!") + END IF CALL section_vals_val_get(block_section, "BLOCK", n_rep_val=nblk) ALLOCATE (blocks(nblk)) DO i = 1, nblk NULLIFY (blocks(i)%array) CALL section_vals_val_get(block_section, "BLOCK", i_rep_val=i, i_vals=tmplist) - IF (SIZE(tmplist) < 1) & + IF (SIZE(tmplist) < 1) THEN CPABORT("Each BLOCK must contain at least 1 state.") + END IF ALLOCATE (blocks(i)%array(SIZE(tmplist))) blocks(i)%array(:) = tmplist(:) END DO @@ -1630,8 +1667,9 @@ CONTAINS ! Check that the requested states exist DO i = 1, nblk DO j = 1, SIZE(blocks(i)%array) - IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) & + IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) THEN CPABORT("Requested state does not exist.") + END IF END DO END DO ! Check for duplicates @@ -1663,9 +1701,10 @@ CONTAINS ELSE nrecursion = nblk/2 END IF - IF (nrecursion /= 1 .AND. .NOT. ignore_excited) & + IF (nrecursion /= 1 .AND. .NOT. ignore_excited) THEN CALL cp_abort(__LOCATION__, & "Keyword IGNORE_EXCITED must be active for recursive diagonalization.") + END IF END IF END SUBROUTINE mixed_cdft_read_block_diag @@ -1709,10 +1748,11 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_block(i)%array >= 0.0_dp)) & + IF (ANY(H_block(i)%array >= 0.0_dp)) THEN CALL cp_abort(__LOCATION__, & "At least one of the interaction energies within block "//TRIM(ADJUSTL(cp_to_string(i)))// & " is repulsive.") + END IF END DO END SUBROUTINE mixed_cdft_get_blocks @@ -1847,10 +1887,11 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_offdiag >= 0.0_dp)) & + IF (ANY(H_offdiag >= 0.0_dp)) THEN CALL cp_abort(__LOCATION__, & "At least one of the interaction energies between blocks "//TRIM(ADJUSTL(cp_to_string(i)))// & " and "//TRIM(ADJUSTL(cp_to_string(j)))//" is repulsive.") + END IF ! Now transform: C_i^T * H * C_j H_offdiag(:, :) = MATMUL(H_offdiag, H_block(j)%array) H_offdiag(:, :) = MATMUL(TRANSPOSE(H_block(i)%array), H_offdiag) diff --git a/src/mixed_environment_types.F b/src/mixed_environment_types.F index 0cb02288c5..267d51da65 100644 --- a/src/mixed_environment_types.F +++ b/src/mixed_environment_types.F @@ -321,10 +321,12 @@ CONTAINS IF (ASSOCIATED(mixed_env%group_distribution)) THEN DEALLOCATE (mixed_env%group_distribution) END IF - IF (ASSOCIATED(mixed_env%cdft_control)) & + IF (ASSOCIATED(mixed_env%cdft_control)) THEN CALL mixed_cdft_type_release(mixed_env%cdft_control) - IF (ASSOCIATED(mixed_env%strength)) & + END IF + IF (ASSOCIATED(mixed_env%strength)) THEN DEALLOCATE (mixed_env%strength) + END IF END SUBROUTINE mixed_env_release diff --git a/src/mode_selective.F b/src/mode_selective.F index 753dfb8bae..9877810b97 100644 --- a/src/mode_selective.F +++ b/src/mode_selective.F @@ -330,8 +330,9 @@ CONTAINS END IF END IF END IF - IF (ms_vib%select_id == 0) & + IF (ms_vib%select_id == 0) THEN CPABORT("no frequency, range or involved atoms specified ") + END IF ionode = para_env%is_source() SELECT CASE (guess) CASE (ms_guess_atomic) @@ -374,7 +375,7 @@ CONTAINS ms_vib%b_vec(jj, i) = ABS(globenv%gaussian_rng_stream%next()) END DO END DO - norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + norm = NORM2(ms_vib%b_vec(:, i)) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO @@ -386,7 +387,7 @@ CONTAINS ms_vib%b_vec(:, j) = & ms_vib%b_vec(:, j) - DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, i))*ms_vib%b_vec(:, i) ms_vib%b_vec(:, j) = & - ms_vib%b_vec(:, j)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, j))) + ms_vib%b_vec(:, j)/NORM2(ms_vib%b_vec(:, j)) END IF END DO END DO @@ -424,8 +425,8 @@ CONTAINS CALL para_env%bcast(ms_vib%b_vec) CALL para_env%bcast(ms_vib%delta_vec) DO i = 1, nrep - ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) - ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) + ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) + ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) END DO CALL timestop(handle) @@ -451,8 +452,8 @@ CONTAINS INTEGER :: nrep CHARACTER(LEN=default_path_length) :: hes_filename - INTEGER :: hesunit, i, j, jj, k, natoms, ncoord, & - output_unit, stat + INTEGER :: hesunit, i, istat, j, jj, k, natoms, & + ncoord, output_unit, stat INTEGER, DIMENSION(:), POINTER :: tmplist REAL(KIND=dp) :: my_val, norm REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp @@ -476,12 +477,14 @@ CONTAINS ALLOCATE (tmplist(ncoord)) ! should use the cp_fm_read_unformatted... + istat = 0 DO i = 1, ncoord READ (UNIT=hesunit, IOSTAT=stat) ms_vib%hes_bfgs(:, i) + istat = istat + stat END DO CALL close_file(hesunit) IF (output_unit > 0) THEN - IF (stat /= 0) THEN + IF (istat /= 0) THEN WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading HESSIAN **" ELSE WRITE (output_unit, FMT="(/,T2,A)") & @@ -517,7 +520,7 @@ CONTAINS CALL sort(tmp, ncoord, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = ms_vib%hes_bfgs(:, tmplist(i)) - norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + norm = NORM2(ms_vib%b_vec(:, i)) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, SIZE(ms_vib%b_vec, 1) @@ -597,18 +600,19 @@ CONTAINS END IF IF (ionode) THEN statint = 0 - READ (UNIT=hesunit, IOSTAT=stat) ms_vib%b_mat + READ (UNIT=hesunit) ms_vib%b_mat READ (UNIT=hesunit, IOSTAT=stat) ms_vib%s_mat - IF (calc_intens) READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) - IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & - "intensities are requested but not present in restart file **" + IF (stat /= 0 .AND. output_unit > 0) THEN + WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" + END IF + IF (calc_intens) THEN + READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) + IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & + "intensities are requested but not present in restart file **" + END IF CALL close_file(hesunit) - IF (output_unit > 0) THEN - IF (stat /= 0) THEN - WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" - ELSE - WRITE (output_unit, FMT="(/,T2,A)") "*** RESTART has been read successfully ***" - END IF + IF (stat == 0 .AND. statint == 0 .AND. output_unit > 0) THEN + WRITE (output_unit, FMT="(/,T2,A)") "*** MS_RESTART has been read successfully ***" END IF END IF CALL para_env%bcast(ms_vib%b_mat) @@ -630,7 +634,7 @@ CONTAINS DO j = 1, ms_vib%mat_size ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i) + approx_H(j, ind(i))*ms_vib%b_mat(:, j) END DO - ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/NORM2(ms_vib%b_vec(:, i)) END DO DEALLOCATE (ms_vib%s_mat) @@ -700,8 +704,8 @@ CONTAINS unit_number=iw) END IF info = "" - READ (iw, *, IOSTAT=stat) info - READ (iw, *, IOSTAT=stat) info + READ (iw, *) info + READ (iw, *) info istat = 0 nvibs = 0 reading_vib = .FALSE. @@ -784,7 +788,7 @@ CONTAINS CALL sort(tmp, nvibs, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = modes(:, tmplist(i))*mass(:) - norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) + norm = NORM2(ms_vib%b_vec(:, i)) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, nrep @@ -920,8 +924,8 @@ CONTAINS END DO DO i = 1, nrep - ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) - ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) + ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) + ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) END DO converged = .FALSE. IF (MAXVAL(criteria(1, :)) <= ms_vib%eps(1) .AND. MAXVAL(criteria(2, :)) & @@ -946,14 +950,14 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) + tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) END DO IF (calc_intens) THEN DO i = 1, ms_vib%mat_size DO j = 1, ms_vib%mat_size tmp_s(:, i) = tmp_s(:, i) + ms_vib%dip_deriv(:, j)*approx_H(j, i) END DO - IF (calc_intens) intensities(i) = SQRT(DOT_PRODUCT(tmp_s(:, i), tmp_s(:, i))) + IF (calc_intens) intensities(i) = NORM2(tmp_s(:, i)) END DO END IF IF (calc_intens) THEN @@ -1041,7 +1045,7 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) + tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) END DO tmp = 0._dp DO i = 1, ms_vib%mat_size @@ -1078,12 +1082,12 @@ CONTAINS IF (PRESENT(criteria)) THEN DO i = 1, nrep criteria(1, i) = MAXVAL((residuum(:, i))) - criteria(2, i) = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) + criteria(2, i) = NORM2(residuum(:, i)) END DO END IF DO i = 1, nrep - norm = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) + norm = NORM2(residuum(:, i)) residuum(:, i) = residuum(:, i)/norm END DO @@ -1091,13 +1095,13 @@ CONTAINS DO j = 1, nrep DO i = 1, ms_vib%mat_size residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), ms_vib%b_mat(:, i))*ms_vib%b_mat(:, i) - residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) + residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) END DO IF (nrep > 1) THEN DO i = 1, nrep IF (i /= j) THEN residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), residuum(:, i))*residuum(:, i) - residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) + residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) END IF END DO END IF @@ -1139,7 +1143,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), OPTIONAL :: intensities TYPE(cp_logger_type), POINTER :: logger - INTEGER :: i, j, msunit, stat + INTEGER :: i, j, msunit REAL(KIND=dp) :: crit_a, crit_b, fint, gintval REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: residuum TYPE(section_vals_type), POINTER :: ms_vib_section @@ -1172,7 +1176,7 @@ CONTAINS residuum(:) = residuum(:) - DOT_PRODUCT(residuum(:), ms_vib%b_mat(:, j))*ms_vib%b_mat(:, j) END DO crit_a = MAXVAL(residuum(:)) - crit_b = SQRT(DOT_PRODUCT(residuum, residuum)) + crit_b = NORM2(residuum) IF (PRESENT(intensities)) THEN gintval = fint*intensities(i)**2 IF (crit_a <= ms_vib%eps(1) .AND. crit_b <= ms_vib%eps(2)) THEN @@ -1200,10 +1204,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv + WRITE (UNIT=msunit) ms_vib%mat_size + WRITE (UNIT=msunit) ms_vib%b_mat + WRITE (UNIT=msunit) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & @@ -1217,10 +1221,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat - WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv + WRITE (UNIT=msunit) ms_vib%mat_size + WRITE (UNIT=msunit) ms_vib%b_mat + WRITE (UNIT=msunit) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & diff --git a/src/mol_force.F b/src/mol_force.F index fecd8c1f7a..8788183cdc 100644 --- a/src/mol_force.F +++ b/src/mol_force.F @@ -53,17 +53,17 @@ CONTAINS SELECT CASE (id_type) CASE (do_ff_quartic) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 energy = (f12*k(1) + (f13*k(2) + f14*k(3)*disp)*disp)*disp*disp fscalar = ((k(1) + (k(2) + k(3)*disp)*disp)*disp)/dij CASE (do_ff_morse) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 energy = k(1)*((1 - EXP(-k(2)*disp))**2 - 1) fscalar = 2*k(1)*k(2)*EXP(-k(2)*disp)*(1 - EXP(-k(2)*disp))/dij CASE (do_ff_cubic) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 energy = k(1)*disp**2*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) fscalar = (2.0_dp*k(1)*disp*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) + & @@ -76,7 +76,7 @@ CONTAINS energy = f14*k(1)*disp*disp fscalar = k(1)*disp CASE (do_ff_charmm, do_ff_amber) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -86,7 +86,7 @@ CONTAINS fscalar = 2.0_dp*k(1)*disp/dij END IF CASE (do_ff_harmonic, do_ff_g87) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -96,7 +96,7 @@ CONTAINS fscalar = k(1)*disp/dij END IF CASE (do_ff_fues) - dij = SQRT(DOT_PRODUCT(rij, rij)) + dij = NORM2(rij) disp = r0/dij energy = f12*k(1)*r0*r0*(1.0_dp + disp*(disp - 2.0_dp)) fscalar = k(1)*r0*disp*disp*(1.0_dp - disp)/dij @@ -507,7 +507,7 @@ CONTAINS b = DOT_PRODUCT(t41, t41) - D !inverse norm of t41 - is41 = 1.0_dp/SQRT(DOT_PRODUCT(t41, t41)) + is41 = 1.0_dp/NORM2(t41) cosphi = SQRT(b)*is41 IF (cosphi > 1.0_dp) cosphi = 1.0_dp diff --git a/src/molecular_dipoles.F b/src/molecular_dipoles.F index 90a768e113..eb53cae2bb 100644 --- a/src/molecular_dipoles.F +++ b/src/molecular_dipoles.F @@ -76,7 +76,7 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dipole_set REAL(KIND=dp), DIMENSION(3) :: ci, gvec, rcc REAL(KIND=dp), DIMENSION(:), POINTER :: ref_point - REAL(KIND=dp), DIMENSION(:, :), POINTER :: center(:, :) + REAL(KIND=dp), DIMENSION(:, :), POINTER :: center TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(cell_type), POINTER :: cell TYPE(cp_logger_type), POINTER :: logger @@ -84,7 +84,7 @@ CONTAINS TYPE(distribution_1d_type), POINTER :: local_molecules TYPE(molecule_kind_type), POINTER :: molecule_kind TYPE(mp_para_env_type), POINTER :: para_env - TYPE(particle_type), POINTER :: particle_set(:) + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set logger => cp_get_default_logger() @@ -224,7 +224,7 @@ CONTAINS dipole_set(:, :) = dipole_set(:, :)*debye ! Debye DO I = 1, SIZE(dipole_set, 2) WRITE (UNIT=iounit, FMT='(T8,I6,T21,5F12.6)') I, charge_set(I), dipole_set(1:3, I), & - SQRT(DOT_PRODUCT(dipole_set(1:3, I), dipole_set(1:3, I))) + NORM2(dipole_set(1:3, I)) END DO WRITE (UNIT=iounit, FMT="(T2,A,T61,E20.12)") ' DIPOLE : CheckSum =', SUM(dipole_set) END IF diff --git a/src/molsym.F b/src/molsym.F index 466f6762b2..3d44715eae 100644 --- a/src/molsym.F +++ b/src/molsym.F @@ -1210,10 +1210,12 @@ CONTAINS IF (.NOT. sym%linear) THEN DO icn = 2, sym%ncn DO isec = 1, sym%nsec(icn) - IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) & + IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) THEN CALL addses(icn, sym%sec(:, isec, icn), sym) - IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) & + END IF + IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) THEN CALL addses(2*icn, sym%sec(:, isec, icn), sym) + END IF END DO END DO END IF diff --git a/src/motion/bfgs_optimizer.F b/src/motion/bfgs_optimizer.F index ef6ae345ea..54e89bffa8 100644 --- a/src/motion/bfgs_optimizer.F +++ b/src/motion/bfgs_optimizer.F @@ -194,13 +194,14 @@ CONTAINS ndf = SIZE(x0) nfree = gopt_env%nfree - IF (ndf > 3000) & + IF (ndf > 3000) THEN CALL cp_warn(__LOCATION__, & "The dimension of the Hessian matrix ("// & TRIM(ADJUSTL(cp_to_string(ndf)))//") is greater than 3000. "// & "The diagonalisation of the full Hessian matrix needed for BFGS "// & "is computationally expensive. You should consider to use the linear "// & "scaling variant L-BFGS instead.") + END IF ! Initialize hessian (hes = unitary matrix or model hessian ) CALL cp_blacs_env_create(blacs_env, para_env, globenv%blacs_grid_layout, & @@ -239,8 +240,10 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) - IF (output_unit > 0) WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, using unity as model Hessian." + IF (output_unit > 0) THEN + WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, using unity as model Hessian." + END IF ELSE DO its = 1, SIZE(eigval) IF (eigval(its) < 0.1_dp) eigval(its) = 0.1_dp @@ -373,8 +376,10 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN - IF (output_unit > 0) WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, resetting Hessian to unity." + IF (output_unit > 0) THEN + WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, resetting Hessian to unity." + END IF CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) CALL cp_fm_to_fm(hess_mat, hess_tmp) CALL choose_eigv_solver(hess_tmp, eigvec_mat, eigval) @@ -1087,7 +1092,7 @@ CONTAINS !pbc for a distance vector r_ij(j, i, :) = pbc(particles%els(i)%r, particles%els(j)%r, cell) r_ij(i, j, :) = -r_ij(j, i, :) - d_ij(j, i) = SQRT(DOT_PRODUCT(r_ij(j, i, :), r_ij(j, i, :))) + d_ij(j, i) = NORM2(r_ij(j, i, :)) d_ij(i, j) = d_ij(j, i) rho_ij(j, i) = EXP(alpha(jat_row, iat_row)*(r0(jat_row, iat_row)**2 - d_ij(j, i)**2)) rho_ij(i, j) = rho_ij(j, i) @@ -1104,25 +1109,28 @@ CONTAINS iat_row = (jglobal + 2)/3 IF (iat_row > natom) CYCLE IF (iat_row /= iat_col) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) & + IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) + END IF ELSE local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) END IF IF (iat_col /= iat_row) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) & + IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN local_data(j, i) = local_data(j, i) - & dist_second_deriv(r_ij(iat_col, iat_row, :), & iind, jind, d_ij(iat_row, iat_col), rho_ij(iat_row, iat_col)) + END IF ELSE DO k = 1, natom IF (k == iat_col) CYCLE - IF (d_ij(iat_row, k) < 6.0_dp) & + IF (d_ij(iat_row, k) < 6.0_dp) THEN local_data(j, i) = local_data(j, i) + & dist_second_deriv(r_ij(iat_col, k, :), & iind, jind, d_ij(iat_row, k), rho_ij(iat_row, k)) + END IF END DO END IF IF (fixed(jind, iat_row) < 0.5_dp .OR. fixed(iind, iat_col) < 0.5_dp) THEN diff --git a/src/motion/cell_opt_utils.F b/src/motion/cell_opt_utils.F index ed25d9fb70..48b29fb216 100644 --- a/src/motion/cell_opt_utils.F +++ b/src/motion/cell_opt_utils.F @@ -184,8 +184,9 @@ CONTAINS pres_ext = 0.0_dp CALL section_vals_val_get(geo_section, "EXTERNAL_PRESSURE", r_vals=pvals) check = (SIZE(pvals) == 1) .OR. (SIZE(pvals) == 9) - IF (.NOT. check) & + IF (.NOT. check) THEN CPABORT("EXTERNAL_PRESSURE can have 1 or 9 components only!") + END IF IF (SIZE(pvals) == 9) THEN ind = 0 @@ -425,7 +426,8 @@ CONTAINS gamma = angle(cell%hmat(:, 1), cell%hmat(:, 2)) cosg = COS(gamma) sing = SIN(gamma) - ! Here, g is the average derivative of the cell vector length ab_length, and deriv_gamma is the derivative of the angle gamma + ! Here, g is the average derivative of the cell vector length ab_length, + ! and deriv_gamma is the derivative of the angle gamma g = 0.5_dp*(gradient(1) + cosg*gradient(2) + sing*gradient(3)) deriv_gamma = (gradient(3)*cosg - gradient(2)*sing)/b_length gradient(1) = g diff --git a/src/motion/cg_utils.F b/src/motion/cg_utils.F index a2beb77590..017c5041f2 100644 --- a/src/motion/cg_utils.F +++ b/src/motion/cg_utils.F @@ -163,7 +163,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: gradient2, ls_norm CALL timeset(routineN, handle) - norm_ls_vec = SQRT(DOT_PRODUCT(ls_vec, ls_vec)) + norm_ls_vec = NORM2(ls_vec) my_use_only_grad = .FALSE. IF (PRESENT(use_only_grad)) my_use_only_grad = use_only_grad IF (norm_ls_vec /= 0.0_dp) THEN @@ -260,7 +260,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: tls_norm CALL timeset(routineN, handle) - norm_tls_vec = SQRT(DOT_PRODUCT(tls_vec, tls_vec)) + norm_tls_vec = NORM2(tls_vec) IF (norm_tls_vec /= 0.0_dp) THEN ALLOCATE (tls_norm(SIZE(tls_vec))) @@ -379,7 +379,7 @@ CONTAINS dimer_env%rot%g0 work = -2.0_dp*(work - dimer_env%rot%g0) work = work - DOT_PRODUCT(work, dimer_env%nvec)*dimer_env%nvec - opt_energy = SQRT(DOT_PRODUCT(work, work)) + opt_energy = NORM2(work) DEALLOCATE (work) END IF dimer_env%rot%angle2 = angle @@ -434,7 +434,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) + xicom = xicom/NORM2(xicom) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -520,7 +520,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) + xicom = xicom/NORM2(xicom) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -866,9 +866,10 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(/,T2,A)") REPEAT("*", 79) WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,I7,T78,A)") & "***", "BRENT - NUMBER OF ENERGY EVALUATIONS : ", loc_iter, "***" - IF (iter == itmax + 1) & + IF (iter == itmax + 1) THEN WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,T78,A)") & - "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" + "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" + END IF WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", 79) END IF CPASSERT(iter /= itmax + 1) @@ -1079,7 +1080,7 @@ CONTAINS g = h h = -xi*dimer_env%cg_rot%norm_theta + gam*dimer_env%cg_rot%norm_h*dimer_env%cg_rot%nvec_old h = h - DOT_PRODUCT(h, dimer_env%nvec)*dimer_env%nvec - norm_h = SQRT(DOT_PRODUCT(h, h)) + norm_h = NORM2(h) IF (norm_h < EPSILON(0.0_dp)) THEN h = 0.0_dp ELSE diff --git a/src/motion/cp_lbfgs.F b/src/motion/cp_lbfgs.F index 8d245095e5..99ff16249c 100644 --- a/src/motion/cp_lbfgs.F +++ b/src/motion/cp_lbfgs.F @@ -1460,8 +1460,9 @@ CONTAINS dtm = -f1/f2 tsum = zero nseg = 1 - IF (iprint >= 99) & + IF (iprint >= 99) THEN WRITE (wunit, 1011) nbreak + END IF nleft = nbreak iter = 1 @@ -3429,24 +3430,30 @@ CONTAINS ! algorithm enters the second stage. ftest = finit + stp*gtest - IF (stage == 1 .AND. f <= ftest .AND. g >= zero) & + IF (stage == 1 .AND. f <= ftest .AND. g >= zero) THEN stage = 2 + END IF ! Test for warnings. - IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) & + IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) THEN task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' - IF (brackt .AND. stmax - stmin <= xtol*stmax) & + END IF + IF (brackt .AND. stmax - stmin <= xtol*stmax) THEN task = 'WARNING: XTOL TEST SATISFIED' - IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) & + END IF + IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) THEN task = 'WARNING: STP = STPMAX' - IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) & + END IF + IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) THEN task = 'WARNING: STP = STPMIN' + END IF ! Test for convergence. - IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) & + IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) THEN task = 'CONVERGENCE' + END IF ! Test for termination. diff --git a/src/motion/cp_lbfgs_geo.F b/src/motion/cp_lbfgs_geo.F index ef4abb4441..83701fccc3 100644 --- a/src/motion/cp_lbfgs_geo.F +++ b/src/motion/cp_lbfgs_geo.F @@ -114,8 +114,9 @@ CONTAINS END IF ! Stop if not implemented - IF (gopt_env%type_id == default_ts_method_id) & + IF (gopt_env%type_id == default_ts_method_id) THEN CPABORT("BFGS method not yet working with DIMER") + END IF ALLOCATE (optimizer) CALL cp_opt_gopt_create(optimizer, para_env=para_env, obj_funct=gopt_env, & diff --git a/src/motion/cp_lbfgs_optimizer_gopt.F b/src/motion/cp_lbfgs_optimizer_gopt.F index 92fcd24488..decb8d6681 100644 --- a/src/motion/cp_lbfgs_optimizer_gopt.F +++ b/src/motion/cp_lbfgs_optimizer_gopt.F @@ -234,10 +234,12 @@ CONTAINS optimizer%gradient = 0.0_dp optimizer%dsave = 0.0_dp optimizer%work_array = 0.0_dp - IF (PRESENT(wanted_relative_f_delta)) & + IF (PRESENT(wanted_relative_f_delta)) THEN optimizer%wanted_relative_f_delta = wanted_relative_f_delta - IF (PRESENT(wanted_projected_gradient)) & + END IF + IF (PRESENT(wanted_projected_gradient)) THEN optimizer%wanted_projected_gradient = wanted_projected_gradient + END IF optimizer%kind_of_bound = 0 IF (PRESENT(kind_of_bound)) optimizer%kind_of_bound = kind_of_bound IF (PRESENT(lower_bound)) optimizer%lower_bound = lower_bound @@ -375,10 +377,12 @@ CONTAINS IF (PRESENT(obj_funct)) obj_funct = optimizer%obj_funct IF (PRESENT(m)) m = optimizer%m IF (PRESENT(max_f_per_iter)) max_f_per_iter = optimizer%max_f_per_iter - IF (PRESENT(wanted_projected_gradient)) & + IF (PRESENT(wanted_projected_gradient)) THEN wanted_projected_gradient = optimizer%wanted_projected_gradient - IF (PRESENT(wanted_relative_f_delta)) & + END IF + IF (PRESENT(wanted_relative_f_delta)) THEN wanted_relative_f_delta = optimizer%wanted_relative_f_delta + END IF IF (PRESENT(print_every)) print_every = optimizer%print_every IF (PRESENT(x)) x => optimizer%x IF (PRESENT(n_var)) n_var = SIZE(x) @@ -389,15 +393,17 @@ CONTAINS IF (PRESENT(last_f)) last_f = optimizer%last_f IF (PRESENT(f)) f = optimizer%f IF (PRESENT(at_end)) at_end = optimizer%status > 3 - IF (PRESENT(actual_projected_gradient)) & + IF (PRESENT(actual_projected_gradient)) THEN actual_projected_gradient = optimizer%projected_gradient + END IF IF (optimizer%master == optimizer%para_env%mepos) THEN IF (optimizer%isave(30) > 1 .AND. (optimizer%task(1:5) == "NEW_X" .OR. & optimizer%task(1:4) == "STOP" .AND. optimizer%task(7:9) == "CPU")) THEN ! nr iterations >1 .and. dsave contains the wanted data IF (PRESENT(last_f)) last_f = optimizer%dsave(2) - IF (PRESENT(actual_projected_gradient)) & + IF (PRESENT(actual_projected_gradient)) THEN actual_projected_gradient = optimizer%dsave(13) + END IF ELSE CPASSERT(.NOT. PRESENT(last_f)) CPASSERT(.NOT. PRESENT(actual_projected_gradient)) @@ -698,8 +704,7 @@ CONTAINS DEALLOCATE (xold) IF (PRESENT(f)) f = optimizer%f IF (PRESENT(last_f)) last_f = optimizer%last_f - IF (PRESENT(projected_gradient)) & - projected_gradient = optimizer%projected_gradient + IF (PRESENT(projected_gradient)) projected_gradient = optimizer%projected_gradient IF (PRESENT(n_iter)) n_iter = optimizer%n_iter CALL timestop(handle) @@ -735,8 +740,7 @@ CONTAINS IF (PRESENT(n_iter)) n_iter = NINT(results(1)) IF (PRESENT(f)) f = results(2) IF (PRESENT(last_f)) last_f = results(3) - IF (PRESENT(projected_gradient)) & - projected_gradient = results(4) + IF (PRESENT(projected_gradient)) projected_gradient = results(4) END SUBROUTINE cp_opt_gopt_bcast_res diff --git a/src/motion/dimer_methods.F b/src/motion/dimer_methods.F index c3b1e2c5cf..63b2ca9eba 100644 --- a/src/motion/dimer_methods.F +++ b/src/motion/dimer_methods.F @@ -197,10 +197,10 @@ CONTAINS END IF IF (debug_this_module .AND. (iw > 0)) THEN WRITE (iw, *) "final gradient:", gradient - WRITE (iw, '(A,F20.10)') "norm gradient:", SQRT(DOT_PRODUCT(gradient, gradient)) + WRITE (iw, '(A,F20.10)') "norm gradient:", NORM2(gradient) END IF IF (.NOT. gopt_env%do_line_search) THEN - f = SQRT(DOT_PRODUCT(gradient, gradient)) + f = NORM2(gradient) ELSE f = -DOT_PRODUCT(gradient, dimer_env%tsl%tls_vec) END IF @@ -237,7 +237,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) natoms = particles%n_els - norm_gradient_old = SQRT(DOT_PRODUCT(gradient, gradient)) + norm_gradient_old = NORM2(gradient) IF (norm_gradient_old > 0.0_dp) THEN IF (natoms > 1) THEN CALL rot_ana(particles%els, mat, dof, print_section, keep_rotations=.FALSE., & diff --git a/src/motion/dimer_types.F b/src/motion/dimer_types.F index 840a3acc4a..608a867801 100644 --- a/src/motion/dimer_types.F +++ b/src/motion/dimer_types.F @@ -193,8 +193,9 @@ CONTAINS CALL dimer_fixed_atom_control(dimer_env%nvec, subsys, unit_nr) ! Normalize dimer vector norm = SQRT(SUM(dimer_env%nvec**2)) - IF (norm <= EPSILON(0.0_dp)) & + IF (norm <= EPSILON(0.0_dp)) THEN CPABORT("The norm of the dimer vector is 0! Calculation cannot proceed further.") + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, "(T2,A,T9,A,T69,F12.6)") & "DIMER|", "Norm of dimer vector to be normalized by rescaling", norm @@ -414,8 +415,9 @@ CONTAINS CALL globenv%gaussian_rng_stream%fill(dimer_env%nvec) CASE (dimer_init_molden) CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CPABORT("INITIALIZATION_METHOD MOLDEN requires VIB_MOLDEN_NAME") + END IF CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", c_val=molden_name) IF (unit > 0) THEN WRITE (unit, "(/,T2,A,T9,A)") & @@ -441,11 +443,12 @@ CONTAINS CALL parser_get_next_line(parser, 1) READ (UNIT=parser%input_line, FMT=*, IOSTAT=ierr) & array_r(3*j - 2), array_r(3*j - 1), array_r(3*j) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CALL cp_abort(__LOCATION__, & "Error while reading MOLDEN file: cannot parse the line "// & TRIM(ADJUSTL(cp_to_string(j)))//" of <"//vib_name//"> "// & "for components of the normal mode") + END IF END DO dimer_env%nvec(:) = dimer_env%nvec(:) + array_r(:)*vib_wt_list(i) END DO Vib_modes diff --git a/src/motion/dimer_utils.F b/src/motion/dimer_utils.F index d5006aa274..9ecc75dfa1 100644 --- a/src/motion/dimer_utils.F +++ b/src/motion/dimer_utils.F @@ -120,7 +120,7 @@ CONTAINS REAL(KIND=dp), INTENT(OUT) :: norm gradient = gradient - DOT_PRODUCT(gradient, dimer_env%nvec)*dimer_env%nvec - norm = SQRT(DOT_PRODUCT(gradient, gradient)) + norm = NORM2(gradient) IF (norm < EPSILON(0.0_dp)) THEN ! This means that NVEC is totally aligned with minimum curvature mode gradient = 0.0_dp diff --git a/src/motion/dumpdcd.F b/src/motion/dumpdcd.F index 8117ddef9f..9db62af431 100644 --- a/src/motion/dumpdcd.F +++ b/src/motion/dumpdcd.F @@ -31,7 +31,8 @@ PROGRAM dumpdcd ! The output in DCD format is in binary format. ! The input coordinates should be in Angstrom. Velocities and forces are expected to be in atomic units. -! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding +! variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -618,9 +619,9 @@ PROGRAM dumpdcd gamma_dcd = gamma END IF ! Overwrite cell information from DCD header - a = SQRT(DOT_PRODUCT(hmat(1:3, 1), hmat(1:3, 1))) - b = SQRT(DOT_PRODUCT(hmat(1:3, 2), hmat(1:3, 2))) - c = SQRT(DOT_PRODUCT(hmat(1:3, 3), hmat(1:3, 3))) + a = NORM2(hmat(1:3, 1)) + b = NORM2(hmat(1:3, 2)) + c = NORM2(hmat(1:3, 3)) ! Lattice vectors from DCD headers of VEL files are atomic units, but the CP2K cell file is in Angstrom IF (unit_string == "[a.u.]") THEN a = a/angstrom @@ -1014,8 +1015,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = SQRT(DOT_PRODUCT(a, a)) - length_of_b = SQRT(DOT_PRODUCT(b, b)) + length_of_a = NORM2(a) + length_of_b = NORM2(b) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion/free_energy_methods.F b/src/motion/free_energy_methods.F index dc4f234ead..1af3620815 100644 --- a/src/motion/free_energy_methods.F +++ b/src/motion/free_energy_methods.F @@ -136,10 +136,11 @@ CONTAINS CASE (do_fe_ac) CALL initf(2) ! Alchemical Changes - IF (.NOT. ASSOCIATED(force_env%mixed_env)) & + IF (.NOT. ASSOCIATED(force_env%mixed_env)) THEN CALL cp_abort(__LOCATION__, & 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)// & ' Free Energy calculations require the definition of a mixed env!') + END IF my_par => force_env%mixed_env%par my_val => force_env%mixed_env%val dx = force_env%mixed_env%dx diff --git a/src/motion/geo_opt.F b/src/motion/geo_opt.F index af142047e5..0a1aec4be0 100644 --- a/src/motion/geo_opt.F +++ b/src/motion/geo_opt.F @@ -103,8 +103,9 @@ CONTAINS ! Reset counter for next iteration, unless rm_restart_info==.FALSE. my_rm_restart_info = .TRUE. IF (PRESENT(rm_restart_info)) my_rm_restart_info = rm_restart_info - IF (my_rm_restart_info) & + IF (my_rm_restart_info) THEN CALL section_vals_val_set(geo_section, "STEP_START_VAL", i_val=0) + END IF DEALLOCATE (x0) CALL gopt_f_release(gopt_env) diff --git a/src/motion/glbopt_callback.F b/src/motion/glbopt_callback.F index 5c65c43d7c..a42d2bfc12 100644 --- a/src/motion/glbopt_callback.F +++ b/src/motion/glbopt_callback.F @@ -69,18 +69,21 @@ CONTAINS ! check if we passed a minimum passed_minimum = .TRUE. DO i = 1, mdctrl_data%bump_steps_upwards - IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) & + IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) THEN passed_minimum = .FALSE. + END IF END DO DO i = mdctrl_data%bump_steps_upwards + 1, mdctrl_data%bump_steps_upwards + mdctrl_data%bump_steps_downwards - IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) & + IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) THEN passed_minimum = .FALSE. + END IF END DO ! count the passed bumps and stop md_run when md_bumps_max is reached. - IF (passed_minimum) & + IF (passed_minimum) THEN mdctrl_data%md_bump_counter = mdctrl_data%md_bump_counter + 1 + END IF IF (mdctrl_data%md_bump_counter >= mdctrl_data%md_bumps_max) THEN should_stop = .TRUE. diff --git a/src/motion/gopt_f77_methods.F b/src/motion/gopt_f77_methods.F index 8d5b6727fd..e7483d533b 100644 --- a/src/motion/gopt_f77_methods.F +++ b/src/motion/gopt_f77_methods.F @@ -171,12 +171,13 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & CALL unpack_subsys_particles(subsys=subsys, r=x) CASE (default_cell_method_id) ! Check for VIRIAL - IF (.NOT. virial%pv_availability) & + IF (.NOT. virial%pv_availability) THEN CALL cp_abort(__LOCATION__, & "For a cell optimization task with CELL_OPT/TYPE "// & "DIRECT_CELL_OPT, the FORCE_EVAL/STRESS_TENSOR "// & "keyword MUST be defined in the input file for the "// & "evaluation of the stress tensor, but none is found!") + END IF IF (gopt_env%cell_env%keep_volume) THEN nparticle = force_env_get_nparticle(gopt_env%force_env) idg = 3*nparticle @@ -228,8 +229,9 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & ! some callers expect pres_int to be available on all ranks. Also, here master is not necessarily a single rank. ! Assume at least master==0 CALL para_env%bcast(gopt_env%cell_env%pres_int, 0) - IF (gopt_env%cell_env%constraint_id /= fix_none) & + IF (gopt_env%cell_env%constraint_id /= fix_none) THEN CALL para_env%bcast(gopt_env%cell_env%pres_constr, 0) + END IF END IF END BLOCK CASE (default_shellcore_method_id) diff --git a/src/motion/gopt_f_methods.F b/src/motion/gopt_f_methods.F index 65682a68ca..bf385d8762 100644 --- a/src/motion/gopt_f_methods.F +++ b/src/motion/gopt_f_methods.F @@ -112,10 +112,12 @@ CONTAINS CASE (default_minimization_method_id, default_ts_method_id) CALL force_env_get(gopt_env%force_env, subsys=subsys) ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) & + IF (gopt_env%force_env%in_use == use_qmmm) THEN CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - IF (gopt_env%force_env%in_use == use_qmmmx) & + END IF + IF (gopt_env%force_env%in_use == use_qmmmx) THEN CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) + END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -124,10 +126,12 @@ CONTAINS ! Store reference cell gopt_env%h_ref = cell%hmat ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) & + IF (gopt_env%force_env%in_use == use_qmmm) THEN CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - IF (gopt_env%force_env%in_use == use_qmmmx) & + END IF + IF (gopt_env%force_env%in_use == use_qmmmx) THEN CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) + END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle + 6)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -670,7 +674,7 @@ CONTAINS IF (PRESENT(pres_diff_constr) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff_constr) < ABS(pres_tol) - ELSEIF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN + ELSE IF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff) < ABS(pres_tol) END IF @@ -896,8 +900,9 @@ CONTAINS CALL write_structure_data(particle_set, cell, motion_section) CALL write_restart(force_env=force_env, root_section=root_section) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(/,T20,' Reevaluating energy at the minimum')") + END IF CALL cp_eval_at(gopt_env, x0, f=etot, master=master, final_evaluation=.TRUE., & para_env=para_env) diff --git a/src/motion/helium_common.F b/src/motion/helium_common.F index d979d518fd..f37fda09d0 100644 --- a/src/motion/helium_common.F +++ b/src/motion/helium_common.F @@ -94,21 +94,21 @@ CONTAINS rx = r(1)*cell_size_inv IF (rx > 0.5_dp) THEN rx = rx - REAL(INT(rx + 0.5_dp), dp) - ELSEIF (rx < -0.5_dp) THEN + ELSE IF (rx < -0.5_dp) THEN rx = rx - REAL(INT(rx - 0.5_dp), dp) END IF ry = r(2)*cell_size_inv IF (ry > 0.5_dp) THEN ry = ry - REAL(INT(ry + 0.5_dp), dp) - ELSEIF (ry < -0.5_dp) THEN + ELSE IF (ry < -0.5_dp) THEN ry = ry - REAL(INT(ry - 0.5_dp), dp) END IF rz = r(3)*cell_size_inv IF (rz > 0.5_dp) THEN rz = rz - REAL(INT(rz + 0.5_dp), dp) - ELSEIF (rz < -0.5_dp) THEN + ELSE IF (rz < -0.5_dp) THEN rz = rz - REAL(INT(rz - 0.5_dp), dp) END IF diff --git a/src/motion/helium_interactions.F b/src/motion/helium_interactions.F index d987d46f6f..2544940b5e 100644 --- a/src/motion/helium_interactions.F +++ b/src/motion/helium_interactions.F @@ -765,7 +765,7 @@ CONTAINS DO i_com = 1, helium%nnp%n_committee !loop over committee members ! Predict energy CALL nnp_predict(helium%nnp%arc(ind), helium%nnp, i_com) - helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) ! + helium%nnp%atom_energies(ind) + helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) !Gradients IF (PRESENT(force)) THEN @@ -1068,7 +1068,7 @@ CONTAINS p = np db = db - 1 END DO - ELSEIF (delta_bead < 0) THEN + ELSE IF (delta_bead < 0) THEN bead = ref_bead p = part db = delta_bead diff --git a/src/motion/helium_sampling.F b/src/motion/helium_sampling.F index 3733c09a9d..252ada46cc 100644 --- a/src/motion/helium_sampling.F +++ b/src/motion/helium_sampling.F @@ -661,7 +661,7 @@ CONTAINS IF (x >= 0.01_dp) EXIT END DO z = -LOG(0.01_dp) - y = LOG(x)/z + 1.0_dp; + y = LOG(x)/z + 1.0_dp cyclen = INT(helium%maxcycle*y) + 1 IF (cyclen /= helium%m_value) EXIT END DO diff --git a/src/motion/helium_types.F b/src/motion/helium_types.F index 835b11bcec..aeed271a61 100644 --- a/src/motion/helium_types.F +++ b/src/motion/helium_types.F @@ -121,7 +121,8 @@ MODULE helium_types REAL(KIND=dp), DIMENSION(3) :: origin = 0.0_dp!< origin of the cell (first voxel position) REAL(KIND=dp) :: droplet_radius = 0.0_dp !< radius of the droplet - REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of periodic cell (if periodic) or COM of helium + REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of + ! periodic cell (if periodic) or COM of helium INTEGER :: sampling_method = helium_sampling_ceperley ! worm sampling parameters @@ -151,7 +152,8 @@ MODULE helium_types LOGICAL :: worm_is_closed = .FALSE.!before isector=1 -> open; isector=0 -> closed INTEGER :: iter_norot = 0!< number of iterations to try for a given imaginary time slice rotation (num inner MC loop iters) - INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) (num outer MC loop iters) + INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) + ! (num outer MC loop iters) ! INTEGER :: maxcycle = 0!< maximum cyclic permutation change to attempt INTEGER :: m_dist_type = 0!< distribution from which the cycle length m is sampled @@ -186,7 +188,8 @@ MODULE helium_types INTEGER(KIND=int_8) :: accepts = 0_int_8!< number of accepted new configurations ! REAL(KIND=dp), DIMENSION(:, :), POINTER :: tmatrix => NULL()!< ? permutation probability related - REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related [use might change/new ones added/etc] + REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related + ! [use might change/new ones added/etc] REAL(KIND=dp) :: pweight = 0.0_dp!< ? permutation probability related REAL(KIND=dp), DIMENSION(:, :), POINTER :: ipmatrix => NULL() INTEGER, DIMENSION(:, :), POINTER :: nmatrix => NULL() @@ -208,7 +211,8 @@ MODULE helium_types TYPE(helium_vector_type) :: prarea2 = helium_vector_type()!< projected area squared TYPE(helium_vector_type) :: mominer = helium_vector_type()!< moment of inertia INTEGER :: averages_iweight = 0!< weight for restarted averages - LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages have been restarted + LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages + ! have been restarted REAL(KIND=dp) :: link_action = 0.0_dp, inter_action = 0.0_dp, pair_action = 0.0_dp @@ -266,8 +270,10 @@ MODULE helium_types INTEGER :: solute_beads = 0!< number of solute beads (pint_env%p) INTEGER :: get_helium_forces = 0!< parameter to determine whether the average or last MC force should be taken to MD CHARACTER(LEN=2), DIMENSION(:), POINTER :: solute_element => NULL()!< element names of solute atoms (pint_env%ndim/3) - TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) (should be removed at some point) - REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent on the solute DIM(p,ndim) + TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) + ! (should be removed at some point) + REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent + ! on the solute DIM(p,ndim) REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_inst => NULL()!< instantaneous forces exerted by He on the solute (p,ndim) CHARACTER(LEN=2), DIMENSION(:), POINTER :: ename => NULL() INTEGER :: enum = 0 diff --git a/src/motion/input_cp2k_restarts.F b/src/motion/input_cp2k_restarts.F index f2db450a6f..13a66afdc8 100644 --- a/src/motion/input_cp2k_restarts.F +++ b/src/motion/input_cp2k_restarts.F @@ -231,7 +231,7 @@ CONTAINS IF (PRESENT(md_env)) THEN CALL get_md_env(md_env=md_env, force_env=my_force_env) - ELSEIF (PRESENT(force_env)) THEN + ELSE IF (PRESENT(force_env)) THEN my_force_env => force_env END IF @@ -551,9 +551,9 @@ CONTAINS ELSE IF (ASSOCIATED(force_env)) THEN para_env => force_env%para_env - ELSEIF (PRESENT(pint_env)) THEN + ELSE IF (PRESENT(pint_env)) THEN para_env => pint_env%logger%para_env - ELSEIF (PRESENT(helium_env)) THEN + ELSE IF (PRESENT(helium_env)) THEN ! Only needed in case that pure helium is simulated ! In this case write_restart is called only by processors ! with associated helium_env @@ -995,7 +995,7 @@ CONTAINS CALL section_vals_val_set(pint_section, "NOSE%VELOCITY%_DEFAULT_KEYWORD_", & r_vals_ptr=r_vals) - ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (tmpsec) tmpsec => section_vals_get_subs_vals(pint_section, "GLE") @@ -1326,8 +1326,9 @@ CONTAINS WRITE (stmp, *) reqlen err_str = TRIM(ADJUSTL(err_str))// & TRIM(ADJUSTL(stmp))//"'." - IF (msgLEN /= reqlen) & + IF (msgLEN /= reqlen) THEN CPABORT(err_str) + END IF ! allocate the buffer to be saved and fill it with forces ! forces should be the same on all processors, but we don't check that here @@ -1458,9 +1459,10 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(work_section%values, 2) == 1) EXIT @@ -1938,9 +1940,10 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT CALL section_vals_add_values(coord_section) @@ -2065,9 +2068,10 @@ CONTAINS CPASSERT(ss_section%ref_count > 0) section => ss_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(ss_section%values, 2) == 1) EXIT CALL section_vals_add_values(ss_section) @@ -2135,9 +2139,10 @@ CONTAINS CPASSERT(ds_section%ref_count > 0) section => ds_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(ds_section%values, 2) == 1) EXIT CALL section_vals_add_values(ds_section) @@ -2204,9 +2209,10 @@ CONTAINS CPASSERT(ww_section%ref_count > 0) section => ww_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(ww_section%values, 2) == 1) EXIT CALL section_vals_add_values(ww_section) @@ -2270,9 +2276,10 @@ CONTAINS CPASSERT(invdt_section%ref_count > 0) section => invdt_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) & + IF (ik == -2) THEN CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") + END IF DO IF (SIZE(invdt_section%values, 2) == 1) EXIT CALL section_vals_add_values(invdt_section) diff --git a/src/motion/integrator.F b/src/motion/integrator.F index 96de427a30..a8bd19ad1f 100644 --- a/src/motion/integrator.F +++ b/src/motion/integrator.F @@ -195,8 +195,9 @@ CONTAINS nshell=nshell, & particles=particles, & virial=virial) - IF (nshell /= 0) & + IF (nshell /= 0) THEN CPABORT("Langevin dynamics is not yet implemented for core-shell models") + END IF nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1651,10 +1652,11 @@ CONTAINS ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the Trajectory frames in the TRAJECTORY file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") + END IF END IF ! Read cell parameters from cell file if requested and if not yet available @@ -1664,10 +1666,11 @@ CONTAINS CPASSERT(trj_itimes == cell_itimes) ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the cell info frames in the CELL file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") + END IF END IF END IF @@ -2527,9 +2530,10 @@ CONTAINS core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial - IF (simpar%constraint) & + IF (simpar%constraint) THEN CALL pv_constraint(gci, local_molecules, molecule_set, & molecule_kind_set, particle_set, virial, para_env) + END IF CALL virial_evaluate(atomic_kind_set, particle_set, & local_particles, virial, para_env) diff --git a/src/motion/integrator_utils.F b/src/motion/integrator_utils.F index eb6f960915..0e567938f2 100644 --- a/src/motion/integrator_utils.F +++ b/src/motion/integrator_utils.F @@ -969,8 +969,8 @@ CONTAINS npt(:, :)%f = (1.0_dp + (3.0_dp*infree))*kin + fdotr - & 3.0_dp*simpar%p_ext*box%deth - ELSEIF (simpar%ensemble == npt_f_ensemble .OR. & - simpar%ensemble == npe_f_ensemble) THEN + ELSE IF (simpar%ensemble == npt_f_ensemble .OR. & + simpar%ensemble == npe_f_ensemble) THEN npt(:, :)%f = virial%pv_virial(:, :) + & pv_kin(:, :) + virial%pv_constraint(:, :) - & unit(:, :)*simpar%p_ext*box%deth + & @@ -980,8 +980,8 @@ CONTAINS trace = trace/3.0_dp npt(:, :)%f = trace*unit(:, :) END IF - ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. & - simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. & + simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v = box%deth vi = 1._dp/v v0 = simpar%v0 diff --git a/src/motion/mc/mc_control.F b/src/motion/mc/mc_control.F index 7a9ca26164..e55faf23dd 100644 --- a/src/motion/mc/mc_control.F +++ b/src/motion/mc/mc_control.F @@ -372,8 +372,9 @@ CONTAINS CALL destroy_force_env(f_env_id, ierr, .FALSE.) IF (ierr /= 0) CPABORT("mc_create_force_env: destroy_force_env failed") - IF (PRESENT(globenv_new)) & + IF (PRESENT(globenv_new)) THEN CALL force_env_get(force_env, globenv=globenv_new) + END IF END SUBROUTINE mc_create_force_env @@ -408,9 +409,10 @@ CONTAINS TYPE(mc_input_file_type), POINTER :: mc_input_file LOGICAL, INTENT(IN) :: ionode - IF (ionode) & + IF (ionode) THEN CALL mc_make_dat_file_new(r(:, :), atom_symbols, nunits_tot, & box_length(:), 'bias_temp.dat', nchains(:), mc_input_file) + END IF CALL mc_create_force_env(bias_env, input_declaration, para_env, 'bias_temp.dat') diff --git a/src/motion/mc/mc_coordinates.F b/src/motion/mc/mc_coordinates.F index d675054f4d..68c12b10bf 100644 --- a/src/motion/mc/mc_coordinates.F +++ b/src/motion/mc/mc_coordinates.F @@ -516,7 +516,7 @@ CONTAINS IF (exponent > exp_max_val) THEN boltz_weights(imove) = max_val - ELSEIF (exponent < exp_min_val) THEN + ELSE IF (exponent < exp_min_val) THEN boltz_weights(imove) = min_val ELSE boltz_weights(imove) = EXP(exponent) @@ -587,8 +587,9 @@ CONTAINS END IF ! make sure a configuration was chosen - IF (choosen == 0) & + IF (choosen == 0) THEN CPABORT('CBMC swap move failed to select config') + END IF ! if this is an old configuration, we always choose the first one IF (lremove) choosen = 1 @@ -761,7 +762,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSEIF (PRESENT(box)) THEN + ELSE IF (PRESENT(box)) THEN ! any molecule in box...need to find molecule type and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(:, box)), KIND=dp)) @@ -779,7 +780,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSEIF (PRESENT(molecule_type_old)) THEN + ELSE IF (PRESENT(molecule_type_old)) THEN ! any molecule of type molecule_type_old...need to find box number and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(molecule_type_old, :)), KIND=dp)) diff --git a/src/motion/mc/mc_ensembles.F b/src/motion/mc/mc_ensembles.F index 87c18a4743..1b9c1650ca 100644 --- a/src/motion/mc/mc_ensembles.F +++ b/src/motion/mc/mc_ensembles.F @@ -426,8 +426,9 @@ CONTAINS ! if we're doing a discrete volume move, we need to set up the array ! that keeps track of which direction we can move in IF (ldiscrete) THEN - IF (nboxes /= 1) & + IF (nboxes /= 1) THEN CPABORT('ldiscrete=.true. ONLY for systems with 1 box') + END IF CALL create_discrete_array(abc(:, 1), discrete_array(:, :), & discrete_step) END IF @@ -549,7 +550,7 @@ CONTAINS END DO END IF - ELSEIF (rand < pmswap) THEN + ELSE IF (rand < pmswap) THEN ! try a swap move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN @@ -569,7 +570,7 @@ CONTAINS mol_type=mol_type, nchain_total=nchain_total, nunits=nunits, & atom_names=atom_names, mass=mass) - ELSEIF (rand < pmhmc) THEN + ELSE IF (rand < pmhmc) THEN ! try hybrid Monte Carlo IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting a hybrid Monte Carlo move" @@ -595,7 +596,7 @@ CONTAINS energy_check(box_number), r_old(:, :, box_number), & rng_stream) - ELSEIF (rand < pmavbmc) THEN + ELSE IF (rand < pmavbmc) THEN ! try an AVBMC move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting an AVBMC1 move" @@ -626,8 +627,9 @@ CONTAINS EXIT END IF END DO - IF (molecule_type_swap == 0) & + IF (molecule_type_swap == 0) THEN CPABORT('Did not choose a molecule type to swap...check AVBMC input') + END IF ! now pick a molecule, automatically rejecting the move if the ! box is empty or only has one molecule @@ -749,8 +751,8 @@ CONTAINS ! figure out what kind of move we're doing IF (rand < conf_prob(1, molecule_type)) THEN move_type = 'bond' - ELSEIF (rand < (conf_prob(1, molecule_type) + & - conf_prob(2, molecule_type))) THEN + ELSE IF (rand < (conf_prob(1, molecule_type) + & + conf_prob(2, molecule_type))) THEN move_type = 'angle' ELSE move_type = 'dihedral' @@ -766,7 +768,7 @@ CONTAINS move_type, lreject, rng_stream) IF (lreject) EXIT END IF - ELSEIF (rand < pmtrans) THEN + ELSE IF (rand < pmtrans) THEN ! translate a whole molecule in the system ! pick a molecule type IF (ionode) rand = rng_stream%next() @@ -783,10 +785,11 @@ CONTAINS 'Did not choose a molecule type to translate...PMTRANS_MOL should not be all 0.0') ! now pick a molecule of that type - IF (ionode) & + IF (ionode) THEN CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) + END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -798,7 +801,7 @@ CONTAINS start_atom, box_number, bias_energy(box_number), & molecule_type, lreject, rng_stream) IF (lreject) EXIT - ELSEIF (rand < pmcltrans) THEN + ELSE IF (rand < pmcltrans) THEN ! translate a whole cluster in the system ! first, pick a box to do it for IF (ionode) rand = rng_stream%next() @@ -835,10 +838,11 @@ CONTAINS __LOCATION__, & 'Did not choose a molecule type to rotate...PMROT_MOL should not be all 0.0') - IF (ionode) & + IF (ionode) THEN CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) + END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -1271,9 +1275,10 @@ CONTAINS CPABORT('The box needs to be cubic for a virial calculation (it is easiest).') END IF IF (virial_cutoffs(nintegral_divisions) > abc(1)/2.0E0_dp) THEN - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, *) "Box length ", abc(1)*angstrom, " virial cutoff ", & - virial_cutoffs(nintegral_divisions)*angstrom + virial_cutoffs(nintegral_divisions)*angstrom + END IF CPABORT('You need a bigger box to deal with this virial cutoff (see above).') END IF @@ -1371,7 +1376,7 @@ CONTAINS IF (exponent > exp_max_val) THEN exponent = exp_max_val - ELSEIF (exponent < exp_min_val) THEN + ELSE IF (exponent < exp_min_val) THEN exponent = exp_min_val END IF mayer(itemp, ibin) = mayer(itemp, ibin) + EXP(exponent) - 1.0_dp @@ -1382,8 +1387,9 @@ CONTAINS END DO ! write out some info that keeps track of where we are IF (iw > 0) THEN - IF (MOD(ivirial, iprint) == 0) & + IF (MOD(ivirial, iprint) == 0) THEN WRITE (iw, '(A,I6,A,I6)') ' Done with config ', ivirial, ' out of ', nvirial + END IF END IF END DO diff --git a/src/motion/mc/mc_ge_moves.F b/src/motion/mc/mc_ge_moves.F index fad365147d..09393baaea 100644 --- a/src/motion/mc/mc_ge_moves.F +++ b/src/motion/mc/mc_ge_moves.F @@ -242,8 +242,9 @@ CONTAINS end_mol = start_mol + SUM(nchains(:, ibox)) - 1 CALL check_for_overlap(bias_env(ibox)%force_env, & nchains(:, ibox), nunits(:), loverlap, mol_type(start_mol:end_mol)) - IF (loverlap) & + IF (loverlap) THEN CPABORT('Quickstep move found an overlap in the old config') + END IF END IF bias_energy_old(ibox) = last_bias_energy(ibox) END DO @@ -254,7 +255,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= -1.0E-8) THEN w = 1.0_dp - ELSEIF (energies <= -500.0_dp) THEN + ELSE IF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -272,7 +273,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= 0.0_dp) THEN w = 1.0_dp - ELSEIF (energies <= -500.0_dp) THEN + ELSE IF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -367,9 +368,10 @@ CONTAINS DO iparticle = 1, nunits_tot(ibox) particles(ibox)%list%els(iparticle)%r(1:3) = & r_old(1:3, iparticle, ibox) - IF (lbias .AND. box_flag(ibox) == 1) & + IF (lbias .AND. box_flag(ibox) == 1) THEN particles_bias(ibox)%list%els(iparticle)%r(1:3) = & - r_old(1:3, iparticle, ibox) + r_old(1:3, iparticle, ibox) + END IF END DO END DO @@ -386,9 +388,10 @@ CONTAINS DO ibox = 1, nboxes CALL cp_subsys_set(subsys(ibox)%subsys, & particles=particles(ibox)%list) - IF (lbias .AND. box_flag(ibox) == 1) & + IF (lbias .AND. box_flag(ibox) == 1) THEN CALL cp_subsys_set(subsys_bias(ibox)%subsys, & particles=particles_bias(ibox)%list) + END IF END DO ! deallocate some stuff @@ -991,7 +994,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSEIF (del_quickstep_energy < exp_min_val) THEN + ELSE IF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = min_val ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -1245,11 +1248,13 @@ CONTAINS ! add to one box, subtract from the other IF (old_cell_length(1, 1)*old_cell_length(2, 1)* & - old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) & + old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN CPABORT('GE_volume moves are trying to make box 1 smaller than 3') + END IF IF (old_cell_length(1, 2)*old_cell_length(2, 2)* & - old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) & + old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN CPABORT('GE_volume moves are trying to make box 2 smaller than 3') + END IF DO iside = 1, 3 new_cell_length(iside, 1) = (old_cell_length(1, 1)**3 + & diff --git a/src/motion/mc/mc_move_control.F b/src/motion/mc/mc_move_control.F index eeb70485d6..7e5d6426bb 100644 --- a/src/motion/mc/mc_move_control.F +++ b/src/motion/mc/mc_move_control.F @@ -401,8 +401,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_bond%successes == 0) THEN rmbond(molecule_type) = rmbond(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_bond%successes == & - move_updates%bias_bond%attempts) THEN + ELSE IF (move_updates%bias_bond%successes == & + move_updates%bias_bond%attempts) THEN rmbond(molecule_type) = rmbond(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -429,8 +429,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_angle%successes == 0) THEN rmangle(molecule_type) = rmangle(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_angle%successes == & - move_updates%bias_angle%attempts) THEN + ELSE IF (move_updates%bias_angle%successes == & + move_updates%bias_angle%attempts) THEN rmangle(molecule_type) = rmangle(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -459,8 +459,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_dihedral%successes == 0) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_dihedral%successes == & - move_updates%bias_dihedral%attempts) THEN + ELSE IF (move_updates%bias_dihedral%successes == & + move_updates%bias_dihedral%attempts) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -489,8 +489,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_trans%successes == 0) THEN rmtrans(molecule_type) = rmtrans(molecule_type)/2.0E0_dp - ELSEIF (move_updates%bias_trans%successes == & - move_updates%bias_trans%attempts) THEN + ELSE IF (move_updates%bias_trans%successes == & + move_updates%bias_trans%attempts) THEN rmtrans(molecule_type) = rmtrans(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -502,8 +502,9 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmtrans(molecule_type) > 10.0E0_dp) & + IF (rmtrans(molecule_type) > 10.0E0_dp) THEN rmtrans(molecule_type) = 10.0E0_dp + END IF ! clear the counters move_updates%bias_trans%attempts = 0 @@ -520,8 +521,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_cltrans%successes == 0) THEN rmcltrans = rmcltrans/2.0E0_dp - ELSEIF (move_updates%bias_cltrans%successes == & - move_updates%bias_cltrans%attempts) THEN + ELSE IF (move_updates%bias_cltrans%successes == & + move_updates%bias_cltrans%attempts) THEN rmcltrans = rmcltrans*2.0E0_dp ELSE ! now for the middle case @@ -533,8 +534,9 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmcltrans > 10.0E0_dp) & + IF (rmcltrans > 10.0E0_dp) THEN rmcltrans = 10.0E0_dp + END IF ! clear the counters move_updates%bias_cltrans%attempts = 0 @@ -554,8 +556,8 @@ CONTAINS IF (rmrot(molecule_type) > pi) rmrot(molecule_type) = pi - ELSEIF (move_updates%bias_rot%successes == & - move_updates%bias_rot%attempts) THEN + ELSE IF (move_updates%bias_rot%successes == & + move_updates%bias_rot%attempts) THEN rmrot(molecule_type) = rmrot(molecule_type)*2.0E0_dp ! more than pi rotation is meaningless @@ -592,8 +594,8 @@ CONTAINS IF (move_updates%volume%successes == 0) THEN rmvolume = rmvolume/2.0E0_dp - ELSEIF (move_updates%volume%successes == & - move_updates%volume%attempts) THEN + ELSE IF (move_updates%volume%successes == & + move_updates%volume%attempts) THEN rmvolume = rmvolume*2.0E0_dp ELSE ! now for the middle case diff --git a/src/motion/mc/mc_moves.F b/src/motion/mc/mc_moves.F index bced55b54c..aabf5bcf1f 100644 --- a/src/motion/mc/mc_moves.F +++ b/src/motion/mc/mc_moves.F @@ -261,7 +261,7 @@ CONTAINS CALL change_bond_length(r_old, r_new, mc_par, molecule_type, & molecule_kind, dis_length, particles, rng_stream) - ELSEIF (move_type == 'angle') THEN + ELSE IF (move_type == 'angle') THEN ! record the attempt moves%angle%attempts = moves%angle%attempts + 1 @@ -338,7 +338,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value)*dis_length**2 @@ -366,7 +366,7 @@ CONTAINS moves%bias_bond%successes = moves%bias_bond%successes + 1 move_updates%bias_bond%successes = & move_updates%bias_bond%successes + 1 - ELSEIF (move_type == 'angle') THEN + ELSE IF (move_type == 'angle') THEN moves%angle%qsuccesses = moves%angle%qsuccesses + 1 move_updates%angle%successes = & move_updates%angle%successes + 1 @@ -581,7 +581,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -780,7 +780,7 @@ CONTAINS IF (dir == 1) THEN lx = .TRUE. - ELSEIF (dir == 2) THEN + ELSE IF (dir == 2) THEN ly = .TRUE. END IF @@ -822,7 +822,7 @@ CONTAINS particles%els(iunit)%r(3) = rznew + nzcm END DO - ELSEIF (ly) THEN + ELSE IF (ly) THEN ! *** ROTATE UNITS OF I AROUND y-AXIS *** @@ -884,7 +884,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1208,8 +1208,9 @@ CONTAINS END IF END IF CALL group%bcast(ltoo_small, source) - IF (ltoo_small) & + IF (ltoo_small) THEN CPABORT("Attempted a volume move where box size got too small.") + END IF ! now compute the energy CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) @@ -1227,7 +1228,7 @@ CONTAINS value = -BETA*(energy_term + volume_term + pressure_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1374,7 +1375,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSEIF (bond_list(ibond)%b == iatom) THEN + ELSE IF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1421,7 +1422,7 @@ CONTAINS ! notice we weight by the opposite masses...therefore lighter segments ! will move further - old_length = SQRT(DOT_PRODUCT(bond_a, bond_a)) + old_length = NORM2(bond_a) new_length_a = dis_length*mass_b/(mass_a + mass_b) new_length_b = dis_length*mass_a/(mass_a + mass_b) @@ -1543,7 +1544,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSEIF (bond_list(ibond)%b == iatom) THEN + ELSE IF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1591,15 +1592,15 @@ CONTAINS bond_c(i) = r_new(i, bend_list(bend_number)%c) - & r_new(i, bend_list(bend_number)%b) END DO - old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) - old_length_c = SQRT(DOT_PRODUCT(bond_c, bond_c)) + old_length_a = NORM2(bond_a) + old_length_c = NORM2(bond_c) old_angle = ACOS(DOT_PRODUCT(bond_a, bond_c)/(old_length_a*old_length_c)) DO i = 1, 3 bisector(i) = bond_a(i)/old_length_a + & ! not yet normalized bond_c(i)/old_length_c END DO - bis_length = SQRT(DOT_PRODUCT(bisector, bisector)) + bis_length = NORM2(bisector) bisector(1:3) = bisector(1:3)/bis_length ! now we need to find the cross product of the B-A and B-C vectors and normalize @@ -1607,14 +1608,14 @@ CONTAINS cross_prod(1) = bond_a(2)*bond_c(3) - bond_a(3)*bond_c(2) cross_prod(2) = bond_a(3)*bond_c(1) - bond_a(1)*bond_c(3) cross_prod(3) = bond_a(1)*bond_c(2) - bond_a(2)*bond_c(1) - cross_prod(1:3) = cross_prod(1:3)/SQRT(DOT_PRODUCT(cross_prod, cross_prod)) + cross_prod(1:3) = cross_prod(1:3)/NORM2(cross_prod) ! we have two axis of a coordinate system...let's get the third cross_prod_plane(1) = cross_prod(2)*bisector(3) - cross_prod(3)*bisector(2) cross_prod_plane(2) = cross_prod(3)*bisector(1) - cross_prod(1)*bisector(3) cross_prod_plane(3) = cross_prod(1)*bisector(2) - cross_prod(2)*bisector(1) cross_prod_plane(1:3) = cross_prod_plane(1:3)/ & - SQRT(DOT_PRODUCT(cross_prod_plane, cross_prod_plane)) + NORM2(cross_prod_plane) ! now bisector is x, cross_prod_plane is the y vector (pointing towards c), ! and cross_prod is z @@ -1636,7 +1637,7 @@ CONTAINS temp(1:3) = r_new(1:3, iatom) - & DOT_PRODUCT(cross_prod(1:3), r_new(1:3, iatom))* & cross_prod(1:3) - temp_length = SQRT(DOT_PRODUCT(temp, temp)) + temp_length = NORM2(temp) ! we can now compute all three components of the new bond vector along the ! axis defined above @@ -1667,7 +1668,7 @@ CONTAINS cross_prod(1:3) END IF - ELSEIF (atom_c(iatom) == 1) THEN + ELSE IF (atom_c(iatom) == 1) THEN ! if the y-coordinate is less than zero, we need to switch the sign when we make the vector, ! as the angle computed by the dot product can't distinguish between that @@ -1805,7 +1806,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSEIF (bond_list(ibond)%b == iatom) THEN + ELSE IF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1846,7 +1847,7 @@ CONTAINS bond_a(i) = r_new(i, torsion_list(torsion_number)%c) - & r_new(i, torsion_list(torsion_number)%b) END DO - old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) + old_length_a = NORM2(bond_a) bond_a(1:3) = bond_a(1:3)/old_length_a ! figure out how much we move each side, since we're mass-weighting, by the @@ -1880,7 +1881,7 @@ CONTAINS temp(1:3) = temp(1:3) + r_new(1:3, torsion_list(torsion_number)%b) r_new(1:3, iatom) = temp(1:3) - ELSEIF (atom_d(iatom) == 1) THEN + ELSE IF (atom_d(iatom) == 1) THEN ! shift the coords so c is at the origin r_new(1:3, iatom) = r_new(1:3, iatom) - & @@ -2214,7 +2215,7 @@ CONTAINS .NOT. lin .AND. move_type == 'out') THEN ! standard Metropolis rule prefactor = 1.0_dp - ELSEIF (.NOT. lin .AND. move_type == 'in') THEN + ELSE IF (.NOT. lin .AND. move_type == 'in') THEN prefactor = (1.0_dp - pbias(molecule_type))*volume_in/(pbias(molecule_type)*volume_out) ELSE prefactor = pbias(molecule_type)*volume_out/((1.0_dp - pbias(molecule_type))*volume_in) @@ -2229,7 +2230,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSEIF (del_quickstep_energy < exp_min_val) THEN + ELSE IF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = 0.0_dp ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -2416,7 +2417,7 @@ CONTAINS value = -BETA*(energy_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -2674,7 +2675,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/mc/mc_types.F b/src/motion/mc/mc_types.F index 71b691a80f..25ace61db2 100644 --- a/src/motion/mc/mc_types.F +++ b/src/motion/mc/mc_types.F @@ -1751,8 +1751,9 @@ CONTAINS rcutsq_max = 0.0e0_dp DO itype = 1, SIZE(potparm%pot, 1) DO jtype = itype, SIZE(potparm%pot, 2) - IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) & + IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) THEN rcutsq_max = potparm%pot(itype, jtype)%pot%rcutsq + END IF END DO END DO @@ -1865,8 +1866,9 @@ CONTAINS DO itype = 1, ntypes lnew_type = .TRUE. DO jtype = 1, itype - 1 - IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) & + IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) THEN lnew_type = .FALSE. + END IF END DO IF (lnew_type) THEN nmol_types = nmol_types + 1 @@ -2068,19 +2070,24 @@ CONTAINS ! some ensembles require multiple boxes or molecule types SELECT CASE (mc_par%ensemble) CASE ("GEMC_NPT") - IF (nmol_types <= 1) & + IF (nmol_types <= 1) THEN CPABORT('Cannot have GEMC-NPT simulation with only one molecule type') - IF (nboxes <= 1) & + END IF + IF (nboxes <= 1) THEN CPABORT('Cannot have GEMC-NPT simulation with only one box') + END IF CASE ("GEMC_NVT") - IF (nboxes <= 1) & + IF (nboxes <= 1) THEN CPABORT('Cannot have GEMC-NVT simulation with only one box') + END IF CASE ("TRADITIONAL") - IF (mc_par%pmswap > 0.0E0_dp) & + IF (mc_par%pmswap > 0.0E0_dp) THEN CPABORT('You cannot do swap moves in a system with only one box') + END IF CASE ("VIRIAL") - IF (nchain_total /= 2) & + IF (nchain_total /= 2) THEN CPABORT('You need exactly two molecules in the box to compute the second virial.') + END IF END SELECT ! can't choose an AVBMC target atom number higher than the number diff --git a/src/motion/mc/tamc_run.F b/src/motion/mc/tamc_run.F index bff6b10485..7be1019e15 100644 --- a/src/motion/mc/tamc_run.F +++ b/src/motion/mc/tamc_run.F @@ -269,13 +269,6 @@ CONTAINS IF (simpar%v0 == 0._dp) simpar%v0 = cell%deth END IF - ! Initialize velocities possibly applying constraints at the zeroth MD step -! ! ! CALL section_vals_val_get(motion_section,"PRINT%RESTART%SPLIT_RESTART_FILE",& -! ! ! l_val=write_binary_restart_file) -!! let us see if this created all the trouble -! CALL setup_velocities(force_env,simpar,globenv,md_env,md_section,constraint_section, & -! write_binary_restart_file) - ! Setup Free Energy Calculation (if required) CALL fe_env_create(fe_env, free_energy_section) CALL set_md_env(md_env=md_env, simpar=simpar, fe_env=fe_env, cell=cell, & @@ -294,7 +287,6 @@ CONTAINS force_env%meta_env%dt = force_env%meta_env%zdt CALL initialize_md_ener(md_ener, force_env, simpar) -! force_env%meta_env%dt=force_env%meta_env%zdt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MC setup up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -306,11 +298,8 @@ CONTAINS ! set some values...will use get_globenv if that ever comes around ! initialize the random numbers -! IF (para_env%is_source()) THEN rng_stream_mc = rng_stream_type(name="Random numbers for monte carlo acc/rej", & distribution_type=UNIFORM) -! ENDIF -!!!!! this should go in a routine hmc_read NULLIFY (mc_section) ALLOCATE (mc_par) @@ -328,7 +317,6 @@ CONTAINS CALL section_vals_val_get(mc_section, "RANDOMTOSKIP", i_val=rand2skip) CPASSERT(rand2skip >= 0) temp = cp_unit_from_cp2k(simpar%temp_ext, "K") -! CALL set_mc_par(mc_par, ensemble=ensemble, nstep=nmccycles, iprint=iprint, temperature=temp, & beta=1.0_dp/temp/boltzmann*joule, exp_max_val=0.9_dp*LOG(HUGE(0.0_dp)), & @@ -372,11 +360,12 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file! "// & "You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR. "// & "Be sure the method you are using can compute the virial!") + END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -386,11 +375,12 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") + END IF END IF ! Computing Forces at zero MD step @@ -411,15 +401,12 @@ CONTAINS CALL section_vals_remove_values(work_section) END IF -! CALL force_env_calc_energy_force (force_env, calc_force=.TRUE.) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) force_env%meta_env => meta_env_saved IF (ASSOCIATED(force_env%qs_env)) THEN -! force_env%qs_env%sim_time=time -! force_env%qs_env%sim_step=itimes force_env%qs_env%sim_time = 0.0_dp force_env%qs_env%sim_step = 0 END IF @@ -434,26 +421,7 @@ CONTAINS END DO END DO END IF -! IF (force_env%meta_env%well_tempered) THEN -! force_env%meta_env%wttemperature = simpar%temp_ext -! IF (force_env%meta_env%wtgamma>EPSILON(1._dp)) THEN -! dummy=force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma-1._dp) -! IF (force_env%meta_env%delta_t>EPSILON(1._dp)) THEN -! check=ABS(force_env%meta_env%delta_t-dummy)<1.E+3_dp*EPSILON(1._dp) -! IF(.NOT.check) CALL cp_abort(__LOCATION__,& -! "Inconsistency between DELTA_T and WTGAMMA (both specified):"//& -! " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") -! ELSE -! force_env%meta_env%delta_t = dummy -! ENDIF -! ELSE -! force_env%meta_env%wtgamma = 1._dp & -! + force_env%meta_env%delta_t/force_env%meta_env%wttemperature -! ENDIF -! force_env%meta_env%invdt = 1._dp/force_env%meta_env%delta_t -! ENDIF CALL tamc_force(force_env) -! CALL metadyn_write_colvar(force_env) END IF IF (simpar%do_respa) THEN @@ -461,16 +429,10 @@ CONTAINS calc_force=.TRUE.) END IF -! CALL force_env_get( force_env, subsys=subsys) -! -! CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& -! particles=particles) - CALL virial_evaluate(atomic_kinds%els, particles%els, local_particles, & virial, force_env%para_env) CALL md_energy(md_env, md_ener) -! CALL md_write_output(md_env) !inits the print env at itimes == 0 also writes trajectories md_stride = 1 ELSE CALL get_md_env(md_env, reftraj=reftraj) @@ -486,7 +448,6 @@ CONTAINS CALL init_mc_moves(moves) CALL init_mc_moves(gmoves) ALLOCATE (r(1:3, SIZE(particles%els))) -! ALLOCATE (r_old(1:3,size(particles%els))) CALL mc_averages_create(MCaverages) !!!!! some more buffers ! Allocate random number for Langevin Thermostat acting on COLVARS @@ -529,7 +490,6 @@ CONTAINS IF (output_unit > 0) THEN WRITE (output_unit, '(a)') "HMC|==== end initial average forces" END IF -! call set_md_env(md_env, init=.FALSE.) CALL metadyn_write_colvar(force_env) @@ -575,8 +535,6 @@ CONTAINS ! Free Energy calculation ! CALL free_energy_evaluate(md_env,should_stop,free_energy_section) - ![AME:UB] IF (should_stop) EXIT - ! Test for .EXIT_MD or for WALL_TIME to exit ! Default: ! IF so we don't overwrite the restart or append to the trajectory @@ -589,30 +547,13 @@ CONTAINS CALL external_control(should_stop, "MD", globenv=globenv) IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) -! CALL md_output(md_env,md_section,force_env%root_section,should_stop) EXIT END IF -! IF(simpar%ensemble /= reftraj_ensemble) THEN -! CALL md_energy(md_env, md_ener) -! CALL temperature_control(simpar, md_env, md_ener, force_env, logger) -! CALL comvel_control(md_ener, force_env, md_section, logger) -! CALL angvel_control(md_ener, force_env, md_section, logger) -! ELSE -! CALL md_ener_reftraj(md_env, md_ener) -! END IF - time_iter_stop = m_walltime() used_time = time_iter_stop - time_iter_start time_iter_start = time_iter_stop -!!!!! this writes the restart... -! CALL md_output(md_env,md_section,force_env%root_section,should_stop) - -! IF(simpar%ensemble == reftraj_ensemble ) THEN -! CALL write_output_reftraj(md_env) -! END IF - IF (output_unit > 0) THEN WRITE (output_unit, '(a,1x,i0)') "HMC| end z step ", istep WRITE (output_unit, '(a)') "HMC|===================================" @@ -627,7 +568,6 @@ CONTAINS CALL write_restart(md_env=md_env, root_section=force_env%root_section) ! if we need the final kinetic energy for Hybrid Monte Carlo -! hmc_ekin%final_ekin=md_ener%ekin ! Remove the iteration level CALL cp_rm_iter_level(logger%iter_info, "MD") @@ -639,15 +579,12 @@ CONTAINS DEALLOCATE (md_env) ! Clean restartable sections.. IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section) -! IF (para_env%is_source()) THEN -! ENDIF CALL MC_ENV_RELEASE(mc_env) DEALLOCATE (mc_env) DEALLOCATE (mc_par) CALL MC_MOVES_RELEASE(moves) CALL MC_MOVES_RELEASE(gmoves) DEALLOCATE (r) -! DEALLOCATE(r_old) DEALLOCATE (xieta) DEALLOCATE (An) DEALLOCATE (fz) @@ -1009,10 +946,6 @@ CONTAINS fz = 0.0_dp ishift = 0 END IF -! lrestart = .false. -! if (present(logger) .and. present(iter)) THEN -! lrestart=.true. -! ENDIF CALL get_mc_par(mc_par, nstep=nstep, iprint=iprint) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) @@ -1070,20 +1003,6 @@ CONTAINS WRITE (output_unit, '(a,f16.8)') "HMC| Running average for potential energy ", averages%ave_energy WRITE (output_unit, '(a,1x,i0)') "HMC|======== End Monte Carlo cycle ", i + ishift END IF -! IF (lrestart) THEN -! k=nstep/5 -! IF(MOD(i,k) == 0) THEN -! force_env%qs_env%sim_time=t1 -! force_env%qs_env%sim_step=it1 -! DO j=1,force_env%meta_env%n_colvar -! force_env%meta_env%metavar(j)%ff_s=fz(j)/real(i+ishift,dp) -! ENDDO -! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=-1) -! CALL section_vals_val_set(mcsec,"RANDOMTOSKIP",i_val=i+ishift) -! CALL write_restart(md_env=mdenv,root_section=force_env%root_section) -! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter) -! ENDIF -! ENDIF END DO force_env%qs_env%sim_time = t1 force_env%qs_env%sim_step = it1 @@ -1216,7 +1135,7 @@ CONTAINS ! to prevent overflows IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value < exp_min_val) THEN + ELSE IF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/md_conserved_quantities.F b/src/motion/md_conserved_quantities.F index 1c09efe72f..dc65d3fd8f 100644 --- a/src/motion/md_conserved_quantities.F +++ b/src/motion/md_conserved_quantities.F @@ -637,8 +637,9 @@ CONTAINS END DO END IF - IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) & + IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) THEN CPABORT("get_part_ke: qmmm bug") + END IF END SUBROUTINE get_part_ke ! ************************************************************************************************** diff --git a/src/motion/md_energies.F b/src/motion/md_energies.F index 629579deb7..099c430dbc 100644 --- a/src/motion/md_energies.F +++ b/src/motion/md_energies.F @@ -488,11 +488,12 @@ CONTAINS CALL cp_print_key_finished_output(tempkind, logger, motion_section, "MD%PRINT%TEMP_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") + END IF END IF !Thermal Region CALL print_thermal_regions_temperature(thermal_regions, itimes, time*femtoseconds, my_pos, my_act) @@ -558,11 +559,12 @@ CONTAINS "MD%PRINT%TEMP_SHELL_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_SHELL_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_SHELL_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") + END IF END IF END IF END IF diff --git a/src/motion/md_run.F b/src/motion/md_run.F index fbf5728dfa..ababfdc8ac 100644 --- a/src/motion/md_run.F +++ b/src/motion/md_run.F @@ -283,8 +283,9 @@ CONTAINS CALL get_md_env(md_env, ehrenfest_md=ehrenfest_md) !If requested set up the REFTRAJ run - IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) & + IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) THEN CPABORT("Ehrenfest MD does not support reftraj ensemble ") + END IF IF (simpar%ensemble == reftraj_ensemble) THEN reftraj_section => section_vals_get_subs_vals(md_section, "REFTRAJ") ALLOCATE (reftraj) @@ -338,11 +339,12 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file!"// & " You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR."// & " Be sure the method you are using can compute the virial!") + END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -352,11 +354,12 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") + END IF END IF ! Computing Forces at zero MD step @@ -402,10 +405,11 @@ CONTAINS dummy = force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma - 1._dp) IF (force_env%meta_env%delta_t > EPSILON(1._dp)) THEN check = ABS(force_env%meta_env%delta_t - dummy) < 1.E+3_dp*EPSILON(1._dp) - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "Inconsistency between DELTA_T and WTGAMMA (both specified):"// & " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") + END IF ELSE force_env%meta_env%delta_t = dummy END IF @@ -526,8 +530,9 @@ CONTAINS IF (itimes >= simpar%max_steps) should_stop = .TRUE. ! call external hook e.g. from global optimization - IF (PRESENT(mdctrl)) & + IF (PRESENT(mdctrl)) THEN CALL mdctrl_callback(mdctrl, md_env, should_stop) + END IF IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) diff --git a/src/motion/md_vel_utils.F b/src/motion/md_vel_utils.F index 3bc1acde2b..715e28439d 100644 --- a/src/motion/md_vel_utils.F +++ b/src/motion/md_vel_utils.F @@ -269,7 +269,7 @@ CONTAINS my_ireg = ireg my_nfree = nfree my_temp = temp - ELSEIF (PRESENT(nfree)) THEN + ELSE IF (PRESENT(nfree)) THEN my_ireg = 0 my_nfree = nfree my_temp = simpar%temp_ext @@ -1257,8 +1257,9 @@ CONTAINS IF (simpar%soften_nsteps <= 0) RETURN !nothing todo - IF (ANY(is_fixed /= use_perd_none)) & + IF (ANY(is_fixed /= use_perd_none)) THEN CPABORT("Velocitiy softening with constraints is not supported.") + END IF !backup positions DO i = 1, SIZE(part) @@ -2001,8 +2002,9 @@ CONTAINS CALL get_molecule_kind(molecule_kind=molecule_kind, fixd_list=fixd_list) IF (ASSOCIATED(fixd_list)) THEN DO ifixd = 1, SIZE(fixd_list) - IF (.NOT. fixd_list(ifixd)%restraint%active) & + IF (.NOT. fixd_list(ifixd)%restraint%active) THEN is_fixed(fixd_list(ifixd)%fixd) = fixd_list(ifixd)%itype + END IF END DO END IF END DO @@ -2112,8 +2114,9 @@ CONTAINS CALL get_molecule_kind_set(molecule_kind_set=molecule_kinds%els, & nconstraint=nconstraint, & nconstraint_fixd=nconstraint_fixd) - IF (nconstraint - nconstraint_fixd /= 0) & + IF (nconstraint - nconstraint_fixd /= 0) THEN CPABORT("Only the fixed atom constraint is implemented for core-shell models") + END IF !MK CPPostcondition(.NOT.simpar%constraint,cp_failure_level,routineP,failure) CPASSERT(ASSOCIATED(shell_particles)) CPASSERT(ASSOCIATED(core_particles)) @@ -2251,8 +2254,9 @@ CONTAINS IF (init_cascade) THEN CALL section_vals_val_get(cascade_section, "ENERGY", r_val=energy) - IF (energy < 0.0_dp) & + IF (energy < 0.0_dp) THEN CPABORT("Error occurred reading &CASCADE section: Negative energy found") + END IF IF (iw > 0) THEN ekin = cp_unit_from_cp2k(energy, "keV") @@ -2266,8 +2270,9 @@ CONTAINS atom_list_section => section_vals_get_subs_vals(cascade_section, "ATOM_LIST") CALL section_vals_val_get(atom_list_section, "_DEFAULT_KEYWORD_", n_rep_val=natom) CALL section_vals_list_get(atom_list_section, "_DEFAULT_KEYWORD_", list=atom_list) - IF (natom <= 0) & + IF (natom <= 0) THEN CPABORT("Error occurred reading &CASCADE section: No atom list found") + END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,T11,A,3(11X,A),9X,A)") & @@ -2286,12 +2291,15 @@ CONTAINS no_read_error = .FALSE. READ (UNIT=line, FMT=*, ERR=999) atom_index(iatom), vatom(1:3, iatom), weight(iatom) no_read_error = .TRUE. -999 IF (.NOT. no_read_error) & +999 IF (.NOT. no_read_error) THEN CPABORT("Error occurred reading &CASCADE section. Last line read <"//TRIM(line)//">") - IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) & + END IF + IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) THEN CPABORT("Error occurred reading &CASCADE section: Invalid atom index found") - IF (weight(iatom) < 0.0_dp) & + END IF + IF (weight(iatom) < 0.0_dp) THEN CPABORT("Error occurred reading &CASCADE section: Negative weight found") + END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,I10,4(1X,F14.6))") & "CASCADE| ", atom_index(iatom), vatom(1:3, iatom), weight(iatom) @@ -2311,7 +2319,7 @@ CONTAINS END DO weight(:) = matom(:)*weight(:)*energy/norm DO iatom = 1, natom - norm = SQRT(DOT_PRODUCT(vatom(1:3, iatom), vatom(1:3, iatom))) + norm = NORM2(vatom(1:3, iatom)) vatom(1:3, iatom) = vatom(1:3, iatom)/norm END DO diff --git a/src/motion/neb_io.F b/src/motion/neb_io.F index 0e23a7bbb3..1cd40721df 100644 --- a/src/motion/neb_io.F +++ b/src/motion/neb_io.F @@ -116,33 +116,37 @@ CONTAINS ! Before continuing let's do some consistency check between keywords IF (neb_env%pot_type /= pot_neb_full) THEN ! Requires the use of colvars - IF (.NOT. neb_env%use_colvar) & + IF (.NOT. neb_env%use_colvar) THEN CALL cp_abort(__LOCATION__, & "A potential energy function based on free energy or minimum energy"// & " was requested without enabling the usage of COLVARS. Both methods"// & " are based on COLVARS definition.") + END IF ! Moreover let's check if the proper sections have been defined.. SELECT CASE (neb_env%pot_type) CASE (pot_neb_fe) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%MD") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CALL cp_abort(__LOCATION__, & "A free energy BAND (colvars projected) calculation is requested"// & " but NONE MD section was defined in the input.") + END IF CASE (pot_neb_me) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%GEO_OPT") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) & + IF (.NOT. explicit) THEN CALL cp_abort(__LOCATION__, & "A minimum energy BAND (colvars projected) calculation is requested"// & " but NONE GEO_OPT section was defined in the input.") + END IF END SELECT ELSE - IF (neb_env%use_colvar) & + IF (neb_env%use_colvar) THEN CALL cp_abort(__LOCATION__, & "A band calculation was requested with a full potential energy. USE_COLVAR cannot"// & " be set for this kind of calculation!") + END IF END IF ! String Method CALL section_vals_val_get(neb_section, "STRING_METHOD%SMOOTHING", r_val=neb_env%smoothing) @@ -263,9 +267,10 @@ CONTAINS END IF END DO - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" + routineN//": Done!" + END IF CALL cp_print_key_finished_output(iw, logger, neb_env%neb_section, "FINAL_BAND") diff --git a/src/motion/neb_methods.F b/src/motion/neb_methods.F index 9af2b50a23..cba323ad65 100644 --- a/src/motion/neb_methods.F +++ b/src/motion/neb_methods.F @@ -462,14 +462,16 @@ CONTAINS IF (do_ls .AND. (.NOT. skip_ls)) THEN CALL neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces, & vels, particle_set, iw, output_unit, distances, diis_section, iw2) - IF (iw2 > 0) & + IF (iw2 > 0) THEN WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD after linesearch", & - stepsize + stepsize + END IF ELSE stepsize = MIN(norm*stepsize0, max_stepsize) - IF (iw2 > 0) & + IF (iw2 > 0) THEN WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD no linesearch performed", & - stepsize + stepsize + END IF END IF sline%wrk = stepsize*sline%wrk diis_on = accept_diis_step(istep > max_sd_steps, n_diis, err, crr, set_err, sline, coords, & diff --git a/src/motion/neb_opt_utils.F b/src/motion/neb_opt_utils.F index 3e1c06599d..ea36fe5d36 100644 --- a/src/motion/neb_opt_utils.F +++ b/src/motion/neb_opt_utils.F @@ -228,7 +228,7 @@ CONTAINS LOGICAL, INTENT(IN) :: check_diis LOGICAL :: accepted - REAL(KIND=dp) :: costh, norm1, norm2 + REAL(KIND=dp) :: costh, ref_norm, step_norm REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp accepted = .TRUE. @@ -237,9 +237,9 @@ CONTAINS ! (a) The direction of the DIIS step, can be compared to the reference step. ! if the angle is grater than a specified value, the DIIS step is not ! acceptable. - norm1 = SQRT(DOT_PRODUCT(ref, ref)) - norm2 = SQRT(DOT_PRODUCT(step, step)) - costh = DOT_PRODUCT(ref, step)/(norm1*norm2) + ref_norm = NORM2(ref) + step_norm = NORM2(step) + costh = DOT_PRODUCT(ref, step)/(ref_norm*step_norm) IF (check_diis) THEN IF (costh < acceptance_factor(MIN(10, nv))) accepted = .FALSE. ELSE @@ -258,7 +258,7 @@ CONTAINS IF (accepted .AND. check_diis) THEN ! (b) The length of the DIIS step is limited to be no more than 10 times ! the reference step - IF (norm1 > norm2*10.0_dp) accepted = .FALSE. + IF (ref_norm > step_norm*10.0_dp) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "The length of the DIIS step is limited to be no more than 10 times", & @@ -267,10 +267,10 @@ CONTAINS END IF IF (accepted .AND. check_diis) THEN ! (d) If the DIIS matrix is nearly singular, the norm of the DIIS step - ! vector becomes small and cwrk/norm1 becomes large, signaling a - ! numerical stability problems. If the magnitude of cwrk/norm1 + ! vector becomes small and cwrk/ref_norm becomes large, signaling a + ! numerical stability problems. If the magnitude of cwrk/ref_norm ! exceeds 10^8 then the step size is assumed to be unacceptable - IF (ANY(ABS(cwrk(1:nv)/norm1) > 10**8_dp)) accepted = .FALSE. + IF (ANY(ABS(cwrk(1:nv)/ref_norm) > 10**8_dp)) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "If the DIIS matrix is nearly singular, the norm of the DIIS step", & diff --git a/src/motion/neb_utils.F b/src/motion/neb_utils.F index 264b4260d7..7f38f3c615 100644 --- a/src/motion/neb_utils.F +++ b/src/motion/neb_utils.F @@ -118,8 +118,7 @@ CONTAINS CALL rmsd3(particle_set, coords%xyz(:, i), coords%xyz(:, i0), & iw, rotate=my_rotate) END IF - distance = SQRT(DOT_PRODUCT(coords%wrk(:, i) - coords%wrk(:, i0), & - coords%wrk(:, i) - coords%wrk(:, i0))) + distance = NORM2(coords%wrk(:, i) - coords%wrk(:, i0)) END SUBROUTINE neb_replica_distance @@ -224,11 +223,12 @@ CONTAINS DO iatom = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format for REPLICA coordinates. Very probably the"// & " line with title is missing or is empty. Please check the XYZ file and rerun your job!") + END IF READ (parser%input_line, *) dummy_char, r(1:3) ic = 3*(iatom - 1) coords%xyz(ic + 1:ic + 3, i_rep) = r(1:3)*bohr @@ -737,7 +737,7 @@ CONTAINS ! String method.. tangent(:) = 0.0_dp END SELECT - distance0 = SQRT(DOT_PRODUCT(tangent(:), tangent(:))) + distance0 = NORM2(tangent(:)) IF (distance0 /= 0.0_dp) tangent(:) = tangent(:)/distance0 END SUBROUTINE get_tangent @@ -849,7 +849,7 @@ CONTAINS ALLOCATE (dtmp1(nsize_wrk)) dtmp1(:) = forces%wrk(:, i) - dot_product_band(neb_env, forces%wrk(:, i), tangent, Mmatrix)*tangent forces%wrk(:, i) = dtmp1 - tmp = SQRT(DOT_PRODUCT(dtmp1, dtmp1)) + tmp = NORM2(dtmp1) dtmp1(:) = dtmp1(:)/tmp ! Project out only the spring component interfering with the ! orthogonal gradient of the band diff --git a/src/motion/pint_methods.F b/src/motion/pint_methods.F index 1f59bcbb61..8e9e1464c4 100644 --- a/src/motion/pint_methods.F +++ b/src/motion/pint_methods.F @@ -182,7 +182,7 @@ CONTAINS CHARACTER(len=2*default_string_length) :: msg CHARACTER(len=default_path_length) :: output_file_name, project_name INTEGER :: handle, iat, ibead, icont, idim, idir, & - ierr, ig, itmp, nrep, prep, stat + ierr, ig, itmp, nrep, prep LOGICAL :: explicit, ltmp REAL(kind=dp) :: dt, mass, omega TYPE(cp_subsys_type), POINTER :: subsys @@ -377,9 +377,7 @@ CONTAINS pint_env%uf_h(pint_env%p, pint_env%ndim), & pint_env%centroid(pint_env%ndim), & pint_env%rtmp_ndim(pint_env%ndim), & - pint_env%rtmp_natom(pint_env%ndim/3), & - STAT=stat) - CPASSERT(stat == 0) + pint_env%rtmp_natom(pint_env%ndim/3)) pint_env%x = 0._dp pint_env%v = 0._dp pint_env%f = 0._dp @@ -476,7 +474,6 @@ CONTAINS pint_env%gle%loc_num_gle = pint_env%p*pint_env%ndim pint_env%gle%glob_num_gle = pint_env%gle%loc_num_gle ALLOCATE (pint_env%gle%map_info%index(pint_env%gle%loc_num_gle)) - CPASSERT(stat == 0) DO itmp = 1, pint_env%gle%loc_num_gle pint_env%gle%map_info%index(itmp) = itmp END DO @@ -1168,8 +1165,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN CPABORT("Invalid size of MOTION%PINT%BEADS%COORD") + END IF ic = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1337,8 +1335,9 @@ CONTAINS WRITE (stmp, *) n_rep_val msg = "Invalid number of atoms in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (3*n_rep_val /= pint_env%ndim) & + IF (3*n_rep_val /= pint_env%ndim) THEN CPABORT(msg) + END IF DO ia = 1, pint_env%ndim/3 CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & i_rep_val=ia, r_vals=r_vals) @@ -1347,8 +1346,9 @@ CONTAINS WRITE (stmp, *) itmp msg = "Number of coordinates != 3 in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (itmp /= 3) & + IF (itmp /= 3) THEN CPABORT(msg) + END IF DO ib = 1, pint_env%p DO ic = 1, 3 idim = 3*(ia - 1) + ic @@ -1464,8 +1464,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN CPABORT("Invalid size of MOTION%PINT%BEAD%VELOCITY") + END IF itmp = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1642,8 +1643,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN CPABORT("Invalid size of MOTION%PINT%NOSE%COORD") + END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1670,8 +1672,9 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN CPABORT("Invalid size of MOTION%PINT%NOSE%VELOCITY") + END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1687,7 +1690,7 @@ CONTAINS END IF END IF - ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (input_section) input_section => section_vals_get_subs_vals(pint_env%input, & "MOTION%PINT%GLE") diff --git a/src/motion/pint_piglet.F b/src/motion/pint_piglet.F index 0170324d7e..781149afb0 100644 --- a/src/motion/pint_piglet.F +++ b/src/motion/pint_piglet.F @@ -493,7 +493,8 @@ CONTAINS END DO END DO - ! the piglet is such a strong thermostat, that it messes up the "exact" integration. The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) + ! the piglet is such a strong thermostat, that it messes up the "exact" integration. + ! The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) piglet_therm%thermostat_energy = piglet_therm%thermostat_energy - 0.5_dp*delta_ekin CALL timestop(handle) diff --git a/src/motion/pint_public.F b/src/motion/pint_public.F index 5d9d1bed66..c305ca9656 100644 --- a/src/motion/pint_public.F +++ b/src/motion/pint_public.F @@ -148,7 +148,7 @@ CONTAINS np = 2**il ! number of points to be generated at this level dl = n/(2*np) ! interval betw points (in index numbers) - vrnc = vrnc/2.0_dp; ! variance at this level (=t at level 0) + vrnc = vrnc/2.0_dp ! variance at this level (=t at level 0) ! loop over points added in this level DO ip = 0, np - 1 diff --git a/src/motion/reftraj_util.F b/src/motion/reftraj_util.F index 55daf473eb..00d61232d1 100644 --- a/src/motion/reftraj_util.F +++ b/src/motion/reftraj_util.F @@ -112,20 +112,22 @@ CONTAINS END IF reftraj%isnap = nskip - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the trajectory file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") + END IF ! Cell File IF (reftraj%info%variable_volume) THEN IF (nskip > 0) THEN CALL parser_get_next_line(reftraj%info%cell_parser, nskip, at_end=my_end) END IF - IF (my_end) & + IF (my_end) THEN CALL cp_abort(__LOCATION__, & "Reached the end of the cell file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") + END IF END IF reftraj%natom = natom diff --git a/src/motion/rt_propagation.F b/src/motion/rt_propagation.F index 5e72c71fbc..67170aa565 100644 --- a/src/motion/rt_propagation.F +++ b/src/motion/rt_propagation.F @@ -294,7 +294,8 @@ CONTAINS CALL rt_initialize_rho_from_mos(rtp, mos) END IF ELSE - !The wavefunction was minimized using a linear scaling method. The density matrix is therefore taken from the ls_scf_env. + ! The wavefunction was minimized using a linear scaling method. + ! The density matrix is therefore taken from the ls_scf_env. CALL get_rtp(rtp=rtp, rho_old=rho_old, rho_new=rho_new) DO ispin = 1, SIZE(rho_old)/2 re = 2*ispin - 1 @@ -417,8 +418,9 @@ CONTAINS CALL cp_iterate(logger%iter_info, last=(i_step == max_steps), iter_nr=i_step) rtp%converged = .FALSE. DO i_iter = 1, max_iter - IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) & + IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) THEN CALL qs_ks_did_change(qs_env%ks_env, s_mstruct_changed=.TRUE.) + END IF rtp%iter = i_iter CALL propagation_step(qs_env, rtp, rtp_control) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) @@ -444,9 +446,10 @@ CONTAINS END DO CALL cp_rm_iter_level(logger%iter_info, "MD") - IF (.NOT. rtp%converged) & + IF (.NOT. rtp%converged) THEN CALL cp_abort(__LOCATION__, "propagation did not converge, "// & "either increase MAX_ITER or use a smaller TIMESTEP") + END IF CALL timestop(handle) @@ -617,8 +620,9 @@ CONTAINS CALL set_ks_env(ks_env, complex_ks=imag_ks) IF (imag_ks) THEN CALL qs_ks_allocate_basics(qs_env, is_complex=imag_ks) - IF (.NOT. dft_control%rtp_control%fixed_ions) & + IF (.NOT. dft_control%rtp_control%fixed_ions) THEN CALL rtp_create_SinvH_imag(rtp, dft_control%nspins) + END IF END IF ! h diff --git a/src/motion/simpar_methods.F b/src/motion/simpar_methods.F index 0e25a66a64..b9b5058f74 100644 --- a/src/motion/simpar_methods.F +++ b/src/motion/simpar_methods.F @@ -320,17 +320,19 @@ CONTAINS CALL section_vals_get(tmp_section, explicit=simpar%constraint) IF (simpar%constraint) THEN CALL section_vals_val_get(tmp_section, "SHAKE_TOLERANCE", r_val=simpar%shake_tol) - IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) & + IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN CALL cp_warn(__LOCATION__, & "Shake tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 1000*EPSILON!") + END IF simpar%shake_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%shake_tol) CALL section_vals_val_get(tmp_section, "ROLL_TOLERANCE", r_val=simpar%roll_tol) - IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) & + IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN CALL cp_warn(__LOCATION__, & "Roll tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up roll_tol to 1000*EPSILON!") + END IF simpar%roll_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%roll_tol) END IF diff --git a/src/motion/thermal_region_utils.F b/src/motion/thermal_region_utils.F index 7d1a6aee4c..b90e95b7af 100644 --- a/src/motion/thermal_region_utils.F +++ b/src/motion/thermal_region_utils.F @@ -425,12 +425,14 @@ CONTAINS TRIM(my_reg)//" which is not allowed!") END IF ELSE - IF (.NOT. ipart > 0) & + IF (.NOT. ipart > 0) THEN CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is non-positive!") - IF (.NOT. ipart <= particles%n_els) & + END IF + IF (.NOT. ipart <= particles%n_els) THEN CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is out of bounds!") + END IF END IF END SUBROUTINE set_t_region_index diff --git a/src/motion/thermostat/al_system_dynamics.F b/src/motion/thermostat/al_system_dynamics.F index c17af73a3b..935d2959e4 100644 --- a/src/motion/thermostat/al_system_dynamics.F +++ b/src/motion/thermostat/al_system_dynamics.F @@ -72,20 +72,23 @@ CONTAINS my_shell_adiabatic = .FALSE. map_info => al%map_info - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "INIT") + END IF IF (al%tau_nh <= 0.0_dp) THEN CALL al_OU_step(0.5_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post OU") + END IF ELSE ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 1st OU") + END IF ! Compute the kinetic energy for the region to thermostat for the (T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & @@ -99,8 +102,9 @@ CONTAINS ! Recompute the kinetic energy for the region to thermostat (for the T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & local_molecules, molecule_set, group, vel=vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post rescale_vel") + END IF ! quarter step of chi CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.FALSE.) @@ -108,8 +112,9 @@ CONTAINS ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) & + IF (debug_this_module) THEN CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 2nd OU") + END IF END IF ! Recompute the final kinetic energy for the region to thermostat @@ -187,7 +192,7 @@ CONTAINS iparticle_local, jj, last_atom, nmol_local, nparticle, nparticle_kind, nparticle_local LOGICAL :: check, present_vel REAL(KIND=dp) :: mass - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w(:, :) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(molecule_type), POINTER :: molecule diff --git a/src/motion/thermostat/al_system_init.F b/src/motion/thermostat/al_system_init.F index f68e657e98..776589c531 100644 --- a/src/motion/thermostat/al_system_init.F +++ b/src/motion/thermostat/al_system_init.F @@ -130,9 +130,10 @@ CONTAINS work_section => section_vals_get_subs_vals(section_vals=al_section, & subsection_name="MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (restart .NEQV. explicit) & + IF (restart .NEQV. explicit) THEN CALL cp_abort(__LOCATION__, & "You need to define both CHI and MASS sections (or none) in the AD_LANGEVIN section") + END IF restart = restart .AND. explicit IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section, keyword_name="_DEFAULT_KEYWORD_", & diff --git a/src/motion/thermostat/barostat_types.F b/src/motion/thermostat/barostat_types.F index b5227e3243..0fcea72931 100644 --- a/src/motion/thermostat/barostat_types.F +++ b/src/motion/thermostat/barostat_types.F @@ -118,14 +118,16 @@ CONTAINS ! User defined virial screening CALL section_vals_val_get(barostat_section, "VIRIAL", i_val=barostat%virial_components) check = barostat%virial_components == do_clv_xyz .OR. simpar%ensemble == npt_f_ensemble - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "The screening of the components of "// & "the virial is available only with the NPT_F ensemble!") + END IF ELSE - IF (explicit) & + IF (explicit) THEN CALL cp_warn(__LOCATION__, & "A barostat has been defined with an MD ensemble which does not support barostat! "// & "Its definition will be ignored!") + END IF END IF END SUBROUTINE create_barostat_type diff --git a/src/motion/thermostat/barostat_utils.F b/src/motion/thermostat/barostat_utils.F index 0028cd607a..9c03aa5a03 100644 --- a/src/motion/thermostat/barostat_utils.F +++ b/src/motion/thermostat/barostat_utils.F @@ -75,7 +75,7 @@ CONTAINS baro_kin = baro_kin + 0.5_dp*npt(i, j)%v**2*npt(i, j)%mass END DO END DO - ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v0 = simpar%v0 iv0 = 1._dp/v0 v_shock = simpar%v_shock diff --git a/src/motion/thermostat/extended_system_init.F b/src/motion/thermostat/extended_system_init.F index 1f3feae8b0..733677c944 100644 --- a/src/motion/thermostat/extended_system_init.F +++ b/src/motion/thermostat/extended_system_init.F @@ -126,9 +126,10 @@ CONTAINS restart = explicit work_section2 => section_vals_get_subs_vals(work_section, "MASS") CALL section_vals_get(work_section2, explicit=explicit) - IF (restart .NEQV. explicit) & + IF (restart .NEQV. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "MASS section (or none) in the BAROSTAT section") + END IF restart = explicit .AND. restart END IF @@ -616,21 +617,24 @@ CONTAINS restart = explicit work_section => section_vals_get_subs_vals(nose_section, "COORD") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) & + IF (.NOT. restart .AND. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") + END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) & + IF (.NOT. restart .AND. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") + END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "FORCE") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) & + IF (.NOT. restart .AND. explicit) THEN CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") + END IF restart = explicit .AND. restart END IF diff --git a/src/motion/thermostat/extended_system_mapping.F b/src/motion/thermostat/extended_system_mapping.F index 24296d6be1..de819b53ab 100644 --- a/src/motion/thermostat/extended_system_mapping.F +++ b/src/motion/thermostat/extended_system_mapping.F @@ -333,8 +333,9 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 + END IF END DO END DO @@ -428,8 +429,9 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 + END IF END DO END DO diff --git a/src/motion/thermostat/gle_system_dynamics.F b/src/motion/thermostat/gle_system_dynamics.F index 9bbbf2728d..819e98448c 100644 --- a/src/motion/thermostat/gle_system_dynamics.F +++ b/src/motion/thermostat/gle_system_dynamics.F @@ -289,7 +289,7 @@ CONTAINS L(i, i) = 1.0_dp D(i) = SST(i, i) DO j = 1, i - 1 - L(i, j) = SST(i, j); + L(i, j) = SST(i, j) DO k = 1, j - 1 L(i, j) = L(i, j) - L(i, k)*L(j, k)*D(k) END DO diff --git a/src/motion/thermostat/thermostat_utils.F b/src/motion/thermostat/thermostat_utils.F index f3e5828f48..3cfc8a24bb 100644 --- a/src/motion/thermostat/thermostat_utils.F +++ b/src/motion/thermostat/thermostat_utils.F @@ -384,8 +384,9 @@ CONTAINS DO ipart = first_atom, last_atom natom_local = natom_local + 1 ! only map the correct region to the thermostat - IF (thermolist(ipart) /= HUGE(0)) & + IF (thermolist(ipart) /= HUGE(0)) THEN thermostat_info%map_loc_thermo_gen(natom_local) = thermolist(ipart) + END IF END DO END DO END DO @@ -452,7 +453,7 @@ CONTAINS qmmm_env) TYPE(section_vals_type), POINTER :: region_sections INTEGER, INTENT(INOUT), OPTIONAL :: sum_of_thermostats - INTEGER, DIMENSION(:), POINTER :: thermolist(:) + INTEGER, POINTER :: thermolist(:) TYPE(molecule_kind_type), POINTER :: molecule_kind_set(:) TYPE(molecule_list_type), POINTER :: molecules TYPE(particle_list_type), POINTER :: particles @@ -652,19 +653,21 @@ CONTAINS nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) & + IF (sum_of_thermostats < 1) THEN CALL cp_abort(__LOCATION__, & "A thermostat type DEFINED is requested but no thermostat "// & "regions are defined in THERMOSTAT/DEFINE_REGION.") + END IF CASE (do_region_thermal) ! Similar to defined region above, but in THERMAL_REGION%DEFINE_REGION nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) & + IF (sum_of_thermostats < 1) THEN CALL cp_abort(__LOCATION__, & "A thermostat type THERMAL is requested but no thermal "// & "regions are defined in THERMAL_REGION/DEFINE_REGION.") + END IF END SELECT ! Here we decide which parallel algorithm to use. @@ -1082,19 +1085,25 @@ CONTAINS atomic_kind => particle_set(ipart)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, mass=mass) IF (present_vel) THEN - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*vel(1, ipart)**2 - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*vel(2, ipart)**2 - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*vel(3, ipart)**2 + END IF ELSE - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*particle_set(ipart)%v(1)**2 - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*particle_set(ipart)%v(2)**2 - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & + END IF + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*particle_set(ipart)%v(3)**2 + END IF END IF END DO END DO diff --git a/src/motion/vibrational_analysis.F b/src/motion/vibrational_analysis.F index 88128bdefa..cdefc2aa4d 100644 --- a/src/motion/vibrational_analysis.F +++ b/src/motion/vibrational_analysis.F @@ -653,7 +653,7 @@ CONTAINS DO j = 1, nvib D_deriv(:) = D_deriv(:) + dip_deriv(:, j)*Hint2(j, i) END DO - intensities_d(i) = SQRT(DOT_PRODUCT(D_deriv, D_deriv)) + intensities_d(i) = NORM2(D_deriv) P_deriv = 0._dp DO j = 1, nvib ! P_deriv has units bohr^2/sqrt(a.u.) @@ -970,7 +970,7 @@ CONTAINS work(:) = work - norm*D(:, i) END DO ! Check norm of the new generated vector - norm = SQRT(DOT_PRODUCT(work, work)) + norm = NORM2(work) IF (norm >= 10E4_dp*thrs_motion) THEN ! Accept new vector ifound = ifound + 1 diff --git a/src/motion/xyz2dcd.F b/src/motion/xyz2dcd.F index 7ccc80c0aa..91cacc54bc 100644 --- a/src/motion/xyz2dcd.F +++ b/src/motion/xyz2dcd.F @@ -13,7 +13,8 @@ PROGRAM xyz2dcd ! ! Note: The input coordinates and the cell vectors should be in Angstrom. -! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) +! and comment the corresponding variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -367,9 +368,9 @@ PROGRAM xyz2dcd a(1:3) = h(1:3, 1) b(1:3) = h(1:3, 2) c(1:3) = h(1:3, 3) - abc(1) = SQRT(DOT_PRODUCT(a(1:3), a(1:3))) - abc(2) = SQRT(DOT_PRODUCT(b(1:3), b(1:3))) - abc(3) = SQRT(DOT_PRODUCT(c(1:3), c(1:3))) + abc(1) = NORM2(a(1:3)) + abc(2) = NORM2(b(1:3)) + abc(3) = NORM2(c(1:3)) alpha = angle(b(1:3), c(1:3))*degree beta = angle(a(1:3), c(1:3))*degree gamma = angle(a(1:3), b(1:3))*degree @@ -579,8 +580,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = SQRT(DOT_PRODUCT(a, a)) - length_of_b = SQRT(DOT_PRODUCT(b, b)) + length_of_a = NORM2(a) + length_of_b = NORM2(b) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion_utils.F b/src/motion_utils.F index d83916a8e3..518479b9b3 100644 --- a/src/motion_utils.F +++ b/src/motion_utils.F @@ -180,7 +180,7 @@ CONTAINS END DO ! Normalize Translations DO i = 1, 3 - norm = SQRT(DOT_PRODUCT(Tr(:, i), Tr(:, i))) + norm = NORM2(Tr(:, i)) Tr(:, i) = Tr(:, i)/norm END DO dof = 3 @@ -445,8 +445,9 @@ CONTAINS CALL section_vals_val_get(root_section, "MOTION%PRINT%TRAJECTORY%CHARGE_EXTENDED", & l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) & + IF (i > 1) THEN CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected, ") + END IF END IF IF (new_file) THEN CALL m_timestamp(timestamp) diff --git a/src/mp2_cphf.F b/src/mp2_cphf.F index 17064b72ff..b79c447ade 100644 --- a/src/mp2_cphf.F +++ b/src/mp2_cphf.F @@ -1204,8 +1204,9 @@ CONTAINS precond(ispin)%local_data(:, :)*residual(ispin)%local_data(:, :) END DO ELSE - IF (mp2_env%ri_grad%polak_ribiere) & + IF (mp2_env%ri_grad%polak_ribiere) THEN residual_new_dot_diff_search_vec_old = accurate_dot_product_spin(residual, diff_search_vector) + END IF DO ispin = 1, nspins diff_search_vector(ispin)%local_data(:, :) = & @@ -1810,7 +1811,8 @@ CONTAINS deb = force(1)%overlap_admm(1:3, 1) IF (use_virial) e_dummy = third_tr(virial%pv_virial) END IF - ! Add the second half of the projector deriatives contracting the first order density matrix with the fockian in the auxiliary basis + ! Add the second half of the projector deriatives contracting the first order + ! density matrix with the fockian in the auxiliary basis IF (do_exx) THEN CALL admm_projection_derivative(qs_env, matrix_ks_aux, matrix_p_mp2) ELSE diff --git a/src/mp2_eri.F b/src/mp2_eri.F index 0f8887f897..41e5c51153 100644 --- a/src/mp2_eri.F +++ b/src/mp2_eri.F @@ -743,9 +743,11 @@ CONTAINS basis_set_a => basis_set_list_a(ikind)%gto_basis_set ! When RI_AUX NONE is invoked, the pointers to basis_set_a and basis_set_b are created, ! but not filled. Therefore, we check for the association and the number of entries. - IF (.NOT. ASSOCIATED(basis_set_a) .OR. SUM(basis_set_a%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_a)) CYCLE + IF (SUM(basis_set_a%nsgf_set) <= 0) CYCLE basis_set_b => basis_set_list_b(jkind)%gto_basis_set - IF (.NOT. ASSOCIATED(basis_set_b) .OR. SUM(basis_set_b%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE + IF (SUM(basis_set_b%nsgf_set) <= 0) CYCLE atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) diff --git a/src/mp2_gpw.F b/src/mp2_gpw.F index 98525dd116..46cb0e6a20 100644 --- a/src/mp2_gpw.F +++ b/src/mp2_gpw.F @@ -559,8 +559,9 @@ CONTAINS starts_array_mc, ends_array_mc, & starts_array_mc_block, ends_array_mc_block, calc_forces) - IF (mp2_env%ri_rpa%do_rse) & + IF (mp2_env%ri_rpa%do_rse) THEN CALL rse_energy(qs_env, mp2_env, para_env, dft_control, mo_coeff, homo, Eigenval) + END IF IF (do_im_time) THEN IF (ASSOCIATED(mat_P_global%matrix)) THEN diff --git a/src/mp2_grids.F b/src/mp2_grids.F index b252e372b8..85dd1350ba 100644 --- a/src/mp2_grids.F +++ b/src/mp2_grids.F @@ -133,12 +133,13 @@ CONTAINS my_regularization = regularization IF (num_integ_points > 20 .AND. e_range < 100.0_dp) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL cp_warn(__LOCATION__, & "You requested a large minimax grid (> 20 points) for a small minimax range R (R < 100). "// & "That may lead to numerical "// & "instabilities when computing minimax grid weights. You can prevent small ranges by choosing "// & "a larger basis set with higher angular momenta or alternatively using all-electron calculations.") + END IF END IF IF (.NOT. do_ri_sos_laplace_mp2) THEN diff --git a/src/mp2_ri_2c.F b/src/mp2_ri_2c.F index 33beee71d0..4ff515a0c1 100644 --- a/src/mp2_ri_2c.F +++ b/src/mp2_ri_2c.F @@ -916,9 +916,9 @@ CONTAINS hab=L_local_col, first_b=my_group_L_start, last_b=my_group_L_end, & eri_method=eri_method) - ELSEIF (eri_method == do_eri_gpw .OR. & - (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & - .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN + ELSE IF (eri_method == do_eri_gpw .OR. & + (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & + .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN CALL mp2_eri_2c_integrate_gpw(qs_env, para_env_sub, my_group_L_start, my_group_L_end, & natom, potential, sab_orb_sub, L_local_col, kind_of) diff --git a/src/mp2_ri_gpw.F b/src/mp2_ri_gpw.F index 93e6956add..39ce98dfc8 100644 --- a/src/mp2_ri_gpw.F +++ b/src/mp2_ri_gpw.F @@ -384,7 +384,8 @@ CONTAINS END IF END DO IF (my_alpha_beta_case .AND. calc_forces) THEN - ! Is just an approximation, but the call does not allow it, it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI + ! Is just an approximation, but the call does not allow it, + ! it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(ispin) + my_B_size(jspin), dimen_RI) ELSE CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(jspin), dimen_RI) @@ -451,11 +452,12 @@ CONTAINS my_Emp2_Ex = my_Emp2_Ex + sym_fac*local_ab(a_global, b)*external_ab(b, a)/ & (Eigenval(homo(ispin) + a_global, ispin) + Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) - IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) & + IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) THEN t_ab(a_global, b) = -(amp_fac*local_ab(a_global, b) - mp2_env%scale_T*external_ab(b, a))/ & (Eigenval(homo(ispin) + a_global, ispin) + & Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) + END IF END DO END DO END DO @@ -673,8 +675,9 @@ CONTAINS ! We do not need this matrix later, so deallocate it here to safe memory IF (calc_forces) DEALLOCATE (mp2_env%ri_grad%PQ_half) - IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) & + IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) THEN DEALLOCATE (mp2_env%ri_grad%operator_half) + END IF CALL dgemm_counter_write(dgemm_counter, para_env) @@ -1394,7 +1397,8 @@ CONTAINS ! 2*(NR/NG)+2*(1-(NR/NG))*(o/NB+NB-2)/NG = (NR/NG)*(1-(o/NB+NB-2)/NG)+(o/NB+NB-2)/NG ! We are looking for the minimum of the communication volume, ! thus, if the prefactor of (NR/NG) is smaller than zero, use the largest possible replication group size. - ! If the factor is larger than zero, set the replication group size to 1. (For small systems and a large number of subgroups) + ! If the factor is larger than zero, set the replication group size to 1. + ! (For small systems and a large number of subgroups) ! Replication group size = 1 implies that the integration group size equals the number of subgroups integ_group_size = ngroup @@ -2547,8 +2551,9 @@ CONTAINS DO iiB = 1, homo ! diagonal elements already updated DO jjB = iiB + 1, homo - IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) & + IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) THEN num_sing_ij = num_sing_ij + 1 + END IF END DO END DO diff --git a/src/mp2_ri_grad.F b/src/mp2_ri_grad.F index 9c98de42df..266f1edd5d 100644 --- a/src/mp2_ri_grad.F +++ b/src/mp2_ri_grad.F @@ -331,7 +331,7 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(matrix_P_munu_local) CALL dbcsr_deallocate_matrix_set(mat_munu_local) - ELSEIF (eri_method == do_eri_gpw) THEN + ELSE IF (eri_method == do_eri_gpw) THEN CALL get_qs_env(qs_env, ks_env=ks_env) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind) diff --git a/src/mpiwrap/message_passing.F b/src/mpiwrap/message_passing.F index 3c62f4ee9b..15f8d39d2c 100644 --- a/src/mpiwrap/message_passing.F +++ b/src/mpiwrap/message_passing.F @@ -33,7 +33,8 @@ MODULE message_passing #include "../base/base_uses.f90" -! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types +! To simplify the transition between the old MPI module and the F08-style module, +! we introduce these constants to switch between the required handle types ! Unfortunately, Fortran does not offer something like typedef in C++ #if defined(__parallel) && defined(__MPI_F08) #define MPI_DATA_TYPE TYPE(MPI_Datatype) @@ -60,9 +61,11 @@ MODULE message_passing #endif #if defined(__parallel) -! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion), +! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines +! (problems with types and ranks explosion), ! we do not quite know what is in the module, so we can not include any.... -! to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is +! to nevertheless get checking for what is included, we use the mpi module +! without use clause, getting all there is #if defined(__MPI_F08) USE mpi_f08 #else diff --git a/src/mpiwrap/mp_perf_env.F b/src/mpiwrap/mp_perf_env.F index 9c331367a6..7a28a50ebc 100644 --- a/src/mpiwrap/mp_perf_env.F +++ b/src/mpiwrap/mp_perf_env.F @@ -13,6 +13,8 @@ MODULE mp_perf_env USE kinds, ONLY: dp #include "../base/base_uses.f90" + IMPLICIT NONE + PRIVATE PUBLIC :: mp_perf_env_type diff --git a/src/mpiwrap/mp_perf_test.F b/src/mpiwrap/mp_perf_test.F index 3e9a701fbc..675e5b675d 100644 --- a/src/mpiwrap/mp_perf_test.F +++ b/src/mpiwrap/mp_perf_test.F @@ -34,6 +34,8 @@ MODULE mp_perf_test #endif #endif + IMPLICIT NONE + PRIVATE PUBLIC :: mpi_perf_test @@ -334,8 +336,9 @@ CONTAINS END IF rcount = Nloc DO itests = 1, 3 - IF (ionode .AND. output_unit > 0) & + IF (ionode .AND. output_unit > 0) THEN WRITE (output_unit, *) "------------------------------- test ", itests, " ------------------------" + END IF ! *** reference *** DO j = 1, Nprocs DO i = 1, Nloc diff --git a/src/mscfg_methods.F b/src/mscfg_methods.F index ee2a906e27..823de2c554 100644 --- a/src/mscfg_methods.F +++ b/src/mscfg_methods.F @@ -191,8 +191,10 @@ CONTAINS smear_almo_scf = qs_env%scf_control%smear%do_smear IF (smear_almo_scf) THEN scf_section => section_vals_get_subs_vals(dft_section, "SCF") - CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) !! Get total number of added MOs - tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 !! Get total number of atoms (assume consecutive atoms) + !! Get total number of added MOs + CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) + !! Get total number of atoms (assume consecutive atoms) + tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 !! Check that number of added MOs matches the number of atoms !! (to ensure compatibility, since each fragment will be computed with such parameters) IF (tot_isize /= tot_added_mos) THEN @@ -200,7 +202,8 @@ CONTAINS END IF !! Get total number of MOs CALL get_qs_env(qs_env, mos=mos) - IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") !! Unrestricted ALMO is not implemented yet + !! Unrestricted ALMO is not implemented yet + IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") CALL get_mo_set(mo_set=mos(1), nmo=nmo) !! Initialize storage of MO energies for ALMO smearing CPASSERT(ASSOCIATED(almo_scf_env)) diff --git a/src/mulliken.F b/src/mulliken.F index d1fe760821..0f77d12cf9 100644 --- a/src/mulliken.F +++ b/src/mulliken.F @@ -726,7 +726,7 @@ CONTAINS charges(i) = charges(i) + p_block(i, j)*s_block(i, j) END DO END DO - ELSEIF (iblock_col == iatom) THEN + ELSE IF (iblock_col == iatom) THEN DO j = 1, SIZE(p_block, 2) DO i = 1, SIZE(p_block, 1) charges(j) = charges(j) + p_block(i, j)*s_block(i, j) diff --git a/src/negf_control_types.F b/src/negf_control_types.F index 8d9c718239..0defb5e2e0 100644 --- a/src/negf_control_types.F +++ b/src/negf_control_types.F @@ -183,16 +183,19 @@ CONTAINS IF (ALLOCATED(negf_control%contacts)) THEN DO i = SIZE(negf_control%contacts), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) & + IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) THEN DEALLOCATE (negf_control%contacts(i)%atomlist_bulk) + END IF - IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) & + IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) THEN DEALLOCATE (negf_control%contacts(i)%atomlist_screening) + END IF IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell)) THEN DO j = SIZE(negf_control%contacts(i)%atomlist_cell), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) & + IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) THEN DEALLOCATE (negf_control%contacts(i)%atomlist_cell(j)%vector) + END IF END DO DEALLOCATE (negf_control%contacts(i)%atomlist_cell) END IF @@ -365,8 +368,9 @@ CONTAINS CALL section_vals_val_get(negf_section, "INTEGRATION_MIN_POINTS", i_val=negf_control%integr_min_points) CALL section_vals_val_get(negf_section, "INTEGRATION_MAX_POINTS", i_val=negf_control%integr_max_points) - IF (negf_control%integr_max_points < negf_control%integr_min_points) & + IF (negf_control%integr_max_points < negf_control%integr_min_points) THEN negf_control%integr_max_points = negf_control%integr_min_points + END IF CALL section_vals_val_get(negf_section, "MAX_SCF", i_val=negf_control%max_scf) @@ -428,8 +432,9 @@ CONTAINS DO i_rep = 1, n_rep IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN - IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) & + IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN natoms_total = natoms_total + SIZE(negf_control%contacts(i_rep)%atomlist_screening) + END IF END IF END DO diff --git a/src/negf_env_types.F b/src/negf_env_types.F index 7ddea351b0..f4d2564279 100644 --- a/src/negf_env_types.F +++ b/src/negf_env_types.F @@ -290,9 +290,10 @@ CONTAINS (icontact, sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, & para_env, negf_env, sub_env, negf_control, negf_section, log_unit, is_separate=.TRUE.) ELSE - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the separate bulk DFT calculation" + " from the separate bulk DFT calculation" + END IF CALL force_env_get(sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, qs_env=qs_env_contact) CALL qs_energies(qs_env_contact, consistent_energies=.FALSE., calc_forces=.FALSE.) CALL negf_env_contact_init_matrices(contact_env=negf_env%contacts(icontact), sub_env=sub_env, & @@ -314,9 +315,10 @@ CONTAINS CALL negf_env_contact_read_write_hs(icontact, force_env, para_env, negf_env, sub_env, negf_control, negf_section, & log_unit, is_separate=.FALSE., is_dft_entire=is_dft_entire) ELSE - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the entire system bulk DFT calculation" + " from the entire system bulk DFT calculation" + END IF IF (.NOT. is_dft_entire) CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) is_dft_entire = .TRUE. CALL negf_env_contact_init_matrices_gamma(contact_env=negf_env%contacts(icontact), & @@ -329,8 +331,9 @@ CONTAINS END DO ! stage 3: obtain an initial KS-matrix for the scattering region - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(/,T2,A,T70)') "NEGF| Construct the Kohn-Sham matrix for the scattering region" + END IF IF (negf_control%read_write_HS) THEN CALL negf_env_scatt_read_write_hs(force_env, para_env, negf_env, sub_env, negf_control, negf_section, log_unit, & is_dft_entire=is_dft_entire) @@ -915,18 +918,22 @@ CONTAINS CALL cp_abort(__LOCATION__, & "Primary and secondary bulk contact cells should not overlap ") ELSE IF (r2_origin_cell(1) < r2_origin_cell(2)) THEN - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(1)%vector))) + END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(1)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(2)%vector))) + END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(2)%vector(:) ELSE - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(2)%vector))) + END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(2)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(1)%vector))) + END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(1)%vector(:) END IF IF (.NOT. contact_control%read_write_HS) THEN @@ -1690,8 +1697,9 @@ CONTAINS natoms_cell0 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) & + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) THEN natoms_cell0 = natoms_cell0 + 1 + END IF END DO ALLOCATE (atomlist_cell0(natoms_cell0)) @@ -1771,8 +1779,9 @@ CONTAINS natoms_cell1 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) & + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) THEN natoms_cell1 = natoms_cell1 + 1 + END IF END DO ALLOCATE (atomlist_cell1(natoms_cell1)) diff --git a/src/negf_green_methods.F b/src/negf_green_methods.F index f7ff34dbbf..bc0d5076e0 100644 --- a/src/negf_green_methods.F +++ b/src/negf_green_methods.F @@ -363,8 +363,9 @@ CONTAINS ! omega * S_S - H_S - V_Hartree CALL cp_fm_to_cfm(msourcer=s_s, mtarget=g_ret_s) CALL cp_cfm_scale_and_add_fm(omega, g_ret_s, z_mone, h_s) - IF (PRESENT(v_hartree_s)) & + IF (PRESENT(v_hartree_s)) THEN CALL cp_cfm_scale_and_add_fm(z_one, g_ret_s, z_one, v_hartree_s) + END IF ! g_ret_s = [omega * S_S - H_S - \sum_{contact} self_energy_{contact}^{ret.} ]^-1 CALL cp_cfm_scale_and_add(z_one, g_ret_s, z_mone, self_energy_ret_sum) diff --git a/src/negf_integr_cc.F b/src/negf_integr_cc.F index c4facd0f4f..87d553d2c0 100644 --- a/src/negf_integr_cc.F +++ b/src/negf_integr_cc.F @@ -173,8 +173,9 @@ CONTAINS ! rescale all but the end-points, as they are transformed into themselves (-1.0 -> -1.0; 0.0 -> 0.0). ! Moreover, by applying this rescaling transformation to the end-points we cannot guarantee the exact ! result due to rounding errors in evaluation of COS function. - IF (nnodes_half > 2) & + IF (nnodes_half > 2) THEN CALL rescale_nodes_cos(nnodes_half - 2, cc_env%tnodes(2:)) + END IF SELECT CASE (interval_id) CASE (cc_interval_full) diff --git a/src/negf_integr_simpson.F b/src/negf_integr_simpson.F index 9d57abd95c..d732913bdf 100644 --- a/src/negf_integr_simpson.F +++ b/src/negf_integr_simpson.F @@ -312,8 +312,9 @@ CONTAINS END IF IF (nintervals > 0) THEN - IF (SIZE(xnodes_unity) < 4*nintervals) & + IF (SIZE(xnodes_unity) < 4*nintervals) THEN nintervals = SIZE(xnodes_unity)/4 + END IF DO interval = 1, nintervals xnodes_unity(4*interval - 3) = 0.125_dp* & @@ -553,14 +554,16 @@ CONTAINS DO interval = 1, nintervals_exist errors(interval) = subintervals(interval)%error - IF (subintervals(interval)%error > subintervals(interval)%conv) & + IF (subintervals(interval)%error > subintervals(interval)%conv) THEN nintervals = nintervals + 1 + END IF END DO CALL sort(errors, nintervals_exist, inds) - IF (nintervals > 0) & + IF (nintervals > 0) THEN ALLOCATE (sr_env%subintervals(nintervals)) + END IF nintervals = 0 DO ipoint = nintervals_exist, 1, -1 diff --git a/src/negf_integr_utils.F b/src/negf_integr_utils.F index 4cb86ead5f..82651f58fa 100644 --- a/src/negf_integr_utils.F +++ b/src/negf_integr_utils.F @@ -81,11 +81,9 @@ CONTAINS SELECT CASE (shape_id) CASE (contour_shape_linear) - IF (PRESENT(xnodes)) & - CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) + IF (PRESENT(xnodes)) CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) - IF (PRESENT(weights)) & - weights(:) = b - a + IF (PRESENT(weights)) weights(:) = b - a CASE (contour_shape_arc) ALLOCATE (tnodes_angle(nnodes)) @@ -93,8 +91,7 @@ CONTAINS tnodes_angle(:) = tnodes(:) CALL rescale_nodes_pi_phi(a, b, nnodes, tnodes_angle) - IF (PRESENT(xnodes)) & - CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) + IF (PRESENT(xnodes)) CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) IF (PRESENT(weights)) THEN rscale = (pi - get_arc_smallest_angle(a, b))*get_arc_radius(a, b) diff --git a/src/negf_matrix_utils.F b/src/negf_matrix_utils.F index 5b55feab07..5e957b06c3 100644 --- a/src/negf_matrix_utils.F +++ b/src/negf_matrix_utils.F @@ -342,8 +342,9 @@ CONTAINS DO ic = 1, ncell rep = i_to_c(direction_axis_abs, ic) - IF (ABS(rep) <= 2) & + IF (ABS(rep) <= 2) THEN CALL dbcsr_add(matrix_cells_raw(rep)%matrix, mat_nosym(ic)%matrix, 1.0_dp, 1.0_dp) + END IF END DO IF (direction_axis >= 0) THEN @@ -469,15 +470,17 @@ CONTAINS block=rblock, found=found) IF (found) THEN iproc = rank_contact(irow, icol) - IF (iproc > 0) & + IF (iproc > 0) THEN send_nelems(iproc) = send_nelems(iproc) + SIZE(rblock) + END IF END IF CALL dbcsr_get_block_p(matrix=matrix_contact, row=irow, col=icol, block=rblock, found=found) IF (found) THEN iproc = rank_device(irow, icol) - IF (iproc > 0) & + IF (iproc > 0) THEN recv_nelems(iproc) = recv_nelems(iproc) + SIZE(rblock) + END IF END IF END DO END DO @@ -485,14 +488,16 @@ CONTAINS ! pack blocks ALLOCATE (recv_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN ALLOCATE (recv_packed_blocks(iproc)%vector(recv_nelems(iproc))) + END IF END DO ALLOCATE (send_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (send_nelems(iproc) > 0) & + IF (send_nelems(iproc) > 0) THEN ALLOCATE (send_packed_blocks(iproc)%vector(send_nelems(iproc))) + END IF END DO send_nelems(:) = 0 @@ -556,15 +561,17 @@ CONTAINS CALL para_env%irecv(recv_packed_blocks(iproc)%vector, iproc - 1, recv_handlers(iproc), 1) END IF ELSE - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN CALL MOVE_ALLOC(send_packed_blocks(iproc)%vector, recv_packed_blocks(iproc)%vector) + END IF END IF END DO ! unpack blocks DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN CALL recv_handlers(iproc)%wait() + END IF END DO recv_nelems(:) = 0 @@ -601,22 +608,25 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) & + IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) THEN CALL send_handlers(iproc)%wait() + END IF END DO ! release memory DEALLOCATE (recv_handlers, send_handlers) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN DEALLOCATE (send_packed_blocks(iproc)%vector) + END IF END DO DEALLOCATE (send_packed_blocks) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) & + IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) THEN DEALLOCATE (recv_packed_blocks(iproc)%vector) + END IF END DO DEALLOCATE (recv_packed_blocks) @@ -744,8 +754,9 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN nomirror = nomirror + 1 + END IF END DO ! create the mirror imgs diff --git a/src/negf_methods.F b/src/negf_methods.F index 8fda96399e..8487a70d82 100644 --- a/src/negf_methods.F +++ b/src/negf_methods.F @@ -304,8 +304,9 @@ CONTAINS ! restart.hs ! ---------- - IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) & + IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) THEN CALL negf_write_restart(filename, negf_env, negf_control) + END IF ! current ! ------- @@ -965,8 +966,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_circular(ispin)) + END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_fm(ispin), & @@ -983,8 +985,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_linear(ispin)) + END IF END DO IF (nspins > 1) THEN @@ -1149,8 +1152,9 @@ CONTAINS END IF END IF - IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) & + IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) THEN CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) + END IF CALL get_qs_env(qs_env, blacs_env=blacs_env, do_kpoints=do_kpoints, dft_control=dft_control, & matrix_ks_kp=matrix_ks_qs_kp, para_env=para_env, rho=rho_struct, subsys=subsys) @@ -1395,8 +1399,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_circular(ispin)) + END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_new_fm(ispin), & @@ -1413,8 +1418,9 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_linear(ispin)) + END IF ! non-equilibrium part delta = 0.0_dp @@ -1439,8 +1445,9 @@ CONTAINS base_contact=base_contact, & matrix_s_global=matrix_s_fm, & g_surf_cache=g_surf_nonequiv(ispin)) - IF (negf_control%disable_cache) & + IF (negf_control%disable_cache) THEN CALL green_functions_cache_release(g_surf_nonequiv(ispin)) + END IF END IF END DO @@ -2134,8 +2141,9 @@ CONTAINS DO ipoint = 1, npoints IF (ASSOCIATED(g_ret_s(ipoint)%matrix_struct)) THEN CALL cp_cfm_finish_copy_general(g_ret_s(ipoint), info1(ipoint)) - IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) & + IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) THEN CALL cp_cfm_cleanup_copy_general(info1(ipoint)) + END IF END IF END DO diff --git a/src/negf_subgroup_types.F b/src/negf_subgroup_types.F index e5efda48c6..2eb0b3a5a6 100644 --- a/src/negf_subgroup_types.F +++ b/src/negf_subgroup_types.F @@ -137,8 +137,9 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) & + IF (ALLOCATED(sub_env%group_distribution)) THEN DEALLOCATE (sub_env%group_distribution) + END IF sub_env%ngroups = 0 diff --git a/src/offload/offload_api.F b/src/offload/offload_api.F index e9f508ee05..c9c4b8c48c 100644 --- a/src/offload/offload_api.F +++ b/src/offload/offload_api.F @@ -158,8 +158,9 @@ CONTAINS device_id = offload_get_chosen_device_c() - IF (device_id < 0) & + IF (device_id < 0) THEN CPABORT("No offload device has been chosen.") + END IF END FUNCTION offload_get_chosen_device diff --git a/src/openpmd_api.F b/src/openpmd_api.F index 82de3ca08c..00265196e0 100644 --- a/src/openpmd_api.F +++ b/src/openpmd_api.F @@ -24,11 +24,14 @@ MODULE openpmd_api USE kinds, ONLY: default_string_length, dp, sp USE message_passing, ONLY: mp_comm_type #include "./base/base_uses.f90" +#endif IMPLICIT NONE PRIVATE +#ifdef __OPENPMD + INTEGER, PARAMETER :: openpmd_access_create = 0 INTEGER, PARAMETER :: openpmd_access_read_only = 1 @@ -259,7 +262,6 @@ MODULE openpmd_api #:for dim in dimensions PUBLIC :: openpmd_dynamic_memory_view_type_${dim}$d #:endfor - #endif CONTAINS @@ -1214,6 +1216,5 @@ MODULE openpmd_api CALL openpmd_c_mesh_set_unit_dimension(this%c_ptr, unitDimension) END SUBROUTINE openpmd_mesh_set_unit_dimension - #endif END MODULE openpmd_api diff --git a/src/optimize_basis.F b/src/optimize_basis.F index 813e9e52a9..9fbbeb1eb1 100644 --- a/src/optimize_basis.F +++ b/src/optimize_basis.F @@ -196,8 +196,9 @@ CONTAINS DO iopt = 0, opt_bas%powell_param%maxfun CALL compute_residuum_vectors(opt_bas, f_env_id, matrix_S_inv, tot_time, & para_env_top, para_env, iopt) - IF (para_env_top%is_source()) & + IF (para_env_top%is_source()) THEN CALL powell_optimize(opt_bas%powell_param%nvar, opt_bas%x_opt, opt_bas%powell_param) + END IF CALL para_env_top%bcast(opt_bas%powell_param%state) CALL para_env_top%bcast(opt_bas%x_opt) CALL update_free_vars(opt_bas) @@ -362,9 +363,10 @@ CONTAINS icomb = MOD(icalc - 1, opt_bas%ncombinations) opt_bas%powell_param%f = opt_bas%powell_param%f + & (f_vec(icalc) + energy(icalc))*opt_bas%fval_weight(icomb) - IF (opt_bas%use_condition_number) & + IF (opt_bas%use_condition_number) THEN opt_bas%powell_param%f = opt_bas%powell_param%f + & LOG(cond_vec(icalc))*opt_bas%condition_weight(icomb) + END IF END DO ELSE f_vec = 0.0_dp; cond_vec = 0.0_dp; my_time = 0.0_dp; energy = 0.0_dp @@ -560,8 +562,7 @@ CONTAINS END DO DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & - SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) END DO CALL timestop(handle) @@ -667,8 +668,9 @@ CONTAINS tot_time = tot_time + my_time unit_nr = -1 - IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) & + IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) THEN unit_nr = cp_logger_get_default_unit_nr(logger) + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,I8)') "BASOPT| Information at iteration number:", iopt diff --git a/src/optimize_basis_types.F b/src/optimize_basis_types.F index ec2b96dff3..de46ed724b 100644 --- a/src/optimize_basis_types.F +++ b/src/optimize_basis_types.F @@ -177,8 +177,9 @@ CONTAINS IF (ALLOCATED(kind%deriv_info(iinfo)%in_use_set)) DEALLOCATE (kind%deriv_info(iinfo)%in_use_set) IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr)) THEN DO icont = 1, SIZE(kind%deriv_info(iinfo)%use_contr) - IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) & + IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) THEN DEALLOCATE (kind%deriv_info(iinfo)%use_contr(icont)%in_use) + END IF END DO DEALLOCATE (kind%deriv_info(iinfo)%use_contr) END IF @@ -190,22 +191,30 @@ CONTAINS DO ibasis = 0, SIZE(kind%flex_basis) - 1 IF (ALLOCATED(kind%flex_basis(ibasis)%subset)) THEN DO iset = 1, SIZE(kind%flex_basis(ibasis)%subset) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) & + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%l) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_coeff) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exps) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_exps) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_x_ind) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) & + END IF + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) THEN DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_const) + END IF END DO DEALLOCATE (kind%flex_basis(ibasis)%subset) END IF diff --git a/src/optimize_basis_utils.F b/src/optimize_basis_utils.F index 239226980e..0646e2fe77 100644 --- a/src/optimize_basis_utils.F +++ b/src/optimize_basis_utils.F @@ -83,8 +83,9 @@ CONTAINS CALL generate_initial_basis(kind_section, opt_bas, para_env) CALL section_vals_get(train_section, n_repetition=opt_bas%ntraining_sets) - IF (opt_bas%ntraining_sets == 0) & + IF (opt_bas%ntraining_sets == 0) THEN CPABORT("No training set was specified in the Input") + END IF ALLOCATE (opt_bas%training_input(opt_bas%ntraining_sets)) ALLOCATE (opt_bas%training_dir(opt_bas%ntraining_sets)) @@ -136,8 +137,9 @@ CONTAINS logger => cp_get_default_logger() unit_nr = -1 - IF (logger%para_env%is_source()) & + IF (logger%para_env%is_source()) THEN unit_nr = cp_logger_get_default_unit_nr(logger) + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,A)') "BASOPT| Total number of calculations ", & @@ -294,14 +296,16 @@ CONTAINS CALL section_vals_val_get(optbas_section, "GROUP_PARTITION", i_vals=i_vals) isize = SIZE(i_vals) nptot = SUM(i_vals) - IF (nptot /= nproc) & + IF (nptot /= nproc) THEN CALL cp_abort(__LOCATION__, & "Number of processors in group distribution does not match number of MPI tasks."// & " Please change input.") - IF (.NOT. isize <= ncalc) & + END IF + IF (.NOT. isize <= ncalc) THEN CALL cp_abort(__LOCATION__, & "Number of Groups larger than number of calculations"// & " Please change input.") + END IF CPASSERT(nptot == nproc) ALLOCATE (opt_bas%comp_group(isize)) ALLOCATE (opt_bas%group_partition(0:isize - 1)) @@ -741,12 +745,14 @@ CONTAINS CALL section_vals_val_get(const_section, "USE_EXP", i_vals=def_exp, i_rep_section=irep) CALL section_vals_val_get(const_section, "BOUNDARIES", explicit=is_bound, i_rep_section=irep) CALL section_vals_val_get(const_section, "MAX_VAR_FRACTION", explicit=is_varlim, i_rep_section=irep) - IF (is_bound .AND. is_varlim) & + IF (is_bound .AND. is_varlim) THEN CALL cp_abort(__LOCATION__, "Exponent has two constraints. "// & "This is not possible at the moment. Please change input.") - IF (.NOT. is_bound .AND. .NOT. is_varlim) & + END IF + IF (.NOT. is_bound .AND. .NOT. is_varlim) THEN CALL cp_abort(__LOCATION__, "Exponent is declared to be constraint but none is given"// & " Please change input.") + END IF IF (def_exp(1) == -1) THEN DO iset = 1, flex_basis%nsets IF (def_exp(2) == -1) THEN @@ -754,27 +760,30 @@ CONTAINS CALL set_constraint(flex_basis, iset, ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (def_exp(2) <= flex_basis%subset(iset)%nexp) & + IF (def_exp(2) <= flex_basis%subset(iset)%nexp) THEN CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") + END IF CALL set_constraint(flex_basis, iset, def_exp(2), const_section, is_bound, is_varlim, irep) END IF END DO ELSE - IF (.NOT. def_exp(1) <= flex_basis%nsets) & + IF (.NOT. def_exp(1) <= flex_basis%nsets) THEN CALL cp_abort(__LOCATION__, & "Set number of constraint is larger than number of sets in the template basis set."// & " Please change input.") + END IF IF (def_exp(2) == -1) THEN DO ipgf = 1, flex_basis%subset(iset)%nexp CALL set_constraint(flex_basis, def_exp(1), ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) & + IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) THEN CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") + END IF CALL set_constraint(flex_basis, def_exp(1), def_exp(2), const_section, is_bound, is_varlim, irep) END IF END IF @@ -805,10 +814,11 @@ CONTAINS REAL(KIND=dp) :: r_val REAL(KIND=dp), DIMENSION(:), POINTER :: r_vals - IF (flex_basis%subset(iset)%exp_has_const(ipgf)) & + IF (flex_basis%subset(iset)%exp_has_const(ipgf)) THEN CALL cp_abort(__LOCATION__, & "Multiple constraints due to collision in CONSTRAIN_EXPONENTS."// & " Please change input.") + END IF flex_basis%subset(iset)%exp_has_const(ipgf) = .TRUE. IF (is_bound) THEN flex_basis%subset(iset)%exp_const(ipgf)%const_type = 0 @@ -816,12 +826,13 @@ CONTAINS flex_basis%subset(iset)%exp_const(ipgf)%llim = MINVAL(r_vals) flex_basis%subset(iset)%exp_const(ipgf)%ulim = MAXVAL(r_vals) r_val = flex_basis%subset(iset)%exps(ipgf) - IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) & + IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) THEN CALL cp_abort(__LOCATION__, & "Exponent "//cp_to_string(r_val)// & " declared in constraint is out of bounds of constraint"//cp_to_string(MINVAL(r_vals))// & " to"//cp_to_string(MAXVAL(r_vals))// & " Please change input.") + END IF flex_basis%subset(iset)%exp_const(ipgf)%init = SUM(r_vals)/2.0_dp flex_basis%subset(iset)%exp_const(ipgf)%var_fac = MAXVAL(r_vals)/flex_basis%subset(iset)%exp_const(ipgf)%init - 1.0_dp END IF @@ -1139,8 +1150,7 @@ CONTAINS ! just to get an understandable basis normalize coefficients DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & - SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) END DO DEALLOCATE (r_val) diff --git a/src/optimize_embedding_potential.F b/src/optimize_embedding_potential.F index c36cbdd7aa..0c38b6568a 100644 --- a/src/optimize_embedding_potential.F +++ b/src/optimize_embedding_potential.F @@ -151,8 +151,9 @@ CONTAINS END DO ! Find out whether we need a spin-dependend embedding potential - IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) & + IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) THEN open_shell_embed = .TRUE. + END IF ! If it's open shell, we need to check spin states IF (open_shell_embed) THEN @@ -667,12 +668,14 @@ CONTAINS TYPE(opt_embed_pot_type) :: opt_embed ! Read the potential as a vector in the auxiliary basis - IF (opt_embed%read_embed_pot) & + IF (opt_embed%read_embed_pot) THEN CALL read_embed_pot_vector(qs_env, embed_pot, spin_embed_pot, section, & opt_embed%embed_pot_coef, opt_embed%open_shell_embed) + END IF ! Read the potential as a cube (two cubes for open shell) - IF (opt_embed%read_embed_pot_cube) & + IF (opt_embed%read_embed_pot_cube) THEN CALL read_embed_pot_cube(embed_pot, spin_embed_pot, section, opt_embed%open_shell_embed) + END IF END SUBROUTINE read_embed_pot @@ -695,8 +698,9 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CPABORT("Embedding cube file not found. ") + END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(embed_pot, filename, scaling_factor) @@ -706,8 +710,9 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_SPIN_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CPABORT("Embedding spin cube file not found. ") + END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(spin_embed_pot, filename, scaling_factor) @@ -784,8 +789,9 @@ CONTAINS READ (restart_unit) dimen_restart_basis ! Check the dimensions of the bases: the actual and the restart one - IF (.NOT. (dimen_restart_basis == dimen_aux)) & + IF (.NOT. (dimen_restart_basis == dimen_aux)) THEN CPABORT("Wrong dimension of the embedding basis in the restart file.") + END IF ALLOCATE (coef_read(dimen_var_aux)) coef_read = 0.0_dp @@ -844,8 +850,9 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_RESTART_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) & + IF (.NOT. exist) THEN CPABORT("Embedding restart file not found. ") + END IF END SUBROUTINE embed_restart_file_name @@ -1505,14 +1512,16 @@ CONTAINS ELSE ! Finite basis optimization ! If the previous step has been rejected, we go back to the previous expansion coefficients - IF (.NOT. opt_embed%accept_step) & + IF (.NOT. opt_embed%accept_step) THEN CALL cp_fm_scale_and_add(1.0_dp, opt_embed%embed_pot_coef, -1.0_dp, opt_embed%step) + END IF ! Do a simple steepest descent IF (opt_embed%steep_desc) THEN - IF (opt_embed%i_iter > 2) & + IF (opt_embed%i_iter > 2) THEN opt_embed%trust_rad = Barzilai_Borwein(opt_embed%step, opt_embed%prev_step, & opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad) + END IF IF (ABS(opt_embed%trust_rad) > opt_embed%max_trad) THEN IF (opt_embed%trust_rad > 0.0_dp) THEN opt_embed%trust_rad = opt_embed%max_trad @@ -1530,9 +1539,11 @@ CONTAINS ! First, update the Hessian inverse if needed IF (opt_embed%i_iter > 1) THEN - IF (opt_embed%accept_step) & ! We don't update Hessian if the step has been rejected + IF (opt_embed%accept_step) THEN + ! We don't update Hessian if the step has been rejected CALL symm_rank_one_update(opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad, & opt_embed%step, opt_embed%prev_embed_pot_Hess, opt_embed%embed_pot_Hess) + END IF END IF ! Add regularization term to the Hessian @@ -2213,8 +2224,9 @@ CONTAINS ! If energy change is larger than the predicted one, increase trust radius twice ! Else (between 0 and 1) leave as it is, unless Newton step has been taken and if the step is less than max IF ((ener_ratio > 1.0_dp) .AND. (.NOT. opt_embed%newton_step) .AND. & - (opt_embed%trust_rad < opt_embed%max_trad)) & + (opt_embed%trust_rad < opt_embed%max_trad)) THEN opt_embed%trust_rad = 2.0_dp*opt_embed%trust_rad + END IF ELSE ! Energy decreases ! If the decrease is not too large we allow this step to be taken ! Otherwise, the step is rejected @@ -2222,8 +2234,9 @@ CONTAINS opt_embed%accept_step = .FALSE. END IF ! Trust radius is decreased 4 times unless it's smaller than the minimal allowed value - IF (opt_embed%trust_rad >= opt_embed%min_trad) & + IF (opt_embed%trust_rad >= opt_embed%min_trad) THEN opt_embed%trust_rad = 0.25_dp*opt_embed%trust_rad + END IF END IF IF (opt_embed%accept_step) opt_embed%last_accepted = opt_embed%i_iter diff --git a/src/optimize_input.F b/src/optimize_input.F index 318487e913..bf550ed1b4 100644 --- a/src/optimize_input.F +++ b/src/optimize_input.F @@ -525,8 +525,9 @@ CONTAINS n_frames_current = 0 NULLIFY (pos_traj, energy_traj, force_traj) filename = oi_env%fm_env%ref_traj_file_name - IF (filename == "") & + IF (filename == "") THEN CPABORT("The reference trajectory file name is empty") + END IF CALL parser_create(local_parser, filename, para_env=para_env) DO CALL parser_read_line(local_parser, 1, at_end=at_end) @@ -559,8 +560,9 @@ CONTAINS ! now force reference trajectory filename = oi_env%fm_env%ref_force_file_name - IF (filename == "") & + IF (filename == "") THEN CPABORT("The reference force file name is empty") + END IF CALL parser_create(local_parser, filename, para_env=para_env) DO iframe = 1, n_frames CALL parser_read_line(local_parser, 1) diff --git a/src/pair_potential.F b/src/pair_potential.F index 6e2d4af4f5..3f56b1de2c 100644 --- a/src/pair_potential.F +++ b/src/pair_potential.F @@ -31,7 +31,7 @@ MODULE pair_potential USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, compare_pot, deepmd_type, ea_type, ft_type, & ftd_type, gal21_type, gal_type, gp_type, gw_type, ip_type, list_pot, lj_charmm_type, & - lj_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & + lj_type, mace_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & pair_potential_single_type, potential_single_allocation, siepmann_type, tab_type, & tersoff_type, wl_type USE pair_potential_util, ONLY: ener_pot,& @@ -188,7 +188,8 @@ CONTAINS DO k = 1, SIZE(pot%type) SELECT CASE (pot%type(k)) CASE (lj_type, lj_charmm_type, wl_type, gw_type, ft_type, ftd_type, ip_type, & - b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, tab_type, deepmd_type, ace_type) + b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, mace_type, tab_type, & + deepmd_type, ace_type) pot%no_pp = .FALSE. CASE (tersoff_type) pot%no_mb = .FALSE. @@ -206,7 +207,7 @@ CONTAINS END SELECT ! Special case for EAM SELECT CASE (pot%type(k)) - CASE (ea_type, nequip_type, allegro_type, deepmd_type, ace_type) + CASE (ea_type, nequip_type, allegro_type, mace_type, deepmd_type, ace_type) pot%no_mb = .FALSE. END SELECT END DO @@ -605,7 +606,7 @@ CONTAINS nvar = 5 + nvar CASE (ea_type) nvar = 4 + nvar - CASE (nequip_type) + CASE (nequip_type, mace_type) nvar = 1 + nvar CASE (allegro_type) nvar = 1 + nvar @@ -688,7 +689,7 @@ CONTAINS pot_par(nk, 2) = potparm%pot(i, j)%pot%set(1)%eam%drhoar pot_par(nk, 3) = potparm%pot(i, j)%pot%set(1)%eam%acutal pot_par(nk, 4) = potparm%pot(i, j)%pot%set(1)%eam%npoints - CASE (nequip_type, allegro_type) + CASE (nequip_type, allegro_type, mace_type) pot_par(nk, 1) = str2id( & TRIM(potparm%pot(i, j)%pot%set(1)%nequip%pot_file_name)) CASE (ace_type) diff --git a/src/pair_potential_types.F b/src/pair_potential_types.F index ec797ee3f5..23aacc5225 100644 --- a/src/pair_potential_types.F +++ b/src/pair_potential_types.F @@ -54,9 +54,10 @@ MODULE pair_potential_types gal21_type = 18, & tab_type = 19, & deepmd_type = 20, & - ace_type = 21 + ace_type = 21, & + mace_type = 22 - INTEGER, PUBLIC, PARAMETER, DIMENSION(21) :: list_pot = [nn_type, & + INTEGER, PUBLIC, PARAMETER, DIMENSION(22) :: list_pot = [nn_type, & lj_type, & lj_charmm_type, & ft_type, & @@ -76,7 +77,8 @@ MODULE pair_potential_types gal21_type, & tab_type, & deepmd_type, & - ace_type] + ace_type, & + mace_type] ! Shell model INTEGER, PUBLIC, PARAMETER :: nosh_nosh = 0, & @@ -468,7 +470,7 @@ CONTAINS CASE (deepmd_type) IF ((pot1%set(i)%deepmd%deepmd_file_name == pot2%set(i)%deepmd%deepmd_file_name) .AND. & (pot1%set(i)%deepmd%atom_deepmd_type == pot2%set(i)%deepmd%atom_deepmd_type)) mycompare = .TRUE. - CASE (nequip_type, allegro_type) + CASE (nequip_type, allegro_type, mace_type) IF ((pot1%set(i)%nequip%pot_file_name == pot2%set(i)%nequip%pot_file_name) .AND. & (pot1%set(i)%nequip%unit_length == pot2%set(i)%nequip%unit_length) .AND. & (pot1%set(i)%nequip%unit_forces == pot2%set(i)%nequip%unit_forces) .AND. & @@ -641,10 +643,12 @@ CONTAINS potparm%at1 = 'NULL' potparm%at2 = 'NULL' potparm%rcutsq = 0.0_dp - IF (ASSOCIATED(potparm%pair_spline_data)) & + IF (ASSOCIATED(potparm%pair_spline_data)) THEN CALL spline_data_p_release(potparm%pair_spline_data) - IF (ASSOCIATED(potparm%spl_f)) & + END IF + IF (ASSOCIATED(potparm%spl_f)) THEN CALL spline_factor_release(potparm%spl_f) + END IF DO i = 1, SIZE(potparm%type) potparm%set(i)%rmin = not_initialized @@ -1049,8 +1053,9 @@ CONTAINS IF (PRESENT(istart)) l_start = istart IF (PRESENT(iend)) l_end = iend DO i = l_start, l_end - IF (.NOT. ASSOCIATED(source%pot(i)%pot)) & + IF (.NOT. ASSOCIATED(source%pot(i)%pot)) THEN CALL pair_potential_single_create(source%pot(i)%pot) + END IF CALL pair_potential_single_copy(source%pot(i)%pot, dest%pot(i)%pot) END DO END SUBROUTINE pair_potential_p_copy @@ -1286,7 +1291,7 @@ CONTAINS CALL pair_potential_goodwin_create(p%pot(i)%pot%set(std_dim)%goodwin) CASE (ea_type) CALL pair_potential_eam_create(p%pot(i)%pot%set(std_dim)%eam) - CASE (nequip_type, allegro_type) + CASE (nequip_type, allegro_type, mace_type) CALL pair_potential_nequip_create(p%pot(i)%pot%set(std_dim)%nequip) CASE (ace_type) CALL pair_potential_ace_create(p%pot(i)%pot%set(std_dim)%ace) diff --git a/src/pair_potential_util.F b/src/pair_potential_util.F index bb0163846f..9e77235b32 100644 --- a/src/pair_potential_util.F +++ b/src/pair_potential_util.F @@ -109,7 +109,7 @@ CONTAINS index = INT(r/pot%set(j)%eam%drar) + 1 IF (index > pot%set(j)%eam%npoints) THEN index = pot%set(j)%eam%npoints - ELSEIF (index < 1) THEN + ELSE IF (index < 1) THEN index = 1 END IF qq = r - pot%set(j)%eam%rval(index) @@ -119,17 +119,17 @@ CONTAINS ELSE IF (pot%type(j) == b4_type) THEN IF (r <= pot%set(j)%buck4r%r1) THEN pp = pot%set(j)%buck4r%a*EXP(-pot%set(j)%buck4r%b*r) - ELSEIF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN + ELSE IF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly1 pp = pp + pot%set(j)%buck4r%poly1(n)*r**n END DO - ELSEIF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN + ELSE IF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly2 pp = pp + pot%set(j)%buck4r%poly2(n)*r**n END DO - ELSEIF (r > pot%set(j)%buck4r%r3) THEN + ELSE IF (r > pot%set(j)%buck4r%r3) THEN pp = -pot%set(j)%buck4r%c/r**6 END IF lvalue = pp @@ -139,7 +139,7 @@ CONTAINS IF (index2 > pot%set(j)%tab%npoints) THEN index2 = pot%set(j)%tab%npoints index1 = index2 - 1 - ELSEIF (index1 < 1) THEN + ELSE IF (index1 < 1) THEN index1 = 1 index2 = 2 END IF @@ -156,8 +156,9 @@ CONTAINS ELSE IF (pot%type(j) == gp_type) THEN pot%set(j)%gp%values(1) = r lvalue = evalf(pot%set(j)%gp%myid, pot%set(j)%gp%values) - IF (EvalErrType > 0) & + IF (EvalErrType > 0) THEN CPABORT("Error evaluating generic potential energy function") + END IF ELSE lvalue = 0.0_dp END IF @@ -189,7 +190,7 @@ CONTAINS fac = pot%z1*pot%z2/evolt ener_zbl = fac/r*(0.1818_dp*EXP(-3.2_dp*x) + 0.5099_dp*EXP(-0.9423_dp*x) + & 0.2802_dp*EXP(-0.4029_dp*x) + 0.02817_dp*EXP(-0.2016_dp*x)) - ELSEIF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN + ELSE IF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN ener_zbl = pot%zbl_poly(0) + pot%zbl_poly(1)*r + pot%zbl_poly(2)*r*r + pot%zbl_poly(3)*r*r*r + & pot%zbl_poly(4)*r*r*r*r + pot%zbl_poly(5)*r*r*r*r*r ELSE diff --git a/src/pao_io.F b/src/pao_io.F index 166da4d769..ac4c035268 100644 --- a/src/pao_io.F +++ b/src/pao_io.F @@ -121,8 +121,9 @@ CONTAINS END IF ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN CPABORT("Restart PAO parametrization does not match") + END IF ! check kinds DO ikind = 1, SIZE(kinds) @@ -130,13 +131,15 @@ CONTAINS END DO ! check number of atoms - IF (SIZE(positions, 1) /= natoms) & + IF (SIZE(positions, 1) /= natoms) THEN CPABORT("Number of atoms do not match") + END IF ! check atom2kind DO iatom = 1, natoms - IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) & + IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) THEN CPABORT("Restart atomic kinds do not match.") + END IF END DO ! check positions, warning only @@ -160,8 +163,9 @@ CONTAINS END IF CALL para_env%bcast(buffer) CALL dbcsr_get_block_p(matrix=pao%matrix_X, row=iatom, col=iatom, block=block_X, found=found) - IF (ASSOCIATED(block_X)) & + IF (ASSOCIATED(block_X)) THEN block_X = buffer + END IF DEALLOCATE (buffer) END DO @@ -212,8 +216,9 @@ CONTAINS ! check if file starts with proper header !TODO: introduce a more unique header READ (unit_nr, fmt=*) label, i1 - IF (TRIM(label) /= "Version") & + IF (TRIM(label) /= "Version") THEN CPABORT("PAO restart file appears to be corrupted.") + END IF IF (i1 /= file_format_version) CPABORT("Restart PAO file format version is wrong") DO WHILE (.TRUE.) @@ -340,8 +345,9 @@ CONTAINS atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) - IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) & + IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) THEN CPABORT("Some kinds are missing.") + END IF CALL get_atomic_kind(atomic_kind_set(ikind), z=z, name=name) CALL get_qs_kind(qs_kind_set(ikind), & @@ -350,20 +356,27 @@ CONTAINS pao_potentials=pao_potentials) CALL pao_param_count(pao, qs_env, ikind=ikind, nparams=nparams) - IF (pao_kind%nparams /= nparams) & + IF (pao_kind%nparams /= nparams) THEN CPABORT("Number of parameters do not match") - IF (TRIM(pao_kind%name) /= TRIM(name)) & + END IF + IF (TRIM(pao_kind%name) /= TRIM(name)) THEN CPABORT("Kind names do not match") - IF (pao_kind%z /= z) & + END IF + IF (pao_kind%z /= z) THEN CPABORT("Atomic numbers do not match") - IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) & + END IF + IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) THEN CPABORT("Primary Basis-set name does not match") - IF (pao_kind%prim_basis_size /= basis_set%nsgf) & + END IF + IF (pao_kind%prim_basis_size /= basis_set%nsgf) THEN CPABORT("Primary Basis-set size does not match") - IF (pao_kind%pao_basis_size /= pao_basis_size) & + END IF + IF (pao_kind%pao_basis_size /= pao_basis_size) THEN CPABORT("PAO basis size does not match") - IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) & + END IF + IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) THEN CPABORT("Number of PAO_POTENTIALS does not match") + END IF DO ipot = 1, SIZE(pao_potentials) IF (pao_kind%pao_potentials(ipot)%maxl /= pao_potentials(ipot)%maxl) THEN @@ -421,8 +434,9 @@ CONTAINS CALL para_env%max(unit_max) IF (unit_max > 0) THEN IF (pao%iw > 0) WRITE (pao%iw, '(A,A)') " PAO| Writing restart file." - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL write_restart_header(pao, qs_env, energy, unit_nr) + END IF CALL pao_write_diagonal_blocks(para_env, pao%matrix_X, "Xblock", unit_nr) @@ -463,8 +477,10 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) & ! catch corner-case + IF (SIZE(local_block) > 0) THEN + ! catch corner-case mpi_buffer(:, :) = local_block(:, :) + END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/pao_linpot_rotinv.F b/src/pao_linpot_rotinv.F index 91c735c395..12698d45c1 100644 --- a/src/pao_linpot_rotinv.F +++ b/src/pao_linpot_rotinv.F @@ -83,10 +83,12 @@ CONTAINS ! terms sensing neighboring atoms DO ipot = 1, npots pot_maxl = pao_potentials(ipot)%maxl ! maxl is taken from central atom - IF (pot_maxl < 0) & + IF (pot_maxl < 0) THEN CPABORT("ROTINV parametrization requires non-negative PAO_POTENTIAL%MAXL") - IF (MOD(pot_maxl, 2) /= 0) & + END IF + IF (MOD(pot_maxl, 2) /= 0) THEN CPABORT("ROTINV parametrization requires even-numbered PAO_POTENTIAL%MAXL") + END IF DO max_shell = 1, nshells DO min_shell = 1, max_shell DO lpot = 0, pot_maxl, 2 @@ -203,8 +205,9 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) & + IF (SIZE(jpao_potentials) /= npots) THEN CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") + END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom @@ -448,8 +451,9 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) & + IF (SIZE(jpao_potentials) /= npots) THEN CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") + END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom diff --git a/src/pao_main.F b/src/pao_main.F index db6fcac257..b4a61ce1ab 100644 --- a/src/pao_main.F +++ b/src/pao_main.F @@ -279,8 +279,9 @@ CONTAINS EXIT END IF - IF (MOD(icycle, pao%write_cycles) == 0) & - CALL pao_write_restart(pao, qs_env, energy) ! write an intermediate restart file + IF (MOD(icycle, pao%write_cycles) == 0) THEN + CALL pao_write_restart(pao, qs_env, energy) + END IF ! write an intermediate restart file END IF ! check for early abort without convergence? diff --git a/src/pao_methods.F b/src/pao_methods.F index 203df6946c..cdce9d2815 100644 --- a/src/pao_methods.F +++ b/src/pao_methods.F @@ -133,8 +133,9 @@ CONTAINS ! Load torch model. IF (LEN_TRIM(pao_model_file) > 0) THEN - IF (.NOT. ALLOCATED(pao%models)) & + IF (.NOT. ALLOCATED(pao%models)) THEN ALLOCATE (pao%models(SIZE(qs_kind_set))) + END IF CALL pao_model_load(pao, qs_env, ikind, pao_model_file, pao%models(ikind)) END IF @@ -290,8 +291,9 @@ CONTAINS CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind), pao_basis_size=M) CPASSERT(M > 0) - IF (blk_sizes_pri(iatom) < M) & + IF (blk_sizes_pri(iatom) < M) THEN CPABORT("PAO basis size exceeds primary basis size.") + END IF blk_sizes_aux(iatom) = M END DO @@ -554,8 +556,9 @@ CONTAINS CALL dbcsr_release(matrix_S_desym) - IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) & + IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) THEN CPABORT("Number of electrons wrong. Trace(PS) ="//cp_to_string(trace_PS)) + END IF CALL timestop(handle) END SUBROUTINE pao_check_trace_PS @@ -983,12 +986,15 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) "PAO| Adding forces." IF (pao%max_pao /= 0) THEN - IF (pao%penalty_strength /= 0.0_dp) & + IF (pao%penalty_strength /= 0.0_dp) THEN CPABORT("PAO forces require PENALTY_STRENGTH or MAX_PAO set to zero") - IF (pao%linpot_regu_strength /= 0.0_dp) & + END IF + IF (pao%linpot_regu_strength /= 0.0_dp) THEN CPABORT("PAO forces require LINPOT_REGULARIZATION_STRENGTH or MAX_PAO set to zero") - IF (pao%regularization /= 0.0_dp) & + END IF + IF (pao%regularization /= 0.0_dp) THEN CPABORT("PAO forces require REGULARIZATION or MAX_PAO set to zero") + END IF END IF CALL get_qs_env(qs_env, & @@ -999,11 +1005,13 @@ CONTAINS ALLOCATE (forces(natoms, 3)) CALL pao_calc_AB(pao, qs_env, ls_scf_env, gradient=.TRUE., forces=forces) ! without penalty terms - IF (SIZE(pao%ml_training_set) > 0) & + IF (SIZE(pao%ml_training_set) > 0) THEN CALL pao_ml_forces(pao, qs_env, pao%matrix_G, forces) + END IF - IF (ALLOCATED(pao%models)) & + IF (ALLOCATED(pao%models)) THEN CALL pao_model_forces(pao, qs_env, pao%matrix_G, forces) + END IF CALL para_env%sum(forces) DO iatom = 1, natoms diff --git a/src/pao_ml.F b/src/pao_ml.F index b711d54387..95de014193 100644 --- a/src/pao_ml.F +++ b/src/pao_ml.F @@ -95,8 +95,9 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO|ML| Initializing maschine learning...' - IF (pao%parameterization /= pao_rotinv_param) & + IF (pao%parameterization /= pao_rotinv_param) THEN CPABORT("PAO maschine learning requires ROTINV parametrization") + END IF CALL get_qs_env(qs_env, para_env=para_env, atomic_kind_set=atomic_kind_set) @@ -166,8 +167,9 @@ CONTAINS CALL pao_read_raw(filename, param, hmat, kinds, atom2kind, positions, xblocks, ml_range) ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN CPABORT("Restart PAO parametrization does not match") + END IF ! map read-in kinds onto kinds of this run CALL match_kinds(pao, qs_env, kinds, kindsmap) @@ -277,8 +279,9 @@ CONTAINS END DO END DO - IF (ANY(kindsmap < 1)) & + IF (ANY(kindsmap < 1)) THEN CPABORT("PAO: Could not match all kinds from training set") + END IF END SUBROUTINE match_kinds ! ************************************************************************************************** @@ -301,8 +304,10 @@ CONTAINS training_list => training_lists(ikind) IF (training_list%npoints > 0) CYCLE ! it's ok CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) - IF (pao_basis_size /= basis_set%nsgf) & ! if this kind has pao enabled... + IF (pao_basis_size /= basis_set%nsgf) THEN + ! if this kind has pao enabled... CPABORT("Found no training-points for kind: "//TRIM(training_list%kindname)) + END IF END DO END SUBROUTINE sanity_check @@ -343,10 +348,12 @@ CONTAINS ! figure out size of input and output inp_size = 0; out_size = 0 - IF (ALLOCATED(training_list%head%input)) & + IF (ALLOCATED(training_list%head%input)) THEN inp_size = SIZE(training_list%head%input) - IF (ALLOCATED(training_list%head%output)) & + END IF + IF (ALLOCATED(training_list%head%output)) THEN out_size = SIZE(training_list%head%output) + END IF CALL para_env%sum(inp_size) CALL para_env%sum(out_size) @@ -574,8 +581,9 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, "(A,E20.10,A,T71,I10)") " PAO|ML| max prediction variance:", & MAXVAL(variances), " for atom:", MAXLOC(variances) - IF (MAXVAL(variances) > pao%ml_tolerance) & + IF (MAXVAL(variances) > pao%ml_tolerance) THEN CPABORT("Variance of prediction above ML_TOLERANCE.") + END IF DEALLOCATE (variances) diff --git a/src/pao_ml_descriptor.F b/src/pao_ml_descriptor.F index a99b71053e..2550b05021 100644 --- a/src/pao_ml_descriptor.F +++ b/src/pao_ml_descriptor.F @@ -138,8 +138,9 @@ CONTAINS Rab = pbc(ra, rb, cell) CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=pao_descriptors) - IF (SIZE(pao_descriptors) /= ndesc) & + IF (SIZE(pao_descriptors) /= ndesc) THEN CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") + END IF weight = pao_descriptors(idesc)%weight beta = pao_descriptors(idesc)%beta CALL pao_calc_gaussian(basis_set, block_V=block_V, Rab=Rab, lpot=0, beta=beta, weight=weight) @@ -150,8 +151,9 @@ CONTAINS CALL diamat_all(V_evecs, V_evals) ! use eigenvalues of V_block as descriptor - IF (PRESENT(descriptor)) & + IF (PRESENT(descriptor)) THEN descriptor((idesc - 1)*N + 1:idesc*N) = V_evals(:) + END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN @@ -254,8 +256,9 @@ CONTAINS ! check if N was chosen large enough IF (natoms > N) THEN - IF (neighbor_dist(N + 1) < screening_radius) & + IF (neighbor_dist(N + 1) < screening_radius) THEN CPABORT("PAO heuristic for descriptor size broke down") + END IF END IF DO idesc = 1, ndesc @@ -273,8 +276,9 @@ CONTAINS CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=jpao_descriptors) CALL get_atomic_kind(particle_set(katom)%atomic_kind, kind_number=kkind) CALL get_qs_kind(qs_kind_set(kkind), pao_descriptors=kpao_descriptors) - IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) & + IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) THEN CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") + END IF jweight = jpao_descriptors(idesc)%weight jbeta = jpao_descriptors(idesc)%beta kweight = kpao_descriptors(idesc)%weight @@ -304,8 +308,9 @@ CONTAINS CALL diamat_all(S_evecs, S_evals) ! use eigenvalues of S_block as descriptor - IF (PRESENT(descriptor)) & + IF (PRESENT(descriptor)) THEN descriptor((idesc - 1)*N + 1:idesc*N) = S_evals(:) + END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN diff --git a/src/pao_ml_gaussprocess.F b/src/pao_ml_gaussprocess.F index b97e60b661..c73c250c12 100644 --- a/src/pao_ml_gaussprocess.F +++ b/src/pao_ml_gaussprocess.F @@ -112,8 +112,9 @@ CONTAINS ! calculate prediction's variance variance = kernel(pao%gp_scale, descriptor, descriptor) - DOT_PRODUCT(weights, cov) - IF (variance < 0.0_dp) & + IF (variance < 0.0_dp) THEN CPABORT("PAO gaussian process found negative variance") + END IF DEALLOCATE (cov, weights) END SUBROUTINE pao_ml_gp_predict diff --git a/src/pao_model.F b/src/pao_model.F index 01dc20903a..1fb7d10fcd 100644 --- a/src/pao_model.F +++ b/src/pao_model.F @@ -120,18 +120,24 @@ CONTAINS ! Check compatibility CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) CALL get_atomic_kind(atomic_kind_set(ikind), name=kind_name, z=z) - IF (model%version /= 2) & + IF (model%version /= 2) THEN CPABORT("Model version not supported.") - IF (TRIM(model%kind_name) /= TRIM(kind_name)) & + END IF + IF (TRIM(model%kind_name) /= TRIM(kind_name)) THEN CPABORT("Kind name does not match.") - IF (model%atomic_number /= z) & + END IF + IF (model%atomic_number /= z) THEN CPABORT("Atomic number does not match.") - IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) & + END IF + IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) THEN CPABORT("Primary basis set name does not match.") - IF (model%prim_basis_size /= basis_set%nsgf) & + END IF + IF (model%prim_basis_size /= basis_set%nsgf) THEN CPABORT("Primary basis set size does not match.") - IF (model%pao_basis_size /= pao_basis_size) & + END IF + IF (model%pao_basis_size /= pao_basis_size) THEN CPABORT("PAO basis size does not match.") + END IF CALL omp_init_lock(model%lock) CALL timestop(handle) diff --git a/src/pao_optimizer.F b/src/pao_optimizer.F index 6b5a46b663..63a5329dd7 100644 --- a/src/pao_optimizer.F +++ b/src/pao_optimizer.F @@ -48,8 +48,9 @@ CONTAINS CALL dbcsr_copy(pao%matrix_D_preconed, pao%matrix_D) END IF - IF (pao%optimizer == pao_opt_bfgs) & + IF (pao%optimizer == pao_opt_bfgs) THEN CALL pao_opt_init_bfgs(pao) + END IF END SUBROUTINE pao_opt_init @@ -85,11 +86,13 @@ CONTAINS CALL dbcsr_release(pao%matrix_D) CALL dbcsr_release(pao%matrix_G_prev) - IF (pao%precondition) & + IF (pao%precondition) THEN CALL dbcsr_release(pao%matrix_D_preconed) + END IF - IF (pao%optimizer == pao_opt_bfgs) & + IF (pao%optimizer == pao_opt_bfgs) THEN CALL dbcsr_release(pao%matrix_BFGS) + END IF END SUBROUTINE pao_opt_finalize diff --git a/src/pao_param_equi.F b/src/pao_param_equi.F index d0c64c33b3..4f81db62e7 100644 --- a/src/pao_param_equi.F +++ b/src/pao_param_equi.F @@ -49,8 +49,9 @@ CONTAINS SUBROUTINE pao_param_init_equi(pao) TYPE(pao_env_type), POINTER :: pao - IF (pao%precondition) & + IF (pao%precondition) THEN CPABORT("PAO preconditioning not supported for selected parametrization.") + END IF END SUBROUTINE pao_param_init_equi diff --git a/src/pao_param_exp.F b/src/pao_param_exp.F index f8a4897ba3..1aba9e19ac 100644 --- a/src/pao_param_exp.F +++ b/src/pao_param_exp.F @@ -104,8 +104,9 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) & + IF (pao%precondition) THEN CPABORT("PAO preconditioning not supported for selected parametrization.") + END IF CALL timestop(handle) END SUBROUTINE pao_param_init_exp diff --git a/src/pao_param_fock.F b/src/pao_param_fock.F index 023bbaae5c..9ffed6bbec 100644 --- a/src/pao_param_fock.F +++ b/src/pao_param_fock.F @@ -95,8 +95,10 @@ CONTAINS ! calculate homo-lumo gap (it's useful for detecting numerical issues) gap = HUGE(dp) - IF (m < n) & ! catch special case n==m + IF (m < n) THEN + ! catch special case n==m gap = H_evals(m + 1) - H_evals(m) + END IF IF (PRESENT(penalty)) THEN ! penalty terms: occupied and virtual eigenvalues repel each other @@ -164,8 +166,9 @@ CONTAINS M5 = MATMUL(MATMUL(block_N, M4), block_N) ! add regularization gradient - IF (PRESENT(penalty)) & + IF (PRESENT(penalty)) THEN M5 = M5 + 2.0_dp*pao%regularization*V + END IF ! symmetrize G = 0.5_dp*(M5 + TRANSPOSE(M5)) ! the final gradient diff --git a/src/pao_param_gth.F b/src/pao_param_gth.F index 31a8a8eda1..51fa85e990 100644 --- a/src/pao_param_gth.F +++ b/src/pao_param_gth.F @@ -123,8 +123,9 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) & + IF (pao%precondition) THEN CALL pao_param_gth_preconditioner(pao, qs_env, nterms) + END IF DEALLOCATE (row_blk_size, col_blk_size, nterms) CALL timestop(handle) @@ -208,8 +209,9 @@ CONTAINS CALL group%sum(block) CALL dbcsr_get_block_p(matrix=matrix_gth_overlap, row=iatom, col=jatom, block=block_overlap, found=found) - IF (ASSOCIATED(block_overlap)) & + IF (ASSOCIATED(block_overlap)) THEN block_overlap = block + END IF DEALLOCATE (block) END DO @@ -232,8 +234,9 @@ CONTAINS converged=converged) CALL dbcsr_release(matrix_gth_overlap) - IF (.NOT. converged) & + IF (.NOT. converged) THEN CPABORT("PAO: Sqrt of GTH-preconditioner did not converge.") + END IF CALL timestop(handle) END SUBROUTINE pao_param_gth_preconditioner @@ -381,8 +384,9 @@ CONTAINS DEALLOCATE (world_X, world_G) ! sum penalty energies across ranks - IF (PRESENT(penalty)) & + IF (PRESENT(penalty)) THEN CALL group%sum(penalty) + END IF ! print homo-lumo gap encountered by fock-layer CALL group%min(gaps) @@ -421,20 +425,24 @@ CONTAINS CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) CALL get_qs_kind(qs_kind_set(ikind), pao_potentials=pao_potentials) - IF (SIZE(pao_potentials) /= 1) & + IF (SIZE(pao_potentials) /= 1) THEN CPABORT("GTH parametrization requires exactly one PAO_POTENTIAL section per KIND") + END IF max_projector = pao_potentials(1)%max_projector maxl = pao_potentials(1)%maxl - IF (maxl < 0) & + IF (maxl < 0) THEN CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAXL") + END IF - IF (max_projector < 0) & + IF (max_projector < 0) THEN CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAX_PROJECTOR") + END IF - IF (MOD(maxl, 2) /= 0) & + IF (MOD(maxl, 2) /= 0) THEN CPABORT("GTH parametrization requires even-numbered PAO_POTENTIAL%MAXL") + END IF ncombis = (max_projector + 1)*(max_projector + 2)/2 nparams = ncombis*(maxl/2 + 1) diff --git a/src/pao_param_linpot.F b/src/pao_param_linpot.F index f4a1e21e2b..d32896a5ac 100644 --- a/src/pao_param_linpot.F +++ b/src/pao_param_linpot.F @@ -124,8 +124,9 @@ CONTAINS CALL pao_param_linpot_regularizer(pao) - IF (pao%precondition) & + IF (pao%precondition) THEN CALL pao_param_linpot_preconditioner(pao) + END IF CALL para_env%sync() ! ensure that timestop is not called too early @@ -445,19 +446,23 @@ CONTAINS CALL dbcsr_get_block_p(matrix=pao%matrix_V_terms, row=iatom, col=iatom, block=block_V_terms, found=found) CPASSERT(ASSOCIATED(block_V_terms)) nterms = SIZE(block_V_terms, 2) - IF (nterms > 0) & ! protect against corner-case of zero pao parameters + IF (nterms > 0) THEN + ! protect against corner-case of zero pao parameters vec_V = MATMUL(block_V_terms, block_X(:, 1)) + END IF block_V(1:n, 1:n) => vec_V(:) ! map vector into matrix ! symmetrize - IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) & + IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) THEN CPABORT("block_V not symmetric") + END IF block_V = 0.5_dp*(block_V + TRANSPOSE(block_V)) ! symmetrize exactly ! regularization energy ! protect against corner-case of zero pao parameters - IF (PRESENT(penalty) .AND. nterms > 0) & + IF (PRESENT(penalty) .AND. nterms > 0) THEN regu_energy = regu_energy + DOT_PRODUCT(block_X(:, 1), MATMUL(block_R, block_X(:, 1))) + END IF CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & gap=gaps(iatom), evals=evals(:, iatom)) @@ -473,16 +478,18 @@ CONTAINS !TODO: this 2nd call does double work. However, *sometimes* this branch is not taken. CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & M1=block_M1, G=block_M2, gap=gaps(iatom), evals=evals(:, iatom)) - IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) & + IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) THEN CPABORT("matrix not symmetric") + END IF ! gradient dE/dX IF (PRESENT(matrix_G)) THEN CALL dbcsr_get_block_p(matrix=matrix_G, row=iatom, col=iatom, block=block_G, found=found) CPASSERT(ASSOCIATED(block_G)) block_G(:, 1) = MATMUL(vec_M2, block_V_terms) - IF (PRESENT(penalty)) & - block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) ! regularization gradient + IF (PRESENT(penalty)) THEN + block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) + END IF ! regularization gradient END IF ! forced dE/dR diff --git a/src/pao_param_methods.F b/src/pao_param_methods.F index 010af4c056..37264fbec9 100644 --- a/src/pao_param_methods.F +++ b/src/pao_param_methods.F @@ -231,8 +231,9 @@ CONTAINS CALL group%max(delta_max) IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO| checked unitaryness, max delta:', delta_max - IF (delta_max > pao%check_unitary_tol) & + IF (delta_max > pao%check_unitary_tol) THEN CPABORT("Found bad unitaryness:"//cp_to_string(delta_max)) + END IF CALL timestop(handle) END SUBROUTINE pao_assert_unitary diff --git a/src/pao_types.F b/src/pao_types.F index 242f6095c4..1cb794451a 100644 --- a/src/pao_types.F +++ b/src/pao_types.F @@ -121,7 +121,8 @@ MODULE pao_types !> \var constants_ready set when stuff, which does not depend of atomic positions is ready !> \var need_initial_scf set when the initial density matrix is not self-consistend !> \var matrix_X parameters of pao basis, which eventually determine matrix_U. Uses diag_distribution. -!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. Uses diag_distribution. +!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. +!> Uses diag_distribution. !> \var matrix_H0 Diagonal blocks of core hamiltonian, uses diag_distribution !> \var matrix_Y selector matrix which translates between primary and pao basis. !> basically a block diagonal "rectangular identity matrix". Uses s_matrix-distribution. @@ -253,8 +254,9 @@ CONTAINS CALL dbcsr_release(pao%matrix_H0) DEALLOCATE (pao%ml_training_set) - IF (ALLOCATED(pao%ml_training_matrices)) & + IF (ALLOCATED(pao%ml_training_matrices)) THEN DEALLOCATE (pao%ml_training_matrices) + END IF IF (ALLOCATED(pao%models)) THEN DO i = 1, SIZE(pao%models) diff --git a/src/particle_methods.F b/src/particle_methods.F index e7336c66ad..97a88055d6 100644 --- a/src/particle_methods.F +++ b/src/particle_methods.F @@ -1184,10 +1184,12 @@ CONTAINS count_list(elem_seen) = 1 END IF END IF - IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) & + IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) THEN w_cif_type_symbol = LEN_TRIM(cif_type_symbol(iatom)) - IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) & + END IF + IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) THEN w_cif_label = LEN_TRIM(cif_label(iatom)) + END IF END DO atom_loop ! Determine the format of each line in cif considering width of cif_type_symbol and cif_label @@ -1260,9 +1262,10 @@ CONTAINS file_unit = cp_print_key_unit_nr(logger, input_section, "PRINT%FINAL_STRUCTURE", & file_status="REPLACE", file_form="FORMATTED", & extension=".xyz") - IF (file_unit > 0) & + IF (file_unit > 0) THEN CALL write_particle_coordinates(particle_set, file_unit, dump_extxyz, "POS", title, & cell=cell, unit_conv=unit_conv, print_kind=print_kind) + END IF END IF ! Write CIF @@ -1430,9 +1433,10 @@ CONTAINS CALL section_release(tmp_cell_section) CALL cp_print_key_finished_output(file_unit, logger, input_section, & "PRINT%FINAL_STRUCTURE") - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" + routineN//": Done!" + END IF CALL timestop(handle) diff --git a/src/pexsi_interface.F b/src/pexsi_interface.F index fccdf461da..e2d09937ab 100644 --- a/src/pexsi_interface.F +++ b/src/pexsi_interface.F @@ -108,17 +108,22 @@ CONTAINS IF (PRESENT(muMin0)) pexsi_options%options%muMin0 = muMin0 IF (PRESENT(muMax0)) pexsi_options%options%muMax0 = muMax0 IF (PRESENT(mu0)) pexsi_options%options%mu0 = mu0 - IF (PRESENT(muInertiaTolerance)) & + IF (PRESENT(muInertiaTolerance)) THEN pexsi_options%options%muInertiaTolerance = muInertiaTolerance - IF (PRESENT(muInertiaExpansion)) & + END IF + IF (PRESENT(muInertiaExpansion)) THEN pexsi_options%options%muInertiaExpansion = muInertiaExpansion - IF (PRESENT(muPEXSISafeGuard)) & + END IF + IF (PRESENT(muPEXSISafeGuard)) THEN pexsi_options%options%muPEXSISafeGuard = muPEXSISafeGuard - IF (PRESENT(numElectronPEXSITolerance)) & + END IF + IF (PRESENT(numElectronPEXSITolerance)) THEN pexsi_options%options%numElectronPEXSITolerance = numElectronPEXSITolerance + END IF IF (PRESENT(matrixType)) pexsi_options%options%matrixType = matrixType - IF (PRESENT(isSymbolicFactorize)) & + IF (PRESENT(isSymbolicFactorize)) THEN pexsi_options%options%isSymbolicFactorize = isSymbolicFactorize + END IF IF (PRESENT(ordering)) pexsi_options%options%ordering = ordering IF (PRESENT(rowOrdering)) pexsi_options%options%rowOrdering = rowOrdering IF (PRESENT(npSymbFact)) pexsi_options%options%npSymbFact = npSymbFact @@ -205,17 +210,22 @@ CONTAINS IF (PRESENT(muMin0)) muMin0 = pexsi_options%options%muMin0 IF (PRESENT(muMax0)) muMax0 = pexsi_options%options%muMax0 IF (PRESENT(mu0)) mu0 = pexsi_options%options%mu0 - IF (PRESENT(muInertiaTolerance)) & + IF (PRESENT(muInertiaTolerance)) THEN muInertiaTolerance = pexsi_options%options%muInertiaTolerance - IF (PRESENT(muInertiaExpansion)) & + END IF + IF (PRESENT(muInertiaExpansion)) THEN muInertiaExpansion = pexsi_options%options%muInertiaExpansion - IF (PRESENT(muPEXSISafeGuard)) & + END IF + IF (PRESENT(muPEXSISafeGuard)) THEN muPEXSISafeGuard = pexsi_options%options%muPEXSISafeGuard - IF (PRESENT(numElectronPEXSITolerance)) & + END IF + IF (PRESENT(numElectronPEXSITolerance)) THEN numElectronPEXSITolerance = pexsi_options%options%numElectronPEXSITolerance + END IF IF (PRESENT(matrixType)) matrixType = pexsi_options%options%matrixType - IF (PRESENT(isSymbolicFactorize)) & + IF (PRESENT(isSymbolicFactorize)) THEN isSymbolicFactorize = pexsi_options%options%isSymbolicFactorize + END IF IF (PRESENT(ordering)) ordering = pexsi_options%options%ordering IF (PRESENT(rowOrdering)) rowOrdering = pexsi_options%options%rowOrdering IF (PRESENT(npSymbFact)) npSymbFact = pexsi_options%options%npSymbFact @@ -281,8 +291,9 @@ CONTAINS CALL timeset(routineN, handle) cp_pexsi_plan_initialize = f_ppexsi_plan_initialize(comm%get_handle(), numProcRow, & numProcCol, outputFileIndex, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(comm) @@ -329,8 +340,9 @@ CONTAINS CALL f_ppexsi_load_real_hs_matrix(plan, pexsi_options%options, nrows, nnz, nnzLocal, & numColLocal, colptrLocal, rowindLocal, & HnzvalLocal, isSIdentity, SnzvalLocal, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) @@ -343,9 +355,11 @@ CONTAINS CPABORT("Requires linking to the PEXSI library.") ! MARK_USED macro does not work on assumed shape variables - IF (.FALSE.) THEN; DO + IF (.FALSE.) THEN + DO IF (colptrLocal(1) > rowindLocal(1) .OR. HnzvalLocal(1) > SnzvalLocal(1)) EXIT - END DO; END IF + END DO + END IF #endif END SUBROUTINE cp_pexsi_load_real_hs_matrix @@ -396,8 +410,9 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) @@ -440,8 +455,9 @@ CONTAINS CALL f_ppexsi_retrieve_real_dft_matrix(plan, DMnzvalLocal, EDMnzvalLocal, & FDMnzvalLocal, totalEnergyH, & totalEnergyS, totalFreeEnergy, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) @@ -470,8 +486,9 @@ CONTAINS CALL timeset(routineN, handle) CALL f_ppexsi_plan_finalize(plan, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") + END IF CALL timestop(handle) #else MARK_USED(plan) diff --git a/src/pexsi_methods.F b/src/pexsi_methods.F index dc9c429e67..3a8bb968b2 100644 --- a/src/pexsi_methods.F +++ b/src/pexsi_methods.F @@ -146,8 +146,9 @@ CONTAINS pexsi_env%num_ranks_per_pole = min_ranks_per_pole ! not a PEXSI option pexsi_env%csr_screening = csr_screening - IF (numElectronInitialTolerance < numElectronTargetTolerance) & + IF (numElectronInitialTolerance < numElectronTargetTolerance) THEN numElectronInitialTolerance = numElectronTargetTolerance + END IF pexsi_env%tol_nel_initial = numElectronInitialTolerance pexsi_env%tol_nel_target = numElectronTargetTolerance @@ -337,20 +338,24 @@ CONTAINS IF (first_call) THEN ! Assertion that matrices have the expected symmetry (both should be symmetric if no ! S preconditioning and no molecular clustering) - IF (.NOT. dbcsr_has_symmetry(matrix_ks)) & + IF (.NOT. dbcsr_has_symmetry(matrix_ks)) THEN CPABORT("PEXSI interface expects a non-symmetric DBCSR Kohn-Sham matrix") - IF (.NOT. dbcsr_has_symmetry(matrix_s)) & + END IF + IF (.NOT. dbcsr_has_symmetry(matrix_s)) THEN CPABORT("PEXSI interface expects a non-symmetric DBCSR overlap matrix") + END IF ! Assertion on datatype IF ((pexsi_env%csr_mat_s%nzval_local%data_type /= dbcsr_csr_type_real_8) & - .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) & + .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) THEN CPABORT("Complex data type not supported by PEXSI") + END IF ! Assertion on number of non-zero elements !(TODO: update when PEXSI changes to Long Int) - IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) & + IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) THEN CPABORT("Total number of non-zero elements of CSR matrix is too large to be handled by PEXSI") + END IF END IF CALL dbcsr_get_info(matrix_ks, distribution=dist) @@ -464,8 +469,9 @@ CONTAINS n_total_inertia_iter END IF - IF (.NOT. pexsi_convergence) & + IF (.NOT. pexsi_convergence) THEN CPABORT("PEXSI did not converge. Consider logPEXSI0 for more information.") + END IF ! Retrieve results from PEXSI IF (mynode < pexsi_env%mp_dims(1)*pexsi_env%mp_dims(2)) THEN diff --git a/src/pilaenv_hack.F b/src/pilaenv_hack.F index 4b59ed9474..89d89b4d54 100644 --- a/src/pilaenv_hack.F +++ b/src/pilaenv_hack.F @@ -18,6 +18,8 @@ !> \return ... ! ************************************************************************************************** INTEGER FUNCTION PILAENV(ICTXT, PREC) + IMPLICIT NONE + INTEGER :: ICTXT CHARACTER(LEN=1) :: PREC @@ -29,5 +31,5 @@ END FUNCTION PILAENV !> \brief ... ! ************************************************************************************************** SUBROUTINE NAG_dummy() - + IMPLICIT NONE END SUBROUTINE NAG_dummy diff --git a/src/pme.F b/src/pme.F index d6703d8124..6470a00c8b 100644 --- a/src/pme.F +++ b/src/pme.F @@ -358,7 +358,7 @@ CONTAINS fgcore_coulomb(2, particle_set(p2)%shell_index) - fat(2)*dvols fgcore_coulomb(3, particle_set(p2)%shell_index) = & fgcore_coulomb(3, particle_set(p2)%shell_index) - fat(3)*dvols - ELSEIF (p2 /= 0) THEN + ELSE IF (p2 /= 0) THEN CALL dg_sum_patch_force_3d(drpot, rhos2, exp_igr%centre(:, p2), fat) fg_coulomb(1, p2) = fg_coulomb(1, p2) - fat(1)*dvols fg_coulomb(2, p2) = fg_coulomb(2, p2) - fat(2)*dvols @@ -505,7 +505,7 @@ CONTAINS ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) - ELSEIF (my_is1_core) THEN + ELSE IF (my_is1_core) THEN center1 => exp_igr%core_centre(:, particle_set(p1)%shell_index) ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) @@ -545,7 +545,7 @@ CONTAINS ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) - ELSEIF (my_is2_core) THEN + ELSE IF (my_is2_core) THEN center2 => exp_igr%core_centre(:, particle_set(p2)%shell_index) ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) @@ -633,7 +633,7 @@ CONTAINS ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) ez1 => exp_igr%core_ez(:, particle_set(p1)%shell_index) - ELSEIF (my_is1_shell) THEN + ELSE IF (my_is1_shell) THEN ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) @@ -659,7 +659,7 @@ CONTAINS ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) ez2 => exp_igr%core_ez(:, particle_set(p2)%shell_index) - ELSEIF (my_is2_shell) THEN + ELSE IF (my_is2_shell) THEN ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) diff --git a/src/population_analyses.F b/src/population_analyses.F index 2a0988a05a..715eeac5bf 100644 --- a/src/population_analyses.F +++ b/src/population_analyses.F @@ -187,10 +187,11 @@ CONTAINS ! Build full S^(1/2) matrix (computationally expensive) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) & + IF (ndep /= 0) THEN CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") + END IF ! Build Lowdin population matrix for each spin DO ispin = 1, nspin diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index 2a0cc28187..09ae1f3d75 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -1938,8 +1938,9 @@ CONTAINS CALL bs_env%para_env%max(z_end_global) n_z = z_end_global - z_start_global + 1 - IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) & + IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) THEN CPABORT("Please choose a cell that has 90° angles to the z-direction.") + END IF ! for integration, we need the dz and the conversion from H -> eV and a_Bohr -> Å bs_env%unit_ldos_int_z_inv_Ang2_eV = bs_env%hmat(3, 3)/REAL(n_z, KIND=dp)/evolt/angstrom**2 diff --git a/src/preconditioner.F b/src/preconditioner.F index 69d1ad3509..15bbe74ebe 100644 --- a/src/preconditioner.F +++ b/src/preconditioner.F @@ -137,8 +137,9 @@ CONTAINS ! Thanks to the mess with the matrices we need to make sure in this case that the ! Previous inverse is properly stored as a sparse matrix, fm gets deallocated here ! if it wasn't anyway - IF (preconditioner_env%solver == ot_precond_solver_update) & + IF (preconditioner_env%solver == ot_precond_solver_update) THEN CALL transfer_fm_to_dbcsr(preconditioner_env%fm, preconditioner_env%dbcsr_matrix, matrix_h) + END IF needs_full_spectrum = .FALSE. needs_homo = .FALSE. @@ -261,7 +262,8 @@ CONTAINS DEALLOCATE (preconditioner(ispin)%preconditioner) END DO DEALLOCATE (preconditioner) - CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, ot_precond_full_single_inverse) ! these are 'independent' + CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, & + ot_precond_full_single_inverse) ! these are 'independent' ! do nothing CASE DEFAULT CPABORT("Unknown preconditioner type") @@ -388,7 +390,7 @@ CONTAINS co_rotate=qs_env%mo_derivs(ispin)%matrix, & para_env=para_env, & blacs_env=blacs_env) - ELSEIF (use_mo_coeff_b) THEN + ELSE IF (use_mo_coeff_b) THEN CALL calculate_subspace_eigenvalues(mo_coeff_b, matrix_ks(ispin)%matrix, & do_rotation=.TRUE., & para_env=para_env, & diff --git a/src/preconditioner_apply.F b/src/preconditioner_apply.F index 0316f37bc9..e567636e74 100644 --- a/src/preconditioner_apply.F +++ b/src/preconditioner_apply.F @@ -167,8 +167,9 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) & + IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) THEN CPABORT("NOT ASSOCIATED preconditioner_env%dbcsr_matrix") + END IF CALL dbcsr_multiply('N', 'N', 1.0_dp, preconditioner_env%dbcsr_matrix, matrix_in, & 0.0_dp, matrix_out) diff --git a/src/preconditioner_makes.F b/src/preconditioner_makes.F index c83f6ce23e..4dae5616cb 100644 --- a/src/preconditioner_makes.F +++ b/src/preconditioner_makes.F @@ -93,8 +93,9 @@ CONTAINS precon_type = preconditioner_env%in_use SELECT CASE (precon_type) CASE (ot_precond_full_single) - IF (my_solver_type /= ot_precond_solver_default) & + IF (my_solver_type /= ot_precond_solver_default) THEN CPABORT("Only PRECOND_SOLVER DEFAULT for the moment") + END IF IF (PRESENT(matrix_s)) THEN CALL make_full_single(preconditioner_env, preconditioner_env%fm, & matrix_h, matrix_s, energy_homo, energy_gap) @@ -105,14 +106,16 @@ CONTAINS CASE (ot_precond_s_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. PRESENT(matrix_s)) & + IF (.NOT. PRESENT(matrix_s)) THEN CPABORT("Type for S=1 not implemented") + END IF CALL make_full_s_inverse(preconditioner_env, matrix_s) CASE (ot_precond_full_kinetic) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) & + IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) THEN CPABORT("Type for S=1 not implemented") + END IF CALL make_full_kinetic(preconditioner_env, matrix_t, matrix_s, energy_gap) CASE (ot_precond_full_single_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol @@ -745,8 +748,9 @@ CONTAINS matrices(1)%matrix => dbcsr_cThc CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=1.0E-3_dp, selection_crit=2, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) - IF (ASSOCIATED(preconditioner_env%max_ev_vector)) & + IF (ASSOCIATED(preconditioner_env%max_ev_vector)) THEN CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%max_ev_vector) + END IF CALL arnoldi_ev(matrices, arnoldi_env) max_ev = REAL(get_selected_ritz_val(arnoldi_env, 1), dp) @@ -776,8 +780,9 @@ CONTAINS CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=2.0E-2_dp, selection_crit=3, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) END IF - IF (ASSOCIATED(preconditioner_env%min_ev_vector)) & + IF (ASSOCIATED(preconditioner_env%min_ev_vector)) THEN CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%min_ev_vector) + END IF ! compute the LUMO energy CALL arnoldi_ev(matrices, arnoldi_env) diff --git a/src/preconditioner_solvers.F b/src/preconditioner_solvers.F index 21834c0f22..92670b6114 100644 --- a/src/preconditioner_solvers.F +++ b/src/preconditioner_solvers.F @@ -91,8 +91,9 @@ CONTAINS ! make sure preconditioner_env is not destroyed in between occ_matrix = 1.0_dp IF (ASSOCIATED(preconditioner_env%sparse_matrix)) THEN - IF (preconditioner_env%condition_num < 0.0_dp) & + IF (preconditioner_env%condition_num < 0.0_dp) THEN CALL estimate_cond_num(preconditioner_env%sparse_matrix, preconditioner_env%condition_num) + END IF CALL dbcsr_filter(preconditioner_env%sparse_matrix, & 1.0_dp/preconditioner_env%condition_num*0.01_dp) occ_matrix = dbcsr_get_occupation(preconditioner_env%sparse_matrix) diff --git a/src/pw/dgs.F b/src/pw/dgs.F index 6f47d09e24..3124a68eb4 100644 --- a/src/pw/dgs.F +++ b/src/pw/dgs.F @@ -420,7 +420,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(1)) THEN + ELSE IF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -433,7 +433,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(2)) THEN + ELSE IF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -446,7 +446,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(3)) THEN + ELSE IF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -495,7 +495,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(1)) THEN + ELSE IF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -508,7 +508,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(2)) THEN + ELSE IF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -521,7 +521,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= rs%npts_local(3)) THEN + ELSE IF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -572,7 +572,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%npts_local(1)) THEN + ELSE IF (ii >= drpot(1)%npts_local(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%npts_local(1) + 1 folded = .TRUE. ELSE @@ -585,7 +585,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%npts_local(2)) THEN + ELSE IF (ii >= drpot(1)%npts_local(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%npts_local(2) + 1 folded = .TRUE. ELSE @@ -598,7 +598,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%npts_local(3)) THEN + ELSE IF (ii >= drpot(1)%npts_local(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%npts_local(3) + 1 folded = .TRUE. ELSE @@ -651,7 +651,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%npts_local(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(1)) THEN + ELSE IF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%npts_local(1) + 1 folded = .TRUE. ELSE @@ -664,7 +664,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%npts_local(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(2)) THEN + ELSE IF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%npts_local(2) + 1 folded = .TRUE. ELSE @@ -677,7 +677,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%npts_local(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(3)) THEN + ELSE IF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%npts_local(3) + 1 folded = .TRUE. ELSE @@ -724,7 +724,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%desc%npts(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%desc%npts(1)) THEN + ELSE IF (ii >= drpot(1)%desc%npts(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -737,7 +737,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%desc%npts(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%desc%npts(2)) THEN + ELSE IF (ii >= drpot(1)%desc%npts(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -750,7 +750,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%desc%npts(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot(1)%desc%npts(3)) THEN + ELSE IF (ii >= drpot(1)%desc%npts(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%desc%npts(3) + 1 folded = .TRUE. ELSE @@ -798,7 +798,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%desc%npts(1) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(1)) THEN + ELSE IF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -811,7 +811,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%desc%npts(2) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(2)) THEN + ELSE IF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -824,7 +824,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%desc%npts(3) + 1 folded = .TRUE. - ELSEIF (ii >= drpot%desc%npts(3)) THEN + ELSE IF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%desc%npts(3) + 1 folded = .TRUE. ELSE diff --git a/src/pw/dirichlet_bc_methods.F b/src/pw/dirichlet_bc_methods.F index 6dc8e30b92..69499538b4 100644 --- a/src/pw/dirichlet_bc_methods.F +++ b/src/pw/dirichlet_bc_methods.F @@ -905,7 +905,7 @@ CONTAINS END SELECT alpha = linspace(0.0_dp, 2*pi, n_dbcs + 1) - alpha_rotd = alpha + delta_alpha; + alpha_rotd = alpha + delta_alpha SELECT CASE (parallel_axis) CASE (x_axis) DO j = 1, n_dbcs @@ -1180,7 +1180,7 @@ CONTAINS IF (direction == FWROT) THEN vec_tmp = MATMUL(Rmat, vec) vec_transfd = vec_tmp + Tp - ELSEIF (direction == BWROT) THEN + ELSE IF (direction == BWROT) THEN Rmat_inv = inv_3x3(Rmat) Tpoint(1) = Rmat_inv(1, 1)*Tp(1) + Rmat_inv(1, 2)*Tp(2) + Rmat_inv(1, 3)*Tp(3) Tpoint(2) = Rmat_inv(2, 1)*Tp(1) + Rmat_inv(2, 2)*Tp(2) + Rmat_inv(2, 3)*Tp(3) diff --git a/src/pw/fft/fftw3_lib.F b/src/pw/fft/fftw3_lib.F index b71f789160..08de4d3143 100644 --- a/src/pw/fft/fftw3_lib.F +++ b/src/pw/fft/fftw3_lib.F @@ -162,9 +162,10 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_export_wisdom_to_filename(wisdom_file_name_c) - IF (isuccess == 0) & + IF (isuccess == 0) THEN CALL cp_warn(__LOCATION__, "Error exporting wisdom to file "//TRIM(wisdom_file)//". "// & "Wisdom was not exported.") + END IF END IF END IF @@ -191,8 +192,9 @@ CONTAINS LOGICAL :: file_exists isuccess = fftw_init_threads() - IF (isuccess == 0) & + IF (isuccess == 0) THEN CPABORT("Error initializing FFTW with threads") + END IF ! Read FFTW wisdom (if available) ! all nodes are opening the file here... @@ -212,10 +214,11 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_import_wisdom_from_filename(wisdom_file_name_c) - IF (isuccess == 0) & + IF (isuccess == 0) THEN CALL cp_warn(__LOCATION__, "Error importing wisdom from file "//TRIM(wisdom_file)//". "// & "Maybe the file was created with a different configuration than CP2K is run with. "// & "CP2K continues without importing wisdom.") + END IF END IF END IF #else @@ -1039,7 +1042,7 @@ CONTAINS IF (plan%fsign == +1 .AND. plan%trans) THEN istride = plan%m idist = 1 - ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN + ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN ostride = plan%m odist = 1 END IF @@ -1161,7 +1164,7 @@ CONTAINS !$ out_offset = 1 + plan%num_rows*my_id*plan%n !$ IF (plan%fsign == +1 .AND. plan%trans) THEN !$ in_offset = 1 + plan%num_rows*my_id -!$ ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN +!$ ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN !$ out_offset = 1 + plan%num_rows*my_id !$ END IF !$ scal_offset = 1 + plan%n*plan%num_rows*my_id diff --git a/src/pw/fft/mltfftsg_tools.F b/src/pw/fft/mltfftsg_tools.F index a81b903ac7..c1a5b01d5b 100644 --- a/src/pw/fft/mltfftsg_tools.F +++ b/src/pw/fft/mltfftsg_tools.F @@ -15,7 +15,10 @@ MODULE mltfftsg_tools #include "../../base/base_uses.f90" + IMPLICIT NONE + PRIVATE + INTEGER, PARAMETER :: ctrig_length = 1024 INTEGER, PARAMETER :: cache_size = 2048 PUBLIC :: mltfftsg diff --git a/src/pw/fft_tools.F b/src/pw/fft_tools.F index 3f05511557..0c0940b882 100644 --- a/src/pw/fft_tools.F +++ b/src/pw/fft_tools.F @@ -1135,7 +1135,7 @@ CONTAINS END IF END IF - ELSEIF (sign == BWFFT) THEN + ELSE IF (sign == BWFFT) THEN ! Stage 3 -> 1 bbuf => fft_scratch%a5buf @@ -1217,7 +1217,7 @@ CONTAINS CALL release_fft_scratch(fft_scratch) - ELSEIF (DIM(2) == 1) THEN + ELSE IF (DIM(2) == 1) THEN ! ! Second case; one stage of communication @@ -1277,7 +1277,7 @@ CONTAINS END IF END IF - ELSEIF (sign == BWFFT) THEN + ELSE IF (sign == BWFFT) THEN ! Stage 3 -> 1 IF (test) THEN diff --git a/src/pw/mt_util.F b/src/pw/mt_util.F index 148c8f3b92..365f65c469 100644 --- a/src/pw/mt_util.F +++ b/src/pw/mt_util.F @@ -110,8 +110,9 @@ CONTAINS g3d = fourpi/g2 screen_function%array(ig) = screen_function%array(ig) - g3d*EXP(-g2/(4.0E0_dp*alpha2)) END DO - IF (screen_function%pw_grid%have_g0) & + IF (screen_function%pw_grid%have_g0) THEN screen_function%array(1) = screen_function%array(1) + fourpi/(4.0E0_dp*alpha2) + END IF CASE (MT2D) iz = special_dimension ! iz is the direction with NO PBC zlength = slab_size ! zlength is the thickness of the cell diff --git a/src/pw/ps_implicit_methods.F b/src/pw/ps_implicit_methods.F index 705f5bbde2..ba575985e8 100644 --- a/src/pw/ps_implicit_methods.F +++ b/src/pw/ps_implicit_methods.F @@ -274,8 +274,9 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -286,8 +287,9 @@ CONTAINS END DO CALL ps_implicit_print_convergence_msg(iter, max_iter, outp_unit) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN CALL pw_copy(v_new, ps_implicit_env%initial_guess) + END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -439,8 +441,9 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -454,8 +457,9 @@ CONTAINS CALL pw_shrink(neumann_directions, dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_local_shftd, v_new_xpndd, v_new) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN CALL pw_copy(v_new_xpndd, ps_implicit_env%initial_guess) + END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -705,8 +709,9 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -994,8 +999,9 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) & + IF (pres_error > large_error) THEN CPABORT("Poisson solver did not converge.") + END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -1249,13 +1255,15 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) & + IF (info /= 0) THEN CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") + END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Inversion of R failed!") + END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) CALL pw_pool_release(pw_pool_xpndd) @@ -1378,13 +1386,15 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) & + IF (info /= 0) THEN CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") + END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) & + IF (info /= 0) THEN CPABORT("Inversion of R failed!") + END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) diff --git a/src/pw/ps_wavelet_base.F b/src/pw/ps_wavelet_base.F index 2a9fc0f9b0..ad7d3efa69 100644 --- a/src/pw/ps_wavelet_base.F +++ b/src/pw/ps_wavelet_base.F @@ -12,6 +12,7 @@ MODULE ps_wavelet_base USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_fft3d, ONLY: ctrig,& ctrig_length,& @@ -705,9 +706,8 @@ CONTAINS REAL(KIND=dp), INTENT(in) :: hx, hy, hz INTEGER :: i1, i2, j1, j2, j3 - REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2, pi + REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2 - pi = 4._dp*ATAN(1._dp) fourpi2 = 4._dp*pi**2 j3 = i3 !n3/2+1-abs(n3/2+2-i3) mu3 = REAL(j3 - 1, KIND=dp)/REAL(n3, KIND=dp) diff --git a/src/pw/ps_wavelet_fft3d.F b/src/pw/ps_wavelet_fft3d.F index 2381556718..cf470a0206 100644 --- a/src/pw/ps_wavelet_fft3d.F +++ b/src/pw/ps_wavelet_fft3d.F @@ -112,15 +112,14 @@ CONTAINS ! Different factorizations affect the performance ! Factoring 64 as 4*4*4 might for example be faster on some machines than 8*8. INTEGER :: n - REAL(KIND=dp) :: trig - INTEGER :: after, before, now, isign, ic + REAL(KIND=dp) :: trig(2, ctrig_length) + INTEGER :: after(7), before(7), now(7), isign, ic CHARACTER(LEN=888) :: err INTEGER :: i, itt, j, nh + INTEGER, DIMENSION(7, 149) :: idata REAL(KIND=dp) :: angle, trigc, trigs, twopi - DIMENSION now(7), after(7), before(7), trig(2, ctrig_length) - INTEGER, DIMENSION(7, 149) :: idata ! The factor 6 is only allowed in the first place! DATA((idata(i, j), i=1, 7), j=1, 76)/ & 3, 3, 1, 1, 1, 1, 1, 4, 4, 1, 1, 1, 1, 1, & @@ -285,7 +284,8 @@ CONTAINS ! GNU General Public License, see http://www.gnu.org/copyleft/gpl.txt . INTEGER :: mm, nfft, m, nn, n - REAL(KIND=dp) :: zin, zout, trig + REAL(KIND=dp) :: zin(2, mm, m), zout(2, nn, n), & + trig(2, ctrig_length) INTEGER :: after, now, before, isign INTEGER :: atb, atn, ia, ias, ib, itrig, itt, j, & @@ -297,7 +297,6 @@ CONTAINS rt2i, s, s1, s2, s25, s3, s34, s4, s5, s6, s7, s8, sin2, sin4, ui1, ui2, ui3, ur1, ur2, & ur3, vi1, vi2, vi3, vr1, vr2, vr3 - DIMENSION trig(2, ctrig_length), zin(2, mm, m), zout(2, nn, n) atn = after*now atb = after*before @@ -321,7 +320,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO DO 2000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -342,7 +342,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -360,7 +361,8 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO; END DO + END DO + END DO END IF ELSE IF (4*ias == after) THEN IF (isign == 1) THEN @@ -382,7 +384,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -402,7 +405,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO END IF ELSE IF (4*ias == 3*after) THEN IF (isign == 1) THEN @@ -424,7 +428,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -444,7 +449,8 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO; END DO + END DO + END DO END IF ELSE itrig = ias*before + 1 @@ -468,7 +474,8 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO; END DO + END DO + END DO END IF 2000 CONTINUE ELSE IF (now == 4) THEN @@ -510,7 +517,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO DO 4000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -554,7 +562,8 @@ CONTAINS s = r2 + r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO ELSE itt = ias*before itrig = itt + 1 @@ -608,7 +617,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO END IF 4000 CONTINUE ELSE @@ -649,7 +659,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO; END DO + END DO + END DO DO 4100, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -693,7 +704,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO; END DO + END DO + END DO ELSE itt = ias*before itrig = itt + 1 @@ -747,7 +759,8 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO; END DO + END DO + END DO END IF 4100 CONTINUE END IF @@ -842,7 +855,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO DO 8000, ia = 2, after ias = ia - 1 itt = ias*before @@ -969,7 +983,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO 8000 CONTINUE ELSE @@ -1062,7 +1077,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO DO 8001, ia = 2, after ias = ia - 1 @@ -1190,7 +1206,8 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO; END DO + END DO + END DO 8001 CONTINUE END IF @@ -1226,7 +1243,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO DO 3000, ia = 2, after ias = ia - 1 IF (4*ias == 3*after) THEN @@ -1259,7 +1277,8 @@ CONTAINS zout(2, j, nout2) = s1 - r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 + r2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1289,7 +1308,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 - s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO END IF ELSE IF (8*ias == 3*after) THEN IF (isign == 1) THEN @@ -1323,7 +1343,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1355,7 +1376,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO END IF ELSE itt = ias*before @@ -1397,7 +1419,8 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO; END DO + END DO + END DO END IF 3000 CONTINUE ELSE IF (now == 5) THEN @@ -1460,7 +1483,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO DO 5000, ia = 2, after ias = ia - 1 IF (8*ias == 5*after) THEN @@ -1519,7 +1543,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1575,7 +1600,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO END IF ELSE ias = ia - 1 @@ -1650,7 +1676,8 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO; END DO + END DO + END DO END IF 5000 CONTINUE ELSE IF (now == 6) THEN @@ -1724,7 +1751,8 @@ CONTAINS zout(2, j, nout2) = ui2 - vi2 zout(1, j, nout6) = ur3 - vr3 zout(2, j, nout6) = ui3 - vi3 - END DO; END DO + END DO + END DO ELSE CPABORT("error fftstp") END IF diff --git a/src/pw/ps_wavelet_kernel.F b/src/pw/ps_wavelet_kernel.F index c535a1fa43..b39df92602 100644 --- a/src/pw/ps_wavelet_kernel.F +++ b/src/pw/ps_wavelet_kernel.F @@ -12,6 +12,7 @@ MODULE ps_wavelet_kernel USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_base, ONLY: scramble_unpack USE ps_wavelet_fft3d, ONLY: ctrig,& @@ -235,8 +236,8 @@ CONTAINS shift INTEGER, ALLOCATABLE, DIMENSION(:) :: after, before, now REAL(kind=dp) :: a, b, c, cp, d, diff, dx, feI, feR, foI, & - foR, fR, mu1, pi, pion, ponx, pony, & - sp, value, x + foR, fR, mu1, pion, ponx, pony, sp, & + value, x REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: kernel_scf, x_scf, y_scf REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: btrig, cossinarr REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: halfft_cache, kernel @@ -355,9 +356,6 @@ CONTAINS ALLOCATE (now(7)) ALLOCATE (before(7)) - !constants - pi = 4._dp*ATAN(1._dp) - !arrays for the halFFT CALL ctrig(n3/2, btrig, after, before, now, 1, ic) diff --git a/src/pw/ps_wavelet_methods.F b/src/pw/ps_wavelet_methods.F index 7ca3a4c95d..624bae7120 100644 --- a/src/pw/ps_wavelet_methods.F +++ b/src/pw/ps_wavelet_methods.F @@ -90,10 +90,12 @@ CONTAINS hz = pw_grid%dr(wavelet%axis(3)) IF (poisson_params%wavelet_method == WAVELET0D) THEN - IF (hx /= hy) & + IF (hx /= hy) THEN CPABORT("Poisson solver for non cubic cells not yet implemented") - IF (hz /= hy) & + END IF + IF (hz /= hy) THEN CPABORT("Poisson solver for non cubic cells not yet implemented") + END IF END IF CALL RS_z_slice_distribution(wavelet, pw_grid) diff --git a/src/pw/ps_wavelet_scaling_function.F b/src/pw/ps_wavelet_scaling_function.F index 1eed8a8d73..6352c34555 100644 --- a/src/pw/ps_wavelet_scaling_function.F +++ b/src/pw/ps_wavelet_scaling_function.F @@ -74,9 +74,7 @@ CONTAINS !open (unit=1,file='scfunction',status='unknown') DO i = 0, nd a(i) = 1._dp*i*ni/nd - (.5_dp*ni - 1._dp) - !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-1._dp),x(i) END DO - !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) END SUBROUTINE scaling_function @@ -128,9 +126,7 @@ CONTAINS !open (unit=1,file='wavelet',status='unknown') DO i = 0, nd - 1 a(i) = 1._dp*i*ni/nd - (.5_dp*ni - .5_dp) - !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-.5_dp),x(i) END DO - !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) @@ -166,7 +162,7 @@ CONTAINS !> \param n ... !> \param x ... ! ************************************************************************************************** - SUBROUTINE zero(n, x) + PURE SUBROUTINE zero(n, x) INTEGER, INTENT(in) :: n REAL(KIND=dp), INTENT(out) :: x(n) diff --git a/src/pw/ps_wavelet_types.F b/src/pw/ps_wavelet_types.F index dfbfceb2db..464697a8d0 100644 --- a/src/pw/ps_wavelet_types.F +++ b/src/pw/ps_wavelet_types.F @@ -55,10 +55,12 @@ CONTAINS TYPE(ps_wavelet_type), POINTER :: wavelet IF (ASSOCIATED(wavelet)) THEN - IF (ASSOCIATED(wavelet%karray)) & + IF (ASSOCIATED(wavelet%karray)) THEN DEALLOCATE (wavelet%karray) - IF (ASSOCIATED(wavelet%rho_z_sliced)) & + END IF + IF (ASSOCIATED(wavelet%rho_z_sliced)) THEN DEALLOCATE (wavelet%rho_z_sliced) + END IF DEALLOCATE (wavelet) END IF END SUBROUTINE ps_wavelet_release diff --git a/src/pw/pw_fpga.F b/src/pw/pw_fpga.F index 3d26adb66c..3819cd0749 100644 --- a/src/pw/pw_fpga.F +++ b/src/pw/pw_fpga.F @@ -117,8 +117,9 @@ CONTAINS CPABORT("OFFLOAD and FPGA cannot be configured concurrently! Recompile with -D__NO_OFFLOAD_PW.") #endif stat = pw_fpga_initialize() - IF (stat /= 0) & + IF (stat /= 0) THEN CPABORT("pw_fpga_init: failed") + END IF #endif #if (__PW_FPGA_SP && !(__PW_FPGA)) diff --git a/src/pw/pw_gpu.F b/src/pw/pw_gpu.F index 2f6a055c4d..3e752e77da 100644 --- a/src/pw/pw_gpu.F +++ b/src/pw/pw_gpu.F @@ -301,8 +301,9 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) & + IF (r_dim(1) == 1) THEN CPABORT("This processor distribution is not supported.") + END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) @@ -463,8 +464,9 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) & + IF (r_dim(1) == 1) THEN CPABORT("This processor distribution is not supported.") + END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) diff --git a/src/pw/pw_grid_types.F b/src/pw/pw_grid_types.F index b5c6024351..62a9f61387 100644 --- a/src/pw/pw_grid_types.F +++ b/src/pw/pw_grid_types.F @@ -44,7 +44,8 @@ MODULE pw_grid_types INTEGER, DIMENSION(:), ALLOCATABLE :: nyzray ! number of g-space rays (pe) TYPE(mp_cart_type) :: group = mp_cart_type() ! real space group (2-dim cart) INTEGER, DIMENSION(:, :, :, :), ALLOCATABLE :: bo ! list of axis distribution - INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane....should go: hard-codes to plane distributed + INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane + ! should go: hard-codes to plane distributed END TYPE pw_para_type ! all you always wanted to know about grids, but were... diff --git a/src/pw/pw_poisson_methods.F b/src/pw/pw_poisson_methods.F index 89f8f65c32..04910df1ab 100644 --- a/src/pw/pw_poisson_methods.F +++ b/src/pw/pw_poisson_methods.F @@ -537,8 +537,9 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN CPABORT("vhartree has a different grid than the poisson solver") + END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -948,8 +949,9 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN CPABORT("vhartree has a different grid than the poisson solver") + END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -1292,12 +1294,12 @@ CONTAINS CALL timeset(routineN, handle) - IF (PRESENT(parameters)) & - poisson_env%parameters = parameters + IF (PRESENT(parameters)) poisson_env%parameters = parameters IF (PRESENT(cell_hmat)) THEN - IF (ANY(poisson_env%cell_hmat /= cell_hmat)) & + IF (ANY(poisson_env%cell_hmat /= cell_hmat)) THEN CALL pw_poisson_cleanup(poisson_env) + END IF poisson_env%cell_hmat(:, :) = cell_hmat(:, :) poisson_env%rebuild = .TRUE. END IF diff --git a/src/pw/pw_poisson_types.F b/src/pw/pw_poisson_types.F index b73b8423cb..624cadd4c0 100644 --- a/src/pw/pw_poisson_types.F +++ b/src/pw/pw_poisson_types.F @@ -367,8 +367,9 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d*(1.0_dp - COS(rlength*gg)) END DO - IF (grid%have_g0) & + IF (grid%have_g0) THEN gf%array(1) = 0.5_dp*fourpi*rlength*rlength + END IF CASE (MT2D, MT1D, MT0D) @@ -377,8 +378,9 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d + green%screen_fn%array(ig) END DO - IF (grid%have_g0) & + IF (grid%have_g0) THEN gf%array(1) = green%screen_fn%array(1) + END IF CASE (PS_IMPLICIT) @@ -452,10 +454,12 @@ CONTAINS DEALLOCATE (gftype%p3m_charge) END IF END IF - IF (ALLOCATED(gftype%p3m_bm2)) & + IF (ALLOCATED(gftype%p3m_bm2)) THEN DEALLOCATE (gftype%p3m_bm2) - IF (ALLOCATED(gftype%p3m_coeff)) & + END IF + IF (ALLOCATED(gftype%p3m_coeff)) THEN DEALLOCATE (gftype%p3m_coeff) + END IF END SUBROUTINE pw_green_release ! ************************************************************************************************** diff --git a/src/pw/pw_spline_utils.F b/src/pw/pw_spline_utils.F index 4e708be0a3..8459f07cb6 100644 --- a/src/pw/pw_spline_utils.F +++ b/src/pw/pw_spline_utils.F @@ -2116,7 +2116,7 @@ CONTAINS + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 + ww0(2)*vv7 + vv0*ww1(2) coarse_coeffs(i + 3, j, k) = coarse_coeffs(i + 3, j, k) & + ww1(4)*vv6 + ww0(3)*vv7 + vv0*ww1(3) - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv0 = fine_values(fi, fj, fk) vv1 = fine_values(fine_bo(1, 1), fj, fk) @@ -2158,7 +2158,7 @@ CONTAINS + ww1(3)*vv4 + ww0(2)*vv5 + ww1(2)*vv6 coarse_coeffs(i + 2, j, k) = coarse_coeffs(i + 2, j, k) & + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv6 = fine_values(fi, fj, fk) vv7 = fine_values(fine_bo(1, 1), fj, fk) @@ -2202,7 +2202,7 @@ CONTAINS + ww1(3)*vv2 + ww0(2)*vv3 + ww1(2)*vv4 coarse_coeffs(i + 1, j, k) = coarse_coeffs(i + 1, j, k) & + ww1(4)*vv2 + ww0(3)*vv3 + ww1(3)*vv4 - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv4 = fine_values(fi, fj, fk) vv5 = fine_values(fine_bo(1, 1), fj, fk) @@ -2244,7 +2244,7 @@ CONTAINS + ww1(3)*vv0 + ww0(2)*vv1 + ww1(2)*vv2 coarse_coeffs(i, j, k) = coarse_coeffs(i, j, k) & + ww1(4)*vv0 + ww0(3)*vv1 + ww1(3)*vv2 - ELSEIF (pbc .AND. .NOT. is_split) THEN + ELSE IF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv2 = fine_values(fi, fj, fk) vv3 = fine_values(fine_bo(1, 1), fk, fk) @@ -2348,8 +2348,9 @@ CONTAINS send_offset(ip) = send_tot_size send_tot_size = send_tot_size + send_size(ip) END DO - IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) & + IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) THEN CPABORT("Error calculating send_tot_size") + END IF ALLOCATE (send_buf(0:send_tot_size - 1)) rcv_tot_size = 0 @@ -2374,10 +2375,12 @@ CONTAINS sent_size(p) = sent_size(p) + coarse_slice_size END DO - IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) & + IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) THEN CPABORT("error 1 filling send buffer") - IF (sent_size(n_procs - 1) /= send_tot_size) & + END IF + IF (sent_size(n_procs - 1) /= send_tot_size) THEN CPABORT("error 2 filling send buffer") + END IF IF (local_data) THEN DEALLOCATE (coarse_coeffs) @@ -2441,10 +2444,12 @@ CONTAINS END DO - IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) & + IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) THEN CPABORT("error 1 handling the rcv buffer") - IF (sent_size(n_procs - 1) /= rcv_tot_size) & + END IF + IF (sent_size(n_procs - 1) /= rcv_tot_size) THEN CPABORT("error 2 handling the rcv buffer") + END IF ! dealloc DEALLOCATE (send_size, send_offset, rcv_size, rcv_offset) diff --git a/src/pw/realspace_grid_cube.F b/src/pw/realspace_grid_cube.F index c470d2ac77..05af7923fa 100644 --- a/src/pw/realspace_grid_cube.F +++ b/src/pw/realspace_grid_cube.F @@ -121,9 +121,10 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") + END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) @@ -268,8 +269,9 @@ CONTAINS ELSE size_of_z = CEILING(REAL(pw%pw_grid%bounds(2, 3) - pw%pw_grid%bounds(1, 3) + 1, dp)/REAL(my_stride(3), dp)) num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) & + IF (MODULO(size_of_z, num_entries_line) /= 0) THEN num_linebreak = num_linebreak + 1 + END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL mp_unit%set_handle(unit_nr) CALL pw_to_cube_parallel(pw, mp_unit, title, particles_r, particles_z, particles_zeff, & @@ -409,8 +411,9 @@ CONTAINS ! Each data line of a Gaussian cube contains max 6 entries with last line potentially containing less if nz % 6 /= 0 ! Thus, this size is simply the number of entries multiplied by the entry size + the number of line breaks num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) & + IF (MODULO(size_of_z, num_entries_line) /= 0) THEN num_linebreak = num_linebreak + 1 + END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL cube_to_pw_parallel(grid, filename, scaling, msglen, silent=silent) END IF @@ -630,9 +633,10 @@ CONTAINS IF ((lbounds_local(1) <= i) .AND. (i <= ubounds_local(1)) .AND. (lbounds_local(2) <= j) & .AND. (j <= ubounds_local(2))) THEN !allow scaling of external potential values by factor 'scaling' (SCALING_FACTOR in input file) - IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) & + IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) THEN CALL cp_abort(__LOCATION__, & "Error in parallel read of input cube file.") + END IF END IF END DO @@ -824,8 +828,9 @@ CONTAINS END IF tmp = TRIM(tmp)//TRIM(value) counter = counter + 1 - IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) & + IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) THEN tmp = TRIM(tmp)//NEW_LINE('C') + END IF END DO writebuffer(islice) = tmp islice = islice + 1 @@ -889,9 +894,10 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") + END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_cube_unittest.F b/src/pw/realspace_grid_cube_unittest.F index 7732cea3ea..b1685dc56b 100644 --- a/src/pw/realspace_grid_cube_unittest.F +++ b/src/pw/realspace_grid_cube_unittest.F @@ -19,20 +19,24 @@ PROGRAM realspace_grid_cube_unittest REAL(KIND=dp), DIMENSION(7) :: slice_buffer, slice_reference WRITE (value, cube_value_format) 0.33004E-101_dp - IF (INDEX(value, "E-101") <= 0) & + IF (INDEX(value, "E-101") <= 0) THEN ERROR STOP "Cube value format must preserve three-digit negative exponents." + END IF reference = [0.0_dp, -0.91458E-35_dp, 0.33004E-101_dp, & -0.32487E-103_dp, 1.0_dp, -1.0_dp] WRITE (values(1:78), cube_values_format) reference values(79:79) = NEW_LINE("C") - IF (INDEX(values, "E-101") <= 0) & + IF (INDEX(values, "E-101") <= 0) THEN ERROR STOP "Cube line format must preserve E-101." - IF (INDEX(values, "E-103") <= 0) & + END IF + IF (INDEX(values, "E-103") <= 0) THEN ERROR STOP "Cube line format must preserve E-103." + END IF CALL cube_read_values(values, buffer) - IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) & + IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) THEN ERROR STOP "Cube reader must parse adjacent explicit-exponent values." + END IF slice_reference(1:6) = reference slice_reference(7) = 0.27183E-123_dp @@ -40,7 +44,8 @@ PROGRAM realspace_grid_cube_unittest slice_values(79:79) = NEW_LINE("C") WRITE (slice_values(80:92), cube_value_format) slice_reference(7) CALL cube_read_values(slice_values, slice_buffer) - IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) & + IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) THEN ERROR STOP "Cube reader must parse multi-line z-slices." + END IF END PROGRAM realspace_grid_cube_unittest diff --git a/src/pw/realspace_grid_openpmd.F b/src/pw/realspace_grid_openpmd.F index b64caaa0e6..131d0344ff 100644 --- a/src/pw/realspace_grid_openpmd.F +++ b/src/pw/realspace_grid_openpmd.F @@ -340,9 +340,10 @@ CONTAINS IF (PRESENT(mpi_io)) parallel_write = mpi_io my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") + END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_types.F b/src/pw/realspace_grid_types.F index b54f99a6ee..57ac9540a9 100644 --- a/src/pw/realspace_grid_types.F +++ b/src/pw/realspace_grid_types.F @@ -659,8 +659,9 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN CPABORT("Different rs and pw indentifiers") + END IF IF (rs%desc%distributed) THEN CALL transfer_rs2pw_distributed(rs, pw) @@ -702,8 +703,9 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN CPABORT("Different rs and pw indentifiers") + END IF IF (rs%desc%distributed) THEN CALL transfer_pw2rs_distributed(rs, pw) diff --git a/src/qcschema.F b/src/qcschema.F index a4eae93faf..23ce8e1b05 100644 --- a/src/qcschema.F +++ b/src/qcschema.F @@ -407,10 +407,12 @@ CONTAINS IF (dft_control%dft_plus_u) CPABORT('WARNING: DFT+U not supported in QCSchema') IF (dft_control%do_sccs) CPABORT('WARNING: SCCS not supported in QCSchema') IF (qs_env%qmmm) CPABORT('WARNING: QM/MM not supported in QCSchema') - IF (dft_control%qs_control%mulliken_restraint) & + IF (dft_control%qs_control%mulliken_restraint) THEN CPABORT('WARNING: Mulliken restrains not supported in QCSchema') - IF (dft_control%qs_control%semi_empirical) & + END IF + IF (dft_control%qs_control%semi_empirical) THEN CPABORT('WARNING: semi_empirical methods not supported in QCSchema') + END IF IF (dft_control%qs_control%dftb) CPABORT('WARNING: DFTB not supported in QCSchema') IF (dft_control%qs_control%xtb) CPABORT('WARNING: xTB not supported in QCSchema') diff --git a/src/qmmm_create.F b/src/qmmm_create.F index f15dd5d2f0..1cbe80ccf4 100644 --- a/src/qmmm_create.F +++ b/src/qmmm_create.F @@ -228,11 +228,12 @@ CONTAINS IF (explicit .AND. use_multipole == do_multipole_section_on) qmmm_env_qm%multipole = .TRUE. IF (qmmm_env_qm%periodic .AND. qmmm_env_qm%multipole) CALL cite_reference(Laino2006) IF (qmmm_coupl_type == do_qmmm_none) THEN - IF (qmmm_env_qm%periodic) & + IF (qmmm_env_qm%periodic) THEN CALL cp_warn(__LOCATION__, & "QMMM periodic calculation with coupling NONE was requested! "// & "Switching off the periodic keyword since periodic and non-periodic "// & "calculation with coupling NONE represent the same method! ") + END IF qmmm_env_qm%periodic = .FALSE. END IF @@ -298,8 +299,9 @@ CONTAINS CALL get_cell(mm_cell, abc=abc_mm) IF (qmmm_env_qm%image_charge) THEN - IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) & + IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) THEN CPABORT("QM and MM box need to have the same size when using image charges") + END IF END IF ! Assign charges and mm_el_pot_radius from fist_topology diff --git a/src/qmmm_elpot.F b/src/qmmm_elpot.F index 9774d16564..da89a5d1a5 100644 --- a/src/qmmm_elpot.F +++ b/src/qmmm_elpot.F @@ -145,7 +145,7 @@ CONTAINS t = 2._dp/(rootpi*x*rc)*EXP(-(x/rc)**2) pot0_2(2, i) = (t - pot0_2(1, i)/x)*dx END DO - ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN ! S-wave expansion :: 1/x - exp(-2*x/rc) * ( 1/x - 1/rc ) pot0_2(1, 1) = 1.0_dp/rc pot0_2(2, 1) = 0.0_dp diff --git a/src/qmmm_force.F b/src/qmmm_force.F index 4b4b876627..a892769aff 100644 --- a/src/qmmm_force.F +++ b/src/qmmm_force.F @@ -135,10 +135,11 @@ CONTAINS WRITE (unit=output_unit, fmt='("ip, j, pos, lat_pos ",2I6,6F12.5)') ip, j, & particles_qm(ip)%r, DOT_PRODUCT(qm_cell%h_inv(j, :), particles_qm(ip)%r) END IF - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, & "QM/MM QM atoms must be fully contained in the same image of the QM box "// & "- No wrapping of coordinates is allowed! ") + END IF END DO END DO diff --git a/src/qmmm_gaussian_init.F b/src/qmmm_gaussian_init.F index c588591b9e..7885a7c400 100644 --- a/src/qmmm_gaussian_init.F +++ b/src/qmmm_gaussian_init.F @@ -163,7 +163,7 @@ CONTAINS IF (qmmm_coupl_type == do_qmmm_gauss) THEN CALL set_mm_potential_erf(qmmm_gaussian_fns, & compatibility, num_geep_gauss) - ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN CALL set_mm_potential_swave(qmmm_gaussian_fns, & num_geep_gauss) END IF diff --git a/src/qmmm_gpw_energy.F b/src/qmmm_gpw_energy.F index af8d7d34af..d62e251621 100644 --- a/src/qmmm_gpw_energy.F +++ b/src/qmmm_gpw_energy.F @@ -126,8 +126,9 @@ CONTAINS print_section => section_vals_get_subs_vals(input_section, "QMMM%PRINT") iw = cp_print_key_unit_nr(logger, print_section, "PROGRAM_RUN_INFO", & extension=".qmmmLog") - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(T2,"QMMM|",1X,A)') "Information on the QM/MM Electrostatic Potential:" + END IF ! ! Initializing vectors: ! Zeroing v_qmmm_rspace @@ -148,7 +149,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -172,9 +173,10 @@ CONTAINS CASE (do_qmmm_pcharge) CPABORT("Point Charge QM/MM electrostatic coupling not implemented for GPW/GAPW.") CASE (do_qmmm_gauss, do_qmmm_swave) - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(T2,"QMMM|",1X,A)') & - "QM/MM Coupling computed collocating the Gaussian Potential Functions." + "QM/MM Coupling computed collocating the Gaussian Potential Functions." + END IF interp_section => section_vals_get_subs_vals(input_section, & "QMMM%INTERPOLATOR") CALL qmmm_elec_with_gaussian(qmmm_env=qmmm_env, & @@ -807,8 +809,9 @@ CONTAINS IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm qt = mm_charges(LIndMM) - IF (shells) & + IF (shells) THEN ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm + END IF ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) diff --git a/src/qmmm_gpw_forces.F b/src/qmmm_gpw_forces.F index f2ecb1a293..a4246fdc39 100644 --- a/src/qmmm_gpw_forces.F +++ b/src/qmmm_gpw_forces.F @@ -176,7 +176,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -1212,8 +1212,9 @@ CONTAINS LIndMM = pot%mm_atom_index(Imm) IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - IF (shells) & + IF (shells) THEN ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm + END IF qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN @@ -1421,10 +1422,11 @@ CONTAINS Err(K) = (Analytical_Forces(K, I) - Num_Forces(K, I))/Num_Forces(K, I)*100.0_dp END IF END DO - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) IndMM, Analytical_Forces(1, I), Num_Forces(1, I), Err(1), & - Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & - Analytical_Forces(3, I), Num_Forces(3, I), Err(3) + Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & + Analytical_Forces(3, I), Num_Forces(3, I), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1532,10 +1534,11 @@ CONTAINS Err(2) = (debug_force(2) - force(2))/force(2)*100.0_dp Err(3) = (debug_force(3) - force(3))/force(3)*100.0_dp END IF - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) Icount, debug_force(1), force(1), Err(1), & - debug_force(2), force(2), Err(2), & - debug_force(3), force(3), Err(3) + debug_force(2), force(2), Err(2), & + debug_force(3), force(3), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1638,9 +1641,10 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + END IF Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1654,10 +1658,11 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1752,9 +1757,10 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) + END IF Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1768,10 +1774,11 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) + END IF CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) diff --git a/src/qmmm_image_charge.F b/src/qmmm_image_charge.F index 607d4db02f..f721612be5 100644 --- a/src/qmmm_image_charge.F +++ b/src/qmmm_image_charge.F @@ -587,11 +587,12 @@ CONTAINS CALL calculate_image_matrix(image_matrix=qs_env%image_matrix, & ipiv=qs_env%ipiv, qs_env=qs_env, qmmm_env=qmmm_env) qmmm_env%image_charge_pot%state_image_matrix = calc_once_done - IF (qmmm_env%center_qm_subsys0) & + IF (qmmm_env%center_qm_subsys0) THEN CALL cp_warn(__LOCATION__, & "The image atoms are fully "// & "constrained and the image matrix is only calculated once. "// & "To be safe, set CENTER to NEVER ") + END IF CASE (calc_once_done) ! do nothing image matrix is stored CASE DEFAULT diff --git a/src/qmmm_init.F b/src/qmmm_init.F index a2499ee7c9..3655e31cd0 100644 --- a/src/qmmm_init.F +++ b/src/qmmm_init.F @@ -667,10 +667,11 @@ CONTAINS ELSE IF (qmmm_env%spherical_cutoff(2) <= 0.0_dp) qmmm_env%spherical_cutoff(2) = EPSILON(0.0_dp) tmp_radius = qmmm_env%spherical_cutoff(1) - 20.0_dp*qmmm_env%spherical_cutoff(2) - IF (tmp_radius <= 0.0_dp) & + IF (tmp_radius <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "SPHERICAL_CUTOFF(1) > 20*SPHERICAL_CUTOFF(1)! Please correct parameters for "// & "the Spherical Cutoff in order to satisfy the previous condition!") + END IF END IF ! ! Initialization of arrays and core_charge_radius... @@ -1032,12 +1033,15 @@ CONTAINS END SELECT END DO END IF - IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) & + IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) THEN ALLOCATE (mm_link_scale_factor(link_involv_mm)) - IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) & + END IF + IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) THEN ALLOCATE (fist_scale_charge_link(link_involv_mm)) - IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) & + END IF + IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) THEN ALLOCATE (mm_link_atoms(link_involv_mm)) + END IF IF (PRESENT(qm_atom_index)) ALLOCATE (qm_atom_index(num_qm_atom_tot)) IF (PRESENT(qm_atom_type)) ALLOCATE (qm_atom_type(num_qm_atom_tot)) IF (PRESENT(qm_atom_index)) qm_atom_index = 0 @@ -1286,8 +1290,9 @@ CONTAINS CALL section_vals_val_get(move_section, "RADIUS", r_val=radius, i_rep_section=i_add) CALL section_vals_val_get(move_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) & + IF (n_rep_val == 1) THEN CALL section_vals_val_get(move_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) + END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1313,8 +1318,9 @@ CONTAINS CALL section_vals_val_get(add_section, "CHARGE", r_val=charge, i_rep_section=i_add) CALL section_vals_val_get(add_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) & + IF (n_rep_val == 1) THEN CALL section_vals_val_get(add_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) + END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, charge, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1496,8 +1502,9 @@ CONTAINS END IF DO j = i + 1, num_image_mm_atom atom_b = qmmm_env%image_charge_pot%image_mm_list(j) - IF (atom_a == atom_b) & + IF (atom_a == atom_b) THEN CPABORT("There are atoms doubled in image list.") + END IF END DO END DO diff --git a/src/qmmm_links_methods.F b/src/qmmm_links_methods.F index c7ca6d962e..671195819f 100644 --- a/src/qmmm_links_methods.F +++ b/src/qmmm_links_methods.F @@ -63,18 +63,20 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") + END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") + END IF ip_mm = ip particles(ip_mm)%r = alpha*particles(ip_mm)%r + (1.0_dp - alpha)*particles(ip_qm)%r END DO @@ -110,18 +112,20 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") + END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) & + IF (ip == SIZE(qm_atom_index) + 1) THEN CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") + END IF ip_mm = ip particles_qm(ip_qm)%f = particles_qm(ip_qm)%f + particles_qm(ip_mm)%f*(1.0_dp - alpha) particles_qm(ip_mm)%f = particles_qm(ip_mm)%f*alpha diff --git a/src/qmmm_per_elpot.F b/src/qmmm_per_elpot.F index c13f0ff4fe..1d46ede77e 100644 --- a/src/qmmm_per_elpot.F +++ b/src/qmmm_per_elpot.F @@ -173,7 +173,7 @@ CONTAINS g = SQRT(g2) IF (qmmm_coupl_type == do_qmmm_gauss) THEN LG(idim) = 4.0_dp*Pi/g2*EXP(-(g2*rc2)/4.0_dp) - ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN tmp = 4.0_dp/rc2 LG(idim) = 4.0_dp*Pi*tmp**2/(g2*(g2 + tmp)**2) END IF @@ -363,8 +363,9 @@ CONTAINS CALL ewald_env_get(ewald_env, ewald_type=ewald_type, do_multipoles=do_multipoles, & gmax=gmax, o_spline=o_spline, alpha=alpha, rcut=rcut) - IF (do_multipoles) & + IF (do_multipoles) THEN CPABORT("No multipole force fields allowed in QM-QM Ewald long range correction") + END IF SELECT CASE (qmmm_coupl_type) CASE (do_qmmm_coulomb) diff --git a/src/qmmm_tb_methods.F b/src/qmmm_tb_methods.F index 8058c41956..a1d0aab62f 100644 --- a/src/qmmm_tb_methods.F +++ b/src/qmmm_tb_methods.F @@ -147,7 +147,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -159,7 +159,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -179,7 +179,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -263,7 +263,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -275,7 +275,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -363,7 +363,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -375,7 +375,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -469,7 +469,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -512,7 +512,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -644,7 +644,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -654,7 +654,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -675,7 +675,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -703,7 +703,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -743,7 +743,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN ! use all kinds END IF DO i = 1, SIZE(list) @@ -887,7 +887,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -897,7 +897,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -917,7 +917,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -1054,7 +1054,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1116,7 +1116,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1159,7 +1159,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSEIF (do_xtb) THEN + ELSE IF (do_xtb) THEN ! END IF DO i = 1, SIZE(list) diff --git a/src/qmmm_topology_util.F b/src/qmmm_topology_util.F index 3ea4eaf263..ad9f796bdb 100644 --- a/src/qmmm_topology_util.F +++ b/src/qmmm_topology_util.F @@ -139,8 +139,9 @@ CONTAINS molecule => molecule_set(imolecule) CALL get_molecule(molecule, molecule_kind=molecule_kind, & first_atom=first_atom, last_atom=last_atom) - IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) & + IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) THEN qm_mol_num = qm_mol_num + 1 + END IF END DO ! ALLOCATE (qm_molecule_index(qm_mol_num)) diff --git a/src/qmmm_util.F b/src/qmmm_util.F index 18cdfd5389..3357a6cfff 100644 --- a/src/qmmm_util.F +++ b/src/qmmm_util.F @@ -128,10 +128,11 @@ CONTAINS END IF IF (force_env%in_use == use_qmmmx) THEN - IF (iwall_type /= do_qmmm_wall_none) & + IF (iwall_type /= do_qmmm_wall_none) THEN CALL cp_warn(__LOCATION__, & "Reflective walls for QM/MM are not implemented (or useful) when "// & "force mixing is active. Skipping!") + END IF RETURN END IF @@ -619,7 +620,7 @@ CONTAINS REAL(KIND=dp) :: r, r0 - r = SQRT(DOT_PRODUCT(rij, rij)) + r = NORM2(rij) r0 = spherical_cutoff(1) - 20.0_dp*spherical_cutoff(2) factor = 0.5_dp*(1.0_dp - TANH((r - r0)/spherical_cutoff(2))) diff --git a/src/qmmmx_force.F b/src/qmmmx_force.F index 1e69447e42..72afe1f591 100644 --- a/src/qmmmx_force.F +++ b/src/qmmmx_force.F @@ -80,9 +80,10 @@ CONTAINS TYPE(section_vals_type), POINTER :: force_env_section IF (PRESENT(require_consistent_energy_force)) THEN - IF (require_consistent_energy_force) & + IF (require_consistent_energy_force) THEN CALL cp_abort(__LOCATION__, & "qmmmx_energy_and_forces got require_consistent_energy_force but force mixing is active. ") + END IF END IF ! Possibly translate the system @@ -118,9 +119,9 @@ CONTAINS IF (mom_conserv_region == do_fm_mom_conserv_core) THEN mom_conserv_min_label = force_mixing_label_QM_core - ELSEIF (mom_conserv_region == do_fm_mom_conserv_QM) THEN + ELSE IF (mom_conserv_region == do_fm_mom_conserv_QM) THEN mom_conserv_min_label = force_mixing_label_QM_dynamics - ELSEIF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN + ELSE IF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN mom_conserv_min_label = force_mixing_label_buffer ELSE CPABORT("Got unknown MOMENTUM_CONSERVATION_REGION (not CORE, QM, or BUFFER) !") @@ -141,8 +142,9 @@ CONTAINS ELSE IF (mom_conserv_type == do_fm_mom_conserv_equal_a) THEN mom_conserv_mass = 0.0_dp DO ip = 1, SIZE(cur_indices) - IF (cur_labels(ip) >= mom_conserv_min_label) & + IF (cur_labels(ip) >= mom_conserv_min_label) THEN mom_conserv_mass = mom_conserv_mass + particles_qmmm_core(cur_indices(ip))%atomic_kind%mass + END IF END DO delta_a = total_f/mom_conserv_mass DO ip = 1, SIZE(cur_indices) diff --git a/src/qmmmx_util.F b/src/qmmmx_util.F index 680cba631d..6779e0100a 100644 --- a/src/qmmmx_util.F +++ b/src/qmmmx_util.F @@ -285,8 +285,9 @@ CONTAINS ![NB] need more sophisticated QM extended, buffer rules ! add QM using hysteretic selection (core_list, r_qm) + unbreakable bonds - IF (debug_this_module .AND. output_unit > 0) & + IF (debug_this_module .AND. output_unit > 0) THEN WRITE (output_unit, *) "BOB QM_extended_seed_is_core_list ", QM_extended_seed_is_core_list + END IF IF (QM_extended_seed_is_core_list) THEN QM_extended_seed_min_label_val = force_mixing_label_QM_core_list ELSE ! QM region seed is all of core, not just core list + unbreakable bonds @@ -378,17 +379,19 @@ CONTAINS EXIT END IF END DO - IF (old_index <= 0) & + IF (old_index <= 0) THEN CALL cp_abort(__LOCATION__, & "add_new_label found atom with a label "// & "already set, but not in new_indices array") + END IF new_labels(old_index) = label ELSE n_new = n_new + 1 - IF (n_new > max_n_qm) & + IF (n_new > max_n_qm) THEN CALL cp_abort(__LOCATION__, & "add_new_label tried to add more atoms "// & "than allowed by &FORCE_MIXING&MAX_N_QM!") + END IF IF (n_new > SIZE(new_indices)) CALL reallocate(new_indices, 1, n_new + 9) IF (n_new > SIZE(new_labels)) CALL reallocate(new_labels, 1, n_new + 9) new_indices(n_new) = ip @@ -483,8 +486,9 @@ CONTAINS adaptive_exclude = .FALSE. DO im_exclude = 1, SIZE(adaptive_exclude_molecules) IF (TRIM(molecule_set(im)%molecule_kind%name) == TRIM(adaptive_exclude_molecules(im_exclude)) .OR. & - TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) & + TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) THEN adaptive_exclude = .TRUE. + END IF END DO IF (adaptive_exclude) CYCLE END IF @@ -493,15 +497,17 @@ CONTAINS IF (molec_in_inner) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) & + IF (new_full_labels(ip) < set_label_val) THEN CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) + END IF END DO ELSE IF (molec_in_outer) THEN IF (ANY(orig_full_labels(molecule_set(im)%first_atom:molecule_set(im)%last_atom) >= set_label_val)) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) & + IF (new_full_labels(ip) < set_label_val) THEN CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) + END IF END DO END IF END IF @@ -644,8 +650,9 @@ CONTAINS ! get CUR_INDICES, CUR_LABELS CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels) - IF (SIZE(cur_indices) <= 0) & + IF (SIZE(cur_indices) <= 0) THEN CPABORT("cur_indices is empty, found no QM atoms") + END IF IF (debug_this_module .AND. output_unit > 0) THEN WRITE (output_unit, *) "cur_indices ", cur_indices @@ -665,21 +672,23 @@ CONTAINS EXIT END IF END DO - IF (.NOT. mapped) & + IF (.NOT. mapped) THEN CALL cp_abort(__LOCATION__, & "Force-mixing failed to find QM_KIND mapping for atom of type "// & TRIM(particles(cur_indices(ip))%atomic_kind%element_symbol)// & "! ") + END IF END IF END DO ! pre-existing QM_KIND section specifies list of core atom qm_kind_section => section_vals_get_subs_vals3(qmmm_section, "QM_KIND") CALL section_vals_get(qm_kind_section, n_repetition=i_rep_section_core) - IF (i_rep_section_core <= 0) & + IF (i_rep_section_core <= 0) THEN CALL cp_abort(__LOCATION__, & "Force-mixing QM didn't find any QM_KIND sections, "// & "so no core specified!") + END IF i_rep_section_extended = i_rep_section_core DO ielem = 1, n_elements new_element_core = .TRUE. @@ -800,8 +809,9 @@ CONTAINS n_labels = n_labels + SIZE(labels_entry) END DO - IF (n_indices /= n_labels) & + IF (n_indices /= n_labels) THEN CPABORT("got unequal numbers of force_mixing indices and labels!") + END IF END SUBROUTINE get_force_mixing_indices END MODULE qmmmx_util diff --git a/src/qs_2nd_kernel_ao.F b/src/qs_2nd_kernel_ao.F index 882a42af8d..dd4e7540c8 100644 --- a/src/qs_2nd_kernel_ao.F +++ b/src/qs_2nd_kernel_ao.F @@ -301,8 +301,9 @@ CONTAINS CPASSERT(.NOT. dft_control%qs_control%gapw_xc) CPASSERT(.NOT. dft_control%qs_control%lrigpw) CPASSERT(.NOT. linres_control%lr_triplet) - IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) & + IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) THEN CPABORT("kpp1_admm has to be associated if ADMM kernel calculations are requested") + END IF nspins = dft_control%nspins diff --git a/src/qs_active_space_methods.F b/src/qs_active_space_methods.F index a4bcfd1e69..56c589cbd6 100644 --- a/src/qs_active_space_methods.F +++ b/src/qs_active_space_methods.F @@ -288,19 +288,23 @@ CONTAINS NULLIFY (kpoints) CALL get_qs_env(qs_env, do_kpoints=do_kpoints, dft_control=dft_control, kpoints=kpoints) IF (do_kpoints) THEN - IF (.NOT. ASSOCIATED(kpoints)) & + IF (.NOT. ASSOCIATED(kpoints)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") + END IF CALL get_kpoint_info(kpoints, kp_scheme=kp_scheme, nkp=nkp, use_real_wfn=use_real_wfn) IF (TRIM(kp_scheme) /= "GAMMA" .OR. nkp /= 1 .OR. .NOT. use_real_wfn) THEN CALL cp_abort(__LOCATION__, & "Only Gamma-point DFT%KPOINTS are supported in the active space module") END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env)) & + IF (.NOT. ASSOCIATED(kpoints%kp_env)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) & + END IF + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) & + END IF + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) THEN CALL cp_abort(__LOCATION__, "Missing Gamma-point MOs for active space module") + END IF END IF ! adiabatic rescaling? @@ -786,7 +790,7 @@ CONTAINS END IF mo_set_active%eigenvalues(i) = eigenvalues(i, ispin) ! if it was not an active orbital, check whether it is an inactive orbital - ELSEIF (nmo_inactive_remaining > 0) THEN + ELSE IF (nmo_inactive_remaining > 0) THEN CALL cp_fm_to_fm(fm_dummy, fm_target_inactive, 1, i, i) ! store on the fly the mapping of inactive orbitals active_space_env%inactive_orbitals(nmo_inactive - nmo_inactive_remaining + 1, ispin) = i @@ -819,7 +823,7 @@ CONTAINS DO j = 0, jm IF (ANY(active_space_env%active_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [A]" - ELSEIF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN + ELSE IF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [I]" ELSE WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [V]" @@ -996,7 +1000,7 @@ CONTAINS IF (i == 1) THEN n1 = nmo n2 = nmo - ELSEIF (i == 2) THEN + ELSE IF (i == 2) THEN n1 = nmo n2 = nmo ELSE @@ -1451,8 +1455,9 @@ CONTAINS ! Check the input group CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) IF (eri_env%eri_gpw%group_size < 1) eri_env%eri_gpw%group_size = para_env%num_pe - IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) & + IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) THEN CPABORT("Group size must be a divisor of the total number of processes!") + END IF ! Create a new para_env or reuse the old one IF (eri_env%eri_gpw%group_size == para_env%num_pe) THEN eri_env%para_env_sub => para_env @@ -1774,7 +1779,7 @@ CONTAINS ! DEALLOCATE (eri, eri_index) END DO - ELSEIF (eri_env%method == eri_method_full_gpw) THEN + ELSE IF (eri_env%method == eri_method_full_gpw) THEN DO isp2 = isp1, nspins CALL get_mo_set(mo_set=mos(isp2), nmo=nmo2) nx = (nmo2*(nmo2 + 1))/2 @@ -2193,7 +2198,7 @@ CONTAINS CALL section_vals_val_get(input, "STRIDE", i_vals=istride) IF (SIZE(istride) == 1) THEN str(1:3) = istride(1) - ELSEIF (SIZE(istride) == 3) THEN + ELSE IF (SIZE(istride) == 3) THEN str(1:3) = istride(1:3) ELSE CPABORT("STRIDE arguments inconsistent") @@ -3136,7 +3141,7 @@ CONTAINS END IF converged = .TRUE. EXIT - ELSEIF (ABS(delta_E) <= eps_iter) THEN + ELSE IF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" @@ -3318,7 +3323,7 @@ CONTAINS converged = .TRUE. EXIT ! check for convergence - ELSEIF (ABS(delta_E) <= eps_iter) THEN + ELSE IF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" diff --git a/src/qs_active_space_mixing.F b/src/qs_active_space_mixing.F index b39d14d962..5813e70d75 100644 --- a/src/qs_active_space_mixing.F +++ b/src/qs_active_space_mixing.F @@ -256,8 +256,7 @@ CONTAINS active_space_env%as_mix_x_buffer(ib, :) = p_old active_space_env%as_mix_r_buffer(ib, :) = p_solver - p_old - res_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & - active_space_env%as_mix_r_buffer(ib, :))) + res_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) IF (nb == 1 .OR. res_norm < 1.E-14_dp) THEN CALL active_space_direct_mix(p_old, p_solver, mixing_store%alpha, p_mixed) @@ -337,7 +336,7 @@ CONTAINS ALLOCATE (p_res(ndim)) p_res(:) = p_solver(:) - p_old(:) - res_norm = SQRT(DOT_PRODUCT(p_res, p_res)) + res_norm = NORM2(p_res) mixing_store%ncall = mixing_store%ncall + 1 IF (mixing_store%ncall == 1) THEN @@ -358,8 +357,7 @@ CONTAINS active_space_env%as_mix_r_buffer(ib, :) = p_res - active_space_env%as_mix_r_old active_space_env%as_mix_x_buffer(ib, :) = p_old - active_space_env%as_mix_x_old - delta_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & - active_space_env%as_mix_r_buffer(ib, :))) + delta_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) can_update = res_norm > 1.E-14_dp .AND. delta_norm > 1.E-14_dp IF (can_update) THEN diff --git a/src/qs_active_space_types.F b/src/qs_active_space_types.F index 8042e71158..c470db2ec7 100644 --- a/src/qs_active_space_types.F +++ b/src/qs_active_space_types.F @@ -237,8 +237,9 @@ CONTAINS DEALLOCATE (active_space_env%as_mix_x_buffer) END IF - IF (ASSOCIATED(active_space_env%pmat_inactive)) & + IF (ASSOCIATED(active_space_env%pmat_inactive)) THEN CALL dbcsr_deallocate_matrix_set(active_space_env%pmat_inactive) + END IF DEALLOCATE (active_space_env) END IF @@ -380,8 +381,9 @@ CONTAINS ! 1) Collect the amount of local data from each process nonzero_elements_local = 0 - IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) & + IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) THEN nonzero_elements_local = eri%nzerow_local(i12l) + END IF CALL mp_group%allgather(nonzero_elements_local, nonzero_elements_global) ! 2) Prepare arrays for communication (calculate the offsets and the total number of elements) diff --git a/src/qs_cdft_methods.F b/src/qs_cdft_methods.F index 03f8f75cdd..950b77b4f7 100644 --- a/src/qs_cdft_methods.F +++ b/src/qs_cdft_methods.F @@ -181,8 +181,9 @@ CONTAINS becke_control => cdft_control%becke_control group => cdft_control%group cutoffs => becke_control%cutoffs - IF (cdft_control%atomic_charges) & + IF (cdft_control%atomic_charges) THEN charge => cdft_control%charge + END IF in_memory = .FALSE. IF (cdft_control%save_pot) THEN in_memory = becke_control%in_memory @@ -221,7 +222,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) END DO END DO @@ -243,8 +244,9 @@ CONTAINS ! A subsequent check (atom_in_group) ensures that the gradients of these dummy atoms are correct IF (cdft_control%save_pot .OR. & becke_control%cavity_confine .OR. & - becke_control%should_skip) & + becke_control%should_skip) THEN is_constraint(catom(i)) = .TRUE. + END IF END DO bo = group(1)%weight%pw_grid%bounds_local dvol = group(1)%weight%pw_grid%dvol @@ -333,7 +335,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(iatom) == 0.0_dp) THEN r = becke_control%vector_buffer%position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) becke_control%vector_buffer%distance_vecs(:, iatom) = dist_vec becke_control%vector_buffer%distances(iatom) = dist1 ELSE @@ -346,7 +348,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist1 = NORM2(dist_vec) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -367,7 +369,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(jatom) == 0.0_dp) THEN r1 = becke_control%vector_buffer%position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) becke_control%vector_buffer%distance_vecs(:, jatom) = dist_vec becke_control%vector_buffer%distances(jatom) = dist2 ELSE @@ -380,7 +382,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + dist2 = NORM2(dist_vec) END IF IF (in_memory) THEN IF (becke_control%vector_buffer%store_vectors) THEN @@ -562,8 +564,9 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) & + IF (ALLOCATED(is_constraint)) THEN DEALLOCATE (is_constraint) + END IF DEALLOCATE (catom) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) @@ -1186,8 +1189,9 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN CPABORT("Becke control has not been allocated.") + END IF group => cdft_control%group ! Initialize nvar = SIZE(cdft_control%target) @@ -1228,9 +1232,10 @@ CONTAINS IF (is_becke .AND. (cdft_control%external_control .AND. becke_control%cavity_confine)) THEN ! With external control, we can use cavity_mat as a mask to kahan sum eps_cavity = becke_control%eps_cavity - IF (igroup /= 1) & + IF (igroup /= 1) THEN CALL cp_abort(__LOCATION__, & "Multiple constraints not yet supported by parallel mixed calculations.") + END IF dE(igroup) = dE(igroup) + sign*accurate_dot_product(group(igroup)%weight%array, rho_r(i)%array, & becke_control%cavity_mat, eps_cavity)*dvol ELSE @@ -1254,9 +1259,10 @@ CONTAINS END IF IF (dft_control%qs_control%gapw) THEN ! GAPW: add core charges (rho_hard - rho_soft) - IF (cdft_control%fragment_density) & + IF (cdft_control%fragment_density) THEN CALL cp_abort(__LOCATION__, & "Fragment constraints not yet compatible with GAPW.") + END IF ALLOCATE (gapw_offset(nvar, dft_control%nspins)) gapw_offset = 0.0_dp CALL get_qs_env(qs_env, rho0_mpole=rho0_mpole) @@ -1622,18 +1628,21 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN CPABORT("Becke control has not been allocated.") + END IF group => cdft_control%group dvol = group(1)%weight%pw_grid%dvol ! Fragment densities are meaningful only for some calculation types - IF (.NOT. qs_env%single_point_run) & + IF (.NOT. qs_env%single_point_run) THEN CALL cp_abort(__LOCATION__, & "CDFT fragment constraints are only compatible with single "// & "point calculations (run_type ENERGY or ENERGY_FORCE).") - IF (dft_control%qs_control%gapw) & + END IF + IF (dft_control%qs_control%gapw) THEN CALL cp_abort(__LOCATION__, & "CDFT fragment constraint not compatible with GAPW.") + END IF needs_spin_density = .FALSE. multiplier = 1.0_dp nfrag_spins = 1 @@ -1691,10 +1700,11 @@ CONTAINS CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, nelectron_total=nelectron_total) nelectron_frag = pw_integrate_function(rho_frag(1)) - IF (NINT(nelectron_frag) /= nelectron_total) & + IF (NINT(nelectron_frag) /= nelectron_total) THEN CALL cp_abort(__LOCATION__, & "The number of electrons in the reference and interacting "// & "configurations does not match. Check your fragment cube files.") + END IF ! Update constraint target value i.e. perform integration w_i*rho_frag_{tot/spin}*dr cdft_control%target = 0.0_dp DO igroup = 1, SIZE(group) diff --git a/src/qs_cdft_opt_types.F b/src/qs_cdft_opt_types.F index 92cb004adb..4a3ed616c6 100644 --- a/src/qs_cdft_opt_types.F +++ b/src/qs_cdft_opt_types.F @@ -135,10 +135,12 @@ CONTAINS TYPE(cdft_opt_type), POINTER :: cdft_opt_control IF (ASSOCIATED(cdft_opt_control)) THEN - IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) & + IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) THEN DEALLOCATE (cdft_opt_control%jacobian_vector) - IF (ALLOCATED(cdft_opt_control%jacobian_step)) & + END IF + IF (ALLOCATED(cdft_opt_control%jacobian_step)) THEN DEALLOCATE (cdft_opt_control%jacobian_step) + END IF DEALLOCATE (cdft_opt_control) END IF @@ -188,22 +190,26 @@ CONTAINS CALL section_vals_val_get(cdft_opt_section, "FACTOR_LS", & r_val=cdft_opt_control%factor_ls) IF (cdft_opt_control%factor_ls <= 0.0_dp .OR. & - cdft_opt_control%factor_ls >= 1.0_dp) & + cdft_opt_control%factor_ls >= 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "Keyword FACTOR_LS must be between 0.0 and 1.0.") + END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", explicit=exists) IF (exists) THEN CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", & i_vals=tmplist) - IF (SIZE(tmplist) /= 2) & + IF (SIZE(tmplist) /= 2) THEN CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes exactly two input values.") - IF (ANY(tmplist < 0)) & + END IF + IF (ANY(tmplist < 0)) THEN CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes only positive values.") - IF (ALL(tmplist == 0)) & + END IF + IF (ALL(tmplist == 0)) THEN CALL cp_abort(__LOCATION__, & "Both values to keyword JACOBIAN_FREQ cannot be zero.") + END IF cdft_opt_control%jacobian_freq(:) = tmplist(1:2) END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_RESTART", & @@ -275,9 +281,10 @@ CONTAINS IF (cdft_opt_control%jacobian_freq(2) > 0) THEN WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(2), " energy evaluation" - IF (cdft_opt_control%jacobian_freq(1) > 0) & + IF (cdft_opt_control%jacobian_freq(1) > 0) THEN WRITE (output_unit, '(T29,A,I4,A)') & - "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" + "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" + END IF ELSE WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" diff --git a/src/qs_cdft_scf_utils.F b/src/qs_cdft_scf_utils.F index f70237f2de..c7b6bf59a1 100644 --- a/src/qs_cdft_scf_utils.F +++ b/src/qs_cdft_scf_utils.F @@ -80,11 +80,12 @@ CONTAINS dft_control=dft_control) IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= 1 .AND. & - SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) & + SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) THEN CALL cp_abort(__LOCATION__, & cp_to_string(SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step))// & " values passed to keyword JACOBIAN_STEP, expected 1 or "// & cp_to_string(SIZE(scf_env%outer_scf%variables, 1))) + END IF ALLOCATE (dh(SIZE(scf_env%outer_scf%variables, 1))) IF (SIZE(dh) /= SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step)) THEN @@ -229,8 +230,9 @@ CONTAINS use_md_history = .TRUE. ! Check that none of the history values are identical in which case we should try something different DO i = 1, nvar - IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) & + IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) THEN use_md_history = .FALSE. + END IF END DO IF (use_md_history) THEN ALLOCATE (jacobian(nvar, nvar)) @@ -238,8 +240,9 @@ CONTAINS jacobian(i, i) = (gradient_history(i, 2) - gradient_history(i, 1))/ & (variable_history(i, 2) - variable_history(i, 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -253,17 +256,19 @@ CONTAINS IF (ihistory >= 2 .AND. .NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ! Next, try history from current SCF procedure nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF must be greater than or equal "// & "to 3 for optimizers that build the Jacobian from SCF history.") + END IF ALLOCATE (jacobian(nvar, nvar)) DO i = 1, nvar jacobian(i, i) = (scf_env%outer_scf%gradient(i, ihistory) - scf_env%outer_scf%gradient(i, ihistory - 1))/ & (scf_env%outer_scf%variables(i, ihistory) - scf_env%outer_scf%variables(i, ihistory - 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -294,11 +299,13 @@ CONTAINS CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control%jacobian_vector)) nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) & + IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) THEN CALL cp_abort(__LOCATION__, & "Too many or too few values defined for restarting inverse Jacobian.") - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + END IF + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian iwork = 1 DO i = 1, nvar diff --git a/src/qs_cdft_types.F b/src/qs_cdft_types.F index 74672844ab..3841d78f60 100644 --- a/src/qs_cdft_types.F +++ b/src/qs_cdft_types.F @@ -315,31 +315,43 @@ CONTAINS TYPE(becke_constraint_type), INTENT(INOUT) :: becke_control IF (becke_control%vector_buffer%store_vectors) THEN - IF (ALLOCATED(becke_control%vector_buffer%distances)) & + IF (ALLOCATED(becke_control%vector_buffer%distances)) THEN DEALLOCATE (becke_control%vector_buffer%distances) - IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) THEN DEALLOCATE (becke_control%vector_buffer%distance_vecs) - IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) THEN DEALLOCATE (becke_control%vector_buffer%position_vecs) - IF (ALLOCATED(becke_control%vector_buffer%R12)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%R12)) THEN DEALLOCATE (becke_control%vector_buffer%R12) - IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) & + END IF + IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) THEN DEALLOCATE (becke_control%vector_buffer%pair_dist_vecs) + END IF END IF - IF (ASSOCIATED(becke_control%cutoffs)) & + IF (ASSOCIATED(becke_control%cutoffs)) THEN DEALLOCATE (becke_control%cutoffs) - IF (ASSOCIATED(becke_control%cutoffs_tmp)) & + END IF + IF (ASSOCIATED(becke_control%cutoffs_tmp)) THEN DEALLOCATE (becke_control%cutoffs_tmp) - IF (ASSOCIATED(becke_control%radii_tmp)) & + END IF + IF (ASSOCIATED(becke_control%radii_tmp)) THEN DEALLOCATE (becke_control%radii_tmp) - IF (ASSOCIATED(becke_control%radii)) & + END IF + IF (ASSOCIATED(becke_control%radii)) THEN DEALLOCATE (becke_control%radii) - IF (ASSOCIATED(becke_control%aij)) & + END IF + IF (ASSOCIATED(becke_control%aij)) THEN DEALLOCATE (becke_control%aij) - IF (ASSOCIATED(becke_control%cavity_mat)) & + END IF + IF (ASSOCIATED(becke_control%cavity_mat)) THEN DEALLOCATE (becke_control%cavity_mat) - IF (becke_control%cavity_confine) & + END IF + IF (becke_control%cavity_confine) THEN CALL release_hirshfeld_type(becke_control%cavity_env) + END IF END SUBROUTINE becke_control_release @@ -435,44 +447,60 @@ CONTAINS INTEGER :: i ! Constraint settings - IF (ASSOCIATED(cdft_control%atoms)) & + IF (ASSOCIATED(cdft_control%atoms)) THEN DEALLOCATE (cdft_control%atoms) - IF (ASSOCIATED(cdft_control%strength)) & + END IF + IF (ASSOCIATED(cdft_control%strength)) THEN DEALLOCATE (cdft_control%strength) - IF (ASSOCIATED(cdft_control%target)) & + END IF + IF (ASSOCIATED(cdft_control%target)) THEN DEALLOCATE (cdft_control%target) - IF (ASSOCIATED(cdft_control%value)) & + END IF + IF (ASSOCIATED(cdft_control%value)) THEN DEALLOCATE (cdft_control%value) - IF (ASSOCIATED(cdft_control%charges_fragment)) & + END IF + IF (ASSOCIATED(cdft_control%charges_fragment)) THEN DEALLOCATE (cdft_control%charges_fragment) - IF (ASSOCIATED(cdft_control%fragments)) & + END IF + IF (ASSOCIATED(cdft_control%fragments)) THEN DEALLOCATE (cdft_control%fragments) - IF (ASSOCIATED(cdft_control%is_constraint)) & + END IF + IF (ASSOCIATED(cdft_control%is_constraint)) THEN DEALLOCATE (cdft_control%is_constraint) - IF (ASSOCIATED(cdft_control%charge)) & + END IF + IF (ASSOCIATED(cdft_control%charge)) THEN DEALLOCATE (cdft_control%charge) + END IF ! Constraint atom groups IF (ASSOCIATED(cdft_control%group)) THEN DO i = 1, SIZE(cdft_control%group) - IF (ASSOCIATED(cdft_control%group(i)%atoms)) & + IF (ASSOCIATED(cdft_control%group(i)%atoms)) THEN DEALLOCATE (cdft_control%group(i)%atoms) - IF (ASSOCIATED(cdft_control%group(i)%coeff)) & - DEALLOCATE (cdft_control%group(i)%coeff) - IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) & - DEALLOCATE (cdft_control%group(i)%d_sum_const_dR) - IF (cdft_control%type == outer_scf_becke_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients)) & - DEALLOCATE (cdft_control%group(i)%gradients) - ELSE IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) & - DEALLOCATE (cdft_control%group(i)%gradients_x) - IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) & - DEALLOCATE (cdft_control%group(i)%gradients_y) - IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) & - DEALLOCATE (cdft_control%group(i)%gradients_z) END IF - IF (ASSOCIATED(cdft_control%group(i)%integrated)) & + IF (ASSOCIATED(cdft_control%group(i)%coeff)) THEN + DEALLOCATE (cdft_control%group(i)%coeff) + END IF + IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) THEN + DEALLOCATE (cdft_control%group(i)%d_sum_const_dR) + END IF + IF (cdft_control%type == outer_scf_becke_constraint) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients)) THEN + DEALLOCATE (cdft_control%group(i)%gradients) + END IF + ELSE IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) THEN + DEALLOCATE (cdft_control%group(i)%gradients_x) + END IF + IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) THEN + DEALLOCATE (cdft_control%group(i)%gradients_y) + END IF + IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) THEN + DEALLOCATE (cdft_control%group(i)%gradients_z) + END IF + END IF + IF (ASSOCIATED(cdft_control%group(i)%integrated)) THEN DEALLOCATE (cdft_control%group(i)%integrated) + END IF END DO DEALLOCATE (cdft_control%group) END IF @@ -488,21 +516,27 @@ CONTAINS ! Release OUTER_SCF types CALL cdft_opt_type_release(cdft_control%ot_control%cdft_opt_control) CALL cdft_opt_type_release(cdft_control%constraint_control%cdft_opt_control) - IF (ASSOCIATED(cdft_control%constraint%variables)) & + IF (ASSOCIATED(cdft_control%constraint%variables)) THEN DEALLOCATE (cdft_control%constraint%variables) - IF (ASSOCIATED(cdft_control%constraint%count)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%count)) THEN DEALLOCATE (cdft_control%constraint%count) - IF (ASSOCIATED(cdft_control%constraint%gradient)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN DEALLOCATE (cdft_control%constraint%gradient) - IF (ASSOCIATED(cdft_control%constraint%energy)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%energy)) THEN DEALLOCATE (cdft_control%constraint%energy) - IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN DEALLOCATE (cdft_control%constraint%inv_jacobian) + END IF ! Storage for mixed CDFT calculations IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations) - IF (ASSOCIATED(cdft_control%occupations(i)%array)) & + IF (ASSOCIATED(cdft_control%occupations(i)%array)) THEN DEALLOCATE (cdft_control%occupations(i)%array) + END IF END DO DEALLOCATE (cdft_control%occupations) END IF @@ -543,8 +577,9 @@ CONTAINS SUBROUTINE hirshfeld_control_release(hirshfeld_control) TYPE(hirshfeld_constraint_type), INTENT(INOUT) :: hirshfeld_control - IF (ASSOCIATED(hirshfeld_control%radii)) & + IF (ASSOCIATED(hirshfeld_control%radii)) THEN DEALLOCATE (hirshfeld_control%radii) + END IF CALL release_hirshfeld_type(hirshfeld_control%hirshfeld_env) END SUBROUTINE hirshfeld_control_release diff --git a/src/qs_cdft_utils.F b/src/qs_cdft_utils.F index c82c9cddc3..a5d0de5020 100644 --- a/src/qs_cdft_utils.F +++ b/src/qs_cdft_utils.F @@ -163,10 +163,11 @@ CONTAINS IF (becke_control%adjust) THEN IF (.NOT. ASSOCIATED(becke_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF ALLOCATE (becke_control%radii(SIZE(atomic_kind_set))) becke_control%radii(:) = becke_control%radii_tmp(:) DEALLOCATE (becke_control%radii_tmp) @@ -180,10 +181,11 @@ CONTAINS CASE (becke_cutoff_global) becke_control%cutoffs(:) = becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does not "// & "match number of atomic kinds in the input coordinate file.") + END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -238,7 +240,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) + becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) ! Set up heteronuclear cell partitioning using user defined radii IF (build) THEN @@ -329,8 +331,9 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) & + IF (ASSOCIATED(radii_list)) THEN DEALLOCATE (radii_list) + END IF END IF ! Form cavity by summing isolated Gaussian densities over constraint atoms NULLIFY (rs_cavity) @@ -425,9 +428,10 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (para_env%is_source() .AND. unit_nr < 1) & + IF (para_env%is_source() .AND. unit_nr < 1) THEN CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") + END IF CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, particles=particles) CALL cp_pw_to_cube(becke_control%cavity, unit_nr, "CAVITY", particles=particles, stride=stride, mpi_io=mpi_io) @@ -435,8 +439,9 @@ CONTAINS DEALLOCATE (stride) END IF END IF - IF (ALLOCATED(is_constraint)) & + IF (ALLOCATED(is_constraint)) THEN DEALLOCATE (is_constraint) + END IF CALL timestop(handle) END SUBROUTINE becke_constraint_init @@ -497,9 +502,10 @@ CONTAINS CALL section_vals_val_get(becke_section, "IN_MEMORY", l_val=becke_control%in_memory) IF (cdft_control%becke_control%cavity_confine) THEN CALL section_vals_val_get(becke_section, "CAVITY_SHAPE", i_val=becke_control%cavity_shape) - IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) & + IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) THEN CALL cp_abort(__LOCATION__, & "Activate keyword ADJUST_SIZE to use cavity shape USER.") + END IF CALL section_vals_val_get(becke_section, "CAVITY_RADIUS", r_val=becke_control%rcavity) CALL section_vals_val_get(becke_section, "EPS_CAVITY", r_val=becke_control%eps_cavity) CALL section_vals_val_get(becke_section, "CAVITY_PRINT", l_val=becke_control%print_cavity) @@ -550,8 +556,9 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) & + IF (SIZE(tmplist) < 1) THEN CPABORT("Each ATOM_GROUP must contain at least 1 atom.") + END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (cdft_control%group(k)%atoms(natoms)) @@ -618,8 +625,9 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) & + IF (SIZE(tmplist) < 1) THEN CPABORT("DUMMY_ATOMS must contain at least 1 atom.") + END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (dummylist(natoms)) @@ -635,16 +643,18 @@ CONTAINS ! Check for duplicates DO j = 1, natoms DO i = j + 1, natoms - IF (dummylist(i) == dummylist(j)) & + IF (dummylist(i) == dummylist(j)) THEN CPABORT("Duplicate atoms defined in section DUMMY_ATOMS.") + END IF END DO END DO ! Check that a dummy atom is not included in any ATOM_GROUP DO j = 1, SIZE(atomlist) DO i = 1, SIZE(dummylist) - IF (dummylist(i) == atomlist(j)) & + IF (dummylist(i) == atomlist(j)) THEN CALL cp_abort(__LOCATION__, & "Duplicate atoms defined in sections ATOM_GROUP and DUMMY_ATOMS.") + END IF END DO END DO END IF @@ -671,22 +681,24 @@ CONTAINS ALLOCATE (cdft_control%value(nvar)) ALLOCATE (cdft_control%target(nvar)) CALL section_vals_val_get(cdft_control_section, "STRENGTH", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) & + IF (SIZE(rtmplist) /= nvar) THEN CALL cp_abort(__LOCATION__, & "The length of keyword STRENGTH is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") + END IF DO j = 1, nvar cdft_control%strength(j) = rtmplist(j) END DO CALL section_vals_val_get(cdft_control_section, "TARGET", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) & + IF (SIZE(rtmplist) /= nvar) THEN CALL cp_abort(__LOCATION__, & "The length of keyword TARGET is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") + END IF DO j = 1, nvar cdft_control%target(j) = rtmplist(j) END DO @@ -756,8 +768,9 @@ CONTAINS outer_scf_section => section_vals_get_subs_vals(cdft_control_section, "OUTER_SCF") CALL outer_scf_read_parameters(cdft_control%constraint_control, outer_scf_section) IF (cdft_control%constraint_control%have_scf) THEN - IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) & + IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) THEN CPABORT("Unsupported CDFT constraint.") + END IF ! Constraint definitions CALL read_constraint_definitions(cdft_control, cdft_control_section) ! Constraint-specific initializations @@ -1014,10 +1027,11 @@ CONTAINS nkind = SIZE(qs_kind_set) ! Parse atomic radii for setting up Gaussian shape function IF (ASSOCIATED(hirshfeld_control%radii)) THEN - IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) & + IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) THEN CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF ALLOCATE (radii_list(SIZE(hirshfeld_control%radii))) DO ikind = 1, SIZE(hirshfeld_control%radii) @@ -1130,8 +1144,9 @@ CONTAINS CALL qs_scf_cdft_constraint_info(iw, cdft_control) ! Print weight function(s) to cube file(s) whenever weight is (re)built - IF (cdft_control%print_weight .AND. cdft_control%need_pot) & + IF (cdft_control%print_weight .AND. cdft_control%need_pot) THEN CALL cdft_print_weight_function(qs_env) + END IF ! Print atomic CDFT charges IF (iw > 0 .AND. cdft_control%atomic_charges) THEN @@ -1290,9 +1305,10 @@ CONTAINS extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) ! Note PROGRAM_RUN_INFO section neeeds to be active! - IF (para_env%is_source() .AND. unit_nr < 1) & + IF (para_env%is_source() .AND. unit_nr < 1) THEN CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print CDFT weight function.") + END IF CALL cp_pw_to_cube(cdft_control%group(igroup)%weight, & unit_nr, & diff --git a/src/qs_charge_mixing.F b/src/qs_charge_mixing.F index d4981f4b0a..7682698cfc 100644 --- a/src/qs_charge_mixing.F +++ b/src/qs_charge_mixing.F @@ -117,8 +117,9 @@ CONTAINS mixer_max_weight = tblite_mixer_max_weight_default IF (PRESENT(tblite_mixer_max_weight)) mixer_max_weight = tblite_mixer_max_weight IF (mixer_max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (mixer_max_weight < mixer_min_weight) & + IF (mixer_max_weight < mixer_min_weight) THEN CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") + END IF mixer_weight_factor = tblite_mixer_weight_factor_default IF (PRESENT(tblite_mixer_weight_factor)) mixer_weight_factor = tblite_mixer_weight_factor IF (mixer_weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") @@ -183,21 +184,21 @@ CONTAINS IF ((iter_count == 1) .OR. (iter_count + 1 <= mixing_store%nskip_mixing)) THEN ! skip mixing mixing_store%iter_method = "NoMix" - ELSEIF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN + ELSE IF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN CALL mix_charges_only(mixing_store, charges, alpha, imin, ns, para_env) mixing_store%iter_method = "Mixing" - ELSEIF (mixing_method == gspace_mixing_nr) THEN + ELSE IF (mixing_method == gspace_mixing_nr) THEN CPABORT("Kerker method not available for Charge Mixing") - ELSEIF (mixing_method == pulay_mixing_nr) THEN + ELSE IF (mixing_method == pulay_mixing_nr) THEN CPABORT("Pulay method not available for Charge Mixing") - ELSEIF (mixing_method == broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr) THEN CALL broyden_mixing(mixing_store, charges, imin, nvec, ns, para_env) mixing_store%iter_method = "Broy." - ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN + ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN CPABORT("Modified Broyden mixing is only available for DFT density mixing") - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN CPABORT("Multisecant_mixing method not available for Charge Mixing") - ELSEIF (mixing_method == new_pulay_mixing_nr) THEN + ELSE IF (mixing_method == new_pulay_mixing_nr) THEN CPABORT("New Pulay method not available for Charge Mixing") END IF diff --git a/src/qs_chargemol.F b/src/qs_chargemol.F index 32f7c50516..e26a09e4fb 100644 --- a/src/qs_chargemol.F +++ b/src/qs_chargemol.F @@ -604,7 +604,7 @@ CONTAINS DO imo = 1, mos(1)%homo IF (nspins == 1) THEN WRITE (iwfx, '(A15)') "Alpha and Beta" - ELSEIF (dft_control%uks) THEN + ELSE IF (dft_control%uks) THEN WRITE (iwfx, '(A6)') "Alpha" ELSE CALL cp_abort(__LOCATION__, "This wavefunction type is currently"// & diff --git a/src/qs_charges_types.F b/src/qs_charges_types.F index 7771cd0745..b72dd7d539 100644 --- a/src/qs_charges_types.F +++ b/src/qs_charges_types.F @@ -73,11 +73,13 @@ CONTAINS REAL(KIND=dp), INTENT(in), OPTIONAL :: total_rho_core_rspace, total_rho_gspace qs_charges%total_rho_core_rspace = 0.0_dp - IF (PRESENT(total_rho_core_rspace)) & + IF (PRESENT(total_rho_core_rspace)) THEN qs_charges%total_rho_core_rspace = total_rho_core_rspace + END IF qs_charges%total_rho_gspace = 0.0_dp - IF (PRESENT(total_rho_gspace)) & + IF (PRESENT(total_rho_gspace)) THEN qs_charges%total_rho_gspace = total_rho_gspace + END IF qs_charges%total_rho_soft_gspace = 0.0_dp qs_charges%total_rho0_hard_lebedev = 0.0_dp qs_charges%total_rho_soft_gspace = 0.0_dp diff --git a/src/qs_cneo_methods.F b/src/qs_cneo_methods.F index 43081fa9b5..3485e11369 100644 --- a/src/qs_cneo_methods.F +++ b/src/qs_cneo_methods.F @@ -185,9 +185,10 @@ CONTAINS CALL get_gto_basis_set(nuc_soft_basis, npgf=npgf_s, gcc=gcc_s) ! There is such a limitation because we rely on atomic code to build S, T and U. ! Usually l=5 is more than enough, suppoting PB6H basis. - IF (maxl > lmat) & + IF (maxl > lmat) THEN CALL cp_abort(__LOCATION__, "Nuclear basis with angular momentum higher than "// & "atom_types::lmat is not supported yet.") + END IF set_index = 0 shell_index = 0 @@ -1074,7 +1075,7 @@ CONTAINS ! initial guess of f is taken from the result of last iteration CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) ! test if zero initial guess is better - IF (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN + IF (NORM2(r) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN CALL atom_solve_cneo(fmat, [0.0_dp, 0.0_dp, 0.0_dp], utrans, wfn, & ener, pmat, r_tmp, distance, nsgf, nne) IF (DOT_PRODUCT(r_tmp, r_tmp) < DOT_PRODUCT(r, r)) THEN @@ -1085,7 +1086,7 @@ CONTAINS max_iter = 20 iter = 0 ! using Newton's method to solve for f - DO WHILE (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp) + DO WHILE (NORM2(r) > 1.e-12_dp) iter = iter + 1 ! construct numerical Jacobian with one-side finite difference DO i = 1, 3 @@ -1118,13 +1119,13 @@ CONTAINS CALL invert_matrix_3x3(jac, jac_inv, det, try_svd=.TRUE.) END IF df = -RESHAPE(MATMUL(jac_inv, RESHAPE(r, [3, 1])), [3]) - df_norm = SQRT(DOT_PRODUCT(df, df)) + df_norm = NORM2(df) f_tmp = f r_tmp = r - g0 = SQRT(DOT_PRODUCT(r_tmp, r_tmp)) + g0 = NORM2(r_tmp) f = f_tmp + df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = SQRT(DOT_PRODUCT(r, r)) + g1 = NORM2(r) step = 1.0_dp DO WHILE (g1 >= g0) ! line search @@ -1136,7 +1137,7 @@ CONTAINS step = step*MAX(-g0p/(2.0_dp*(g1 - g0 - g0p)), 0.1_dp) f = f_tmp + step*df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = SQRT(DOT_PRODUCT(r, r)) + g1 = NORM2(r) END DO IF (iter >= max_iter) THEN CALL cp_warn(__LOCATION__, "CNEO nuclear position constraint solver failed to "// & diff --git a/src/qs_cneo_types.F b/src/qs_cneo_types.F index 40dd2fb323..f5661286f4 100644 --- a/src/qs_cneo_types.F +++ b/src/qs_cneo_types.F @@ -121,32 +121,45 @@ CONTAINS TYPE(rhoz_cneo_type), POINTER :: rhoz_cneo IF (ASSOCIATED(rhoz_cneo)) THEN - IF (ASSOCIATED(rhoz_cneo%pmat)) & + IF (ASSOCIATED(rhoz_cneo%pmat)) THEN DEALLOCATE (rhoz_cneo%pmat) - IF (ASSOCIATED(rhoz_cneo%core)) & + END IF + IF (ASSOCIATED(rhoz_cneo%core)) THEN DEALLOCATE (rhoz_cneo%core) - IF (ASSOCIATED(rhoz_cneo%vmat)) & + END IF + IF (ASSOCIATED(rhoz_cneo%vmat)) THEN DEALLOCATE (rhoz_cneo%vmat) - IF (ASSOCIATED(rhoz_cneo%fmat)) & + END IF + IF (ASSOCIATED(rhoz_cneo%fmat)) THEN DEALLOCATE (rhoz_cneo%fmat) - IF (ASSOCIATED(rhoz_cneo%wfn)) & + END IF + IF (ASSOCIATED(rhoz_cneo%wfn)) THEN DEALLOCATE (rhoz_cneo%wfn) - IF (ASSOCIATED(rhoz_cneo%cpc_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%cpc_h)) THEN DEALLOCATE (rhoz_cneo%cpc_h) - IF (ASSOCIATED(rhoz_cneo%cpc_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%cpc_s)) THEN DEALLOCATE (rhoz_cneo%cpc_s) - IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) THEN DEALLOCATE (rhoz_cneo%rho_rad_h) - IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) THEN DEALLOCATE (rhoz_cneo%rho_rad_s) - IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) THEN DEALLOCATE (rhoz_cneo%vrho_rad_h) - IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) THEN DEALLOCATE (rhoz_cneo%vrho_rad_s) - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) & + END IF + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) THEN DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_h) - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) & + END IF + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) THEN DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_s) + END IF END IF END SUBROUTINE deallocate_rhoz_cneo @@ -181,8 +194,9 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential - IF (ASSOCIATED(potential)) & + IF (ASSOCIATED(potential)) THEN CALL deallocate_cneo_potential(potential) + END IF ALLOCATE (potential) @@ -197,36 +211,51 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential IF (ASSOCIATED(potential)) THEN - IF (ASSOCIATED(potential%elec_conf)) & + IF (ASSOCIATED(potential%elec_conf)) THEN DEALLOCATE (potential%elec_conf) - IF (ASSOCIATED(potential%my_gcc_h)) & + END IF + IF (ASSOCIATED(potential%my_gcc_h)) THEN DEALLOCATE (potential%my_gcc_h) - IF (ASSOCIATED(potential%my_gcc_s)) & + END IF + IF (ASSOCIATED(potential%my_gcc_s)) THEN DEALLOCATE (potential%my_gcc_s) - IF (ASSOCIATED(potential%ovlp)) & + END IF + IF (ASSOCIATED(potential%ovlp)) THEN DEALLOCATE (potential%ovlp) - IF (ASSOCIATED(potential%kin)) & + END IF + IF (ASSOCIATED(potential%kin)) THEN DEALLOCATE (potential%kin) - IF (ASSOCIATED(potential%utrans)) & + END IF + IF (ASSOCIATED(potential%utrans)) THEN DEALLOCATE (potential%utrans) - IF (ASSOCIATED(potential%distance)) & + END IF + IF (ASSOCIATED(potential%distance)) THEN DEALLOCATE (potential%distance) - IF (ASSOCIATED(potential%harmonics)) & + END IF + IF (ASSOCIATED(potential%harmonics)) THEN CALL deallocate_harmonics_atom(potential%harmonics) - IF (ASSOCIATED(potential%Qlm_gg)) & + END IF + IF (ASSOCIATED(potential%Qlm_gg)) THEN DEALLOCATE (potential%Qlm_gg) - IF (ASSOCIATED(potential%gg)) & + END IF + IF (ASSOCIATED(potential%gg)) THEN DEALLOCATE (potential%gg) - IF (ASSOCIATED(potential%vgg)) & + END IF + IF (ASSOCIATED(potential%vgg)) THEN DEALLOCATE (potential%vgg) - IF (ASSOCIATED(potential%n2oindex)) & + END IF + IF (ASSOCIATED(potential%n2oindex)) THEN DEALLOCATE (potential%n2oindex) - IF (ASSOCIATED(potential%o2nindex)) & + END IF + IF (ASSOCIATED(potential%o2nindex)) THEN DEALLOCATE (potential%o2nindex) - IF (ASSOCIATED(potential%rad2l)) & + END IF + IF (ASSOCIATED(potential%rad2l)) THEN DEALLOCATE (potential%rad2l) - IF (ASSOCIATED(potential%oorad2l)) & + END IF + IF (ASSOCIATED(potential%oorad2l)) THEN DEALLOCATE (potential%oorad2l) + END IF DEALLOCATE (potential) END IF @@ -356,8 +385,9 @@ CONTAINS IF (PRESENT(z)) THEN potential%z = z potential%zeff = REAL(z, dp) - IF (ASSOCIATED(potential%elec_conf)) & + IF (ASSOCIATED(potential%elec_conf)) THEN CPABORT("elec_conf is already associated") + END IF ALLOCATE (potential%elec_conf(0:3)) potential%elec_conf(0:3) = ptable(z)%e_conv(0:3) CPASSERT(potential%mass == 0.0_dp) diff --git a/src/qs_collocate_density.F b/src/qs_collocate_density.F index 57925e0e86..c0df7d1eaf 100644 --- a/src/qs_collocate_density.F +++ b/src/qs_collocate_density.F @@ -1245,9 +1245,10 @@ CONTAINS CALL transfer_rs2pw(rs_rho, rhoc_r) - IF (PRESENT(total_rho_metal)) & + IF (PRESENT(total_rho_metal)) THEN !minus sign: account for the fact that rho_metal has opposite sign total_rho_metal = pw_integrate_function(rhoc_r, isign=-1) + END IF CALL pw_transfer(rhoc_r, rho_metal) CALL auxbas_pw_pool%give_back_pw(rhoc_r) @@ -1569,7 +1570,7 @@ CONTAINS IF (PRESENT(soft_valid)) my_soft_valid = soft_valid IF (PRESENT(task_list_external)) THEN task_list => task_list_external - ELSEIF (my_soft_valid) THEN + ELSE IF (my_soft_valid) THEN CALL get_ks_env(ks_env, task_list_soft=task_list) ELSE CALL get_ks_env(ks_env, task_list=task_list) @@ -2358,44 +2359,48 @@ CONTAINS END SELECT IF (iatom <= jatom) THEN - IF (iatom == lambda) & + IF (iatom == lambda) THEN CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - IF (jatom == lambda) & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF + IF (jatom == lambda) THEN CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF ELSE rab_inv = -rab - IF (jatom == lambda) & + IF (jatom == lambda) THEN CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - IF (iatom == lambda) & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF + IF (iatom == lambda) THEN CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + END IF END IF END DO loop_tasks diff --git a/src/qs_core_hamiltonian.F b/src/qs_core_hamiltonian.F index ff5dfb464e..2ab3d7e09c 100644 --- a/src/qs_core_hamiltonian.F +++ b/src/qs_core_hamiltonian.F @@ -230,9 +230,10 @@ CONTAINS IF (dft_control%tddfpt2_control%enabled) THEN nders = 1 IF (dft_control%do_admm) THEN - IF (dft_control%admm_control%purification_method /= do_admm_purify_none) & + IF (dft_control%admm_control%purification_method /= do_admm_purify_none) THEN CALL cp_abort(__LOCATION__, & "Only purification method NONE is possible with TDDFT at the moment") + END IF END IF END IF @@ -336,9 +337,10 @@ CONTAINS nkind = SIZE(atomic_kind_set) CALL allocate_oce_set(oce, nkind) eps_fit = dft_control%qs_control%gapw_control%eps_fit - IF (ASSOCIATED(sap_oce)) & + IF (ASSOCIATED(sap_oce)) THEN CALL build_oce_matrices(oce%intac, calculate_forces, nder, qs_kind_set, particle_set, & sap_oce, eps_fit) + END IF END IF ! *** KG atomic potentials for nonadditive kinetic energy diff --git a/src/qs_core_matrices.F b/src/qs_core_matrices.F index 8ee4e78031..b57e8fd83c 100644 --- a/src/qs_core_matrices.F +++ b/src/qs_core_matrices.F @@ -567,7 +567,7 @@ CONTAINS END IF IF (PRESENT(matrixkp_t)) THEN CALL build_atomic_relmat(matrixkp_t(1, ic)%matrix, atomic_kind_set, qs_kind_set) - ELSEIF (PRESENT(matrix_t)) THEN + ELSE IF (PRESENT(matrix_t)) THEN CALL build_atomic_relmat(matrix_t(1)%matrix, atomic_kind_set, qs_kind_set) END IF ELSE diff --git a/src/qs_dcdr_utils.F b/src/qs_dcdr_utils.F index 9de800d1c3..9c83bf24e0 100644 --- a/src/qs_dcdr_utils.F +++ b/src/qs_dcdr_utils.F @@ -778,8 +778,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(dcdr_section, "REFERENCE_POINT", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) & + IF (reference == use_mom_ref_user) THEN CPABORT("User-defined reference point should be given explicitly") + END IF END IF CALL get_reference_point(rpoint=dcdr_env%ref_point, qs_env=qs_env, & diff --git a/src/qs_dftb_parameters.F b/src/qs_dftb_parameters.F index 35c95324c7..60d7083667 100644 --- a/src/qs_dftb_parameters.F +++ b/src/qs_dftb_parameters.F @@ -204,10 +204,11 @@ CONTAINS CALL parser_release(parser) END BLOCK END IF - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "Failure in assigning KINDS <"//TRIM(iname)//"> and <"//TRIM(jname)// & "> to a DFTB interaction pair!") + END IF END DO END DO ! reading the files diff --git a/src/qs_dftb_utils.F b/src/qs_dftb_utils.F index 79a4972d93..43440135a1 100644 --- a/src/qs_dftb_utils.F +++ b/src/qs_dftb_utils.F @@ -62,8 +62,9 @@ CONTAINS TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter - IF (ASSOCIATED(dftb_parameter)) & + IF (ASSOCIATED(dftb_parameter)) THEN CALL deallocate_dftb_atom_param(dftb_parameter) + END IF ALLOCATE (dftb_parameter) diff --git a/src/qs_dispersion_cnum.F b/src/qs_dispersion_cnum.F index 9d5d96d71a..2632a12933 100644 --- a/src/qs_dispersion_cnum.F +++ b/src/qs_dispersion_cnum.F @@ -1261,9 +1261,9 @@ CONTAINS rcut = rcut + 0.1_dp IF (cnfun == 1) THEN CALL cnparam_d3(rcut, rcov, dispersion_env%k1, cnab, dcnab) - ELSEIF (cnfun == 2) THEN + ELSE IF (cnfun == 2) THEN CALL modcn_d3(rcut, rcov, cnab, dcnab) - ELSEIF (cnfun == 3) THEN + ELSE IF (cnfun == 3) THEN den = 0.0_dp CALL cn_d4per(rcut, rcov, den, cnab, dcnab) ELSE @@ -1367,9 +1367,9 @@ CONTAINS rcovab = dispersion_env%rcov(za) + dispersion_env%rcov(zb) IF (cnfun == 1) THEN CALL cnparam_d3(rcc, rcovab, dispersion_env%k1, cnab, dcnab) - ELSEIF (cnfun == 2) THEN + ELSE IF (cnfun == 2) THEN CALL modcn_d3(rcc, rcovab, cnab, dcnab) - ELSEIF (cnfun == 3) THEN + ELSE IF (cnfun == 3) THEN den = ABS(dispersion_env%eneg(za) - dispersion_env%eneg(zb)) CALL cn_d4per(rcc, rcovab, den, cnab, dcnab) ELSE diff --git a/src/qs_dispersion_d3.F b/src/qs_dispersion_d3.F index 83f2a1ed5d..0afac622bf 100644 --- a/src/qs_dispersion_d3.F +++ b/src/qs_dispersion_d3.F @@ -984,7 +984,7 @@ CONTAINS IF (rab >= ru) THEN fcc = 0._dp dfcc = 0._dp - ELSEIF (rab <= rl) THEN + ELSE IF (rab <= rl) THEN fcc = 1._dp dfcc = 0._dp ELSE diff --git a/src/qs_dispersion_nonloc.F b/src/qs_dispersion_nonloc.F index fa63eaf80f..e4cce04a17 100644 --- a/src/qs_dispersion_nonloc.F +++ b/src/qs_dispersion_nonloc.F @@ -583,7 +583,7 @@ CONTAINS COMPLEX(KIND=dp) :: uu COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: theta - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw(:, :) + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw INTEGER :: handle, ig, iq, l, m, nl_type, nqs, & q1_i, q2_i LOGICAL :: use_virial diff --git a/src/qs_dispersion_pairpot.F b/src/qs_dispersion_pairpot.F index 3f68b76445..26d6bff01b 100644 --- a/src/qs_dispersion_pairpot.F +++ b/src/qs_dispersion_pairpot.F @@ -188,11 +188,12 @@ CONTAINS disp%defined = .FALSE. END IF ! Check if the parameter is defined - IF (.NOT. disp%defined) & + IF (.NOT. disp%defined) THEN CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") + END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO CASE (vdw_pairpot_dftd3, vdw_pairpot_dftd3bj) @@ -274,11 +275,12 @@ CONTAINS ELSE disp%defined = .FALSE. END IF - IF (.NOT. disp%defined) & + IF (.NOT. disp%defined) THEN CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") + END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO @@ -479,11 +481,11 @@ CONTAINS IF (dispersion_env%pp_type == vdw_pairpot_dftd2) THEN CALL calculate_dispersion_d2_pairpot(qs_env, dispersion_env, evdw, calculate_forces, atevdw) - ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & - dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN + ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & + dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN CALL calculate_dispersion_d3_pairpot(qs_env, dispersion_env, evdw, calculate_forces, & unit_nr, atevdw) - ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN + ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN IF (dispersion_env%lrc) THEN CPABORT("Long range correction with DFTD4 not implemented") END IF diff --git a/src/qs_efield_berry.F b/src/qs_efield_berry.F index 48de8e24b0..bf69918821 100644 --- a/src/qs_efield_berry.F +++ b/src/qs_efield_berry.F @@ -263,7 +263,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -296,8 +296,9 @@ CONTAINS END IF END IF IF (use_virial) THEN - IF (para_env%mepos == 0) & + IF (para_env%mepos == 0) THEN CALL virial_pair_force(virial%pv_virial, 1.0_dp, forcea, ria) + END IF END IF END DO qi = AIMAG(LOG(zi)) @@ -752,7 +753,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) + fieldpol = fieldpol/NORM2(fieldpol) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/qs_electric_field_gradient.F b/src/qs_electric_field_gradient.F index c706d01b8e..31adb830c8 100644 --- a/src/qs_electric_field_gradient.F +++ b/src/qs_electric_field_gradient.F @@ -153,7 +153,7 @@ CONTAINS smoothing = .FALSE. ecut = 1.e10_dp ! not used, just to have vars defined sigma = 1._dp ! not used, just to have vars defined - ELSEIF (ecut == -1._dp .AND. sigma == -1._dp) THEN + ELSE IF (ecut == -1._dp .AND. sigma == -1._dp) THEN smoothing = .TRUE. CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL auxbas_pw_pool%create_pw(dvr2rs) diff --git a/src/qs_energy.F b/src/qs_energy.F index 9ef6f0d88a..2c83157a0d 100644 --- a/src/qs_energy.F +++ b/src/qs_energy.F @@ -167,8 +167,9 @@ CONTAINS END IF IF (dft_control%tddfpt2_control%do_smearing) THEN - IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) & + IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) THEN CPABORT("Smearing occupation not associated.") + END IF CALL deallocate_fermi_params(dft_control%tddfpt2_control%smeared_occup) END IF IF (dft_control%qs_control%lrigpw) THEN diff --git a/src/qs_energy_init.F b/src/qs_energy_init.F index 7e82c28f28..48655f12db 100644 --- a/src/qs_energy_init.F +++ b/src/qs_energy_init.F @@ -283,12 +283,14 @@ CONTAINS CALL set_kpoint_info(kpoints, sab_nl_nosym=sab_nl_nosym) END IF IF (dft_control%qs_control%cdft) THEN - IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) & + IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) THEN dft_control%qs_control%cdft_control%need_pot = .TRUE. + END IF IF (ASSOCIATED(dft_control%qs_control%cdft_control%group)) THEN ! In case CDFT weight function was built beforehand (in mixed force_eval) - IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) & + IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) THEN dft_control%qs_control%cdft_control%need_pot = .FALSE. + END IF END IF END IF @@ -300,13 +302,13 @@ CONTAINS CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.FALSE.) CALL get_qs_env(qs_env=qs_env, dispersion_env=dispersion_env, energy=energy) CALL calculate_dispersion_pairpot(qs_env, dispersion_env, energy%dispersion, calc_forces) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL qs_env_update_s_mstruct(qs_env) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.FALSE.) ELSE diff --git a/src/qs_energy_window.F b/src/qs_energy_window.F index 6c41baed36..5e782d11cf 100644 --- a/src/qs_energy_window.F +++ b/src/qs_energy_window.F @@ -88,7 +88,7 @@ CONTAINS INTEGER :: handle, i, lanzcos_max_iter, last, nao, & nelectron_total, newton_schulz_order, & next, nwindows, print_unit, unit_nr - INTEGER, DIMENSION(:), POINTER :: stride(:) + INTEGER, DIMENSION(:), POINTER :: stride LOGICAL :: mpi_io, print_cube, restrict_range REAL(KIND=dp) :: bin_width, density_ewindow_total, density_total, energy_range, fermi_level, & filter_eps, frob_norm, lanzcos_threshold, lower_bound, occupation, upper_bound diff --git a/src/qs_environment.F b/src/qs_environment.F index bf7ae4766d..08194e09b6 100644 --- a/src/qs_environment.F +++ b/src/qs_environment.F @@ -417,14 +417,17 @@ CONTAINS do_tddfpt_unsupported_kpoints = tddfpt_kernel /= tddfpt_kernel_none IF (.NOT. do_tddfpt_unsupported_kpoints) THEN CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) & + IF (use_real_wfn) THEN CALL cp_abort(__LOCATION__, "K-point TDDFPT requires complex wavefunctions.") + END IF END IF CALL section_vals_val_get(tddfpt_section, "DO_BSE", l_val=do_bse) - IF (.NOT. do_bse) & + IF (.NOT. do_bse) THEN CALL section_vals_val_get(tddfpt_section, "DO_BSE_W_ONLY", l_val=do_bse) - IF (.NOT. do_bse) & + END IF + IF (.NOT. do_bse) THEN CALL section_vals_val_get(tddfpt_section, "DO_BSE_GW_ONLY", l_val=do_bse) + END IF END IF do_active_space = .FALSE. active_space_section => section_vals_get_subs_vals(qs_env%input, "DFT%ACTIVE_SPACE") @@ -471,10 +474,11 @@ CONTAINS l_val=do_wfc_low_scaling) CALL section_vals_val_get(qs_env%input, "DFT%XC%WF_CORRELATION%LOW_SCALING%DO_KPOINTS", & l_val=do_wfc_low_scaling_kpoints) - IF (.NOT. do_bse) & + IF (.NOT. do_bse) THEN CALL section_vals_val_get(qs_env%input, & "DFT%XC%WF_CORRELATION%RI_RPA%GW%BSE%_SECTION_PARAMETERS_", & l_val=do_bse) + END IF END IF CALL restrict_unsupported_atomic_kpoint_symmetry(kpoints, method_id, do_hfx, do_exx, do_gw, & do_tddfpt_unsupported_kpoints, & @@ -534,8 +538,9 @@ CONTAINS ! more kpoint stuff CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints, blacs_env=blacs_env) IF (do_kpoints) THEN - IF (dft_control%qs_control%do_ls_scf) & + IF (dft_control%qs_control%do_ls_scf) THEN CPABORT("DFT%KPOINTS are not implemented with QS/LS_SCF; use a real-space supercell instead.") + END IF CALL kpoint_env_initialize(kpoints, para_env, blacs_env, with_aux_fit=dft_control%do_admm) CALL kpoint_initialize_mos(kpoints, qs_env%mos) CALL get_qs_env(qs_env=qs_env, wf_history=wf_history) @@ -1189,7 +1194,7 @@ CONTAINS CALL ewald_pw_create(ewald_pw, ewald_env, cell, cell_ref, print_section=print_section) CALL set_qs_env(qs_env, ewald_env=ewald_env, ewald_pw=ewald_pw) END IF - ELSEIF (dft_control%qs_control%method_id == do_method_xtb) THEN + ELSE IF (dft_control%qs_control%method_id == do_method_xtb) THEN ! Read xTB parameter file xtb_control => dft_control%qs_control%xtb_control CALL get_qs_env(qs_env, nkind=nkind) @@ -1623,11 +1628,13 @@ CONTAINS IF (.NOT. dft_control%qs_control%do_ls_scf) THEN SELECT CASE (dft_control%qs_control%method_id) CASE (do_method_dftb) - IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & + IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN scf_control%max_scf = dft_control%qs_control%dftb_control%tblite_mixer_iterations + END IF CASE (do_method_xtb) - IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & + IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN scf_control%max_scf = dft_control%qs_control%xtb_control%tblite_mixer_iterations + END IF END SELECT END IF @@ -1873,7 +1880,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN + ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd3bj dispersion_env%eps_cn = dftb_control%epscn @@ -1889,7 +1896,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN + ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd2 dispersion_env%exp_pre = dftb_control%exp_pre @@ -2217,10 +2224,11 @@ CONTAINS n_mo(1) = n_mo(1) + scf_control%added_mos(1) IF (dft_control%nspins == 2) THEN - IF (n_mo(2) > n_mo(1)) & + IF (n_mo(2) > n_mo(1)) THEN CALL cp_warn(__LOCATION__, & "More beta than alpha MOs requested. "// & "The number of beta MOs will be reduced to the number alpha MOs.") + END IF n_mo(2) = MIN(n_mo(1), n_mo(2)) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2230,10 +2238,11 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) IF (do_kpoints .AND. dft_control%nspins == 2) THEN ! we need equal number of calculated states - IF (n_mo(2) /= n_mo(1)) & + IF (n_mo(2) /= n_mo(1)) THEN CALL cp_warn(__LOCATION__, & "Kpoints: Different number of MOs requested. "// & "The number of beta MOs will be set to the number alpha MOs.") + END IF n_mo(2) = n_mo(1) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2480,7 +2489,7 @@ CONTAINS "- Orbital basis functions: ", maxlgto, & "- Local part of the GTH pseudopotential: ", maxlppl, & "- Non-local part of the GTH pseudopotential: ", maxlppnl - ELSEIF (maxlppl > -1) THEN + ELSE IF (maxlppl > -1) THEN WRITE (UNIT=output_unit, FMT="(/,T3,A,(T30,A,T75,I6))") & "Maximum angular momentum of the", & "- Orbital basis functions: ", maxlgto, & diff --git a/src/qs_environment_types.F b/src/qs_environment_types.F index ac6c8fa2a6..ac95bc2f66 100644 --- a/src/qs_environment_types.F +++ b/src/qs_environment_types.F @@ -163,6 +163,8 @@ MODULE qs_environment_types USE wannier_states_types, ONLY: wannier_centres_type USE xas_env_types, ONLY: xas_env_release,& xas_environment_type + USE xc_gauxc_cache, ONLY: cp_gauxc_cache_type,& + gauxc_cache_release #include "./base/base_uses.f90" IMPLICIT NONE @@ -322,6 +324,7 @@ MODULE qs_environment_types TYPE(mo_set_type), DIMENSION(:), POINTER :: mos_last_converged => NULL() ! tblite TYPE(tblite_type), POINTER :: tb_tblite => Null() + TYPE(cp_gauxc_cache_type), POINTER :: gauxc_cache => NULL() END TYPE qs_environment_type CONTAINS @@ -741,20 +744,27 @@ CONTAINS ! Resp charges IF (PRESENT(rhs)) rhs => qs_env%rhs - IF (PRESENT(local_rho_set)) & + IF (PRESENT(local_rho_set)) THEN local_rho_set => qs_env%local_rho_set - IF (PRESENT(rho_atom_set)) & + END IF + IF (PRESENT(rho_atom_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rho_atom_set=rho_atom_set) - IF (PRESENT(rho0_atom_set)) & + END IF + IF (PRESENT(rho0_atom_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_atom_set=rho0_atom_set) - IF (PRESENT(rho0_mpole)) & + END IF + IF (PRESENT(rho0_mpole)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_mpole) - IF (PRESENT(rhoz_set)) & + END IF + IF (PRESENT(rhoz_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rhoz_set=rhoz_set) - IF (PRESENT(rhoz_cneo_set)) & + END IF + IF (PRESENT(rhoz_cneo_set)) THEN CALL get_local_rho(qs_env%local_rho_set, rhoz_cneo_set=rhoz_cneo_set) - IF (PRESENT(ecoul_1c)) & + END IF + IF (PRESENT(ecoul_1c)) THEN CALL get_hartree_local(qs_env%hartree_local, ecoul_1c=ecoul_1c) + END IF IF (PRESENT(rho0_s_rs)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_m) IF (ASSOCIATED(rho0_m)) THEN @@ -1001,6 +1011,7 @@ CONTAINS IF (.NOT. ASSOCIATED(qs_env%molecular_scf_guess_env)) ALLOCATE (qs_env%molecular_scf_guess_env) NULLIFY (qs_env%tb_tblite) + NULLIFY (qs_env%gauxc_cache) END SUBROUTINE init_qs_env @@ -1485,10 +1496,12 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) & + IF (ASSOCIATED(qs_env%gradient_history)) THEN DEALLOCATE (qs_env%gradient_history) - IF (ASSOCIATED(qs_env%variable_history)) & + END IF + IF (ASSOCIATED(qs_env%variable_history)) THEN DEALLOCATE (qs_env%variable_history) + END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) @@ -1680,6 +1693,11 @@ 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 ! ************************************************************************************************** @@ -1717,10 +1735,12 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) & + IF (ASSOCIATED(qs_env%gradient_history)) THEN DEALLOCATE (qs_env%gradient_history) - IF (ASSOCIATED(qs_env%variable_history)) & + END IF + IF (ASSOCIATED(qs_env%variable_history)) THEN DEALLOCATE (qs_env%variable_history) + END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) @@ -1904,6 +1924,11 @@ 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 ec813c6695..e77b4b3655 100644 --- a/src/qs_external_potential.F +++ b/src/qs_external_potential.F @@ -91,7 +91,7 @@ CONTAINS qs_env%sim_step, qs_env%sim_time, & scaling_factor) dft_control%eval_external_potential = .FALSE. - ELSEIF (dft_control%expot_control%read_from_cube) THEN + ELSE IF (dft_control%expot_control%read_from_cube) THEN scaling_factor = dft_control%expot_control%scaling_factor CALL cp_cube_to_pw(v_ee, 'pot.cube', scaling_factor) dft_control%eval_external_potential = .FALSE. diff --git a/src/qs_fb_env_types.F b/src/qs_fb_env_types.F index 3b580c1ac1..0b0173c14b 100644 --- a/src/qs_fb_env_types.F +++ b/src/qs_fb_env_types.F @@ -266,24 +266,33 @@ CONTAINS CPASSERT(ASSOCIATED(fb_env%obj)) CPASSERT(fb_env%obj%ref_count > 0) - IF (PRESENT(rcut)) & + IF (PRESENT(rcut)) THEN rcut => fb_env%obj%rcut - IF (PRESENT(filter_temperature)) & + END IF + IF (PRESENT(filter_temperature)) THEN filter_temperature = fb_env%obj%filter_temperature - IF (PRESENT(auto_cutoff_scale)) & + END IF + IF (PRESENT(auto_cutoff_scale)) THEN auto_cutoff_scale = fb_env%obj%auto_cutoff_scale - IF (PRESENT(eps_default)) & + END IF + IF (PRESENT(eps_default)) THEN eps_default = fb_env%obj%eps_default - IF (PRESENT(atomic_halos)) & + END IF + IF (PRESENT(atomic_halos)) THEN CALL fb_atomic_halo_list_associate(atomic_halos, fb_env%obj%atomic_halos) - IF (PRESENT(trial_fns)) & + END IF + IF (PRESENT(trial_fns)) THEN CALL fb_trial_fns_associate(trial_fns, fb_env%obj%trial_fns) - IF (PRESENT(collective_com)) & + END IF + IF (PRESENT(collective_com)) THEN collective_com = fb_env%obj%collective_com - IF (PRESENT(local_atoms)) & + END IF + IF (PRESENT(local_atoms)) THEN local_atoms => fb_env%obj%local_atoms - IF (PRESENT(nlocal_atoms)) & + END IF + IF (PRESENT(nlocal_atoms)) THEN nlocal_atoms = fb_env%obj%nlocal_atoms + END IF END SUBROUTINE fb_env_get ! ********************************************************************** @@ -329,32 +338,38 @@ CONTAINS END IF fb_env%obj%rcut => rcut END IF - IF (PRESENT(filter_temperature)) & + IF (PRESENT(filter_temperature)) THEN fb_env%obj%filter_temperature = filter_temperature - IF (PRESENT(auto_cutoff_scale)) & + END IF + IF (PRESENT(auto_cutoff_scale)) THEN fb_env%obj%auto_cutoff_scale = auto_cutoff_scale - IF (PRESENT(eps_default)) & + END IF + IF (PRESENT(eps_default)) THEN fb_env%obj%eps_default = eps_default + END IF IF (PRESENT(atomic_halos)) THEN CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos) CALL fb_atomic_halo_list_associate(fb_env%obj%atomic_halos, atomic_halos) END IF IF (PRESENT(trial_fns)) THEN - IF (fb_trial_fns_has_data(trial_fns)) & + IF (fb_trial_fns_has_data(trial_fns)) THEN CALL fb_trial_fns_retain(trial_fns) + END IF CALL fb_trial_fns_release(fb_env%obj%trial_fns) CALL fb_trial_fns_associate(fb_env%obj%trial_fns, trial_fns) END IF - IF (PRESENT(collective_com)) & + IF (PRESENT(collective_com)) THEN fb_env%obj%collective_com = collective_com + END IF IF (PRESENT(local_atoms)) THEN IF (ASSOCIATED(fb_env%obj%local_atoms)) THEN DEALLOCATE (fb_env%obj%local_atoms) END IF fb_env%obj%local_atoms => local_atoms END IF - IF (PRESENT(nlocal_atoms)) & + IF (PRESENT(nlocal_atoms)) THEN fb_env%obj%nlocal_atoms = nlocal_atoms + END IF END SUBROUTINE fb_env_set END MODULE qs_fb_env_types diff --git a/src/qs_fb_filter_matrix_methods.F b/src/qs_fb_filter_matrix_methods.F index 1be7bcdc2a..5b94b8fdc0 100644 --- a/src/qs_fb_filter_matrix_methods.F +++ b/src/qs_fb_filter_matrix_methods.F @@ -480,7 +480,7 @@ CONTAINS INTEGER :: handle, handle_mpi, iatom_global, iatom_in_halo, ind, ipair, ipe, itrial, & jatom_global, jatom_in_halo, jkind, natoms_global, natoms_in_halo, ncols_atmatrix, & - ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode, stat + ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs_recv, pairs_send INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data, ind_in_halo, & @@ -583,9 +583,7 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_H_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -603,9 +601,7 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_S_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -797,7 +793,7 @@ CONTAINS INTEGER :: handle, iatom_global, iatom_in_halo, itrial, jatom_global, jatom_in_halo, jkind, & natoms_global, natoms_in_halo, ncols_atmatrix, ncols_blk, ncols_blk_max, nrows_atmatrix, & - nrows_blk, nrows_blk_max, stat + nrows_blk, nrows_blk_max INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data INTEGER, DIMENSION(:), POINTER :: halo_atoms, ntfns, row_block_size_data @@ -841,9 +837,7 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_H_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -859,9 +853,7 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1), & - STAT=stat) - CPASSERT(stat == 0) + atomic_S_blk_col_start(natoms_in_halo + 1)) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -906,9 +898,6 @@ CONTAINS nrows_blk = row_block_size_data(iatom_global) ncols_blk = ntfns(jkind) - ! ALLOCATE(mat_blk(nrows_blk,ncols_blk) STAT=stat) - ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) - ! do it column-wise one trial function at a time DO itrial = 1, ntfns(jkind) CALL dgemv("N", & diff --git a/src/qs_force.F b/src/qs_force.F index 3bf365e4c1..ab1f8d5ece 100644 --- a/src/qs_force.F +++ b/src/qs_force.F @@ -227,8 +227,9 @@ CONTAINS CALL calc_c_mat_force(qs_env) IF (dft_control%do_admm) CALL rt_admm_force(qs_env) - IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) & + IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) THEN CALL velocity_gauge_nl_force(qs_env, particle_set) + END IF END IF ! from an eventual Mulliken restraint IF (dft_control%qs_control%mulliken_restraint) THEN @@ -286,18 +287,18 @@ CONTAINS CALL build_se_core_matrix(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.TRUE.) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.TRUE.) ELSE CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) END IF - ELSEIF (perform_ec) THEN + ELSE IF (perform_ec) THEN ! Calculates core and grid based forces CALL energy_correction(qs_env, ec_init=.FALSE., calculate_forces=.TRUE.) ELSE @@ -305,10 +306,12 @@ CONTAINS CALL build_core_hamiltonian_matrix(qs_env=qs_env, calculate_forces=.TRUE.) ! The above line reset the core H, which should be re-updated in case a TD field is applied: IF (qs_env%run_rtp) THEN - IF (dft_control%apply_efield_field) & + IF (dft_control%apply_efield_field) THEN CALL efield_potential_lengh_gauge(qs_env) - IF (dft_control%rtp_control%velocity_gauge) & + END IF + IF (dft_control%rtp_control%velocity_gauge) THEN CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) + END IF END IF CALL calculate_ecore_self(qs_env) @@ -368,9 +371,9 @@ CONTAINS t3=dummy_real) END IF END IF - ELSEIF (perform_ec) THEN + ELSE IF (perform_ec) THEN ! energy correction forces postponed - ELSEIF (qs_env%harris_method) THEN + ELSE IF (qs_env%harris_method) THEN ! Harris method forces already done in harris_energy_correction ELSE ! Compute grid-based forces diff --git a/src/qs_fxc.F b/src/qs_fxc.F index 6fe283637e..1380dc5c1d 100644 --- a/src/qs_fxc.F +++ b/src/qs_fxc.F @@ -371,8 +371,9 @@ CONTAINS END DO ! Create fields for mGGA functionals. This implementation is not ready yet! IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) & + IF (.NOT. ASSOCIATED(tau1_r)) THEN CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") + END IF ALLOCATE (fxc_tau(spindim), gxc_tau(nspins)) DO ispin = 1, spindim CALL pw_pool%create_pw(fxc_tau(ispin)) diff --git a/src/qs_gapw_densities.F b/src/qs_gapw_densities.F index 567c7e99bb..2aaa407afc 100644 --- a/src/qs_gapw_densities.F +++ b/src/qs_gapw_densities.F @@ -158,10 +158,11 @@ CONTAINS END IF !Calculate rho0_h and rho0_s on the radial grids centered on the atomic position - IF (my_do_rho0) & + IF (my_do_rho0) THEN CALL calculate_rho0_atom(gapw_control, rho_atom_set, rhoz_cneo_set, rho0_atom_set, & rho0_mpole, atom_list, natom, ikind, my_kind_set(ikind), & rho0_h_tot) + END IF END DO !Do not mess with charges if using a non-default kind_set diff --git a/src/qs_gspace_mixing.F b/src/qs_gspace_mixing.F index eb64b2fbfa..e88926315d 100644 --- a/src/qs_gspace_mixing.F +++ b/src/qs_gspace_mixing.F @@ -164,25 +164,25 @@ CONTAINS CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSEIF (mixing_method == gspace_mixing_nr) THEN + ELSE IF (mixing_method == gspace_mixing_nr) THEN CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSEIF (mixing_method == pulay_mixing_nr) THEN + ELSE IF (mixing_method == pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Pulay" - ELSEIF (mixing_method == new_pulay_mixing_nr) THEN + ELSE IF (mixing_method == new_pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "NPulay" - ELSEIF (mixing_method == broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr) THEN CALL cite_reference(Broyden1965) CALL broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Broy." - ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN + ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN CALL cite_reference(Johnson1988) CALL modified_broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "MBroy" - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN CPASSERT(.NOT. gapw) CALL multisecant_mixing(mixing_store, rho, para_env) mixing_store%iter_method = "MSec." @@ -1446,7 +1446,7 @@ CONTAINS DO jb = 1, nb + 1 IF (jb < ib) THEN kb = jb - ELSEIF (jb > ib) THEN + ELSE IF (jb > ib) THEN kb = jb - 1 ELSE CYCLE @@ -1564,7 +1564,7 @@ CONTAINS AIMAG(pgn(ig))*AIMAG(pgn(ig)) END DO CALL para_env%sum(pgn_norm) - ELSEIF (use_zgemm_rev) THEN + ELSE IF (use_zgemm_rev) THEN CALL zgemv("N", nb, ng_global, cone, a_matrix(1, 1), & nb, gn_global(1), 1, czero, tmp_vec(1), 1) diff --git a/src/qs_initial_guess.F b/src/qs_initial_guess.F index 5c5acca6c7..0df0b262a5 100644 --- a/src/qs_initial_guess.F +++ b/src/qs_initial_guess.F @@ -330,8 +330,9 @@ CONTAINS IF (j /= 0) THEN filename = TRIM(file_name)//".bak-"//ADJUSTL(cp_to_string(j)) END IF - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN INQUIRE (FILE=filename, exist=exist) + END IF CALL para_env%bcast(exist) IF ((.NOT. exist) .AND. (i < not_read)) THEN not_read = i @@ -417,7 +418,7 @@ CONTAINS IF (has_unit_metric) THEN CALL make_basis_simple(mo_coeff, nmo) - ELSEIF (dft_control%smear) THEN + ELSE IF (dft_control%smear) THEN CALL make_basis_lowdin(vmatrix=mo_coeff, ncol=nmo, & matrix_s=s_sparse(1)%matrix) ELSE @@ -937,11 +938,11 @@ CONTAINS WRITE (ounit, *) 'wrong', i, SUM(buff**2) END IF END IF - length = SQRT(DOT_PRODUCT(buff(:, 1), buff(:, 1))) + length = NORM2(buff(:, 1)) buff(:, :) = buff(:, :)/length DO j = i + 1, nmo CALL cp_fm_get_submatrix(mo_coeff, buff2, 1, j, nao, 1) - length = SQRT(DOT_PRODUCT(buff2(:, 1), buff2(:, 1))) + length = NORM2(buff2(:, 1)) buff2(:, :) = buff2(:, :)/length IF (ABS(DOT_PRODUCT(buff(:, 1), buff2(:, 1)) - 1.0_dp) < 1E-10_dp) THEN IF (ounit > 0) THEN @@ -1289,10 +1290,10 @@ CONTAINS lmax=maxll, occupation=edftb) maxll = MIN(maxll, maxl) econf(0:maxl) = edftb(0:maxl) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, z=z, natorb=nsgf, nao=naox, lao=laox, occupation=occupation) - ELSEIF (has_pot) THEN + ELSE IF (has_pot) THEN CALL get_atomic_kind(atomic_kind_set(ikind), z=z) CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff) maxll = MIN(SIZE(elec_conf) - 1, maxl) @@ -1334,7 +1335,7 @@ CONTAINS END SELECT END DO END DO - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN DO iatom = 1, natom atom_a = atom_list(iatom) isgfa = first_sgf(atom_a) @@ -1351,7 +1352,7 @@ CONTAINS END DO END IF END DO - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN yy = REAL(dft_control%charge, KIND=dp)/REAL(nao, KIND=dp) DO iatom = 1, natom atom_a = atom_list(iatom) diff --git a/src/qs_integrate_potential_product.F b/src/qs_integrate_potential_product.F index decbe53525..e99302334e 100644 --- a/src/qs_integrate_potential_product.F +++ b/src/qs_integrate_potential_product.F @@ -417,54 +417,58 @@ CONTAINS END IF IF (iatom <= jatom) THEN - IF (iatom == lambda) & + IF (iatom == lambda) THEN CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) - IF (jatom == lambda) & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) + END IF + IF (jatom == lambda) THEN CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) + END IF ELSE rab_inv = -rab - IF (iatom == lambda) & + IF (iatom == lambda) THEN CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) - IF (jatom == lambda) & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) + END IF + IF (jatom == lambda) THEN CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) + END IF END IF new_set_pair_coming = .FALSE. diff --git a/src/qs_kind_types.F b/src/qs_kind_types.F index 8928bc4553..3367d1ec57 100644 --- a/src/qs_kind_types.F +++ b/src/qs_kind_types.F @@ -1008,7 +1008,7 @@ CONTAINS IF (PRESENT(maxlppl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nexp_ppl=n) maxlppl = MAX(maxlppl, 2*(n - 1)) - ELSEIF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSE IF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nrloc=nrloc, ecp_semi_local=ecp_semi_local) n = MAXVAL(nrloc) - 2 maxlppl = MAX(maxlppl, 2*(n - 1)) @@ -1023,7 +1023,7 @@ CONTAINS IF (PRESENT(maxlppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, lprj_ppnl_max=imax) maxlppnl = MAX(maxlppnl, imax) - ELSEIF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSE IF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, lmax=imax) maxlppnl = MAX(maxlppnl, imax) END IF @@ -1046,7 +1046,7 @@ CONTAINS IF (PRESENT(maxppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) - ELSEIF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSE IF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) END IF @@ -1327,7 +1327,7 @@ CONTAINS IF (ASSOCIATED(qs_kind%gth_potential)) THEN CALL init_potential(qs_kind%gth_potential) - ELSEIF (ASSOCIATED(qs_kind%sgp_potential)) THEN + ELSE IF (ASSOCIATED(qs_kind%sgp_potential)) THEN CALL init_potential(qs_kind%sgp_potential) END IF @@ -1790,12 +1790,12 @@ CONTAINS basis_set_type(i) = "ORB" basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(1) - ELSEIF (SIZE(tmpstringlist) == 2) THEN + ELSE IF (SIZE(tmpstringlist) == 2) THEN ! default is GTO basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(2) - ELSEIF (SIZE(tmpstringlist) == 3) THEN + ELSE IF (SIZE(tmpstringlist) == 3) THEN basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = tmpstringlist(2) basis_set_name(i) = tmpstringlist(3) @@ -1876,7 +1876,7 @@ CONTAINS potential_type = potential_name END IF END IF - ELSEIF (SIZE(tmpstringlist) == 2) THEN + ELSE IF (SIZE(tmpstringlist) == 2) THEN potential_type = tmpstringlist(1) potential_name = tmpstringlist(2) ELSE @@ -1930,19 +1930,22 @@ CONTAINS CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RHO0_EXP_RADIUS", r_val=qs_kind%hard0_radius) END IF - IF (qs_kind%hard_radius < qs_kind%hard0_radius) & + IF (qs_kind%hard_radius < qs_kind%hard0_radius) THEN CPABORT("rc0 should be <= rc") + END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="MAX_RAD_LOCAL", r_val=qs_kind%max_rad_local) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="LEBEDEV_GRID", i_val=qs_kind%ngrid_ang) - IF (qs_kind%ngrid_ang <= 0) & + IF (qs_kind%ngrid_ang <= 0) THEN CPABORT("# point lebedev grid < 0") + END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RADIAL_GRID", i_val=qs_kind%ngrid_rad) - IF (qs_kind%ngrid_rad <= 0) & + IF (qs_kind%ngrid_rad <= 0) THEN CPABORT("# point radial grid < 0") + END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="GPW_TYPE", l_val=qs_kind%gpw_type_forced) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & @@ -2146,21 +2149,25 @@ CONTAINS keyword_name="ORBITALS", & i_vals=orbitals) norbitals = SIZE(orbitals) - IF (norbitals <= 0 .OR. norbitals > 2*l + 1) & + IF (norbitals <= 0 .OR. norbitals > 2*l + 1) THEN CALL cp_abort(__LOCATION__, "DFT+U| Invalid number of ORBITALS specified: "// & "1 to 2*L+1 integer numbers are expected") + END IF ALLOCATE (qs_kind%dft_plus_u%orbitals(norbitals)) qs_kind%dft_plus_u%orbitals(:) = orbitals(:) NULLIFY (orbitals) DO m = 1, norbitals - IF (qs_kind%dft_plus_u%orbitals(m) > l) & + IF (qs_kind%dft_plus_u%orbitals(m) > l) THEN CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m > l") - IF (qs_kind%dft_plus_u%orbitals(m) < -l) & + END IF + IF (qs_kind%dft_plus_u%orbitals(m) < -l) THEN CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m < -l") + END IF DO j = 1, norbitals IF (j /= m) THEN - IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) & + IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) THEN CPABORT("DFT+U| An orbital magnetic quantum number was specified twice") + END IF END IF END DO END DO @@ -2254,16 +2261,18 @@ CONTAINS qs_kind%se_parameter%zeff = qs_kind%se_parameter%zeff - zeff_correction check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF CASE (do_method_dftb) ! Allocate all_potential @@ -2287,16 +2296,18 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF CASE (do_method_xtb) ! Allocate all_potential @@ -2320,16 +2331,18 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) & + IF (check) THEN CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") + END IF CASE (do_method_pw) ! PW DFT @@ -2645,8 +2658,9 @@ CONTAINS CALL atom_release_upf(upfpot) CALL atom_sgp_release(sgppot) CASE ("CNEO") - IF (zeff_correction /= 0.0_dp) & + IF (zeff_correction /= 0.0_dp) THEN CPABORT("CORE_CORRECTION is not compatible with CNEO") + END IF CALL allocate_cneo_potential(qs_kind%cneo_potential) CALL set_cneo_potential(qs_kind%cneo_potential, z=z) mass = 0.0_dp @@ -2773,14 +2787,17 @@ CONTAINS CALL get_qs_kind(qs_kind, name=name, gth_potential=gth_potential, basis_set=basis_set) npp = -1; nbs = -1 - IF (ASSOCIATED(gth_potential)) & + IF (ASSOCIATED(gth_potential)) THEN npp = parse_valence_electrons(gth_potential%aliases) - IF (ASSOCIATED(basis_set)) & + END IF + IF (ASSOCIATED(basis_set)) THEN nbs = parse_valence_electrons(basis_set%aliases) + END IF - IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) & + IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) THEN CALL cp_abort(__LOCATION__, "Basis-set and pseudo-potential of atomic kind '"//TRIM(name)//"'"// & " were optimized for different valence electron numbers.") + END IF END SUBROUTINE check_potential_basis_compatibility @@ -3986,7 +4003,7 @@ CONTAINS IF (ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nlcc_present=nlcc_present) nlcc = nlcc .OR. nlcc_present - ELSEIF (ASSOCIATED(sgp_potential)) THEN + ELSE IF (ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, has_nlcc=nlcc_present) nlcc = nlcc .OR. nlcc_present END IF diff --git a/src/qs_kinetic.F b/src/qs_kinetic.F index b743911176..e9926351ad 100644 --- a/src/qs_kinetic.F +++ b/src/qs_kinetic.F @@ -220,7 +220,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSEIF (PRESENT(matrixkp_t)) THEN + ELSE IF (PRESENT(matrixkp_t)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -279,7 +279,7 @@ CONTAINS ELSE IF (PRESENT(matrix_p)) THEN matp => matrix_p - ELSEIF (PRESENT(matrixkp_p)) THEN + ELSE IF (PRESENT(matrixkp_p)) THEN matp => matrixkp_p(1, 1)%matrix ELSE CPABORT("Missing density matrix") diff --git a/src/qs_kpp1_env_methods.F b/src/qs_kpp1_env_methods.F index 2ff3fe8229..504224f6c8 100644 --- a/src/qs_kpp1_env_methods.F +++ b/src/qs_kpp1_env_methods.F @@ -200,8 +200,9 @@ CONTAINS poisson_env=poisson_env) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) & + IF (gapw .OR. gapw_xc) THEN CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) + END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -454,7 +455,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=my_calc_forces, tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) diff --git a/src/qs_ks_apply_restraints.F b/src/qs_ks_apply_restraints.F index d2d9c792c7..79524ca9f1 100644 --- a/src/qs_ks_apply_restraints.F +++ b/src/qs_ks_apply_restraints.F @@ -83,22 +83,25 @@ CONTAINS CALL auxbas_pw_pool%create_pw(cdft_control%group(igroup)%weight) ! Sanity check IF (cdft_control%group(igroup)%constraint_type /= cdft_charge_constraint & - .AND. dft_control%nspins == 1) & + .AND. dft_control%nspins == 1) THEN CALL cp_abort(__LOCATION__, & "Spin constraints require a spin polarized calculation.") + END IF END DO IF (cdft_control%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control%charge)) & + IF (.NOT. ASSOCIATED(cdft_control%charge)) THEN ALLOCATE (cdft_control%charge(cdft_control%natoms)) + END IF DO iatom = 1, cdft_control%natoms CALL auxbas_pw_pool%create_pw(cdft_control%charge(iatom)) END DO END IF ! Another sanity check CALL get_qs_env(qs_env, natom=natom) - IF (natom < cdft_control%natoms) & + IF (natom < cdft_control%natoms) THEN CALL cp_abort(__LOCATION__, & "The number of constraint atoms exceeds the total number of atoms.") + END IF ELSE DO igroup = 1, SIZE(cdft_control%group) inv_vol = 1.0_dp/cdft_control%group(igroup)%weight%pw_grid%dvol diff --git a/src/qs_ks_atom.F b/src/qs_ks_atom.F index fbf62a1fe3..891c94351b 100644 --- a/src/qs_ks_atom.F +++ b/src/qs_ks_atom.F @@ -649,14 +649,14 @@ CONTAINS 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (dista) THEN + ELSE IF (dista) THEN CALL DGEMM('N', 'T', nsp, ncontb, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_b(:, :, 1), SIZE(C_hh_b, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, ncontb, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & C_ss_b(:, :, 1), SIZE(C_ss_b, 1), 1.0_dp, coc, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & coc, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (distb) THEN + ELSE IF (distb) THEN CALL DGEMM('N', 'N', nconta, nsp, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, nconta) CALL DGEMM('N', 'N', nconta, nsp, nsp, -factor, C_ss_a(:, :, 1), SIZE(C_ss_a, 1), & @@ -692,14 +692,14 @@ CONTAINS CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, coc, nsp, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', ncontb, nconta, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (dista) THEN + ELSE IF (dista) THEN CALL DGEMM('N', 'N', ncontb, nsp, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, ncontb) CALL DGEMM('N', 'N', ncontb, nsp, nsp, -factor, C_ss_b(:, :, 1), SIZE(C_ss_b, 1), & int_soft, SIZE(int_soft, 1), 1.0_dp, coc, ncontb) CALL DGEMM('N', 'T', ncontb, nconta, nsp, 1.0_dp, coc, ncontb, & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSEIF (distb) THEN + ELSE IF (distb) THEN CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, nconta, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index 652655dae1..a2cf906d65 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -143,6 +143,7 @@ MODULE qs_ks_methods get_gauxc_section,& xc_section_uses_native_skala_grid USE smeagol_interface, ONLY: smeagol_shift_v_hartree + USE string_utilities, ONLY: uppercase USE surface_dipole, ONLY: calc_dipsurf_potential USE tblite_ks_matrix, ONLY: build_tblite_ks_matrix USE virial_types, ONLY: virial_type @@ -199,14 +200,15 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_build_kohn_sham_matrix' - CHARACTER(len=default_string_length) :: name + CHARACTER(len=default_string_length) :: gauxc_model_name, name INTEGER :: ace_rebuild_frequency, atom_a, handle, & iatom, ikind, img, ispin, natom, & nimages, nspins, output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of LOGICAL :: ace_active, do_adiabatic_rescaling, do_ddapc, do_hfx, do_kpoints, do_ppl, dokp, & - gapw, gapw_xc, just_energy_xc, lrigpw, my_print, native_grid_diagnostics, & - native_grid_use_cuda, native_skala_restore_exc, rigpw, use_gauxc_matrix, use_virial + gapw, gapw_xc, gauxc_model_none, just_energy_xc, lrigpw, my_print, & + native_grid_diagnostics, native_grid_use_cuda, native_skala_restore_exc, rigpw, & + use_gauxc_matrix, use_virial LOGICAL, SAVE :: native_grid_cpu_kpoints_warned = .FALSE. REAL(KIND=dp) :: ecore_ppl, edisp, ee_ener, ekin_mol, & mulliken_order_p, & @@ -575,7 +577,7 @@ CONTAINS CALL admm_mo_calc_rho_aux(qs_env) END IF END IF - ELSEIF (dft_control%do_admm_dm) THEN + ELSE IF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF @@ -922,12 +924,19 @@ CONTAINS NULLIFY (rho1) IF (dft_control%use_gauxc .AND. (gapw .OR. gapw_xc) .AND. & .NOT. xc_section_uses_native_skala_grid(xc_section)) THEN - ! Molecular GauXC evaluates the XC term outside xc_derivatives. - ! The accurate-XCINT force correction would otherwise try to - ! evaluate the GAUXC section through CP2K's local functional path. - ! Native-grid SKALA can provide this correction through the - ! CP2K grid path and needs it for GAPW_XC force consistency. - CONTINUE + gauxc_model_none = .FALSE. + gauxc_section => get_gauxc_section(xc_section) + IF (ASSOCIATED(gauxc_section)) THEN + CALL section_vals_val_get(gauxc_section, "MODEL", c_val=gauxc_model_name) + gauxc_model_name = ADJUSTL(gauxc_model_name) + CALL uppercase(gauxc_model_name) + gauxc_model_none = (TRIM(gauxc_model_name) == "" .OR. & + TRIM(gauxc_model_name) == "NONE") + END IF + IF (gauxc_model_none .AND. & + (gapw_xc .OR. gauxc_gapw_has_paw_pseudopotentials(qs_kind_set))) THEN + CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) + END IF ELSE CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) END IF @@ -1084,7 +1093,7 @@ CONTAINS ELSE CALL admm_mo_merge_ks_matrix(qs_env) END IF - ELSEIF (dft_control%do_admm_dm) THEN + ELSE IF (dft_control%do_admm_dm) THEN CALL admm_dm_merge_ks_matrix(qs_env) END IF @@ -1162,8 +1171,9 @@ CONTAINS IF (native_skala_restore_exc) energy%total = native_skala_total_scf - IF (abnormal_value(energy%total)) & + IF (abnormal_value(energy%total)) THEN CPABORT("KS energy is an abnormal value (NaN/Inf).") + END IF ! Print detailed energy IF (my_print) THEN @@ -1439,8 +1449,9 @@ CONTAINS END IF ! kinetic energy - IF (ASSOCIATED(matrixkp_t)) & + IF (ASSOCIATED(matrixkp_t)) THEN CALL calculate_ptrace(matrixkp_t, rho_ao_kp, energy%kinetic, dft_control%nspins) + END IF CALL timestop(handle) END SUBROUTINE evaluate_core_matrix_traces @@ -1473,12 +1484,12 @@ CONTAINS calculate_forces=calculate_forces, & just_energy=just_energy) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL build_dftb_ks_matrix(qs_env, & calculate_forces=calculate_forces, & just_energy=just_energy) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, & calculate_forces=calculate_forces, & diff --git a/src/qs_ks_types.F b/src/qs_ks_types.F index 73e953562b..0f6c029414 100644 --- a/src/qs_ks_types.F +++ b/src/qs_ks_types.F @@ -621,8 +621,9 @@ CONTAINS IF (PRESENT(potential_changed)) ks_env%potential_changed = potential_changed IF (PRESENT(forces_up_to_date)) ks_env%forces_up_to_date = forces_up_to_date IF (PRESENT(complex_ks)) ks_env%complex_ks = complex_ks - IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) & + IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) THEN ks_env%forces_up_to_date = .FALSE. + END IF IF (PRESENT(exc_accint)) ks_env%exc_accint = exc_accint IF (PRESENT(v_hartree_rspace)) ks_env%v_hartree_rspace => v_hartree_rspace @@ -763,10 +764,12 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) & + IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & + END IF + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) + END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -775,12 +778,15 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%distribution_2d)) & + IF (ASSOCIATED(ks_env%distribution_2d)) THEN CALL distribution_2d_release(ks_env%distribution_2d) - IF (ASSOCIATED(ks_env%task_list)) & + END IF + IF (ASSOCIATED(ks_env%task_list)) THEN CALL deallocate_task_list(ks_env%task_list) - IF (ASSOCIATED(ks_env%task_list_soft)) & + END IF + IF (ASSOCIATED(ks_env%task_list_soft)) THEN CALL deallocate_task_list(ks_env%task_list_soft) + END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() @@ -869,10 +875,12 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) & + IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & + END IF + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) + END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -881,10 +889,12 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%task_list)) & + IF (ASSOCIATED(ks_env%task_list)) THEN CALL deallocate_task_list(ks_env%task_list) - IF (ASSOCIATED(ks_env%task_list_soft)) & + END IF + IF (ASSOCIATED(ks_env%task_list_soft)) THEN CALL deallocate_task_list(ks_env%task_list_soft) + END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() diff --git a/src/qs_ks_utils.F b/src/qs_ks_utils.F index 98755af9bf..aa83ab16a1 100644 --- a/src/qs_ks_utils.F +++ b/src/qs_ks_utils.F @@ -789,8 +789,9 @@ CONTAINS IF (dft_control%sic_method_id == sic_none) RETURN IF (dft_control%sic_method_id == sic_eo) RETURN - IF (dft_control%qs_control%gapw) & + IF (dft_control%qs_control%gapw) THEN CPABORT("sic and GAPW not yet compatible") + END IF ! OK, right now we like two spins to do sic, could be relaxed for AD CPASSERT(dft_control%nspins == 2) @@ -1131,18 +1132,22 @@ CONTAINS "Integral of the (density * v_xc): ", energy%exc END IF - IF (energy%e_hartree /= 0.0_dp) & + IF (energy%e_hartree /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Coulomb (electron-electron) energy: ", energy%e_hartree - IF (energy%dispersion /= 0.0_dp) & + "Coulomb (electron-electron) energy: ", energy%e_hartree + END IF + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Dispersion energy: ", energy%dispersion - IF (energy%efield /= 0.0_dp) & + "Dispersion energy: ", energy%dispersion + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Electric field interaction energy: ", energy%efield - IF (energy%gcp /= 0.0_dp) & + "Electric field interaction energy: ", energy%efield + END IF + IF (energy%gcp /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "gCP energy: ", energy%gcp + "gCP energy: ", energy%gcp + END IF IF (dft_control%qs_control%gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T61,F20.10))") & "GAPW| Exc from hard and soft atomic rho1: ", energy%exc1 + energy%exc1_aux_fit, & @@ -1530,7 +1535,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1634,7 +1639,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1672,7 +1677,7 @@ CONTAINS IF (calculate_forces) THEN CALL calculate_lri_forces(lri_env, lri_density, qs_env, rho_ao_kp, atomic_kind_set) END IF - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN CALL get_qs_env(qs_env, matrix_s=smat) DO ispin = 1, nspins CALL calculate_ri_ks_matrix(lri_env, lri_v_int, ks_matrix(ispin, 1)%matrix, & diff --git a/src/qs_kubo_transport.F b/src/qs_kubo_transport.F index 8ec3525d01..68825aecb2 100644 --- a/src/qs_kubo_transport.F +++ b/src/qs_kubo_transport.F @@ -193,7 +193,7 @@ CONTAINS END IF IF (ALL(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "CP2K canonical MOs" - ELSEIF (ANY(reused_mos)) THEN + ELSE IF (ANY(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "mixed canonical/internal" ELSE WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "internal diagonalization" @@ -708,7 +708,7 @@ CONTAINS x = (eig - mu)/kT IF (x > 80.0_dp) THEN occ = 0.0_dp - ELSEIF (x < -80.0_dp) THEN + ELSE IF (x < -80.0_dp) THEN occ = maxocc ELSE occ = maxocc/(1.0_dp + EXP(x)) diff --git a/src/qs_linres_atom_current.F b/src/qs_linres_atom_current.F index 43eee3ff8c..a258a30e77 100644 --- a/src/qs_linres_atom_current.F +++ b/src/qs_linres_atom_current.F @@ -266,16 +266,11 @@ CONTAINS NULLIFY (basis_1c_set, jp_RARnu, jp2_RARnu) ALLOCATE (a_block(nspins), b_block(nspins), c_block(nspins), d_block(nspins), & - jp_RARnu(nspins), jp2_RARnu(nspins), & - STAT=istat) - CPASSERT(istat == 0) + jp_RARnu(nspins), jp2_RARnu(nspins)) ALLOCATE (a_matrix(max_nsgf, max_nsgf), b_matrix(max_nsgf, max_nsgf), & - c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf), & - STAT=istat) - CPASSERT(istat == 0) - ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC), STAT=istat) - CPASSERT(istat == 0) + c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf)) + ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC)) !$OMP SINGLE !$ ALLOCATE (alloc_lock(natom)) @@ -602,8 +597,9 @@ CONTAINS END IF CALL para_env%sum(tmp_coeff) - IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) & + IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) THEN nbr_dbl = nbr_dbl + 8.0_dp*REAL(SIZE(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef), dp) + END IF END DO ! ispin END DO ! iat diff --git a/src/qs_linres_current.F b/src/qs_linres_current.F index 400cc30712..a0f155514c 100644 --- a/src/qs_linres_current.F +++ b/src/qs_linres_current.F @@ -1024,8 +1024,9 @@ CONTAINS IF (do_igaim) CALL dbcsr_get_block_p(matrix=deltajp_d(1)%matrix, row=brow, col=bcol, & block=jp_block_d, found=den_found) - IF (.NOT. ASSOCIATED(jp_block_a)) & + IF (.NOT. ASSOCIATED(jp_block_a)) THEN CPABORT("p_block not associated in deltap") + END IF iatom_old = iatom jatom_old = jatom diff --git a/src/qs_linres_current_utils.F b/src/qs_linres_current_utils.F index b31ce717f5..49c842e78f 100644 --- a/src/qs_linres_current_utils.F +++ b/src/qs_linres_current_utils.F @@ -794,8 +794,9 @@ CONTAINS current_env%do_selected_states = n_rep > 0 ! ! for the moment selected states doesnt work with the preconditioner FULL_ALL - IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) & + IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) THEN CPABORT("Selected states doesnt work with the preconditioner FULL_ALL") + END IF ! ! NULLIFY (current_env%selected_states_on_atom_list) @@ -1160,7 +1161,7 @@ CONTAINS REPEAT(' ', 20 - LEN_TRIM(current_env%orb_center_name))//TRIM(current_env%orb_center_name) IF (current_env%orb_center == current_orb_center_common) THEN WRITE (output_unit, "(T2,A,T50,3F10.6)") "CURRENT| Common center", common_center(1:3) - ELSEIF (current_env%orb_center == current_orb_center_box) THEN + ELSE IF (current_env%orb_center == current_orb_center_box) THEN WRITE (output_unit, "(T2,A,T60,3I5)") "CURRENT| Nbr boxes in each direction", nbox(1:3) END IF ! diff --git a/src/qs_linres_epr_nablavks.F b/src/qs_linres_epr_nablavks.F index 9a571ba003..6761fb1794 100644 --- a/src/qs_linres_epr_nablavks.F +++ b/src/qs_linres_epr_nablavks.F @@ -631,7 +631,7 @@ CONTAINS rap(1) = MODULO(rap(1), cell%hmat(1, 1)) - cell%hmat(1, 1)/2._dp rap(2) = MODULO(rap(2), cell%hmat(2, 2)) - cell%hmat(2, 2)/2._dp rap(3) = MODULO(rap(3), cell%hmat(3, 3)) - cell%hmat(3, 3)/2._dp - sqrt_rap = SQRT(DOT_PRODUCT(rap, rap)) + sqrt_rap = NORM2(rap) exp_rap = EXP(-alpha*sqrt_rap**2) sqrt_rap = MAX(sqrt_rap, 1.e-10_dp) ! d_x diff --git a/src/qs_linres_issc_utils.F b/src/qs_linres_issc_utils.F index c02149d74f..44ed32e9f2 100644 --- a/src/qs_linres_issc_utils.F +++ b/src/qs_linres_issc_utils.F @@ -200,11 +200,8 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) - !CALL cp_fm_to_fm(p_psi0(ispin,ijdir)%matrix, psi1(ispin)) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! - !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(efg_psi0(ispin, ijdir), h1_psi0(ispin)) END DO @@ -223,18 +220,6 @@ CONTAINS chk = chk + fro END DO ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_efg',& - ! idir=ijdir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -281,18 +266,6 @@ CONTAINS chk = chk + fro END DO ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -314,11 +287,8 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) - !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! - !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(fc_psi0(ispin), h1_psi0(ispin)) END DO @@ -337,18 +307,6 @@ CONTAINS chk = chk + fro END DO ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -394,20 +352,6 @@ CONTAINS fro = cp_fm_frobenius_norm(psi1(ispin)) chk = chk + fro END DO - ! - ! print response functions - !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN - ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") - ! DO ispin = 1,nspins - ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& - ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin) - ! ENDDO ! ispin - !ENDIF ! print response functions - ! - ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" END IF @@ -600,27 +544,6 @@ CONTAINS ! !>>>>> for debugging we compute here the polarizability and NOT the DSO term! IF (do_dso .AND. iatom == natom .AND. jatom == natom) THEN - ! - ! build the integral for the jatom - !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(4)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(5)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(6)%matrix,0.0_dp) - !CALL build_dso_matrix(qs_env,matrix_dso,r_i,r_j) - !DO ixyz = 1,6 - ! CALL cp_sm_fm_multiply(matrix_dso(ixyz)%matrix,mo_coeff,& - ! & fc_psi0(ispin),ncol=nmo,& ! fc_psi0 a buffer - ! & alpha=1.0_dp,beta=0.0_dp) - ! CALL cp_fm_trace(fc_psi0(ispin),mo_coeff,buf) - ! issc_dso = 2.0_dp * maxocc * facdso * buf - ! issc(ixyz,jxyz,iatom,jatom,4) = issc_dso - !ENDDO - !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) - !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) - !CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1) DO ixyz = 1, 3 CALL cp_dbcsr_sm_fm_multiply(matrix_dso(ixyz)%matrix, mo_coeff, & fc_psi0(ispin), ncol=nmo,& ! fc_psi0 a buffer @@ -779,9 +702,9 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_env_init' - INTEGER :: handle, iatom, idir, ini, ir, ispin, & - istat, m, n, n_rep, nao, natom, & - nspins, output_unit + INTEGER :: handle, iatom, idir, ini, ir, ispin, m, & + n, n_rep, nao, natom, nspins, & + output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf, last_sgf INTEGER, DIMENSION(:), POINTER :: list, row_blk_sizes LOGICAL :: gapw @@ -841,9 +764,10 @@ CONTAINS natom = SIZE(particle_set, 1) ! ! check that the psi0 are localized and you have all the centers - IF (.NOT. linres_control%localized_psi0) & + IF (.NOT. linres_control%localized_psi0) THEN CALL cp_warn(__LOCATION__, 'To get indirect spin-spin coupling parameters within '// & 'PBC you need to localize zero order orbitals') + END IF ! ! ! read terms need to be calculated @@ -876,8 +800,7 @@ CONTAINS END DO ! IF (.NOT. ASSOCIATED(issc_env%issc_on_atom_list)) THEN - ALLOCATE (issc_env%issc_on_atom_list(natom), STAT=istat) - CPASSERT(istat == 0) + ALLOCATE (issc_env%issc_on_atom_list(natom)) DO iatom = 1, natom issc_env%issc_on_atom_list(iatom) = iatom END DO @@ -887,20 +810,15 @@ CONTAINS ! ! Initialize the issc tensor ALLOCATE (issc_env%issc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & - issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & - STAT=istat) - CPASSERT(istat == 0) + issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4)) issc_env%issc(:, :, :, :, :) = 0.0_dp issc_env%issc_loc(:, :, :, :, :) = 0.0_dp ! ! allocation ALLOCATE (issc_env%efg_psi0(nspins, 6), issc_env%pso_psi0(nspins, 3), issc_env%fc_psi0(nspins), & issc_env%psi1_efg(nspins, 6), issc_env%psi1_pso(nspins, 3), issc_env%psi1_fc(nspins), & - issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3), & - STAT=istat) - CPASSERT(istat == 0) + issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3)) DO ispin = 1, nspins - !mo_coeff => current_env%psi0_order(ispin)%matrix CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff) CALL cp_fm_get_info(mo_coeff, ncol_global=m, nrow_global=nao) diff --git a/src/qs_linres_kernel.F b/src/qs_linres_kernel.F index c9ac0c1255..a8d15ea670 100644 --- a/src/qs_linres_kernel.F +++ b/src/qs_linres_kernel.F @@ -142,9 +142,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Linear response not available with SE methods") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("Linear response not available with DFTB") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL apply_op_2_xtb(qs_env, p_env) ELSE CALL apply_op_2_dft(qs_env, p_env) @@ -278,8 +278,9 @@ CONTAINS CALL auxbas_pw_pool%create_pw(v_hartree_gspace) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) & + IF (gapw .OR. gapw_xc) THEN CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) + END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -444,8 +445,9 @@ CONTAINS END IF IF (lrigpw) THEN - IF (ASSOCIATED(v_xc_tau)) & + IF (ASSOCIATED(v_xc_tau)) THEN CPABORT("metaGGA-functionals not supported with LRI!") + END IF lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind) @@ -506,7 +508,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=.FALSE., tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) diff --git a/src/qs_linres_methods.F b/src/qs_linres_methods.F index f730cfc2cf..ad5d4d0c72 100644 --- a/src/qs_linres_methods.F +++ b/src/qs_linres_methods.F @@ -642,7 +642,7 @@ CONTAINS CALL qs_rho_update_rho(rho, qs_env=qs_env) ! that could be called before IF (dft_control%qs_control%gapw) THEN CALL prepare_gapw_den(qs_env) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL prepare_gapw_den(qs_env, do_rho0=.FALSE.) END IF diff --git a/src/qs_linres_module.F b/src/qs_linres_module.F index 4da28f2d80..ff4d100b67 100644 --- a/src/qs_linres_module.F +++ b/src/qs_linres_module.F @@ -202,8 +202,9 @@ CONTAINS vcd_env%apt_total_nvpt(:, :, vcd_env%dcdr_env%lambda) = & vcd_env%apt_el_nvpt(:, :, vcd_env%dcdr_env%lambda) + vcd_env%apt_nuc_nvpt(:, :, vcd_env%dcdr_env%lambda) - IF (vcd_env%do_mfp) & + IF (vcd_env%do_mfp) THEN vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda) = vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda)*4._dp + END IF END DO !lambda diff --git a/src/qs_linres_op.F b/src/qs_linres_op.F index ad52669b40..ed9e9fe2b8 100644 --- a/src/qs_linres_op.F +++ b/src/qs_linres_op.F @@ -1276,7 +1276,7 @@ CONTAINS IF ((b == a + 1 .OR. b == a - 2) .AND. (c == b + 1 .OR. c == b - 2)) THEN factor = 1.0_dp - ELSEIF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN + ELSE IF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN factor = -1.0_dp END IF @@ -1298,9 +1298,9 @@ CONTAINS l(1:3) = 0 IF (ii == 0) THEN l(iii) = 1 - ELSEIF (iii == 0) THEN + ELSE IF (iii == 0) THEN l(ii) = 1 - ELSEIF (ii == iii) THEN + ELSE IF (ii == iii) THEN l(ii) = 2 i = coset(l(1), l(2), l(3)) - 1 ELSE @@ -1324,10 +1324,10 @@ CONTAINS IF (i1 == 1) THEN i2 = 2 i3 = 3 - ELSEIF (i1 == 2) THEN + ELSE IF (i1 == 2) THEN i2 = 3 i3 = 1 - ELSEIF (i1 == 3) THEN + ELSE IF (i1 == 3) THEN i2 = 1 i3 = 2 ELSE @@ -1347,9 +1347,9 @@ CONTAINS IF ((i1 + i2) == 3) THEN i3 = 3 - ELSEIF ((i1 + i2) == 4) THEN + ELSE IF ((i1 + i2) == 4) THEN i3 = 2 - ELSEIF ((i1 + i2) == 5) THEN + ELSE IF ((i1 + i2) == 5) THEN i3 = 1 ELSE END IF diff --git a/src/qs_loc_main.F b/src/qs_loc_main.F index 356f10d813..f929aacda9 100644 --- a/src/qs_loc_main.F +++ b/src/qs_loc_main.F @@ -401,7 +401,7 @@ CONTAINS CALL cp_fm_release(tmp_fm) CALL cp_fm_release(tmp_fm_1) CALL cp_fm_struct_release(tmp_fm_struct) - ELSEIF (my_guess_wan) THEN + ELSE IF (my_guess_wan) THEN nguess = localized_wfn_control%nguess(myspin) ALLOCATE (tmp_mat(nao, nguess)) CALL cp_fm_get_submatrix(moloc_coeff(myspin), tmp_mat, 1, 1, nao, nguess) diff --git a/src/qs_loc_states.F b/src/qs_loc_states.F index 0c9d90a473..8163a283a2 100644 --- a/src/qs_loc_states.F +++ b/src/qs_loc_states.F @@ -133,16 +133,21 @@ CONTAINS IF (qs_loc_env%do_localize) THEN ! Do the Real localization.. - IF (output_unit > 0 .AND. do_homo) WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for OCCUPIED ORBITALS. Spin:", ispin - IF (output_unit > 0 .AND. do_mixed) WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & - "LOCALIZATION| Computing localization properties for OCCUPIED, ", & - "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin - IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) & + IF (output_unit > 0 .AND. do_homo) THEN WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for UNOCCUPIED ORBITALS. Spin:", ispin + "LOCALIZATION| Computing localization properties "// & + "for OCCUPIED ORBITALS. Spin:", ispin + END IF + IF (output_unit > 0 .AND. do_mixed) THEN + WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & + "LOCALIZATION| Computing localization properties for OCCUPIED, ", & + "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin + END IF + IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) THEN + WRITE (output_unit, "(/,T2,A,I3)") & + "LOCALIZATION| Computing localization properties "// & + "for UNOCCUPIED ORBITALS. Spin:", ispin + END IF scenter => qs_loc_env%localized_wfn_control%centers_set(ispin)%array diff --git a/src/qs_loc_types.F b/src/qs_loc_types.F index e22f26abb8..4da4fc2c07 100644 --- a/src/qs_loc_types.F +++ b/src/qs_loc_types.F @@ -196,8 +196,9 @@ CONTAINS INTEGER :: i, ii, j IF (ASSOCIATED(qs_loc_env%cell)) CALL cell_release(qs_loc_env%cell) - IF (ASSOCIATED(qs_loc_env%local_molecules)) & + IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN CALL distribution_1d_release(qs_loc_env%local_molecules) + END IF IF (ASSOCIATED(qs_loc_env%localized_wfn_control)) THEN CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control) END IF @@ -336,8 +337,9 @@ CONTAINS IF (PRESENT(cell)) cell => qs_loc_env%cell IF (PRESENT(moloc_coeff)) moloc_coeff => qs_loc_env%moloc_coeff IF (PRESENT(local_molecules)) local_molecules => qs_loc_env%local_molecules - IF (PRESENT(localized_wfn_control)) & + IF (PRESENT(localized_wfn_control)) THEN localized_wfn_control => qs_loc_env%localized_wfn_control + END IF IF (PRESENT(op_sm_set)) op_sm_set => qs_loc_env%op_sm_set IF (PRESENT(op_fm_set)) op_fm_set => qs_loc_env%op_fm_set IF (PRESENT(para_env)) para_env => qs_loc_env%para_env @@ -392,8 +394,9 @@ CONTAINS IF (PRESENT(local_molecules)) THEN CALL distribution_1d_retain(local_molecules) - IF (ASSOCIATED(qs_loc_env%local_molecules)) & + IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN CALL distribution_1d_release(qs_loc_env%local_molecules) + END IF qs_loc_env%local_molecules => local_molecules END IF diff --git a/src/qs_loc_utils.F b/src/qs_loc_utils.F index 988b9b6212..3a8cd53d04 100644 --- a/src/qs_loc_utils.F +++ b/src/qs_loc_utils.F @@ -340,10 +340,11 @@ CONTAINS IF (localized_wfn_control%do_homo) THEN occ_imo = occupations(imo) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) & + IF (localized_wfn_control%localization_method /= do_loc_none) THEN CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") + END IF END IF END IF ! Take the imo vector from the full set and copy in the imoloc vector of the subset @@ -357,10 +358,11 @@ CONTAINS my_occ = occupations(lb) occ_imo = occupations(ub) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) & + IF (localized_wfn_control%localization_method /= do_loc_none) THEN CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") + END IF END IF nmosub = localized_wfn_control%nloc_states(ispin) @@ -414,7 +416,7 @@ CONTAINS END DO END DO - ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN natoms = SIZE(qs_loc_env%particle_set, 1) ALLOCATE (qs_loc_env%op_fm_set(natoms, 1)) CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=natoms) @@ -439,7 +441,7 @@ CONTAINS CALL get_berry_operator(qs_loc_env, qs_env) - ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN !! here we don't have to do anything !! CALL get_pipek_mezey_operator ( qs_loc_env, qs_env ) @@ -757,7 +759,7 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSEIF (my_do_mixed) THEN + ELSE IF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -872,12 +874,13 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN fname_key = "LOCHOMO_RESTART_FILE_NAME" - ELSEIF (my_do_mixed) THEN + ELSE IF (my_do_mixed) THEN fname_key = "LOCMIXD_RESTART_FILE_NAME" ELSE fname_key = "LOCLUMO_RESTART_FILE_NAME" - IF (.NOT. PRESENT(evals)) & + IF (.NOT. PRESENT(evals)) THEN CPABORT("Missing argument to localize unoccupied states.") + END IF END IF file_exists = .FALSE. @@ -889,7 +892,7 @@ CONTAINS print_key => section_vals_get_subs_vals(section2, "LOC_RESTART") IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSEIF (my_do_mixed) THEN + ELSE IF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -914,8 +917,10 @@ CONTAINS READ (rst_unit) qs_loc_env%localized_wfn_control%nloc_states END IF ELSE - IF (output_unit > 0) WRITE (output_unit, "(/,T10,A)") & - "Restart file not available filename=<"//TRIM(filename)//'>' + IF (output_unit > 0) THEN + WRITE (output_unit, "(/,T10,A)") & + "Restart file not available filename=<"//TRIM(filename)//'>' + END IF END IF CALL para_env%bcast(file_exists) @@ -956,14 +961,16 @@ CONTAINS eig_read = 0.0_dp READ (rst_unit) eig_read(1:nmo_read) END IF - IF (nmo_read < nmo) & + IF (nmo_read < nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. ") - IF (nmo_read > nmo) & + END IF + IF (nmo_read > nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") + END IF nmo = MIN(nmo, nmo_read) IF (do_homo .OR. do_mixed) THEN @@ -1186,7 +1193,6 @@ CONTAINS maxocc=maxocc) ! Get eigenstates (only needed if not already calculated before) IF ((.NOT. my_do_mo_cubes) & - ! .OR. section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO")==0)& .AND. my_do_homo .AND. ASSOCIATED(qs_env%scf_env) & .AND. qs_env%scf_env%method == ot_method_nr .AND. (.NOT. dft_control%restricted)) THEN CALL make_mo_eig(mos, nspin, ks_rmpv, scf_control, mo_derivs) @@ -1207,11 +1213,12 @@ CONTAINS localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = ilast_intocc IF (nmoloc(ispin) /= n_mo(ispin)) THEN - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - ilast_intocc, " occupied orbitals are localized,", " with energies from ", & - mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." + "LOCALIZATION| Spin ", ispin, " The first ", & + ilast_intocc, " occupied orbitals are localized,", " with energies from ", & + mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." + END IF END IF ELSE IF (localized_wfn_control%set_of_states == energy_loc_range .AND. my_do_homo) THEN ilow = 0 @@ -1243,11 +1250,12 @@ CONTAINS nmoloc(ispin) = n_mo(ispin) - homo localized_wfn_control%lu_bound_states(1, ispin) = homo + 1 localized_wfn_control%lu_bound_states(2, ispin) = n_mo(ispin) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & - mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & + mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." + END IF ELSE IF (localized_wfn_control%set_of_states == state_loc_mixed) THEN nextra = localized_wfn_control%nextra nocc = homo @@ -1262,14 +1270,15 @@ CONTAINS nmoloc(ispin) = nocc + nextra localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = nmoloc(ispin) - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,I6,/,T15,A,I6,/,T15,A,I6,/,T15,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " orbitals are localized.", & - "Number of fully occupied MOs: ", nocc, & - "Number of partially occupied MOs: ", npocc, & - "Number of extra degrees of freedom: ", nextra, & - "Excess charge: ", my_tot_zeff_corr, " electrons" + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " orbitals are localized.", & + "Number of fully occupied MOs: ", nocc, & + "Number of partially occupied MOs: ", npocc, & + "Number of extra degrees of freedom: ", nextra, & + "Excess charge: ", my_tot_zeff_corr, " electrons" + END IF ELSE nmoloc(ispin) = MIN(localized_wfn_control%nloc_states(1), n_mo(ispin)) IF (output_unit > 0 .AND. my_do_homo) WRITE (output_unit, "(/,T2,A,I4,A,I6,A)") "LOCALIZATION| Spin ", ispin, & diff --git a/src/qs_local_rho_types.F b/src/qs_local_rho_types.F index 2efbf1089a..97b456cf64 100644 --- a/src/qs_local_rho_types.F +++ b/src/qs_local_rho_types.F @@ -156,12 +156,9 @@ CONTAINS nkind = SIZE(rhoz_set) DO ikind = 1, nkind - IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) & - DEALLOCATE (rhoz_set(ikind)%r_coef) - IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) & - DEALLOCATE (rhoz_set(ikind)%dr_coef) - IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) & - DEALLOCATE (rhoz_set(ikind)%vr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) DEALLOCATE (rhoz_set(ikind)%r_coef) + IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) DEALLOCATE (rhoz_set(ikind)%dr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) DEALLOCATE (rhoz_set(ikind)%vr_coef) END DO DEALLOCATE (rhoz_set) diff --git a/src/qs_localization_methods.F b/src/qs_localization_methods.F index 97b0e6c4b8..6cc9eebe2f 100644 --- a/src/qs_localization_methods.F +++ b/src/qs_localization_methods.F @@ -162,7 +162,6 @@ CONTAINS END DO END DO CALL C%matrix_struct%para_env%sum(f2) - !write(*,*) 'qs_localize: f_2=',f2 !------------------------------------------------------------------- ! compute the derivative of f_2 ! f_2(x)=(x^2+eps)^1/2 @@ -179,7 +178,6 @@ CONTAINS !------------------------------------------------------------------- ! gnorm = cp_fm_frobenius_norm(G) - !write(*,*) 'qs_localize: norm(G)=',gnorm ! ! rescale for steepest descent CALL cp_fm_scale(-alpha, G) @@ -191,7 +189,6 @@ CONTAINS expfactor = 1.0_dp CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, G) tnorm = cp_fm_frobenius_norm(G) - !write(*,*) 'Taylor expansion i=',1,' norm(X^i)/i!=',tnorm IF (tnorm > 1.0E-10_dp) THEN ! other orders CALL cp_fm_to_fm(G, Gp1) @@ -203,7 +200,6 @@ CONTAINS expfactor = expfactor/REAL(i, KIND=dp) CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, Gp1) tnorm = cp_fm_frobenius_norm(Gp1) - !write(*,*) 'Taylor expansion i=',i,' norm(X^i)/i!=',tnorm*expfactor IF (tnorm*expfactor < 1.0E-10_dp) EXIT END DO END IF @@ -219,7 +215,6 @@ CONTAINS ! ! Are we done? sweeps = istep - !IF(gnorm<=grad_thresh.AND.ABS((f2-f2old)/f2)<=f2_thresh.AND.istep>1) THEN IF (ABS((f2 - f2old)/f2) <= eps .AND. istep > 1) THEN converged = .TRUE. EXIT @@ -231,23 +226,6 @@ CONTAINS ! ! Print the final result IF (output_unit > 0) WRITE (output_unit, '(A,E16.10)') ' sparseness function f2 = ', f2 - ! - ! sparsity - !DO i=1,size(thresh,1) - ! gnorm = 0.0_dp - ! DO o=1,ncol_local - ! DO p=1,nrow_local - ! IF(ABS(C%local_data(p,o))>thresh(i)) THEN - ! gnorm = gnorm + 1.0_dp - ! ENDIF - ! ENDDO - ! ENDDO - ! CALL C%matrix_struct%para_env%sum(gnorm) - ! IF(output_unit>0) THEN - ! WRITE(output_unit,*) 'qs_localize: ratio2=',gnorm / ( REAL(k,KIND=dp)*REAL(n,KIND=dp) ),thresh(i) - ! ENDIF - !ENDDO - ! ! deallocate CALL cp_fm_struct_release(fm_struct_k_k) CALL cp_fm_release(CTmp) @@ -689,7 +667,7 @@ CONTAINS IF (do_cinit_random) THEN icinit = 1 do_U_guess_mo = .FALSE. - ELSEIF (do_cinit_mo) THEN + ELSE IF (do_cinit_mo) THEN icinit = 2 do_U_guess_mo = .TRUE. END IF @@ -1161,7 +1139,7 @@ CONTAINS IF ((ABS(ds) < 1.0E-10_dp) .AND. (lsl == 1)) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha - ELSEIF (ABS(ds) > 10.0_dp) THEN + ELSE IF (ABS(ds) > 10.0_dp) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha ELSE @@ -1349,7 +1327,7 @@ CONTAINS IF (ABS(b12) > 1.e-10_dp) THEN ratio = -a12/b12 theta = 0.25_dp*ATAN(ratio) - ELSEIF (ABS(b12) < 1.e-10_dp) THEN + ELSE IF (ABS(b12) < 1.e-10_dp) THEN b12 = 0.0_dp theta = 0.0_dp ELSE @@ -1997,14 +1975,6 @@ CONTAINS IF (new_direction) THEN ! energy converged up to machine precision ? line_searches = line_searches + 1 - ! DO i=1,line_search_count - ! write(15,*) pos(i),energy(i) - ! ENDDO - ! write(15,*) "" - ! CALL m_flush(15) - !write(16,*) evals(:) - !write(17,*) matrix_A%local_data(:,:) - !write(18,*) matrix_G%local_data(:,:) IF (output_unit > 0) THEN WRITE (output_unit, '(T5,I10,T18,I10,T31,2F20.6,F10.3)') line_searches, Iterations, Omega, tol, ds_min CALL m_flush(output_unit) @@ -2513,9 +2483,9 @@ CONTAINS COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: c_array_me, c_array_partner COMPLEX(KIND=dp), POINTER :: mii(:), mij(:), mjj(:) INTEGER :: i, idim, ii, ik, il1, il2, il_recv, il_recv_partner, ilow1, ilow2, ip, ip_has_i, & - ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istat, istate, iu1, iu2, iup1, & - iup2, j, jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, & - ns_recv_from, ns_recv_partner + ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istate, iu1, iu2, iup1, iup2, j, & + jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, ns_recv_from, & + ns_recv_partner INTEGER, ALLOCATABLE, DIMENSION(:) :: rcount, rdispl INTEGER, ALLOCATABLE, DIMENSION(:, :) :: list_pair LOGICAL :: should_stop @@ -2532,8 +2502,8 @@ CONTAINS ALLOCATE (mii(dim2), mij(dim2), mjj(dim2)) - ALLOCATE (rcount(para_env%num_pe), STAT=istat) - ALLOCATE (rdispl(para_env%num_pe), STAT=istat) + ALLOCATE (rcount(para_env%num_pe)) + ALLOCATE (rdispl(para_env%num_pe)) tolerance = 1.0e10_dp sweeps = 0 @@ -2705,7 +2675,6 @@ CONTAINS IF (ilow1 < ilow2) THEN ! no longer compiles in official sdgb: - !CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1, k), nstate, rmat_loc(1 + n1, 1), n1 + n2, 0.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, rmat_loc(1 + n1:, 1:n1), & n2, 0.0_dp, gmat(:, :), nstate) @@ -2715,7 +2684,6 @@ CONTAINS CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, & rmat_loc(1:, n2 + 1:), n1 + n2, 0.0_dp, gmat(:, :), nstate) ! no longer compiles in official sdgb: - !CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1, 1), nstate, rmat_loc(n2 + 1, n2 + 1), n1 + n2, 1.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1:, 1:), nstate, rmat_loc(n2 + 1:, n2 + 1:), & n1, 1.0_dp, gmat(:, :), nstate) @@ -2993,7 +2961,7 @@ CONTAINS list_pair(JJ, II) = i END DO IF (MOD(para_env%num_pe, 2) == 1) list_pair(2, npair) = -1 - ELSEIF (MOD(iperm, 2) == 0) THEN + ELSE IF (MOD(iperm, 2) == 0) THEN !..a type shift jj = list_pair(1, npair) DO I = npair, 3, -1 diff --git a/src/qs_mixing_utils.F b/src/qs_mixing_utils.F index d5869da8f0..b61e5251e4 100644 --- a/src/qs_mixing_utils.F +++ b/src/qs_mixing_utils.F @@ -188,7 +188,7 @@ CONTAINS CPASSERT(.NOT. mixing_store%gmix_p) IF (dft_control%qs_control%dftb) THEN max_shell = max_dftb_scc_vars - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN max_shell = max_xtb_scc_vars ELSE CPABORT('UNKNOWN METHOD') @@ -219,7 +219,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%pulay_matrix)) DEALLOCATE (mixing_store%pulay_matrix) ALLOCATE (mixing_store%pulay_matrix(nbuffer, nbuffer, nspins)) mixing_store%pulay_matrix = 0.0_dp - ELSEIF (mixing_method == broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr) THEN IF (ASSOCIATED(mixing_store%abroy)) DEALLOCATE (mixing_store%abroy) ALLOCATE (mixing_store%abroy(nbuffer, nbuffer)) mixing_store%abroy = 0.0_dp @@ -232,7 +232,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%ubroy)) DEALLOCATE (mixing_store%ubroy) ALLOCATE (mixing_store%ubroy(na, max_shell, nbuffer)) mixing_store%ubroy = 0.0_dp - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN CPABORT("multisecant_mixing not available") END IF ELSE @@ -588,7 +588,7 @@ CONTAINS END IF IF (mixing_method == gspace_mixing_nr) THEN - ELSEIF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN + ELSE IF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN IF (mixing_store%gmix_p .AND. PRESENT(rho_atom)) THEN DO ispin = 1, nspin DO iat = 1, natom @@ -613,7 +613,7 @@ CONTAINS END DO END DO END IF - ELSEIF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN + ELSE IF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN DO ispin = 1, nspin IF (.NOT. ASSOCIATED(mixing_store%rhoin_old(ispin)%cc)) THEN ALLOCATE (mixing_store%rhoin_old(ispin)%cc(ng)) @@ -685,7 +685,7 @@ CONTAINS END DO IF (rho_g(1)%pw_grid%have_g0) mixing_store%p_metric(1) = bconst END IF - ELSEIF (mixing_method == multisecant_mixing_nr) THEN + ELSE IF (mixing_method == multisecant_mixing_nr) THEN IF (.NOT. ASSOCIATED(mixing_store%ig_global_index)) THEN ALLOCATE (mixing_store%ig_global_index(ng)) END IF diff --git a/src/qs_mo_io.F b/src/qs_mo_io.F index 4504787e02..55c77ef141 100644 --- a/src/qs_mo_io.F +++ b/src/qs_mo_io.F @@ -346,7 +346,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -383,7 +383,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 @@ -754,8 +754,9 @@ CONTAINS IF (nao_read /= nao) THEN WRITE (cp_logger_get_default_unit_nr(logger), *) & " READ RESTART : WARNING : DIFFERENT # AOs ", nao, nao_read - IF (PRESENT(rt_mos)) & + IF (PRESENT(rt_mos)) THEN CPABORT("To change basis is not possible. ") + END IF END IF READ (rst_unit) nset_info @@ -810,14 +811,16 @@ CONTAINS occ_read = 0.0_dp nmo = MIN(nmo, nmo_read) - IF (nmo_read < nmo) & + IF (nmo_read < nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. The MO set will be padded with zeros!") - IF (nmo_read > nmo) & + END IF + IF (nmo_read > nmo) THEN CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") + END IF READ (rst_unit) eig_read(1:nmo_read), occ_read(1:nmo_read) mos(ispin)%eigenvalues(1:nmo) = eig_read(1:nmo) @@ -878,7 +881,7 @@ CONTAINS nshell=nshell, & l=l) minbas = .FALSE. - ELSEIF (ASSOCIATED(dftb_parameter)) THEN + ELSE IF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset = 1 minbas = .TRUE. @@ -1326,14 +1329,16 @@ CONTAINS name = TRIM(energy_str)//", OCCUPATION NUMBERS, AND "// & TRIM(orbital_str)//" "//TRIM(vector_str) - IF (.NOT. my_final) & + IF (.NOT. my_final) THEN WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step + END IF ELSE IF (print_occup .OR. print_eigvals) THEN name = TRIM(energy_str)//" AND OCCUPATION NUMBERS" - IF (.NOT. my_final) & + IF (.NOT. my_final) THEN WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step + END IF END IF ! print_eigvecs ! Print headline diff --git a/src/qs_mo_occupation.F b/src/qs_mo_occupation.F index 38d815e707..dcd2c88e4f 100644 --- a/src/qs_mo_occupation.F +++ b/src/qs_mo_occupation.F @@ -155,10 +155,11 @@ CONTAINS CPWARN_IF(is_large, TRIM(method_label)//" smearing includes the first MO") is_large = ABS(all_occ(all_nmo)) > smear%eps_fermi_dirac - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF IF (.NOT. do_gce) THEN ! check that the total electron count is accurate is_large = (ABS(all_nelec - accurate_sum(all_occ(:))) > smear%eps_fermi_dirac*all_nelec) @@ -342,13 +343,15 @@ CONTAINS multiplicity_old = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (mo_array(1)%nelectron >= mo_array(1)%nmo) & + IF (mo_array(1)%nelectron >= mo_array(1)%nmo) THEN CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") - IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) & + END IF + IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) THEN CALL cp_warn(__LOCATION__, "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") + END IF eigval_a => mo_array(1)%eigenvalues eigval_b => mo_array(2)%eigenvalues @@ -367,20 +370,22 @@ CONTAINS lumo_b = lumo_b + 1 END IF IF (lumo_a > mo_array(1)%nmo) THEN - IF (i /= nelec) & + IF (i /= nelec) THEN CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") + END IF IF (i < nelec) THEN lumo_a = lumo_a - 1 lumo_b = lumo_b + 1 END IF END IF IF (lumo_b > mo_array(2)%nmo) THEN - IF (lumo_b < lumo_a) & + IF (lumo_b < lumo_a) THEN CALL cp_warn(__LOCATION__, & "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") + END IF IF (i < nelec) THEN lumo_a = lumo_a + 1 lumo_b = lumo_b - 1 @@ -406,11 +411,12 @@ CONTAINS mo_array(2)%nelectron = mo_array(2)%homo multiplicity_new = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (multiplicity_new /= multiplicity_old) & + IF (multiplicity_new /= multiplicity_old) THEN CALL cp_warn(__LOCATION__, & "Multiplicity changed from "// & TRIM(ADJUSTL(cp_to_string(multiplicity_old)))//" to "// & TRIM(ADJUSTL(cp_to_string(multiplicity_new)))) + END IF IF (PRESENT(probe)) THEN CALL set_mo_occupation_1(mo_array(1), smear=smear, probe=probe) @@ -496,8 +502,9 @@ CONTAINS mo_set%occupation_numbers(1:nomo) = mo_set%maxocc IF (xas_estate > 0) mo_set%occupation_numbers(xas_estate) = occ_estate el_count = SUM(mo_set%occupation_numbers(1:nomo)) - IF (el_count > xas_nelectron) & + IF (el_count > xas_nelectron) THEN mo_set%occupation_numbers(nomo) = mo_set%occupation_numbers(nomo) - (el_count - xas_nelectron) + END IF el_count = SUM(mo_set%occupation_numbers(1:nomo)) is_large = ABS(el_count - xas_nelectron) > xas_nelectron*EPSILON(el_count) CPASSERT(.NOT. is_large) @@ -586,13 +593,13 @@ CONTAINS END DO nomo = nomo - irmo IF (mo_set%occupation_numbers(nomo) == 0.0_dp) nomo = nomo - 1 - ELSEIF (delectron < 0.0_dp) THEN + ELSE IF (delectron < 0.0_dp) THEN mo_set%occupation_numbers(nomo) = -delectron ELSE mo_set%occupation_numbers(nomo) = 0.0_dp nomo = nomo - 1 END IF - ELSEIF (total_zeff_corr > 0.0_dp) THEN + ELSE IF (total_zeff_corr > 0.0_dp) THEN ! add electron density to the mos delectron = total_zeff_corr - REAL(mo_set%maxocc, KIND=dp) IF (delectron > 0.0_dp) THEN @@ -655,8 +662,9 @@ CONTAINS END DO is_large = ABS(MAXVAL(mo_set%occupation_numbers) - mo_set%maxocc) > probe(1)%eps_hp ! this is not a real problem, but the temperature might be a bit large - IF (is_large) & + IF (is_large) THEN CPWARN("Hair-probes occupancy distribution includes the first MO") + END IF ! Find the highest (fractional) occupied MO which will be now the HOMO DO imo = nmo, mo_set%lfomo, -1 @@ -666,15 +674,17 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > probe(1)%eps_hp - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & "Hair-probes occupancy distribution includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > probe(1)%eps_hp*nelec) - IF (is_large) & + IF (is_large) THEN CPWARN("Total number of electrons is not accurate") + END IF END IF @@ -750,10 +760,11 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > smear%eps_fermi_dirac - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & "Fermi-Dirac smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -806,10 +817,11 @@ CONTAINS END IF END DO is_large = ABS(mo_set%occupation_numbers(nmo)) > smear%eps_fermi_dirac - IF (is_large) & + IF (is_large) THEN CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! Check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -826,10 +838,11 @@ CONTAINS END IF e2 = mo_set%eigenvalues(mo_set%homo) + 0.5_dp*smear%window_size - IF (e2 >= mo_set%eigenvalues(nmo)) & + IF (e2 >= mo_set%eigenvalues(nmo)) THEN CALL cp_warn(__LOCATION__, & "Energy window for smearing includes the last MO => "// & "Add more MOs for proper smearing.") + END IF ! Find the lowest fractional occupied MO (LFOMO) DO imo = i_first, nomo diff --git a/src/qs_mom_methods.F b/src/qs_mom_methods.F index 29544e3795..9d5921eaab 100644 --- a/src/qs_mom_methods.F +++ b/src/qs_mom_methods.F @@ -89,8 +89,9 @@ CONTAINS ! Ensure that all orbital indices are positive integers. ! A special value '0' means 'disabled keyword', ! it must appear once to be interpreted in such a way - IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) & + IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) THEN CPABORT("MOM: all molecular orbital indices must be positive integer numbers") + END IF DEALLOCATE (tmp_iarr) END IF @@ -265,9 +266,10 @@ CONTAINS (mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccA) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccB) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occA) .AND. & - mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) & + mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) THEN CALL cp_abort(__LOCATION__, & "Duplicate orbital indices were found in the MOM section") + END IF ! ignore beta orbitals for spin-unpolarized calculations IF (nspins == 1 .AND. (scf_control%diagonalization%mom_deoccB(1) /= 0 & @@ -308,16 +310,18 @@ CONTAINS END DO ! proceed alpha orbitals - IF (nspins >= 1) & + IF (nspins >= 1) THEN CALL mom_reoccupy_orbitals(mos(1), & scf_control%diagonalization%mom_deoccA, & scf_control%diagonalization%mom_occA, 'alpha') + END IF ! proceed beta orbitals (if any) - IF (nspins >= 2) & + IF (nspins >= 2) THEN CALL mom_reoccupy_orbitals(mos(2), & scf_control%diagonalization%mom_deoccB, & scf_control%diagonalization%mom_occB, 'beta') + END IF ! recompute the density matrix if the molecular orbitals are here; ! otherwise do nothing to prevent zeroing out the density matrix @@ -392,9 +396,10 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. scf_control%diagonalization%mom_didguess) & + IF (.NOT. scf_control%diagonalization%mom_didguess) THEN CALL cp_abort(__LOCATION__, & "The current implementation of the maximum overlap method is incompatible with the initial SCF guess") + END IF ! number of spins == dft_control%nspins nspins = SIZE(matrix_ks) diff --git a/src/qs_moments.F b/src/qs_moments.F index 6a8ac14ccf..c434f3ca8b 100644 --- a/src/qs_moments.F +++ b/src/qs_moments.F @@ -3361,8 +3361,9 @@ CONTAINS kpnts => section_vals_get_subs_vals(qs_env%input, "DFT%PRINT%MOMENTS%KPOINTS") CALL section_vals_get(kpset, explicit=explicit_kpset) CALL section_vals_get(kpnts, explicit=explicit_kpnts) - IF (explicit_kpset .AND. explicit_kpnts) & + IF (explicit_kpset .AND. explicit_kpnts) then CPABORT("Both KPOINT_SET and KPOINTS present in MOMENTS section") + end if IF (explicit_kpset) THEN CALL get_qs_env(qs_env, cell=cell) @@ -4011,8 +4012,9 @@ CONTAINS IF (ABS(energy_diff) <= eps_degenerate) CYCLE CALL cp_fm_get_element(moment_re, m, n, creal) CALL cp_fm_get_element(moment_im, m, n, cimag) - IF (para_env%is_source()) & + IF (para_env%is_source()) then dipole(ispin, ikp, i_dir, n, m) = CMPLX(creal, cimag, KIND=dp)/energy_diff + end if END DO END DO END DO diff --git a/src/qs_neighbor_list_types.F b/src/qs_neighbor_list_types.F index c77afac074..f85df43651 100644 --- a/src/qs_neighbor_list_types.F +++ b/src/qs_neighbor_list_types.F @@ -358,8 +358,9 @@ CONTAINS TYPE(neighbor_list_set_p_type), DIMENSION(:), & POINTER :: nl - IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) & + IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) THEN CPABORT("Parallel iterator calls must include 'mepos'") + END IF IF (PRESENT(mepos)) THEN me = mepos @@ -461,10 +462,10 @@ CONTAINS IF (iterator%inode >= iterator%nnode) THEN ! end of loop istat = 1 - ELSEIF (iterator%inode == 0) THEN + ELSE IF (iterator%inode == 0) THEN iterator%inode = 1 iterator%neighbor_node => first_node(iterator%neighbor_list) - ELSEIF (iterator%inode > 0) THEN + ELSE IF (iterator%inode > 0) THEN ! we can be sure that there is another node in this list iterator%inode = iterator%inode + 1 iterator%neighbor_node => iterator%neighbor_node%next_neighbor_node diff --git a/src/qs_neighbor_lists.F b/src/qs_neighbor_lists.F index 4c8e38cf4f..b67e328c93 100644 --- a/src/qs_neighbor_lists.F +++ b/src/qs_neighbor_lists.F @@ -112,6 +112,10 @@ MODULE qs_neighbor_lists END TYPE local_atoms_type ! ************************************************************************************************** + TYPE local_lists + INTEGER, DIMENSION(:), POINTER :: list => NULL() + END TYPE local_lists + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_neighbor_lists' ! private counter, used to version qs neighbor lists @@ -430,7 +434,7 @@ CONTAINS IF (dokp) THEN ! no MIC for kpoints mic = .FALSE. - ELSEIF (nddo) THEN + ELSE IF (nddo) THEN ! enforce MIC for interaction lists in SE mic = .TRUE. END IF @@ -663,8 +667,9 @@ CONTAINS CALL pair_radius_setup(orb_present, orb_present, orb_radius, orb_radius, pair_radius_lb) DO jkind = 1, nkind DO ikind = 1, nkind - IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) & + IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) THEN pair_radius(ikind, jkind) = pair_radius_lb(ikind, jkind) - roperator + END IF END DO END DO ELSE @@ -947,7 +952,7 @@ CONTAINS qs_env%lri_env%soo_list => soo_list CALL write_neighbor_lists(soo_list, particle_set, cell, para_env, neighbor_list_section, & "/SOO_LIST", "soo_list", "ORBITAL ORBITAL (RI)") - ELSEIF (rigpw) THEN + ELSE IF (rigpw) THEN ALLOCATE (ri_present(nkind), ri_radius(nkind)) ri_present = .FALSE. ri_radius = 0.0_dp @@ -1081,31 +1086,28 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'build_neighbor_lists' - TYPE local_lists - INTEGER, DIMENSION(:), POINTER :: list - END TYPE local_lists - - INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, & - iatom_subcell, icell, ikind, j, jatom, jatom_local, jcell, jkind, k, & - kcell, maxat, mol_a, mol_b, nkind, otype, natom, inode, nnode, nentry + INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, iatom_subcell, icell, ikind, & + inode, j, jatom, jatom_local, jcell, jkind, k, kcell, maxat, mol_a, mol_b, natom, nentry, & + nkind, nnode, otype + INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb INTEGER, DIMENSION(3) :: cell_b, ncell, nsubcell, periodic INTEGER, DIMENSION(:), POINTER :: index_list - LOGICAL :: include_ab, my_mic, & - my_molecular, my_symmetric, my_sort_atomb + LOGICAL :: include_ab, my_mic, my_molecular, & + my_sort_atomb, my_symmetric LOGICAL, ALLOCATABLE, DIMENSION(:) :: pres_a, pres_b - REAL(dp) :: rab2, rab2_max, rab_max, rabm, deth, subcell_scale - REAL(dp), DIMENSION(3) :: r, rab, ra, rb, sab_max, sb, & - sb_pbc, sb_min, sb_max, rab_pbc, pd, sab_max_guard - INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb + REAL(dp) :: deth, rab2, rab2_max, rab_max, rabm, & + subcell_scale + REAL(dp), DIMENSION(3) :: pd, r, ra, rab, rab_pbc, rb, sab_max, & + sab_max_guard, sb, sb_max, sb_min, & + sb_pbc + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: r_pbc TYPE(local_lists), DIMENSION(:), POINTER :: lista, listb - TYPE(neighbor_list_p_type), & - ALLOCATABLE, DIMENSION(:) :: kind_a - TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set - TYPE(subcell_type), DIMENSION(:, :, :), & - POINTER :: subcell - REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: r_pbc TYPE(neighbor_list_iterator_p_type), & DIMENSION(:), POINTER :: nl_iterator + TYPE(neighbor_list_p_type), ALLOCATABLE, & + DIMENSION(:) :: kind_a + TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set + TYPE(subcell_type), DIMENSION(:, :, :), POINTER :: subcell CALL timeset(routineN//"_"//TRIM(nlname), handle) diff --git a/src/qs_nonscf_utils.F b/src/qs_nonscf_utils.F index bc73ecfbd9..79bf5fd5e2 100644 --- a/src/qs_nonscf_utils.F +++ b/src/qs_nonscf_utils.F @@ -82,19 +82,22 @@ CONTAINS "Self energy of the core charge distribution: ", energy%core_self, & "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", energy%exc - IF (energy%dispersion /= 0.0_dp) & + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - IF (energy%gcp /= 0.0_dp) & + "Dispersion energy: ", energy%dispersion + END IF + IF (energy%gcp /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - IF (energy%efield /= 0.0_dp) & + "gCP energy: ", energy%gcp + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT("NONSCF not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPASSERT(energy%dftb3 == 0.0_dp) energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & @@ -103,10 +106,11 @@ CONTAINS "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Dispersion energy: ", energy%dispersion - IF (energy%efield /= 0.0_dp) & + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - ELSEIF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + END IF + ELSE IF (dft_control%qs_control%xtb) THEN energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & "Diagonalization", "Time:", tdiag, energy%total @@ -117,12 +121,14 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - IF (energy%efield /= 0.0_dp) & + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF ELSE CPABORT("NONSCF not available") END IF diff --git a/src/qs_ot.F b/src/qs_ot.F index 2b13565c51..598749bc9c 100644 --- a/src/qs_ot.F +++ b/src/qs_ot.F @@ -295,8 +295,9 @@ CONTAINS ! ! compute the P^(-1/2) DO i = 1, k - IF (eig(i) <= 0.0_dp) & + IF (eig(i) <= 0.0_dp) THEN CPABORT("P not positive definite") + END IF IF (eig(i) < 1.0E-8_dp) THEN fun(i) = 0.0_dp ELSE diff --git a/src/qs_ot_types.F b/src/qs_ot_types.F index d184e998fd..d301039af0 100644 --- a/src/qs_ot_types.F +++ b/src/qs_ot_types.F @@ -269,25 +269,31 @@ CONTAINS CALL dbcsr_set(qs_ot_env%matrix_gx, 0.0_dp) - IF (qs_ot_env%use_dx) & + IF (qs_ot_env%use_dx) THEN CALL dbcsr_set(qs_ot_env%matrix_dx, 0.0_dp) + END IF - IF (qs_ot_env%use_gx_old) & + IF (qs_ot_env%use_gx_old) THEN CALL dbcsr_set(qs_ot_env%matrix_gx_old, 0.0_dp) + END IF IF (qs_ot_env%settings%do_rotation) THEN CALL dbcsr_set(qs_ot_env%rot_mat_gx, 0.0_dp) - IF (qs_ot_env%use_dx) & + IF (qs_ot_env%use_dx) THEN CALL dbcsr_set(qs_ot_env%rot_mat_dx, 0.0_dp) - IF (qs_ot_env%use_gx_old) & + END IF + IF (qs_ot_env%use_gx_old) THEN CALL dbcsr_set(qs_ot_env%rot_mat_gx_old, 0.0_dp) + END IF END IF IF (qs_ot_env%settings%do_ener) THEN qs_ot_env%ener_gx(:) = 0.0_dp - IF (qs_ot_env%use_dx) & + IF (qs_ot_env%use_dx) THEN qs_ot_env%ener_dx(:) = 0.0_dp - IF (qs_ot_env%use_gx_old) & + END IF + IF (qs_ot_env%use_gx_old) THEN qs_ot_env%ener_gx_old(:) = 0.0_dp + END IF END IF END SUBROUTINE qs_ot_init diff --git a/src/qs_outer_scf.F b/src/qs_outer_scf.F index 1b4a93e52d..55d7d7b239 100644 --- a/src/qs_outer_scf.F +++ b/src/qs_outer_scf.F @@ -318,10 +318,11 @@ CONTAINS END IF IF (scf_control%outer_scf%cdft_opt_control%broyden_update) THEN ! Perform a Broyden update of the inverse Jacobian J^(-1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF "// & "must be greater than or equal to 3 for Broyden optimizers.") + END IF nvar = SIZE(scf_env%outer_scf%gradient, 1) ALLOCATE (f(nvar, 1), x(nvar, 1)) DO i = 1, nvar @@ -572,31 +573,37 @@ CONTAINS cdft_control%constraint%deallocate_jacobian = scf_env%outer_scf%deallocate_jacobian IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN nvariables = SIZE(scf_env%outer_scf%inv_jacobian, 1) - IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) & + IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN ALLOCATE (cdft_control%constraint%inv_jacobian(nvariables, nvariables)) + END IF cdft_control%constraint%inv_jacobian = scf_env%outer_scf%inv_jacobian END IF ! Now switch - IF (ASSOCIATED(scf_env%outer_scf%energy)) & + IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN DEALLOCATE (scf_env%outer_scf%energy) + END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%variables)) & + IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN DEALLOCATE (scf_env%outer_scf%variables) + END IF ALLOCATE (scf_env%outer_scf%variables(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%gradient)) & + IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN DEALLOCATE (scf_env%outer_scf%gradient) + END IF ALLOCATE (scf_env%outer_scf%gradient(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%count)) & + IF (ASSOCIATED(scf_env%outer_scf%count)) THEN DEALLOCATE (scf_env%outer_scf%count) + END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = 0 ! OT SCF does not need Jacobian scf_env%outer_scf%deallocate_jacobian = .TRUE. - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN DEALLOCATE (scf_env%outer_scf%inv_jacobian) + END IF CASE (ot2cdft) ! OT -> constraint scf_control%outer_scf%have_scf = cdft_control%constraint_control%have_scf @@ -610,27 +617,32 @@ CONTAINS CALL cdft_opt_type_copy(scf_control%outer_scf%cdft_opt_control, & cdft_control%constraint_control%cdft_opt_control) nvariables = SIZE(cdft_control%constraint%variables, 1) - IF (ASSOCIATED(scf_env%outer_scf%energy)) & + IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN DEALLOCATE (scf_env%outer_scf%energy) + END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = cdft_control%constraint%energy - IF (ASSOCIATED(scf_env%outer_scf%variables)) & + IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN DEALLOCATE (scf_env%outer_scf%variables) + END IF ALLOCATE (scf_env%outer_scf%variables(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = cdft_control%constraint%variables - IF (ASSOCIATED(scf_env%outer_scf%gradient)) & + IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN DEALLOCATE (scf_env%outer_scf%gradient) + END IF ALLOCATE (scf_env%outer_scf%gradient(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = cdft_control%constraint%gradient - IF (ASSOCIATED(scf_env%outer_scf%count)) & + IF (ASSOCIATED(scf_env%outer_scf%count)) THEN DEALLOCATE (scf_env%outer_scf%count) + END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = cdft_control%constraint%count scf_env%outer_scf%iter_count = cdft_control%constraint%iter_count scf_env%outer_scf%deallocate_jacobian = cdft_control%constraint%deallocate_jacobian IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN DEALLOCATE (scf_env%outer_scf%inv_jacobian) + END IF ALLOCATE (scf_env%outer_scf%inv_jacobian(nvariables, nvariables)) scf_env%outer_scf%inv_jacobian = cdft_control%constraint%inv_jacobian END IF diff --git a/src/qs_overlap.F b/src/qs_overlap.F index 857850a5bf..6007a9739d 100644 --- a/src/qs_overlap.F +++ b/src/qs_overlap.F @@ -235,7 +235,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSEIF (PRESENT(matrixkp_s)) THEN + ELSE IF (PRESENT(matrixkp_s)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -868,7 +868,7 @@ CONTAINS IF (PRESENT(matrix_p)) THEN dokp = .FALSE. use_cell_mapping = .FALSE. - ELSEIF (PRESENT(matrixkp_p)) THEN + ELSE IF (PRESENT(matrixkp_p)) THEN dokp = .TRUE. CALL get_ks_env(ks_env=ks_env, kpoints=kpoints) CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) diff --git a/src/qs_p_env_methods.F b/src/qs_p_env_methods.F index b7e2b9a78c..7fde38663a 100644 --- a/src/qs_p_env_methods.F +++ b/src/qs_p_env_methods.F @@ -224,8 +224,9 @@ CONTAINS END DO p_env%orthogonal_orbitals = .FALSE. - IF (PRESENT(orthogonal_orbitals)) & + IF (PRESENT(orthogonal_orbitals)) THEN p_env%orthogonal_orbitals = orthogonal_orbitals + END IF CALL fm_pools_create_fm_vect(ao_mo_fm_pools, elements=p_env%S_psi0, & name="p_env%S_psi0") @@ -265,7 +266,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, p_env%local_rho_set%rho0_mpole) CALL hartree_local_create(p_env%hartree_local) CALL init_coulomb_local(p_env%hartree_local, natom) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) diff --git a/src/qs_pdos.F b/src/qs_pdos.F index 5a16f5b080..3f569ade73 100644 --- a/src/qs_pdos.F +++ b/src/qs_pdos.F @@ -579,8 +579,9 @@ CONTAINS eval_ref => mos_ref(ispin_ref)%eigenvalues occ_ref => mos_ref(ispin_ref)%occupation_numbers DO imo_ref = 1, nmo_ref - IF (occ_ref(imo_ref) > 1.0e-10_dp) & + IF (occ_ref(imo_ref) > 1.0e-10_dp) THEN hoco_ref(ispin_ref) = MAX(hoco_ref(ispin_ref), eval_ref(imo_ref)) + END IF IF (ABS(occ_ref(imo_ref) - REAL(NINT(occ_ref(imo_ref)), KIND=dp)) > & 1.0e-8_dp) fractional_occupation = .TRUE. END DO @@ -618,10 +619,12 @@ CONTAINS !Adjust energy range for r_ldos DO ildos = 1, n_r_ldos - IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) & + IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) THEN r_ldos_p(ildos)%ldos%eval_range(1) = eigenvalues(1) - IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) & + END IF + IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) THEN r_ldos_p(ildos)%ldos%eval_range(2) = eigenvalues(nmo + nvirt) + END IF END DO IF (output_unit > 0) WRITE (UNIT=output_unit, FMT='(/,(T15,A))') & diff --git a/src/qs_resp.F b/src/qs_resp.F index 971dd1768c..13843d37cc 100644 --- a/src/qs_resp.F +++ b/src/qs_resp.F @@ -396,9 +396,10 @@ CONTAINS r_val=resp_env%rheavies_strength) END IF CALL section_vals_val_get(resp_section, "STRIDE", i_vals=my_stride) - IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) & + IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) THEN CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 (the same for X,Y,Z) "// & "or 3 values. Correct your input file.") + END IF IF (SIZE(my_stride) == 1) THEN DO i = 1, 3 resp_env%stride(i) = my_stride(1) @@ -726,8 +727,9 @@ CONTAINS DO j = i + 1, num_atom atom_a = atom_list(i) atom_b = atom_list(j) - IF (atom_a == atom_b) & + IF (atom_a == atom_b) THEN CPABORT("There are atoms doubled in atom list for RESP.") + END IF END DO END DO diff --git a/src/qs_rho0_ggrid.F b/src/qs_rho0_ggrid.F index a6a8c57793..d3fa12931d 100644 --- a/src/qs_rho0_ggrid.F +++ b/src/qs_rho0_ggrid.F @@ -440,9 +440,10 @@ CONTAINS ! END IF !END IF - IF (PRESENT(local_rho_set)) & + IF (PRESENT(local_rho_set)) THEN CALL get_local_rho(local_rho_set, rho0_mpole=rho0_mpole, rho_atom_set=rho_atom_set, & rhoz_cneo_set=rhoz_cneo_set) + END IF ! Q from rho0_mpole of local_rho_set ! for TDDFT forces we need mixed potential / integral space ! potential stored on local_rho_set_2nd diff --git a/src/qs_rho_methods.F b/src/qs_rho_methods.F index 7cb0436876..f54d7afcd9 100644 --- a/src/qs_rho_methods.F +++ b/src/qs_rho_methods.F @@ -140,8 +140,9 @@ CONTAINS do_kpoints=do_kpoints, & pw_env=pw_env, & dft_control=dft_control) - IF (PRESENT(pw_env_external)) & + IF (PRESENT(pw_env_external)) THEN pw_env => pw_env_external + END IF nimg = dft_control%nimages @@ -182,8 +183,9 @@ CONTAINS ! rho_ao IF (my_rebuild_ao .OR. (.NOT. ASSOCIATED(rho_ao_kp))) THEN - IF (ASSOCIATED(rho_ao_kp)) & + IF (ASSOCIATED(rho_ao_kp)) THEN CALL dbcsr_deallocate_matrix_set(rho_ao_kp) + END IF ! Create a new density matrix set CALL dbcsr_allocate_matrix_set(rho_ao_kp, nspins, nimg) CALL qs_rho_set(rho, rho_ao_kp=rho_ao_kp) @@ -406,12 +408,12 @@ CONTAINS CALL calculate_harris_density(qs_env, harris_env%rhoin, rho_struct) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSEIF (dft_control%qs_control%semi_empirical .OR. & - dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%semi_empirical .OR. & + dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE.) - ELSEIF (dft_control%qs_control%lrigpw) THEN + ELSE IF (dft_control%qs_control%lrigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) @@ -427,7 +429,7 @@ CONTAINS CALL set_qs_env(qs_env, lri_density=lri_density) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSEIF (dft_control%qs_control%rigpw) THEN + ELSE IF (dft_control%qs_control%rigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL get_qs_env(qs_env, lri_env=lri_env) diff --git a/src/qs_scf.F b/src/qs_scf.F index 30865f773b..8c9eaf8760 100644 --- a/src/qs_scf.F +++ b/src/qs_scf.F @@ -278,8 +278,9 @@ CONTAINS scf_control%outer_scf%cdft_opt_control%ijacobian(2) = scf_control%outer_scf%cdft_opt_control%ijacobian(2) + 1 IF (scf_control%outer_scf%cdft_opt_control%ijacobian(2) >= & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) .AND. & - scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) & + scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) THEN scf_env%outer_scf%deallocate_jacobian = .TRUE. + END IF END IF END IF ! *** add the converged wavefunction to the wavefunction history @@ -317,8 +318,9 @@ CONTAINS ! *** cleanup CALL scf_env_cleanup(scf_env) - IF (dft_control%qs_control%cdft) & + IF (dft_control%qs_control%cdft) THEN CALL cdft_control_cleanup(dft_control%qs_control%cdft_control) + END IF IF (PRESENT(has_converged)) THEN has_converged = converged @@ -474,10 +476,11 @@ CONTAINS CALL get_results(results, description=description, & values=res_val_3, n_entries=i_tmp) CPASSERT(i_tmp == 3) - IF (ALL(res_val_3(:) <= 0.0)) & + IF (ALL(res_val_3(:) <= 0.0)) THEN CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)// & ") which is not correctly stored.") + END IF CALL external_comm%set_handle(NINT(res_val_3(1))) END IF ext_master_id = NINT(res_val_3(2)) @@ -578,7 +581,7 @@ CONTAINS IF (tblite_native_mixer) THEN scf_env%iter_param = dft_control%qs_control%xtb_control%tblite_mixer_damping scf_env%iter_method = "TBLite/Diag" - ELSEIF (internal_tblite_mixer) THEN + ELSE IF (internal_tblite_mixer) THEN scf_env%iter_method = "TBLite/Diag" IF (dft_control%qs_control%dftb) THEN scf_env%iter_param = dft_control%qs_control%dftb_control%tblite_mixer_damping @@ -641,8 +644,9 @@ CONTAINS END IF IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) & + scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) THEN t1 = m_walltime() + END IF ! mixing methods have the new density matrix in p_mix_new IF (scf_env%mixing_method > 0) THEN @@ -691,9 +695,10 @@ CONTAINS converged = inner_loop_converged .AND. outer_loop_converged total_scf_steps = total_steps - IF (dft_control%qs_control%cdft) & + IF (dft_control%qs_control%cdft) THEN dft_control%qs_control%cdft_control%total_steps = & - dft_control%qs_control%cdft_control%total_steps + total_steps + dft_control%qs_control%cdft_control%total_steps + total_steps + END IF IF (.NOT. converged) THEN IF (scf_control%ignore_convergence_failure .OR. should_stop) THEN @@ -715,8 +720,10 @@ CONTAINS ! if needed copy mo_coeff dbcsr->fm for later use in post_scf!fm->dbcsr DO ispin = 1, SIZE(mos) !fm -> dbcsr IF (mos(ispin)%use_mo_coeff_b) THEN !fm->dbcsr - IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) & !fm->dbcsr - CPABORT("mo_coeff_b is not allocated") !fm->dbcsr + IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) THEN + !fm->dbcsr + CPABORT("mo_coeff_b is not allocated") + END IF !fm->dbcsr CALL copy_dbcsr_to_fm(mos(ispin)%mo_coeff_b, & !fm->dbcsr mos(ispin)%mo_coeff) !fm -> dbcsr END IF !fm->dbcsr @@ -921,10 +928,11 @@ CONTAINS IF (dft_control%restricted) THEN scf_env%qs_ot_env(1)%restricted = .TRUE. ! requires rotation - IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) & + IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) THEN CALL cp_abort(__LOCATION__, & "Restricted calculation with OT requires orbital rotation. Please "// & "activate the OT%ROTATION keyword!") + END IF ELSE scf_env%qs_ot_env(:)%restricted = .FALSE. END IF @@ -934,8 +942,9 @@ CONTAINS do_rotation = scf_env%qs_ot_env(1)%settings%do_rotation ! only full all needs rotation is_full_all = scf_env%qs_ot_env(1)%settings%preconditioner_type == ot_precond_full_all - IF (do_rotation .AND. is_full_all) & + IF (do_rotation .AND. is_full_all) THEN CPABORT('PRECONDITIONER FULL_ALL is not compatible with ROTATION.') + END IF ! might need the KS matrix to init properly CALL qs_ks_update_qs_env(qs_env, just_energy=.FALSE., & @@ -943,10 +952,11 @@ CONTAINS ! if an old preconditioner is still around (i.e. outer SCF is active), ! remove it if this could be worthwhile - IF (.NOT. reuse_precond) & + IF (.NOT. reuse_precond) THEN CALL restart_preconditioner(qs_env, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & dft_control%nspins) + END IF ! ! preconditioning still needs to be done correctly with has_unit_metric @@ -958,13 +968,14 @@ CONTAINS orthogonality_metric => matrix_s(1)%matrix END IF - IF (.NOT. reuse_precond) & + IF (.NOT. reuse_precond) THEN CALL prepare_preconditioner(qs_env, mos, matrix_ks, matrix_s, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & scf_env%qs_ot_env(1)%settings%precond_solver_type, & scf_env%qs_ot_env(1)%settings%energy_gap, dft_control%nspins, & has_unit_metric=has_unit_metric, & chol_type=scf_env%qs_ot_env(1)%settings%cholesky_type) + END IF IF (reuse_precond) reuse_precond = .FALSE. CALL ot_scf_init(mo_array=mos, matrix_s=orthogonality_metric, & @@ -1203,8 +1214,9 @@ CONTAINS ! usually this means that the electronic structure has already converged to the correct state ! but the constraint optimizer keeps jumping over the optimal solution IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count == 1 & - .AND. cdft_control%total_steps /= 1) & + .AND. cdft_control%total_steps /= 1) THEN cdft_control%nreused = cdft_control%nreused - 1 + END IF ! SCF converged in less than precond_freq steps IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count <= cdft_control%precond_freq .AND. & cdft_control%total_steps /= 1 .AND. cdft_control%nreused < cdft_control%max_reuse) THEN @@ -1356,17 +1368,22 @@ CONTAINS SUBROUTINE cdft_control_cleanup(cdft_control) TYPE(cdft_control_type), POINTER :: cdft_control - IF (ASSOCIATED(cdft_control%constraint%variables)) & + IF (ASSOCIATED(cdft_control%constraint%variables)) THEN DEALLOCATE (cdft_control%constraint%variables) - IF (ASSOCIATED(cdft_control%constraint%count)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%count)) THEN DEALLOCATE (cdft_control%constraint%count) - IF (ASSOCIATED(cdft_control%constraint%gradient)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN DEALLOCATE (cdft_control%constraint%gradient) - IF (ASSOCIATED(cdft_control%constraint%energy)) & + END IF + IF (ASSOCIATED(cdft_control%constraint%energy)) THEN DEALLOCATE (cdft_control%constraint%energy) + END IF IF (ASSOCIATED(cdft_control%constraint%inv_jacobian) .AND. & - cdft_control%constraint%deallocate_jacobian) & + cdft_control%constraint%deallocate_jacobian) THEN DEALLOCATE (cdft_control%constraint%inv_jacobian) + END IF END SUBROUTINE cdft_control_cleanup @@ -1438,10 +1455,11 @@ CONTAINS IF (explicit_jacobian) THEN ! Build Jacobian with finite differences cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) & + IF (.NOT. ASSOCIATED(cdft_control)) THEN CALL cp_abort(__LOCATION__, & "Optimizers that need the explicit Jacobian can"// & " only be used together with a valid CDFT constraint.") + END IF ! Redirect output from Jacobian calculation to a new file by creating a temporary logger project_name = logger%iter_info%project_name CALL create_tmp_logger(para_env, project_name, "-JacobianInfo.out", output_unit, tmp_logger) @@ -1537,8 +1555,9 @@ CONTAINS jacobian(i, j) = jacobian(i, j)/dh(j) END DO END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) + END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) scf_control%outer_scf%cdft_opt_control%broyden_update = .FALSE. @@ -1629,22 +1648,25 @@ CONTAINS do_linesearch = .FALSE. CASE (broyden_type_1_ls, broyden_type_1_explicit_ls, broyden_type_2_ls, broyden_type_2_explicit_ls) cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) & + IF (.NOT. ASSOCIATED(cdft_control)) THEN CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & + END IF + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN do_linesearch = .TRUE. + END IF END SELECT END SELECT IF (do_linesearch) THEN BLOCK TYPE(mo_set_type), DIMENSION(:), ALLOCATABLE :: mos_ls, mos_stashed cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) & + IF (.NOT. ASSOCIATED(cdft_control)) THEN CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") + END IF CPASSERT(ASSOCIATED(scf_env%outer_scf%inv_jacobian)) CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) alpha = scf_control%outer_scf%cdft_opt_control%newton_step_save @@ -1778,8 +1800,9 @@ CONTAINS IF (i == max_linesearch) continue_ls_exit = .TRUE. ! Exit if constraint target is satisfied to requested tolerance IF (SQRT(MAXVAL(scf_env%outer_scf%gradient(:, scf_env%outer_scf%iter_count + 1)**2)) < & - scf_control%outer_scf%eps_scf) & + scf_control%outer_scf%eps_scf) THEN continue_ls_exit = .TRUE. + END IF ! Exit if line search jumped over the optimal step length IF (sign_changed) continue_ls_exit = .TRUE. END IF @@ -1835,9 +1858,10 @@ CONTAINS "Line search did not converge. CDFT SCF proceeds with fixed step size.") scf_control%outer_scf%cdft_opt_control%newton_step = scf_control%outer_scf%cdft_opt_control%newton_step_save END IF - IF (reached_maxls) & + IF (reached_maxls) THEN CALL cp_warn(__LOCATION__, & "Line search did not converge. CDFT SCF proceeds with lasted iterated step size.") + END IF CALL cp_rm_default_logger() CALL cp_logger_release(tmp_logger) ! Release temporary storage diff --git a/src/qs_scf_csr_write.F b/src/qs_scf_csr_write.F index c92135f798..557ff151d3 100644 --- a/src/qs_scf_csr_write.F +++ b/src/qs_scf_csr_write.F @@ -594,8 +594,9 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN nomirror = nomirror + 1 + END IF END DO ! create the mirror imgs diff --git a/src/qs_scf_diagonalization.F b/src/qs_scf_diagonalization.F index 0c0619c93f..fc7973f9c5 100644 --- a/src/qs_scf_diagonalization.F +++ b/src/qs_scf_diagonalization.F @@ -223,7 +223,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1124,9 +1124,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(subspace_env%mixing_store) - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, para_env) @@ -1378,7 +1378,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1476,7 +1476,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/OTdiag." - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/OTdiag." END IF @@ -1695,7 +1695,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF @@ -1917,10 +1917,11 @@ CONTAINS CALL lanczos_refinement(scf_env%krylov_space, ks, c0, c1, mo_eigenvalues, & nao, eps_iter, ispin, check_moconv_only=my_check_moconv_only) t2 = m_walltime() - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, '(T8,I3,T16,I5,T24,I6,T33,E12.4,2x,E12.4,T60,F8.3)') & - ispin, iter, scf_env%krylov_space%nmo_conv, & - scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 + ispin, iter, scf_env%krylov_space%nmo_conv, & + scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 + END IF CYCLE ELSE @@ -2038,8 +2039,9 @@ CONTAINS output_unit = cp_print_key_unit_nr(logger, scf_section, "PRINT%DAVIDSON", & extension=".scfLog") - IF (output_unit > 0) & + IF (output_unit > 0) THEN WRITE (output_unit, "(/T15,A)") '<<<<<<<<< DAVIDSON ITERATIONS <<<<<<<<<<' + END IF IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha diff --git a/src/qs_scf_initialization.F b/src/qs_scf_initialization.F index 71bed6abc6..fd63e14991 100644 --- a/src/qs_scf_initialization.F +++ b/src/qs_scf_initialization.F @@ -349,13 +349,15 @@ CONTAINS NULLIFY (outer_scf_history, gradient_history, variable_history) CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) ! Test kpoints - IF (do_kpoints) & + IF (do_kpoints) THEN CPABORT("CDFT calculation not possible with kpoints") + END IF ! Check that OUTER_SCF section in DFT&SCF is active ! This section must always be active to facilitate ! switching of the CDFT and SCF control parameters in outer_loop_switch - IF (.NOT. scf_control%outer_scf%have_scf) & + IF (.NOT. scf_control%outer_scf%have_scf) THEN CPABORT("Section SCF&OUTER_SCF must be active for CDFT calculations.") + END IF ! Initialize CDFT and outer_loop variables (constraint settings active in scf_control) IF (dft_control%qs_control%cdft_control%constraint_control%have_scf) THEN nhistory = dft_control%qs_control%cdft_control%constraint_control%max_scf + 1 @@ -660,10 +662,12 @@ CONTAINS ! possible for OT gamma point calculations qs_env%requires_mo_derivs = .FALSE. END IF - IF (dft_control%do_xas_calculation) & + IF (dft_control%do_xas_calculation) THEN CPABORT("No XAS implemented with kpoints") - IF (qs_env%do_rixs) & + END IF + IF (qs_env%do_rixs) THEN CPABORT("RIXS not implemented with kpoints") + END IF DO ik = 1, SIZE(kpoints%kp_env) CALL mpools_get(kpoints%mpools, ao_mo_fm_pools=ao_mo_fm_pools) mos_k => kpoints%kp_env(ik)%kpoint_env%mos @@ -794,12 +798,14 @@ CONTAINS IF (scf_control%use_diag) THEN ! sanity check whether combinations are allowed - IF (dft_control%restricted) & + IF (dft_control%restricted) THEN CPABORT("OT only for restricted (ROKS)") + END IF SELECT CASE (scf_control%diagonalization%method) CASE (diag_ot, diag_block_krylov, diag_block_davidson) - IF (.NOT. not_se_or_tb) & + IF (.NOT. not_se_or_tb) THEN CPABORT("TB and SE not possible with OT diagonalization") + END IF END SELECT SELECT CASE (scf_control%diagonalization%method) ! Diagonalization: additional check whether we are in an orthonormal basis @@ -820,32 +826,39 @@ CONTAINS END IF ! OT Diagonalization: not possible with ROKS CASE (diag_ot) - IF (dft_control%roks) & + IF (dft_control%roks) THEN CPABORT("ROKS with OT diagonalization not possible") - IF (do_kpoints) & + END IF + IF (do_kpoints) THEN CPABORT("OT diagonalization not possible with kpoint calculations") + END IF scf_env%method = ot_diag_method_nr need_coeff_b = .TRUE. ! Block Krylov diagonlization: not possible with ROKS, ! allocation of additional matrices is needed CASE (diag_block_krylov) - IF (dft_control%roks) & + IF (dft_control%roks) THEN CPABORT("ROKS with block PF diagonalization not possible") - IF (do_kpoints) & + END IF + IF (do_kpoints) THEN CPABORT("Block Krylov diagonalization not possible with kpoint calculations") + END IF scf_env%method = block_krylov_diag_method_nr scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%krylov_space)) & + IF (.NOT. ASSOCIATED(scf_env%krylov_space)) THEN CALL krylov_space_create(scf_env%krylov_space, scf_section) + END IF CALL krylov_space_allocate(scf_env%krylov_space, scf_control, mos) ! Block davidson diagonlization: allocation of additional matrices is needed CASE (diag_block_davidson) - IF (do_kpoints) & + IF (do_kpoints) THEN CPABORT("Block Davidson diagonalization not possible with kpoint calculations") + END IF scf_env%method = block_davidson_diag_method_nr - IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) & + IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) THEN CALL block_davidson_env_create(scf_env%block_davidson_env, dft_control%nspins, & scf_section) + END IF DO ispin = 1, dft_control%nspins CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff, nao=nao, nmo=nmo) CALL block_davidson_allocate(scf_env%block_davidson_env(ispin), mo_coeff, nao, nmo) @@ -868,24 +881,29 @@ CONTAINS ! Check if subspace diagonlization is requested: allocation of additional matrices is needed IF (scf_control%do_diag_sub) THEN scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%subspace_env)) & + IF (.NOT. ASSOCIATED(scf_env%subspace_env)) THEN CALL diag_subspace_env_create(scf_env%subspace_env, scf_section, & dft_control%qs_control%cutoff) + END IF CALL diag_subspace_allocate(scf_env%subspace_env, qs_env, mos) - IF (do_kpoints) & + IF (do_kpoints) THEN CPABORT("No subspace diagonlization with kpoint calculation") + END IF END IF ! OT: check if OT is used instead of diagonalization. Not possible with added MOS at the moment - ELSEIF (scf_control%use_ot) THEN + ELSE IF (scf_control%use_ot) THEN scf_env%method = ot_method_nr need_coeff_b = .TRUE. - IF (SUM(ABS(scf_control%added_mos)) > 0) & + IF (SUM(ABS(scf_control%added_mos)) > 0) THEN CPABORT("OT with ADDED_MOS/=0 not implemented") - IF (dft_control%restricted .AND. dft_control%nspins /= 2) & + END IF + IF (dft_control%restricted .AND. dft_control%nspins /= 2) THEN CPABORT("nspin must be 2 for restricted (ROKS)") - IF (do_kpoints) & + END IF + IF (do_kpoints) THEN CPABORT("OT not possible with kpoint calculations") - ELSEIF (scf_env%method /= smeagol_method_nr) THEN + END IF + ELSE IF (scf_env%method /= smeagol_method_nr) THEN CPABORT("OT or DIAGONALIZATION have to be set") END IF DO ispin = 1, dft_control%nspins @@ -1289,9 +1307,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(scf_env%mixing_store) - ELSEIF (dft_control%qs_control%semi_empirical) THEN + ELSE IF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & diff --git a/src/qs_scf_loop_utils.F b/src/qs_scf_loop_utils.F index 9732a0c488..148d1bc942 100644 --- a/src/qs_scf_loop_utils.F +++ b/src/qs_scf_loop_utils.F @@ -172,13 +172,13 @@ CONTAINS "SCF%DIAGONALIZATION if "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE ") - ELSEIF (dft_control%roks) THEN + ELSE IF (dft_control%roks) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE "// & "is not implemented with ROKS") - ELSEIF (scf_control%diagonalization%mom) THEN + ELSE IF (scf_control%diagonalization%mom) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & @@ -342,8 +342,9 @@ CONTAINS scf_control%eps_diis = 0.0_dp END IF - IF (dft_control%roks) & + IF (dft_control%roks) THEN CPABORT("KP code: ROKS method not available: ") + END IF SELECT CASE (scf_env%method) CASE DEFAULT @@ -370,7 +371,7 @@ CONTAINS ELSE IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSEIF (scf_env%mixing_method > 1) THEN + ELSE IF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF diff --git a/src/qs_scf_methods.F b/src/qs_scf_methods.F index bfba4f2e90..cbb13c407d 100644 --- a/src/qs_scf_methods.F +++ b/src/qs_scf_methods.F @@ -197,14 +197,16 @@ CONTAINS CASE (cholesky_reduce) CALL cp_fm_cholesky_reduce(matrix_ks_fm, ortho) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF CASE (cholesky_restore) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -213,15 +215,17 @@ CONTAINS CALL cp_fm_cholesky_restore(work, nao, ortho, matrix_ks_fm, & "SOLVE", pos="LEFT", transa="T") - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF CASE (cholesky_inverse) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -231,17 +235,19 @@ CONTAINS CALL cp_fm_triangular_multiply(ortho, matrix_ks_fm, side="L", transpose_tr=.TRUE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nao, alpha=1.0_dp) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_triangular_multiply(ortho, work, side="L", transpose_tr=.FALSE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nmo, alpha=1.0_dp) CALL cp_fm_to_fm(work, mo_coeff, nmo, 1, 1) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF END SELECT @@ -426,9 +432,10 @@ CONTAINS CALL cp_fm_symm("L", "U", nao, nao_red, 1.0_dp, matrix_ks_fm, ortho_red, 0.0_dp, work_red) CALL parallel_gemm("T", "N", nao_red, nao_red, nao, 1.0_dp, ortho_red, work_red, 0.0_dp, matrix_ks_fm_red) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm_red, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm_red) + END IF CALL cp_fm_create(work_red2, matrix_ks_fm_red%matrix_struct) ALLOCATE (eigenvalues(nao_red)) @@ -440,16 +447,18 @@ CONTAINS ELSE CALL cp_fm_symm("L", "U", nao, nao, 1.0_dp, matrix_ks_fm, ortho, 0.0_dp, work) CALL parallel_gemm("T", "N", nao, nao, nao, 1.0_dp, ortho, work, 0.0_dp, matrix_ks_fm) - IF (do_level_shift) & + IF (do_level_shift) THEN CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm) + END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL parallel_gemm("N", "N", nao, nmo, nao, 1.0_dp, ortho, work, 0.0_dp, & mo_coeff) END IF - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF END IF @@ -519,8 +528,9 @@ CONTAINS END IF - IF (do_level_shift) & + IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) + END IF CALL timestop(handle) diff --git a/src/qs_scf_output.F b/src/qs_scf_output.F index 203abdc458..60afbc842b 100644 --- a/src/qs_scf_output.F +++ b/src/qs_scf_output.F @@ -252,11 +252,13 @@ CONTAINS occup_stats_occ_threshold = 1e-6_dp IF (SIZE(tmpstringlist) > 0) THEN ! the lone_keyword_c_vals doesn't work as advertised, handle it manually print_occup_stats = .TRUE. - IF (LEN_TRIM(tmpstringlist(1)) > 0) & + IF (LEN_TRIM(tmpstringlist(1)) > 0) THEN READ (tmpstringlist(1), *) print_occup_stats + END IF END IF - IF (SIZE(tmpstringlist) > 1) & + IF (SIZE(tmpstringlist) > 1) THEN READ (tmpstringlist(2), *) occup_stats_occ_threshold + END IF logger => cp_get_default_logger() print_mo_info = (cp_print_key_should_output(logger%iter_info, dft_section, "PRINT%MO") /= 0) @@ -701,22 +703,25 @@ CONTAINS "Two-electron integral energy [eV]: ", energy%hartree*evolt, & "Electronic energy [eV]: ", & (energy%core + 0.5_dp*energy%hartree)*evolt - IF (energy%dispersion /= 0.0_dp) & + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy [eV]: ", energy%dispersion*evolt - ELSEIF (dft_control%qs_control%dftb) THEN + "Dispersion energy [eV]: ", energy%dispersion*evolt + END IF + ELSE IF (dft_control%qs_control%dftb) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "Dispersion energy: ", energy%dispersion - IF (energy%dftb3 /= 0.0_dp) & + IF (energy%dftb3 /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "DFTB3 3rd order energy: ", energy%dftb3 - IF (energy%efield /= 0.0_dp) & + "DFTB3 3rd order energy: ", energy%dftb3 + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - ELSEIF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + END IF + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & @@ -733,28 +738,31 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN + ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "DFTB3 3rd order energy: ", energy%dftb3, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%xb_interaction) & + IF (dft_control%qs_control%xtb_control%xb_interaction) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN + "Correction for halogen bonding: ", energy%xtb_xb_inter + END IF + ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN CPABORT("gfn_typ 2 NYA") ELSE CPABORT("invalid gfn_typ") END IF END IF - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - IF (energy%efield /= 0.0_dp) & + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF ELSE IF (dft_control%do_admm) THEN exc_energy = energy%exc + energy%exc_aux_fit @@ -792,22 +800,27 @@ CONTAINS "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", exc_energy END IF - IF (energy%e_hartree /= 0.0_dp) & + IF (energy%e_hartree /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,/,T3,A,T56,F25.14)") & - "Coulomb Electron-Electron Interaction Energy ", & - "- Already included in the total Hartree term ", energy%e_hartree - IF (energy%ex /= 0.0_dp) & + "Coulomb Electron-Electron Interaction Energy ", & + "- Already included in the total Hartree term ", energy%e_hartree + END IF + IF (energy%ex /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Hartree-Fock Exchange energy: ", energy%ex - IF (energy%dispersion /= 0.0_dp) & + "Hartree-Fock Exchange energy: ", energy%ex + END IF + IF (energy%dispersion /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - IF (energy%gcp /= 0.0_dp) & + "Dispersion energy: ", energy%dispersion + END IF + IF (energy%gcp /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - IF (energy%efield /= 0.0_dp) & + "gCP energy: ", energy%gcp + END IF + IF (energy%efield /= 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield + "Electric field interaction energy: ", energy%efield + END IF IF (gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "GAPW| Exc from hard and soft atomic rho1: ", exc1_energy, & @@ -1200,9 +1213,10 @@ CONTAINS WRITE (output_unit, '(A,L7)') & " Precompute gradients : ", cdft_control%becke_control%in_memory WRITE (output_unit, '(A)') " " - IF (cdft_control%becke_control%adjust) & + IF (cdft_control%becke_control%adjust) THEN WRITE (output_unit, '(A)') & - " Using atomic radii to generate a heteronuclear charge partitioning" + " Using atomic radii to generate a heteronuclear charge partitioning" + END IF WRITE (output_unit, '(A)') " " IF (.NOT. cdft_control%becke_control%cavity_confine) THEN WRITE (output_unit, '(A)') & diff --git a/src/qs_scf_post_gpw.F b/src/qs_scf_post_gpw.F index 16cd43613c..a4fe7a7a25 100644 --- a/src/qs_scf_post_gpw.F +++ b/src/qs_scf_post_gpw.F @@ -903,9 +903,9 @@ CONTAINS IF (p_loc_homo) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSEIF (dft_control%restricted & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN + ELSE IF (dft_control%restricted & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN CPABORT("ROKS works only with LOCALIZE METHOD NONE or JACOBI") ELSE ALLOCATE (occupied_orbs(dft_control%nspins)) @@ -1053,7 +1053,7 @@ CONTAINS IF (p_loc_mixed) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSEIF (dft_control%restricted) THEN + ELSE IF (dft_control%restricted) THEN IF (output_unit > 0) WRITE (output_unit, *) & " Unclear how we define MOs / localization in the restricted case... skipping" ELSE @@ -2277,7 +2277,7 @@ CONTAINS CALL section_vals_val_get(dft_section, "PRINT%DOS%NLUMO", i_val=nlumo_dos) IF (nlumo_dos == -1) THEN nlumo_required = -1 - ELSEIF (nlumo_required /= -1) THEN + ELSE IF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_dos) END IF END IF @@ -2285,7 +2285,7 @@ CONTAINS IF (defer_molden) THEN IF (nlumo_molden == -1) THEN nlumo_required = -1 - ELSEIF (nlumo_required /= -1) THEN + ELSE IF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_molden) END IF END IF @@ -3539,10 +3539,11 @@ CONTAINS IF (do_radius) THEN radius_type = radius_user CALL section_vals_val_get(input_section, "ATOMIC_RADII", r_vals=radii) - IF (.NOT. SIZE(radii) == nkind) & + IF (.NOT. SIZE(radii) == nkind) THEN CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") + END IF ELSE radius_type = radius_covalent END IF diff --git a/src/qs_scf_post_scf.F b/src/qs_scf_post_scf.F index 5287b69456..57ef526d5b 100644 --- a/src/qs_scf_post_scf.F +++ b/src/qs_scf_post_scf.F @@ -55,15 +55,15 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CALL scf_post_calculation_se(qs_env) - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CALL wfn_localization_tb(qs_env, "DFTB") CALL scf_post_calculation_tb(qs_env, "DFTB", .FALSE.) - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL wfn_localization_tb(qs_env, "xTB") CALL scf_post_calculation_tb(qs_env, "xTB", .FALSE.) - ELSEIF (dft_control%qs_control%ofgpw) THEN + ELSE IF (dft_control%qs_control%ofgpw) THEN CPWARN("No properties from PRINT section available for OFGPW methods") - ELSEIF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN + ELSE IF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN CALL optimize_lri_basis(qs_env) ELSE IF (PRESENT(wf_type)) THEN diff --git a/src/qs_scf_wfn_mix.F b/src/qs_scf_wfn_mix.F index 0830d2bd0a..5fa98ca6f2 100644 --- a/src/qs_scf_wfn_mix.F +++ b/src/qs_scf_wfn_mix.F @@ -193,10 +193,11 @@ CONTAINS ELSE IF (orig_type == wfn_mix_orig_external) THEN CALL section_vals_val_get(update_section, "ORIG_EXT_FILE_NAME", i_rep_section=i_rep, & c_val=read_file_name) - IF (read_file_name == "EMPTY") & + IF (read_file_name == "EMPTY") THEN CALL cp_abort(__LOCATION__, & "If ORIG_TYPE is set to EXTERNAL, a file name should be set in ORIG_EXT_FILE_NAME "// & "so that it can be used as the orginal MO.") + END IF ALLOCATE (mos_orig_ext(SIZE(mos))) DO ispin = 1, SIZE(mos) @@ -205,9 +206,10 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(read_file_name), exist=is_file) - IF (.NOT. is_file) & + IF (.NOT. is_file) THEN CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(read_file_name)) + END IF CALL open_file(file_name=read_file_name, & file_action="READ", & @@ -261,10 +263,12 @@ CONTAINS IF (my_for_rtp) THEN DO ispin = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) & + IF (mos_new(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) - IF (mos(1)%use_mo_coeff_b) & + END IF + IF (mos(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) + END IF END DO ELSE IF (scf_env%method == special_diag_method_nr) THEN @@ -283,11 +287,13 @@ CONTAINS DO ispin = 1, SIZE(mos_new) IF (overwrite_mos) THEN CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) & + IF (mos_new(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) + END IF END IF - IF (mos(1)%use_mo_coeff_b) & + IF (mos(1)%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) + END IF END DO CALL write_mo_set_to_restart(mos_new, particle_set, dft_section=dft_section, & qs_kind_set=qs_kind_set) diff --git a/src/qs_subsys_types.F b/src/qs_subsys_types.F index 0787f1db4f..3fb4c80a20 100644 --- a/src/qs_subsys_types.F +++ b/src/qs_subsys_types.F @@ -77,12 +77,15 @@ CONTAINS CALL cp_subsys_release(subsys%cp_subsys) CALL cell_release(subsys%cell_ref) - IF (ASSOCIATED(subsys%qs_kind_set)) & + IF (ASSOCIATED(subsys%qs_kind_set)) THEN CALL deallocate_qs_kind_set(subsys%qs_kind_set) - IF (ASSOCIATED(subsys%energy)) & + END IF + IF (ASSOCIATED(subsys%energy)) THEN CALL deallocate_qs_energy(subsys%energy) - IF (ASSOCIATED(subsys%force)) & + END IF + IF (ASSOCIATED(subsys%force)) THEN CALL deallocate_qs_force(subsys%force) + END IF END SUBROUTINE qs_subsys_release diff --git a/src/qs_tddfpt2_densities.F b/src/qs_tddfpt2_densities.F index c9c283e13b..63ce4065f6 100644 --- a/src/qs_tddfpt2_densities.F +++ b/src/qs_tddfpt2_densities.F @@ -100,8 +100,9 @@ CONTAINS END DO ! take into account that all MOs are doubly occupied in spin-restricted case - IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) & + IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) THEN CALL dbcsr_scale(rho_ij_ao(1)%matrix, 2.0_dp) + END IF CALL get_qs_env(qs_env, dft_control=dft_control) @@ -112,7 +113,7 @@ CONTAINS task_list_external=sub_env%task_list_orb_soft, & para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, local_rho_set=sub_env%local_rho_set, pw_env_sub=sub_env%pw_env) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL qs_rho_update_rho(rho_orb_struct, qs_env, & rho_xc_external=rho_xc_struct, & local_rho_set=sub_env%local_rho_set, & diff --git a/src/qs_tddfpt2_eigensolver.F b/src/qs_tddfpt2_eigensolver.F index dcfa59166d..12900d5dbb 100644 --- a/src/qs_tddfpt2_eigensolver.F +++ b/src/qs_tddfpt2_eigensolver.F @@ -779,8 +779,9 @@ CONTAINS ! eref = e_virt - e_occ - lambda = e_virt - e_occ - (eref_scale*lambda + (1-eref_scale)*lambda); ! eref_new = e_virt - e_occ - eref_scale*lambda = eref + (1 - eref_scale)*lambda - IF (ABS(eref) < threshold) & + IF (ABS(eref) < threshold) THEN eref = eref + (1.0_dp - eref_scale)*lambda + END IF weights_ldata(irow_local, icol_local) = weights_ldata(irow_local, icol_local)/eref END DO @@ -930,8 +931,9 @@ CONTAINS conv = MAXVAL(ABS(evals_last(1:nstates) - evals(1:nstates))) nvects_exist = nvects_exist + nvects_new - IF (nvects_exist + nvects_new > max_krylov_vects) & + IF (nvects_exist + nvects_new > max_krylov_vects) THEN nvects_new = max_krylov_vects - nvects_exist + END IF IF (iter >= tddfpt_control%niters) nvects_new = 0 IF (conv > tddfpt_control%conv .AND. nvects_new > 0) THEN @@ -982,8 +984,9 @@ CONTAINS IF (iter_unit > 0) THEN nstates_conv = 0 DO istate = 1, nstates - IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) & + IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) THEN nstates_conv = nstates_conv + 1 + END IF END DO WRITE (iter_unit, '(T7,I8,T24,F7.1,T40,ES11.4,T66,I8)') iter, t2 - t1, conv, nstates_conv diff --git a/src/qs_tddfpt2_fhxc.F b/src/qs_tddfpt2_fhxc.F index 6c4ba207e8..a8b9dfbad0 100644 --- a/src/qs_tddfpt2_fhxc.F +++ b/src/qs_tddfpt2_fhxc.F @@ -201,8 +201,8 @@ CONTAINS para_env_external=sub_env%para_env, & tddfpt_lri_env=kernel_env%lri_env, & tddfpt_lri_density=kernel_env%lri_density) - ELSEIF (dft_control%qs_control%lrigpw .OR. & - dft_control%qs_control%rigpw) THEN + ELSE IF (dft_control%qs_control%lrigpw .OR. & + dft_control%qs_control%rigpw) THEN CALL qs_rho_update_tddfpt(work_matrices%rho_orb_struct_sub, qs_env, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb, & @@ -216,7 +216,7 @@ CONTAINS para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, work_matrices%local_rho_set, & do_rho0=(.NOT. is_rks_triplets), pw_env_sub=sub_env%pw_env) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL qs_rho_update_rho(work_matrices%rho_orb_struct_sub, qs_env, & rho_xc_external=work_matrices%rho_xc_struct_sub, & local_rho_set=work_matrices%local_rho_set, & @@ -447,7 +447,7 @@ CONTAINS qs_env=qs_env, calculate_forces=.FALSE., gapw=gapw, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb_soft) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN IF (.NOT. is_rks_triplets) THEN CALL integrate_v_rspace(v_rspace=work_matrices%A_ia_rspace_sub(ispin), & hmat=work_matrices%A_ia_munu_sub(ispin), & diff --git a/src/qs_tddfpt2_fhxc_forces.F b/src/qs_tddfpt2_fhxc_forces.F index 535be9af2e..2bc0d14fc9 100644 --- a/src/qs_tddfpt2_fhxc_forces.F +++ b/src/qs_tddfpt2_fhxc_forces.F @@ -612,7 +612,7 @@ CONTAINS CALL qs_fgxc_analytic(rho, rhox, xc_section, weights, auxbas_pw_pool, & fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) END IF - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, & weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) @@ -633,7 +633,7 @@ CONTAINS IF (gapw .OR. gapw_xc) THEN IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, ex_env%local_rho_set%rho_atom_set, & local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, & @@ -820,7 +820,7 @@ CONTAINS END IF IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd derivatives of EXC not available") - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, & is_rks_triplets, weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau) @@ -909,7 +909,7 @@ CONTAINS IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSEIF (do_numeric) THEN + ELSE IF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, rho_atom_set, & rho_atom_set_f, rho_atom_set_g, & diff --git a/src/qs_tddfpt2_forces.F b/src/qs_tddfpt2_forces.F index 35fc7b95f1..af37574cee 100644 --- a/src/qs_tddfpt2_forces.F +++ b/src/qs_tddfpt2_forces.F @@ -907,7 +907,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, local_rho_set%rho0_mpole) CALL hartree_local_create(hartree_local) CALL init_coulomb_local(hartree_local, natom) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) diff --git a/src/qs_tddfpt2_fprint.F b/src/qs_tddfpt2_fprint.F index 8f89d0a44a..4eb8f2ab0e 100644 --- a/src/qs_tddfpt2_fprint.F +++ b/src/qs_tddfpt2_fprint.F @@ -225,9 +225,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=debug_forces) ELSE CALL response_force(qs_env=qs_env, vh_rspace=ex_env%vh_rspace, & @@ -330,9 +330,9 @@ CONTAINS CALL get_qs_env(qs_env, para_env=para_env) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT| SE not available") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT| DFTB not available") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) CALL build_xtb_ks_matrix(qs_env, calculate_forces=.TRUE., just_energy=.FALSE.) ELSE diff --git a/src/qs_tddfpt2_methods.F b/src/qs_tddfpt2_methods.F index 9ca62a9333..0d5e1af192 100644 --- a/src/qs_tddfpt2_methods.F +++ b/src/qs_tddfpt2_methods.F @@ -285,12 +285,15 @@ CONTAINS CALL kernel_info(log_unit, dft_control, tddfpt_control, xc_section) IF (do_kpoints) THEN - IF (calc_forces) & + IF (calc_forces) THEN CPABORT("TDDFPT forces are not implemented for k-points") - IF (do_rixs) & + END IF + IF (do_rixs) THEN CPABORT("RIXS/TDDFPT is not implemented for k-points") - IF (do_soc) & + END IF + IF (do_soc) THEN CPABORT("TDDFPT-SOC is not implemented for k-points") + END IF CALL tddfpt_kpoint_independent_particle(qs_env, logger, tddfpt_control) CALL cp_print_key_finished_output(log_unit, & logger, & @@ -341,8 +344,9 @@ CONTAINS ! multiplicity of molecular system IF (nspins > 1) THEN mult = ABS(SIZE(gs_mos(1)%evals_occ) - SIZE(gs_mos(2)%evals_occ)) + 1 - IF (mult > 2) & + IF (mult > 2) THEN CALL cp_warn(__LOCATION__, "There is a convergence issue for multiplicity >= 3") + END IF ELSE IF (tddfpt_control%rks_triplets) THEN mult = 3 @@ -511,7 +515,7 @@ CONTAINS state_change = .FALSE. IF (ex_env%state > 0) THEN my_state = ex_env%state - ELSEIF (ex_env%state < 0) THEN + ELSE IF (ex_env%state < 0) THEN ! state following ALLOCATE (my_mos(nspins)) DO ispin = 1, nspins @@ -634,8 +638,9 @@ CONTAINS END DO DEALLOCATE (gs_mos) - IF (ASSOCIATED(matrix_ks_oep)) & + IF (ASSOCIATED(matrix_ks_oep)) THEN CALL dbcsr_deallocate_matrix_set(matrix_ks_oep) + END IF CALL timestop(handle) @@ -681,21 +686,27 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control, input=input, kpoints=kpoints) IF (dft_control%nimages > 1) THEN - IF (tddfpt_control%kernel /= tddfpt_kernel_none) & + IF (tddfpt_control%kernel /= tddfpt_kernel_none) THEN CPABORT("TDDFPT with k-points currently supports only KERNEL NONE") + END IF CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) & + IF (use_real_wfn) THEN CPABORT("K-point TDDFPT requires complex wavefunctions") - IF (tddfpt_control%spinflip /= no_sf_tddfpt) & + END IF + IF (tddfpt_control%spinflip /= no_sf_tddfpt) THEN CPABORT("Spin-flip TDDFPT is not implemented for k-points") - IF (tddfpt_control%do_smearing) & + END IF + IF (tddfpt_control%do_smearing) THEN CPABORT("Smeared-occupation TDDFPT is not implemented for k-points") - IF (tddfpt_control%oe_corr /= oe_none) & + END IF + IF (tddfpt_control%oe_corr /= oe_none) THEN CPABORT("Orbital-energy-corrected TDDFPT is not implemented for k-points") + END IF IF (tddfpt_control%dipole_form /= 0 .AND. & tddfpt_control%dipole_form /= tddfpt_dipole_velocity .AND. & - tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) & + tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) THEN CPABORT("K-point TDDFPT supports only velocity-form or SCF_MOMENT transition dipoles") + END IF END IF IF (tddfpt_control%nstates <= 0) THEN @@ -710,8 +721,9 @@ CONTAINS IF (dft_control%nimages > 1) THEN IF (tddfpt_control%do_exciton_descriptors .OR. & - tddfpt_control%do_directional_exciton_descriptors) & + tddfpt_control%do_directional_exciton_descriptors) THEN CPABORT("Exciton descriptors are not implemented for k-point TDDFPT") + END IF print_sub => section_vals_get_subs_vals(tddfpt_print_section, "NTO_ANALYSIS") CALL section_vals_get(print_sub, explicit=explicit) IF (explicit) CPABORT("NTO analysis is not implemented for k-point TDDFPT") @@ -1074,13 +1086,15 @@ CONTAINS ntrans_kpoint = 0 DO ispin = 1, nspins nvirt_spin(ispin) = nmo_spin(ispin) - homo_spin(ispin) - IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) & + IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) THEN CPABORT("At least one occupied and one unoccupied MO are required for k-point TDDFPT") + END IF ntrans_kpoint = ntrans_kpoint + homo_spin(ispin)*nvirt_spin(ispin) END DO ntrans_total = nkp*ntrans_kpoint - IF (ntrans_total <= 0) & + IF (ntrans_total <= 0) THEN CPABORT("No independent-particle k-point transitions available") + END IF ALLOCATE (transition_energy(ntrans_total), transition_dipole_re(ntrans_total, nderivs), & transition_dipole_im(ntrans_total, nderivs), oscillator_strength(ntrans_total), & @@ -1143,8 +1157,9 @@ CONTAINS IF (my_kpgrp) THEN CALL get_mo_set(mos_kp(1, ispin), eigenvalues=eigenvalues) CPASSERT(ASSOCIATED(eigenvalues)) - IF (para_env_kp%is_source()) & + IF (para_env_kp%is_source()) THEN eigenvalues_kp(1:nmo_spin(ispin)) = eigenvalues(1:nmo_spin(ispin)) + END IF IF (.NOT. use_scf_moment_dipoles) THEN CALL get_mo_set(mos_kp(1, ispin), mo_coeff=mo_coeff_re) CALL get_mo_set(mos_kp(2, ispin), mo_coeff=mo_coeff_im) @@ -1206,8 +1221,9 @@ CONTAINS trans_index = (ikp - 1)*ntrans_kpoint + spin_offset + & (iocc - 1)*nvirt_spin(ispin) + ivirt - homo_spin(ispin) gap = eigenvalues_kp(ivirt) - eigenvalues_kp(iocc) - IF (gap <= 0.0_dp) & + IF (gap <= 0.0_dp) THEN CPABORT("K-point TDDFPT requires positive occupied-virtual energy gaps") + END IF IF (use_scf_moment_dipoles) THEN oscillator_factor = SQRT(spin_factor*wkp(ikp)) dipole_re = REAL(kpoint_dipole(ispin, ikp, ideriv, iocc, ivirt), KIND=dp) @@ -1245,8 +1261,9 @@ CONTAINS END DO END DO - IF (ANY(transition_energy <= 0.0_dp)) & + IF (ANY(transition_energy <= 0.0_dp)) THEN CPABORT("K-point TDDFPT KERNEL NONE requires positive occupied-virtual energy gaps") + END IF CALL sort(transition_energy, ntrans_total, inds) nstates = MIN(tddfpt_control%nstates, ntrans_total) @@ -1971,7 +1988,7 @@ CONTAINS DO ispin = 1, nspins CPASSERT(.NOT. ASSOCIATED(gs_mos(ispin)%evals_occ_matrix)) END DO - ELSEIF (ewcut) THEN + ELSE IF (ewcut) THEN ! Filter orbitals wrt energy window DO ispin = 1, nspins DO i = 1, gs_mos(ispin)%nmo_occ diff --git a/src/qs_tddfpt2_properties.F b/src/qs_tddfpt2_properties.F index 0ea5e1abef..3f32e85a70 100644 --- a/src/qs_tddfpt2_properties.F +++ b/src/qs_tddfpt2_properties.F @@ -835,8 +835,9 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc - 1 /= para_env%mepos) & + IF (iproc - 1 /= para_env%mepos) THEN CALL recv_handlers(iproc)%wait() + END IF END DO ! compute total number of non-negligible excitations @@ -936,8 +937,9 @@ CONTAINS END IF ! deallocate temporary arrays - IF (para_env%is_source()) & + IF (para_env%is_source()) THEN DEALLOCATE (weights_recv, weights_neg_abs_recv, inds_recv, inds) + END IF END DO DEALLOCATE (weights_local, inds_local) @@ -1525,7 +1527,7 @@ CONTAINS cell, dft_control, particle_set, pw_env) IF (iset == 1) THEN WRITE (filename, '(a4,I3.3,I2.2,a11)') "NTO_STATE", istate, i, "_Hole_State" - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (filename, '(a4,I3.3,I2.2,a15)') "NTO_STATE", istate, i, "_Particle_State" END IF mpi_io = .TRUE. @@ -1534,7 +1536,7 @@ CONTAINS log_filename=.FALSE., ignore_should_output=.TRUE., mpi_io=mpi_io) IF (iset == 1) THEN WRITE (title, *) "Natural Transition Orbital Hole State", i - ELSEIF (iset == 2) THEN + ELSE IF (iset == 2) THEN WRITE (title, *) "Natural Transition Orbital Particle State", i END IF CALL cp_pw_to_cube(wf_r, unit_nr, title, particles=particles, stride=stride, mpi_io=mpi_io) diff --git a/src/qs_tddfpt2_restart.F b/src/qs_tddfpt2_restart.F index 8ed2934237..4c2e0a02f5 100644 --- a/src/qs_tddfpt2_restart.F +++ b/src/qs_tddfpt2_restart.F @@ -294,8 +294,9 @@ CONTAINS END DO END DO - IF (para_env_global%is_source()) & + IF (para_env_global%is_source()) THEN CALL close_file(unit_number=iunit) + END IF CALL timestop(handle) @@ -634,11 +635,13 @@ CONTAINS sum_sign_array(icol_global) = sum_sign_array(icol_global) + sign_int IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) & + IF (minrow_pos_array(icol_global) > irow_global) THEN minrow_pos_array(icol_global) = irow_global + END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) & + IF (minrow_neg_array(icol_global) > irow_global) THEN minrow_neg_array(icol_global) = irow_global + END IF END IF END DO diff --git a/src/qs_tddfpt2_stda_types.F b/src/qs_tddfpt2_stda_types.F index 333da363e7..c175409e56 100644 --- a/src/qs_tddfpt2_stda_types.F +++ b/src/qs_tddfpt2_stda_types.F @@ -277,8 +277,9 @@ CONTAINS TYPE(stda_kind_type), POINTER :: kind_param - IF (ASSOCIATED(kind_param)) & + IF (ASSOCIATED(kind_param)) THEN CALL deallocate_stda_kind_param(kind_param) + END IF ALLOCATE (kind_param) diff --git a/src/qs_tddfpt2_stda_utils.F b/src/qs_tddfpt2_stda_utils.F index 68840bfd85..c98d3e93ef 100644 --- a/src/qs_tddfpt2_stda_utils.F +++ b/src/qs_tddfpt2_stda_utils.F @@ -252,7 +252,7 @@ CONTAINS IF (dr < 1.e-6) THEN ! on site terms gblock(:, :) = gblock(:, :) + eta - ELSEIF (dr > rcut) THEN + ELSE IF (dr > rcut) THEN ! do nothing ELSE IF (dr < rcut - rsmooth) THEN @@ -408,10 +408,11 @@ CONTAINS CALL cp_fm_struct_release(fmstruct=fmstruct) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) & + IF (ndep /= 0) THEN CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") + END IF CALL copy_fm_to_dbcsr(fm_s_half, sm_h) CALL cp_fm_release(fm_s_half) CALL cp_fm_release(fm_work1) diff --git a/src/qs_tddfpt2_subgroups.F b/src/qs_tddfpt2_subgroups.F index 009f80a27c..6097231eb9 100644 --- a/src/qs_tddfpt2_subgroups.F +++ b/src/qs_tddfpt2_subgroups.F @@ -302,8 +302,9 @@ CONTAINS NULLIFY (sub_env%task_list_orb_soft, sub_env%task_list_aux_fit_soft) IF (sub_env%is_mgrid) THEN - IF (tddfpt_control%mgrid_is_explicit) & + IF (tddfpt_control%mgrid_is_explicit) THEN CALL init_tddfpt_mgrid(qs_control, tddfpt_control, mgrid_saved) + END IF IF (ASSOCIATED(weights)) THEN CPABORT('Redefining MGRID and integration weights not compatible') @@ -344,8 +345,9 @@ CONTAINS END IF END IF - IF (tddfpt_control%mgrid_is_explicit) & + IF (tddfpt_control%mgrid_is_explicit) THEN CALL restore_qs_mgrid(qs_control, mgrid_saved) + END IF ELSE CALL pw_env_retain(pw_env_global) sub_env%pw_env => pw_env_global @@ -380,7 +382,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, sub_env%local_rho_set%rho0_mpole) CALL hartree_local_create(sub_env%hartree_local) CALL init_coulomb_local(sub_env%hartree_local, natom) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -448,17 +450,21 @@ CONTAINS CALL timeset(routineN, handle) IF (sub_env%is_mgrid) THEN - IF (ASSOCIATED(sub_env%task_list_aux_fit)) & + IF (ASSOCIATED(sub_env%task_list_aux_fit)) THEN CALL deallocate_task_list(sub_env%task_list_aux_fit) + END IF - IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) & + IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) THEN CALL deallocate_task_list(sub_env%task_list_aux_fit_soft) + END IF - IF (ASSOCIATED(sub_env%task_list_orb)) & + IF (ASSOCIATED(sub_env%task_list_orb)) THEN CALL deallocate_task_list(sub_env%task_list_orb) + END IF - IF (ASSOCIATED(sub_env%task_list_orb_soft)) & + IF (ASSOCIATED(sub_env%task_list_orb_soft)) THEN CALL deallocate_task_list(sub_env%task_list_orb_soft) + END IF CALL release_neighbor_list_sets(sub_env%sab_aux_fit) CALL release_neighbor_list_sets(sub_env%sab_orb) @@ -468,8 +474,9 @@ CONTAINS DEALLOCATE (sub_env%dbcsr_dist) END IF - IF (ASSOCIATED(sub_env%dist_2d)) & + IF (ASSOCIATED(sub_env%dist_2d)) THEN CALL distribution_2d_release(sub_env%dist_2d) + END IF END IF ! GAPW @@ -512,8 +519,9 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) & + IF (ALLOCATED(sub_env%group_distribution)) THEN DEALLOCATE (sub_env%group_distribution) + END IF sub_env%is_split = .FALSE. @@ -578,8 +586,9 @@ CONTAINS END DO ! igrid == 0 if qs_control%cutoff is larger than the largest manually provided cutoff value; ! use the largest actual value - IF (igrid <= 0) & + IF (igrid <= 0) THEN qs_control%cutoff = qs_control%e_cutoff(1) + END IF ELSE qs_control%e_cutoff(1) = qs_control%cutoff DO igrid = 2, ngrids @@ -607,8 +616,9 @@ CONTAINS CALL timeset(routineN, handle) - IF (ASSOCIATED(qs_control%e_cutoff)) & + IF (ASSOCIATED(qs_control%e_cutoff)) THEN DEALLOCATE (qs_control%e_cutoff) + END IF qs_control%commensurate_mgrids = mgrid_saved%commensurate_mgrids qs_control%realspace_mgrids = mgrid_saved%realspace_mgrids diff --git a/src/qs_tddfpt2_types.F b/src/qs_tddfpt2_types.F index 0a9790800e..19ea44ddac 100644 --- a/src/qs_tddfpt2_types.F +++ b/src/qs_tddfpt2_types.F @@ -465,7 +465,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, work_matrices%local_rho_set%rho0_mpole) CALL hartree_local_create(work_matrices%hartree_local) CALL init_coulomb_local(work_matrices%hartree_local, natom) - ELSEIF (dft_control%qs_control%gapw_xc) THEN + ELSE IF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -939,8 +939,9 @@ CONTAINS CALL cp_fm_release(work_matrices%slambda) DEALLOCATE (work_matrices%slambda) END IF - IF (ASSOCIATED(work_matrices%S_eigenvalues)) & + IF (ASSOCIATED(work_matrices%S_eigenvalues)) THEN DEALLOCATE (work_matrices%S_eigenvalues) + END IF ! Ewald IF (ASSOCIATED(work_matrices%ewald_env)) THEN CALL ewald_env_release(work_matrices%ewald_env) diff --git a/src/qs_tddfpt2_utils.F b/src/qs_tddfpt2_utils.F index 4a98dbc280..814d6db052 100644 --- a/src/qs_tddfpt2_utils.F +++ b/src/qs_tddfpt2_utils.F @@ -297,12 +297,14 @@ CONTAINS CALL section_vals_val_get(print_section, "NAMD_PRINT%PRINT_PHASES", l_val=print_phases) nmo_virt = nao - nmo_occ - IF (nlumo >= 0) & + IF (nlumo >= 0) THEN nmo_virt = MIN(nmo_virt, nlumo) + END IF - IF (nmo_virt <= 0) & + IF (nmo_virt <= 0) THEN CALL cp_abort(__LOCATION__, & 'At least one unoccupied molecular orbital is required to calculate excited states.') + END IF do_eigen = .FALSE. ! diagonalise the Kohn-Sham matrix one more time if the number of available unoccupied states are too small @@ -426,11 +428,13 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) & + IF (minrow_pos_array(icol_global) > irow_global) THEN minrow_pos_array(icol_global) = irow_global + END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) & + IF (minrow_neg_array(icol_global) > irow_global) THEN minrow_neg_array(icol_global) = irow_global + END IF END IF END DO END DO @@ -508,11 +512,13 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) & + IF (minrow_pos_array(icol_global) > irow_global) THEN minrow_pos_array(icol_global) = irow_global + END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) & + IF (minrow_neg_array(icol_global) > irow_global) THEN minrow_neg_array(icol_global) = irow_global + END IF END IF END DO END DO @@ -570,20 +576,25 @@ CONTAINS CALL timeset(routineN, handle) - IF (ALLOCATED(gs_mos%phases_occ)) & + IF (ALLOCATED(gs_mos%phases_occ)) THEN DEALLOCATE (gs_mos%phases_occ) + END IF - IF (ALLOCATED(gs_mos%evals_virt)) & + IF (ALLOCATED(gs_mos%evals_virt)) THEN DEALLOCATE (gs_mos%evals_virt) + END IF - IF (ALLOCATED(gs_mos%evals_occ)) & + IF (ALLOCATED(gs_mos%evals_occ)) THEN DEALLOCATE (gs_mos%evals_occ) + END IF - IF (ALLOCATED(gs_mos%phases_virt)) & + IF (ALLOCATED(gs_mos%phases_virt)) THEN DEALLOCATE (gs_mos%phases_virt) + END IF - IF (ALLOCATED(gs_mos%index_active)) & + IF (ALLOCATED(gs_mos%index_active)) THEN DEALLOCATE (gs_mos%index_active) + END IF IF (ASSOCIATED(gs_mos%evals_occ_matrix)) THEN CALL cp_fm_release(gs_mos%evals_occ_matrix) @@ -686,9 +697,9 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT with SE not possible") - ELSEIF (dft_control%qs_control%dftb) THEN + ELSE IF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT with DFTB not possible") - ELSEIF (dft_control%qs_control%xtb) THEN + ELSE IF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., & ext_ks_matrix=matrix_ks_oep) @@ -1132,9 +1143,10 @@ CONTAINS DO istate = 1, nstates IF (ASSOCIATED(evects(1, istate)%matrix_struct)) THEN ! Initial guess vector read from restart file - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(T7,I8,T28,A19,T60,F14.5)') & - istate, "*** restarted ***", evals(istate)*evolt + istate, "*** restarted ***", evals(istate)*evolt + END IF ELSE ! New initial guess vector ! @@ -1166,9 +1178,10 @@ CONTAINS ! Assign initial guess for excitation energy evals(istate) = e_virt_minus_occ(istate) - IF (log_unit > 0) & + IF (log_unit > 0) THEN WRITE (log_unit, '(T7,I8,T24,I8,T37,A5,T45,I8,T54,A5,T60,F14.5)') & - istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt + istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt + END IF DO jspin = 1, SIZE(evects, 1) ! .NOT. ASSOCIATED(evects(jspin, istate)%matrix_struct)) diff --git a/src/qs_tensors.F b/src/qs_tensors.F index ca92892f16..01298654b6 100644 --- a/src/qs_tensors.F +++ b/src/qs_tensors.F @@ -713,7 +713,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -722,7 +722,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1030,7 +1030,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1039,7 +1039,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1262,7 +1262,7 @@ CONTAINS IF (do_kpoints_prv) THEN prefac = 0.5_dp - ELSEIF (nl_3c%sym == symmetric_jk) THEN + ELSE IF (nl_3c%sym == symmetric_jk) THEN IF (jatom == katom) THEN prefac = 0.5_dp ELSE @@ -1548,7 +1548,7 @@ CONTAINS END DO END DO - ELSEIF (nl_3c%sym == symmetric_jk) THEN + ELSE IF (nl_3c%sym == symmetric_jk) THEN !Add the transpose of t3c_der_j to t3c_der_k to get the fully populated tensor CALL dbt_create(t3c_der_k(1, 1, 1), t3c_tmp) DO i_xyz = 1, 3 @@ -1567,7 +1567,7 @@ CONTAINS END DO CALL dbt_destroy(t3c_tmp) - ELSEIF (nl_3c%sym == symmetric_none) THEN + ELSE IF (nl_3c%sym == symmetric_none) THEN DO i_xyz = 1, 3 DO kcell = 1, ncell_RI DO jcell = 1, nimg @@ -1701,7 +1701,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1710,7 +1710,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2238,7 +2238,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN + ELSE IF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2247,7 +2247,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN + ELSE IF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2454,7 +2454,7 @@ CONTAINS ELSE prefac = 1.0_dp END IF - ELSEIF (nl_3c%sym == symmetric_ij) THEN + ELSE IF (nl_3c%sym == symmetric_ij) THEN IF (iatom == jatom) THEN ! factor 0.5 due to double-counting of diagonal blocks ! (we desymmetrize by adding transpose) @@ -2689,13 +2689,13 @@ CONTAINS END DO CALL dbt_destroy(t_3c_tmp) END IF - ELSEIF (nl_3c%sym == symmetric_ij) THEN + ELSE IF (nl_3c%sym == symmetric_ij) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps/2) END DO END DO - ELSEIF (nl_3c%sym == symmetric_none) THEN + ELSE IF (nl_3c%sym == symmetric_none) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps) diff --git a/src/qs_update_s_mstruct.F b/src/qs_update_s_mstruct.F index dd9017adf9..bee9f33d9e 100644 --- a/src/qs_update_s_mstruct.F +++ b/src/qs_update_s_mstruct.F @@ -227,8 +227,9 @@ CONTAINS IF (ASSOCIATED(qs_env%kg_env%subset)) THEN DO isub = 1, qs_env%kg_env%nsubsets - IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) & + IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) THEN CALL deallocate_task_list(qs_env%kg_env%subset(isub)%task_list) + END IF END DO ELSE ALLOCATE (qs_env%kg_env%subset(qs_env%kg_env%nsubsets)) diff --git a/src/qs_vcd_utils.F b/src/qs_vcd_utils.F index 379326e61d..75b0ff3b6c 100644 --- a/src/qs_vcd_utils.F +++ b/src/qs_vcd_utils.F @@ -153,8 +153,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "MAGNETIC_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) & + IF (reference == use_mom_ref_user) THEN CPABORT("User-defined reference point should be given explicitly") + END IF END IF CALL get_reference_point(rpoint=vcd_env%magnetic_origin, qs_env=qs_env, & @@ -167,8 +168,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "SPATIAL_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) & + IF (reference == use_mom_ref_user) THEN CPABORT("User-defined reference point should be given explicitly") + END IF END IF CALL get_reference_point(rpoint=vcd_env%spatial_origin, qs_env=qs_env, & @@ -824,9 +826,10 @@ CONTAINS + apt_total_nvpt(2, 2, l) & + apt_total_nvpt(3, 3, l))/3._dp DO i = 1, 3 - IF (vcd_env%output_unit > 0) & + IF (vcd_env%output_unit > 0) THEN WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", apt_total_nvpt(i, :, l) + "NVP | ", apt_total_nvpt(i, :, l) + END IF END DO END DO @@ -836,9 +839,10 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'NVP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) & + IF (vcd_env%output_unit > 0) THEN WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) + "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) + END IF END DO END DO @@ -849,9 +853,10 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'MFP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) & + IF (vcd_env%output_unit > 0) THEN WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "MFP | ", vcd_env%aat_atom_mfp(i, :, l) + "MFP | ", vcd_env%aat_atom_mfp(i, :, l) + END IF END DO END DO END IF diff --git a/src/qs_vxc.F b/src/qs_vxc.F index 924ff307d4..a3410e78ac 100644 --- a/src/qs_vxc.F +++ b/src/qs_vxc.F @@ -206,11 +206,13 @@ CONTAINS ! test if the real space density is available CPASSERT(ASSOCIATED(rho_struct)) - IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) & + IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) THEN CPABORT("nspins must be 1 or 2") + END IF mspin = SIZE(rho_struct_r) - IF (dft_control%nspins == 2 .AND. mspin == 1) & + IF (dft_control%nspins == 2 .AND. mspin == 1) THEN CPABORT("Spin count mismatch") + END IF ! there are some options related to SIC here. ! Normal DFT computes E(rho_alpha,rho_beta) (or its variant E(2*rho_alpha) for non-LSD) @@ -242,8 +244,9 @@ CONTAINS sic_scaling_b_zero = .FALSE. END IF - IF (PRESENT(pw_env_external)) & + IF (PRESENT(pw_env_external)) THEN pw_env => pw_env_external + END IF CALL pw_env_get(pw_env, xc_pw_pool=xc_pw_pool, auxbas_pw_pool=auxbas_pw_pool) uf_grid = .NOT. pw_grid_compare(auxbas_pw_pool%pw_grid, xc_pw_pool%pw_grid) @@ -759,7 +762,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_struct_g, rho_r, rho_g) - ELSEIF (ASSOCIATED(rho_struct_r)) THEN + ELSE IF (ASSOCIATED(rho_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho_struct_r, rho_r, rho_g) ELSE CPABORT("Fine Grid in qs_xc_density requires rho_r or rho_g") @@ -767,7 +770,7 @@ CONTAINS IF (tau_r_valid) THEN IF (tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau_struct_g, tau_r, tau_g) - ELSEIF (ASSOCIATED(tau_struct_r)) THEN + ELSE IF (ASSOCIATED(tau_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau_struct_r, tau_r, tau_g) ELSE CPABORT("Fine Grid in qs_xc_density requires tau_r or tau_g") diff --git a/src/qs_vxc_atom.F b/src/qs_vxc_atom.F index 77ca466195..34110e06a9 100644 --- a/src/qs_vxc_atom.F +++ b/src/qs_vxc_atom.F @@ -15,6 +15,8 @@ MODULE qs_vxc_atom USE basis_set_types, ONLY: get_gto_basis_set,& gto_basis_set_type USE cp_control_types, ONLY: dft_control_type + USE external_potential_types, ONLY: gth_potential_type,& + sgp_potential_type USE input_constants, ONLY: xc_none USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type,& @@ -120,14 +122,16 @@ CONTAINS INTEGER :: bo(2), gapw_density_partition, handle, & iat, iatom, idir, ikind, ir, jdir, & - myfun, na, natom, nr, nspins, num_pe + myfun, na, natom, nr, nspins, num_pe, & + zatom INTEGER, DIMENSION(2, 3) :: bounds INTEGER, DIMENSION(:), POINTER :: atom_list LOGICAL :: accint, donlcc, evaluate_hard, evaluate_soft, gradient_f, lsd, & my_calculate_forces, nlcc, paw_atom, skala_atom_grid, tau_f, use_virial REAL(dp) :: agr, alpha, density_cut, exc_h, exc_s, & gradient_cut, & - my_adiabatic_rescale_factor, tau_cut + my_adiabatic_rescale_factor, tau_cut, & + zeff REAL(dp), DIMENSION(1, 1, 1) :: tau_d REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d REAL(dp), DIMENSION(3) :: skala_atom_force_h, skala_atom_force_s @@ -140,6 +144,7 @@ CONTAINS TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(dft_control_type), POINTER :: dft_control TYPE(grid_atom_type), POINTER :: grid_atom + TYPE(gth_potential_type), POINTER :: gth_potential TYPE(gto_basis_set_type), POINTER :: basis_1c TYPE(harmonics_atom_type), POINTER :: harmonics TYPE(mp_para_env_type), POINTER :: para_env @@ -151,6 +156,7 @@ CONTAINS TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set TYPE(rho_atom_type), POINTER :: rho_atom TYPE(section_vals_type), POINTER :: input, my_xc_section, xc_fun_section + TYPE(sgp_potential_type), POINTER :: sgp_potential TYPE(tau_basis_cache_type) :: tau_basis_cache TYPE(virial_type), POINTER :: virial TYPE(xc_derivative_set_type) :: deriv_set @@ -165,6 +171,7 @@ CONTAINS NULLIFY (my_kind_set) NULLIFY (atomic_kind_set) NULLIFY (grid_atom) + NULLIFY (gth_potential) NULLIFY (force) NULLIFY (harmonics) NULLIFY (input) @@ -173,6 +180,7 @@ CONTAINS NULLIFY (rho_atom) NULLIFY (my_rho_atom_set) NULLIFY (rho_nlcc) + NULLIFY (sgp_potential) NULLIFY (virial) my_calculate_forces = .FALSE. IF (PRESENT(calculate_forces)) my_calculate_forces = calculate_forces @@ -250,11 +258,17 @@ CONTAINS DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom) + NULLIFY (gth_potential, sgp_potential) CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, & - harmonics=harmonics, grid_atom=grid_atom) + gth_potential=gth_potential, harmonics=harmonics, & + grid_atom=grid_atom, sgp_potential=sgp_potential, & + zatom=zatom, zeff=zeff) CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C") IF (.NOT. paw_atom) CYCLE + IF (skala_atom_grid .AND. & + (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. & + ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE nr = grid_atom%nr na = grid_atom%ng_sphere @@ -982,7 +996,7 @@ CONTAINS lsd = .TRUE. scale_rho = .TRUE. END IF - ELSEIF (PRESENT(do_triplet)) THEN + ELSE IF (PRESENT(do_triplet)) THEN IF (nspins == 1 .AND. do_triplet) lsd = .TRUE. END IF diff --git a/src/qs_wannier90.F b/src/qs_wannier90.F index b2c7989282..ad9bb42de0 100644 --- a/src/qs_wannier90.F +++ b/src/qs_wannier90.F @@ -57,8 +57,9 @@ MODULE qs_wannier90 kpoint_initialize_mo_set,& kpoint_initialize_mos,& rskp_transform + USE kpoint_mo_symmetry_methods, ONLY: kpoint_same_periodic,& + kpoint_transform_scf_mo USE kpoint_types, ONLY: get_kpoint_info,& - kind_rotmat_type,& kpoint_create,& kpoint_env_type,& kpoint_release,& @@ -1168,12 +1169,12 @@ CONTAINS num_candidates = 0 ! Little-group operations can reach the same target k-point; keep the first valid eigenspace. DO isym_try = 1, kpsym%nwred - IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & + IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE num_candidates = num_candidates + 1 - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, & - candidate_reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, & + candidate_reason) IF (.NOT. ok) THEN reason = candidate_reason CYCLE @@ -1191,9 +1192,9 @@ CONTAINS END IF IF (.NOT. ok) THEN IF (source_window) THEN - CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, & - dst_real_full, dst_imag_full, qs_kpoint, & - ikred, isym_try, para_env, ok, candidate_reason) + CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, & + dst_real_full, dst_imag_full, qs_kpoint, & + ikred, isym_try, para_env, ok, candidate_reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, & dst_real, dst_imag, matrix_s, & @@ -1232,15 +1233,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) - ELSEIF (.NOT. ok .AND. num_candidates == 0) THEN + ELSE IF (.NOT. ok .AND. num_candidates == 0) THEN reason = "no matching SCF symmetry operation candidate" END IF ELSE reason = "SCF k-point symmetry operation is not available" END IF ELSE - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) END IF IF (ok .AND. sym_index(ik) <= 0) THEN ! Even a direct k-point copy must be a closed H(k),S(k) subspace. This catches @@ -1251,9 +1252,9 @@ CONTAINS ok, reason, aligned_blocks, aligned_max_size, & aligned_min_svalue, candidate_residual) IF (.NOT. ok .AND. source_window) THEN - CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, dst_real_full, & - dst_imag_full, qs_kpoint, ikred, sym_index(ik), & - para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, dst_real_full, & + dst_imag_full, qs_kpoint, ikred, sym_index(ik), & + para_env, ok, reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, dst_real, & dst_imag, matrix_s, matrix_ks, & @@ -1262,7 +1263,7 @@ CONTAINS reason, source_window_min_svalue, & candidate_residual) END IF - ELSEIF (.NOT. ok) THEN + ELSE IF (.NOT. ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real, dst_imag, dst_real, dst_imag, & matrix_s, matrix_ks, kpoint%xkp(1:3, ik), & cell_to_index, sab_nl, ispin, & @@ -1723,8 +1724,8 @@ CONTAINS best_residual = 0.0_dp best_svalue = 0.0_dp IF (sym_index(ik) <= 0) THEN - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) IF (ok) THEN CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, matrix_s, & kpoint%xkp(1:3, ik), cell_to_index, sab_nl, & @@ -1752,14 +1753,14 @@ CONTAINS END IF END IF END IF - ELSEIF (ASSOCIATED(qs_kpoint%kp_sym)) THEN + ELSE IF (ASSOCIATED(qs_kpoint%kp_sym)) THEN kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym IF (ASSOCIATED(kpsym)) THEN DO isym_try = 1, kpsym%nwred - IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & + IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE - CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, reason) + CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, reason) IF (.NOT. ok) CYCLE CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, & matrix_s, kpoint%xkp(1:3, ik), cell_to_index, & @@ -2615,7 +2616,7 @@ CONTAINS ik_match = 0 DO ik = 1, SIZE(xkp_mesh, 2) - IF (same_periodic_kpoint(xkp_mesh(1:3, ik), xkp_search)) THEN + IF (kpoint_same_periodic(xkp_mesh(1:3, ik), xkp_search)) THEN ik_match = ik RETURN END IF @@ -2623,209 +2624,6 @@ CONTAINS END FUNCTION find_matching_kpoint -! ************************************************************************************************** -!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. -!> \param xkp_a first k-point -!> \param xkp_b second k-point -!> \return true if the k-points are equivalent -! ************************************************************************************************** - LOGICAL FUNCTION same_periodic_kpoint(xkp_a, xkp_b) RESULT(same) - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b - - REAL(KIND=dp), DIMENSION(3) :: diff - - diff(1:3) = xkp_a(1:3) - xkp_b(1:3) - diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) - same = SUM(ABS(diff(1:3))) < 1.0e-8_dp - - END FUNCTION same_periodic_kpoint - -! ************************************************************************************************** -!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. -!> \param src_real real part of source MO coefficients -!> \param src_imag imaginary part of source MO coefficients -!> \param dst_real real part of transformed MO coefficients -!> \param dst_imag imaginary part of transformed MO coefficients -!> \param qs_kpoint SCF k-point object containing symmetry operations -!> \param ikred representative k-point index -!> \param isym symmetry operation index; 0 direct copy, -1 time reversal -!> \param para_env global parallel environment -!> \param success true if the transformation was performed -!> \param reason diagnostic message -! ************************************************************************************************** - SUBROUTINE transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & - isym, para_env, success, reason) - TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: ikred, isym - TYPE(mp_para_env_type), POINTER :: para_env - LOGICAL, INTENT(OUT) :: success - CHARACTER(LEN=*), INTENT(OUT) :: reason - - INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & - nmo, rot_slot, source_atom, source_dim, target_atom, target_dim - INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start - LOGICAL :: reverse_phase, time_reversal - REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & - phase_imag, phase_real, sinkl - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r - REAL(KIND=dp), DIMENSION(3) :: xkp_phase - REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat - TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot - TYPE(kpoint_sym_type), POINTER :: kpsym - - success = .FALSE. - reason = "" - IF (isym == 0) THEN - CALL cp_fm_copy_general(src_real, dst_real, para_env) - CALL cp_fm_copy_general(src_imag, dst_imag, para_env) - success = .TRUE. - RETURN - END IF - - CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) - ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) - CALL cp_fm_get_submatrix(src_real, src_r) - CALL cp_fm_get_submatrix(src_imag, src_i) - dst_r(:, :) = 0.0_dp - dst_i(:, :) = 0.0_dp - - IF (isym == -1) THEN - dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) - dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i) - success = .TRUE. - RETURN - END IF - - IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN - reason = "SCF symmetry operation data are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym - IF (.NOT. ASSOCIATED(kpsym)) THEN - reason = "SCF k-point symmetry operation is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (isym > kpsym%nwred) THEN - reason = "SCF k-point symmetry operation index is out of range" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN - reason = "SCF atom mappings or basis rotation matrices are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - - rot_slot = find_wannier90_rotation_slot(qs_kpoint, kpsym%rotp(isym)) - IF (rot_slot == 0) THEN - reason = "could not match the SCF symmetry operation to a basis rotation" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) - natom = SIZE(qs_kpoint%atype) - ALLOCATE (ao_start(natom), ao_size(natom)) - irow = 1 - DO iatom = 1, natom - ikind = qs_kpoint%atype(iatom) - IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN - reason = "a required basis rotation matrix is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - ao_start(iatom) = irow - ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) - irow = irow + ao_size(iatom) - END DO - IF (irow - 1 /= nao) THEN - reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - - time_reversal = kpsym%rotp(isym) < 0 - reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) - IF (ASSOCIATED(kpsym%phase_mode)) THEN - IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 - END IF - xkp_phase(1:3) = kpsym%xkp(1:3, isym) - DO iatom = 1, natom - source_atom = iatom - target_atom = kpsym%f0(iatom, isym) - ikind = qs_kpoint%atype(source_atom) - rotmat => kind_rot(ikind)%rmat - source_dim = ao_size(source_atom) - target_dim = ao_size(target_atom) - IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN - reason = "basis rotation dimensions do not match the atom/AO symmetry transform" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & - REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & - REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) - IF (ASSOCIATED(kpsym%kgphase)) THEN - arg = arg + kpsym%kgphase(source_atom, isym) - END IF - IF (reverse_phase) arg = -arg - coskl = COS(twopi*arg) - sinkl = SIN(twopi*arg) - DO imo = 1, nmo - DO irow_work = 1, source_dim - irow_source = ao_start(source_atom) + irow_work - 1 - coeff_real = src_r(irow_source, imo) - coeff_imag = src_i(irow_source, imo) - IF (time_reversal) coeff_imag = -coeff_imag - phase_real = coskl*coeff_real - sinkl*coeff_imag - phase_imag = sinkl*coeff_real + coskl*coeff_imag - DO iao = 1, target_dim - irow_target = ao_start(target_atom) + iao - 1 - dst_r(irow_target, imo) = dst_r(irow_target, imo) + & - rotmat(iao, irow_work)*phase_real - dst_i(irow_target, imo) = dst_i(irow_target, imo) + & - rotmat(iao, irow_work)*phase_imag - END DO - END DO - END DO - END DO - - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - success = .TRUE. - - END SUBROUTINE transform_wannier90_scf_mo - -! ************************************************************************************************** -!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. -!> \param qs_kpoint SCF k-point object -!> \param rotp signed operation identifier -!> \return rotation slot, or zero when no slot matches -! ************************************************************************************************** - INTEGER FUNCTION find_wannier90_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: rotp - - INTEGER :: irot, rot_abs - - rot_slot = 0 - rot_abs = ABS(rotp) - IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN - DO irot = 1, SIZE(qs_kpoint%ibrot) - IF (rot_abs == qs_kpoint%ibrot(irot)) THEN - rot_slot = irot - RETURN - END IF - END DO - - END FUNCTION find_wannier90_rotation_slot - ! ************************************************************************************************** !> \brief Infer a tensor-product Wannier90 mesh from explicit fractional k-point coordinates. !> \param kpt_latt explicit k-point coordinates in reciprocal-lattice units diff --git a/src/qs_wf_history_methods.F b/src/qs_wf_history_methods.F index af061e3cea..e70607cffd 100644 --- a/src/qs_wf_history_methods.F +++ b/src/qs_wf_history_methods.F @@ -761,8 +761,9 @@ CONTAINS END IF END SELECT - IF (PRESENT(extrapolation_method_nr)) & + IF (PRESENT(extrapolation_method_nr)) THEN extrapolation_method_nr = actual_extrapolation_method_nr + END IF my_orthogonal_wf = .FALSE. SELECT CASE (actual_extrapolation_method_nr) @@ -2305,8 +2306,9 @@ CONTAINS wfi_linear_ps_method_nr, wfi_ps_method_nr, & wfi_aspc_nr, wfi_gext_proj_nr, wfi_gext_proj_qtr_nr) IF (qs_env%wf_history%snapshot_count >= 2) THEN - IF (debug_this_module .AND. io_unit > 0) & + IF (debug_this_module .AND. io_unit > 0) THEN WRITE (io_unit, FMT="(T2,A)") "QS| Purging WFN history" + END IF CALL wfi_create(wf_history, interpolation_method_nr= & dft_control%qs_control%wf_interpolation_method_nr, & extrapolation_order=dft_control%qs_control%wf_extrapolation_order, & diff --git a/src/replica_methods.F b/src/replica_methods.F index 0fd4b3b08c..b8a1de1b67 100644 --- a/src/replica_methods.F +++ b/src/replica_methods.F @@ -295,8 +295,9 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) & + IF (.NOT. ASSOCIATED(rep_env)) THEN CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) + END IF NULLIFY (qs_env, dft_control, subsys) CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() diff --git a/src/replica_types.F b/src/replica_types.F index 646349fcae..41f96a58b2 100644 --- a/src/replica_types.F +++ b/src/replica_types.F @@ -206,8 +206,9 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) & + IF (.NOT. ASSOCIATED(rep_env)) THEN CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) + END IF CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() CALL cp_rm_iter_level(iteration_info=logger%iter_info, & diff --git a/src/response_solver.F b/src/response_solver.F index 9985ca3402..8409bc3eaa 100644 --- a/src/response_solver.F +++ b/src/response_solver.F @@ -1244,7 +1244,7 @@ CONTAINS CALL pw_zero(vhxc_rspace) IF (gapw) THEN CALL pw_transfer(v_hartree_rspace_gs, vhxc_rspace) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL pw_transfer(vh_rspace, vhxc_rspace) END IF CALL integrate_v_rspace(v_rspace=vhxc_rspace, & @@ -1795,7 +1795,7 @@ CONTAINS CALL pw_zero(v_xc(ispin)) IF (gapw) THEN ! Hartree potential of response density CALL pw_axpy(v_hartree_rspace_t, v_xc(ispin)) - ELSEIF (gapw_xc) THEN + ELSE IF (gapw_xc) THEN CALL pw_axpy(zv_hartree_rspace, v_xc(ispin)) END IF CALL integrate_v_rspace(qs_env=qs_env, & diff --git a/src/restraint.F b/src/restraint.F index 4b2d6d7738..53c602452a 100644 --- a/src/restraint.F +++ b/src/restraint.F @@ -442,9 +442,9 @@ CONTAINS r0_13(:) = particle_set(index_a)%r - particle_set(index_c)%r r0_23(:) = particle_set(index_b)%r - particle_set(index_c)%r - rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) - rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) - rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) + rab = NORM2(r0_12) + rac = NORM2(r0_13) + rbc = NORM2(r0_23) tab = rab - g3x3_list(ng3x3)%dab tac = rac - g3x3_list(ng3x3)%dac tbc = rbc - g3x3_list(ng3x3)%dbc @@ -508,12 +508,12 @@ CONTAINS r0_24(:) = particle_set(index_b)%r - particle_set(index_d)%r r0_34(:) = particle_set(index_c)%r - particle_set(index_d)%r - rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) - rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) - rad = SQRT(DOT_PRODUCT(r0_14, r0_14)) - rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) - rbd = SQRT(DOT_PRODUCT(r0_24, r0_24)) - rcd = SQRT(DOT_PRODUCT(r0_34, r0_34)) + rab = NORM2(r0_12) + rac = NORM2(r0_13) + rad = NORM2(r0_14) + rbc = NORM2(r0_23) + rbd = NORM2(r0_24) + rcd = NORM2(r0_34) tab = rab - g4x6_list(ng4x6)%dab tac = rac - g4x6_list(ng4x6)%dac diff --git a/src/rpa_grad.F b/src/rpa_grad.F index a24334cf14..2ea5e679e9 100644 --- a/src/rpa_grad.F +++ b/src/rpa_grad.F @@ -1054,8 +1054,9 @@ CONTAINS mem_per_block = REAL(number_of_elements_per_blk, KIND=dp)*8.0_dp number_of_parallel_channels = MAX(1, MIN(MAXVAL(grid) - 1, FLOOR(mem_real/mem_per_block))) CALL para_env%min(number_of_parallel_channels) - IF (mp2_env%ri_grad%max_parallel_comm > 0) & + IF (mp2_env%ri_grad%max_parallel_comm > 0) THEN number_of_parallel_channels = MIN(number_of_parallel_channels, mp2_env%ri_grad%max_parallel_comm) + END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,T75,I6)') 'GRAD_INFO| Number of parallel communication channels:', number_of_parallel_channels @@ -1671,11 +1672,13 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) & + IF (ALLOCATED(index2send(pcol_send)%array)) THEN size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) + END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) & + IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) + END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -1829,11 +1832,13 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) & + IF (ALLOCATED(index2send(pcol_send)%array)) THEN size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) + END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) & + IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) + END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -2273,14 +2278,18 @@ CONTAINS DO ispin = 1, nspins DO pcol = 0, SIZE(sos_mp2_work_occ(ispin)%index2send, 1) - 1 - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & + END IF + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & + END IF + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & + END IF + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) + END IF END DO DEALLOCATE (sos_mp2_work_occ(ispin)%index2send, & sos_mp2_work_occ(ispin)%index2recv, & @@ -2309,7 +2318,8 @@ CONTAINS mp2_env%ri_grad%P_ij(ispin)%array(:, :) = 0.5_dp*(mp2_env%ri_grad%P_ij(ispin)%array + & TRANSPOSE(mp2_env%ri_grad%P_ij(ispin)%array)) - ! The first index of P_ab has to be distributed within the subgroups, so sum it up first and add the required elements later + ! The first index of P_ab has to be distributed within the subgroups, + ! so sum it up first and add the required elements later CALL para_env%sum(sos_mp2_work_virt(ispin)%P) itmp = get_limit(virtual(ispin), para_env_sub%num_pe, para_env_sub%mepos) diff --git a/src/rpa_gw_kpoints_util.F b/src/rpa_gw_kpoints_util.F index 460a46aaa6..00699efc4f 100644 --- a/src/rpa_gw_kpoints_util.F +++ b/src/rpa_gw_kpoints_util.F @@ -1315,8 +1315,9 @@ CONTAINS ELSE IF (kpoint_weights_W_method == kp_weights_W_tailored .OR. & kpoint_weights_W_method == kp_weights_W_auto) THEN - IF (kpoint_weights_W_method == kp_weights_W_tailored) & + IF (kpoint_weights_W_method == kp_weights_W_tailored) THEN exp_kpoints = qs_env%mp2_env%ri_rpa_im_time%exp_tailored_weights + END IF IF (kpoint_weights_W_method == kp_weights_W_auto) THEN IF (SUM(periodic) == 2) exp_kpoints = -1.0_dp diff --git a/src/rpa_im_time.F b/src/rpa_im_time.F index 5c1054cbb8..8081575ae5 100644 --- a/src/rpa_im_time.F +++ b/src/rpa_im_time.F @@ -477,8 +477,9 @@ CONTAINS first_cycle_im_time = .FALSE. - IF (jquad == 1 .AND. flops_2 == 0) & + IF (jquad == 1 .AND. flops_2 == 0) THEN has_mat_P_blocks(i_cell_T, i_mem, j_mem, i_cell_R_1, i_cell_R_2) = .FALSE. + END IF END DO END DO diff --git a/src/rpa_main.F b/src/rpa_main.F index 294525cce1..c005965d59 100644 --- a/src/rpa_main.F +++ b/src/rpa_main.F @@ -330,18 +330,20 @@ CONTAINS input_num_integ_groups = mp2_env%ri_rpa%rpa_num_integ_groups IF (my_do_gw .AND. do_minimax_quad) THEN IF (num_integ_points > 34) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 30.") + END IF num_integ_points = 30 END IF ELSE IF (do_minimax_quad .AND. num_integ_points > 20) THEN - IF (unit_nr > 0) & + IF (unit_nr > 0) THEN CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 20.") + END IF num_integ_points = 20 END IF END IF @@ -973,8 +975,9 @@ CONTAINS CALL cp_fm_struct_release(fm_struct) - IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) & + IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) THEN CALL cp_blacs_env_release(blacs_env_Q) + END IF END IF ! release blacs_env @@ -1333,9 +1336,10 @@ CONTAINS IF (calc_forces .AND. .NOT. do_im_time) CALL rpa_grad_create(rpa_grad, fm_mat_Q(1), & fm_mat_S, homo, virtual, mp2_env, Eigenval(:, 1, :), & unit_nr, do_ri_sos_laplace_mp2) - IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) & + IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) THEN CALL exchange_work%create(qs_env, para_env_sub, mat_munu, dimen_RI_red, & fm_mat_S, fm_mat_Q(1), fm_mat_Q_gemm(1), homo, virtual) + END IF Erpa = 0.0_dp IF (mp2_env%ri_rpa%exchange_correction /= rpa_exchange_none) e_exchange = 0.0_dp first_cycle = .TRUE. diff --git a/src/rt_propagation_forces.F b/src/rt_propagation_forces.F index bb9d1ac65c..5d8ffc1854 100644 --- a/src/rt_propagation_forces.F +++ b/src/rt_propagation_forces.F @@ -122,16 +122,18 @@ CONTAINS IF (rtp%linear_scaling) THEN CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_new(re)%matrix, zero, tmp, & filter_eps=rtp%filter_eps) - IF (rtp%propagate_complex_ks) & + IF (rtp%propagate_complex_ks) THEN CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) + END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) CALL compute_forces(force, tmp, S_der, rho_new(im)%matrix, C_mat, kind_of, atom_of_kind) ELSE CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_ao(ispin)%matrix, zero, tmp) - IF (rtp%propagate_complex_ks) & + IF (rtp%propagate_complex_ks) THEN CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) + END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) CALL compute_forces(force, tmp, S_der, rho_ao_im(ispin)%matrix, C_mat, kind_of, atom_of_kind) END IF diff --git a/src/rt_propagation_types.F b/src/rt_propagation_types.F index ec1e3f4823..416906664d 100644 --- a/src/rt_propagation_types.F +++ b/src/rt_propagation_types.F @@ -476,12 +476,15 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(rtp%H_last_iter) CALL dbcsr_deallocate_matrix_set(rtp%propagator_matrix) IF (ASSOCIATED(rtp%rho)) THEN - IF (ASSOCIATED(rtp%rho%old)) & + IF (ASSOCIATED(rtp%rho%old)) THEN CALL dbcsr_deallocate_matrix_set(rtp%rho%old) - IF (ASSOCIATED(rtp%rho%next)) & + END IF + IF (ASSOCIATED(rtp%rho%next)) THEN CALL dbcsr_deallocate_matrix_set(rtp%rho%next) - IF (ASSOCIATED(rtp%rho%new)) & + END IF + IF (ASSOCIATED(rtp%rho%new)) THEN CALL dbcsr_deallocate_matrix_set(rtp%rho%new) + END IF DEALLOCATE (rtp%rho) END IF @@ -490,20 +493,27 @@ CONTAINS CALL dbcsr_deallocate_matrix(rtp%S_inv) CALL dbcsr_deallocate_matrix(rtp%S_half) CALL dbcsr_deallocate_matrix(rtp%S_minus_half) - IF (ASSOCIATED(rtp%B_mat)) & + IF (ASSOCIATED(rtp%B_mat)) THEN CALL dbcsr_deallocate_matrix(rtp%B_mat) - IF (ASSOCIATED(rtp%C_mat)) & + END IF + IF (ASSOCIATED(rtp%C_mat)) THEN CALL dbcsr_deallocate_matrix_set(rtp%C_mat) - IF (ASSOCIATED(rtp%S_der)) & + END IF + IF (ASSOCIATED(rtp%S_der)) THEN CALL dbcsr_deallocate_matrix_set(rtp%S_der) - IF (ASSOCIATED(rtp%SinvH)) & + END IF + IF (ASSOCIATED(rtp%SinvH)) THEN CALL dbcsr_deallocate_matrix_set(rtp%SinvH) - IF (ASSOCIATED(rtp%SinvH_imag)) & + END IF + IF (ASSOCIATED(rtp%SinvH_imag)) THEN CALL dbcsr_deallocate_matrix_set(rtp%SinvH_imag) - IF (ASSOCIATED(rtp%SinvB)) & + END IF + IF (ASSOCIATED(rtp%SinvB)) THEN CALL dbcsr_deallocate_matrix_set(rtp%SinvB) - IF (ASSOCIATED(rtp%history)) & + END IF + IF (ASSOCIATED(rtp%history)) THEN CALL rtp_history_release(rtp) + END IF DEALLOCATE (rtp%orders) END SUBROUTINE rt_prop_release @@ -515,14 +525,18 @@ CONTAINS TYPE(rt_prop_type), INTENT(inout) :: rtp IF (ASSOCIATED(rtp%mos)) THEN - IF (ASSOCIATED(rtp%mos%old)) & + IF (ASSOCIATED(rtp%mos%old)) THEN CALL cp_fm_release(rtp%mos%old) - IF (ASSOCIATED(rtp%mos%new)) & + END IF + IF (ASSOCIATED(rtp%mos%new)) THEN CALL cp_fm_release(rtp%mos%new) - IF (ASSOCIATED(rtp%mos%next)) & + END IF + IF (ASSOCIATED(rtp%mos%next)) THEN CALL cp_fm_release(rtp%mos%next) - IF (ASSOCIATED(rtp%mos%admm)) & + END IF + IF (ASSOCIATED(rtp%mos%admm)) THEN CALL cp_fm_release(rtp%mos%admm) + END IF CALL cp_fm_struct_release(rtp%ao_ao_fmstruct) DEALLOCATE (rtp%mos) END IF @@ -593,8 +607,9 @@ CONTAINS IF (ASSOCIATED(rtp%history%s_history)) THEN DO i = 1, SIZE(rtp%history%s_history) - IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) & + IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) THEN CALL dbcsr_deallocate_matrix(rtp%history%s_history(i)%matrix) + END IF END DO DEALLOCATE (rtp%history%s_history) END IF diff --git a/src/rt_propagation_velocity_gauge.F b/src/rt_propagation_velocity_gauge.F index ee205d1999..9ad2819d5c 100644 --- a/src/rt_propagation_velocity_gauge.F +++ b/src/rt_propagation_velocity_gauge.F @@ -1090,48 +1090,58 @@ CONTAINS na = SIZE(acint_cos, 1) np = SIZE(acint_cos, 2) nb = SIZE(bcint_cos, 1) - ! Re(dV_ab/dRA) = + + + - ! Im(dV_ab/dRA) = - - + + ! Re(dV_ab/dRA) = + + ! + + + ! Im(dV_ab/dRA) = - + ! - + katom = alist_cos_ac%clist(kac)%catom DO idir = 1, 3 IF (iatom <= jatom) THEN ! For fa: - IF (found_real) & + IF (found_real) THEN fa(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & + MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (+MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & - MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) + END IF ! For fb: - IF (found_real) & + IF (found_real) THEN fb(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (-MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))))) + END IF ELSE ! For fa: - IF (found_real) & + IF (found_real) THEN fa(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & + MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (+MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & - MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) + END IF ! For fb - IF (found_real) & + IF (found_real) THEN fb(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))))) - IF (found_imag) & + END IF + IF (found_imag) THEN fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (-MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))))) + END IF END IF force_thread(idir, iatom) = force_thread(idir, iatom) + f0*fa(idir) force_thread(idir, katom) = force_thread(idir, katom) - f0*fa(idir) diff --git a/src/scf_control_types.F b/src/scf_control_types.F index 527bb5e81f..623af5359f 100644 --- a/src/scf_control_types.F +++ b/src/scf_control_types.F @@ -302,8 +302,9 @@ CONTAINS END IF DEALLOCATE (scf_control%smear) - IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) & + IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) THEN CALL cdft_opt_type_release(scf_control%outer_scf%cdft_opt_control) + END IF IF (ASSOCIATED(scf_control%gce)) THEN DEALLOCATE (scf_control%gce) @@ -353,7 +354,7 @@ CONTAINS IF (scf_control%use_diag .AND. scf_control%use_ot) THEN ! don't allow both options to be true CPABORT("Don't activate OT and Diagonaliztion together") - ELSEIF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN + ELSE IF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN ! set default to diagonalization scf_control%use_diag = .TRUE. END IF @@ -699,9 +700,10 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T25,A,T71,ES10.2)") & "Smearing width (sigma) [a.u.]:", scf_control%smear%smearing_width, & "Accuracy threshold:", scf_control%smear%eps_fermi_dirac - IF (scf_control%smear%fixed_mag_mom > 0.0_dp) & + IF (scf_control%smear%fixed_mag_mom > 0.0_dp) THEN WRITE (UNIT=output_unit, FMT="(T25,A,T61,F20.1)") & - "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom + "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom + END IF CASE (smear_energy_window) WRITE (UNIT=output_unit, FMT="(T25,A,T71,F10.6)") & "Smear window [a.u.]: ", scf_control%smear%window_size diff --git a/src/scine_utils.F b/src/scine_utils.F index 208d4b2f0b..8bd0ee64ca 100644 --- a/src/scine_utils.F +++ b/src/scine_utils.F @@ -117,15 +117,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSEIF (nc == j + 4) THEN + ELSE IF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 3) THEN + ELSE IF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 2) THEN + ELSE IF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 1) THEN + ELSE IF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j) THEN + ELSE IF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -134,15 +134,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSEIF (nc == j + 4) THEN + ELSE IF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 3) THEN + ELSE IF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 2) THEN + ELSE IF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 1) THEN + ELSE IF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j) THEN + ELSE IF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -151,15 +151,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSEIF (nc == j + 4) THEN + ELSE IF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 3) THEN + ELSE IF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 2) THEN + ELSE IF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j + 1) THEN + ELSE IF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSEIF (nc == j) THEN + ELSE IF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO diff --git a/src/se_core_matrix.F b/src/se_core_matrix.F index 2c53f7ca31..10bda9bd4e 100644 --- a/src/se_core_matrix.F +++ b/src/se_core_matrix.F @@ -281,24 +281,6 @@ CONTAINS ! two-centre one-electron term NULLIFY (s_block) -! CALL dbcsr_get_block_p(matrix_s(1)%matrix,& -! irow,icol,s_block,found) -! CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) -! -! if( irow == iatom )then -! R= -rij -! call makeS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,S) -! else -! R= rij -! call makeS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,S) -! endif -! -! do i=1,4 -! do j=1,4 -! s_block(i,j)=S(ix(i),ix(j)) -! enddo -! enddo - CALL dbcsr_get_block_p(matrix_s(1)%matrix, & irow, icol, s_block, found) CPASSERT(ASSOCIATED(s_block)) @@ -319,28 +301,11 @@ CONTAINS atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) -! if( irow == iatom )then -! R= -rij -! call makedS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,dS) -! else -! R= rij -! call makedS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,dS) -! endif - CALL dbcsr_get_block_p(matrix_p(1)%matrix, irow, icol, pabmat, found) CPASSERT(ASSOCIATED(pabmat)) DO icor = 1, 3 force_ab(icor) = 0._dp -! CALL dbcsr_get_block_p(matrix_s(icor+1)%matrix,irow,icol,dsmat,found) -! CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,failure) -! -! do i=1,4 -! do j=1,4 -! dsmat(i,j)=dS(ix(i),ix(j),icor) -! enddo -! enddo - CALL dbcsr_get_block_p(matrix_s(icor + 1)%matrix, irow, icol, dsmat, found) CPASSERT(ASSOCIATED(dsmat)) dsmat = 2._dp*kh*dsmat*pabmat @@ -628,7 +593,7 @@ CONTAINS S(:, :) = 0.0_dp v(:) = R(:) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) IF (rr < 1.0e-20_dp) THEN @@ -1006,7 +971,7 @@ CONTAINS dS(:, :, :) = 0.0_dp v(:) = R(:) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) IF (rr < 1.0e-20_dp) THEN diff --git a/src/semi_empirical_int_ana.F b/src/semi_empirical_int_ana.F index d9e33d563a..3698bf1625 100644 --- a/src/semi_empirical_int_ana.F +++ b/src/semi_empirical_int_ana.F @@ -548,7 +548,7 @@ CONTAINS (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2)*(-2.0_dp*apdg*(rij - dbi - daj)) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2)*(-2.0_dp*apdg*(rij - dbi - dbj)) END IF - ELSEIF (itype == do_method_pchg) THEN + ELSE IF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp dscale = 0.0_dp @@ -571,15 +571,15 @@ CONTAINS IF (l_denuc) dscale = dscale*(2._dp*xab*EXP(-aab*rija*rija)) - & scale*2._dp*xab*EXP(-aab*rija*rija)*(2.0_dp*aab*rija)*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) & - scale*2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6))*aab*(1.0_dp + 6.0_dp*0.0003_dp*rija**5)*drija & - scale*9.28_dp*EXP(-5.98_dp*rija)*5.98_dp*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) & @@ -1578,8 +1578,7 @@ CONTAINS ! Evaluate additional taper function for dumped integrals IF (se_int_control%integral_screening == do_se_IS_kdso_d) THEN se_int_screen%ft = taper_eval(se_taper%taper_add, rij) - IF (lgrad) & - se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) + IF (lgrad) se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) END IF ! Integral Values for sp shells only diff --git a/src/semi_empirical_int_debug.F b/src/semi_empirical_int_debug.F index 2a77ae1016..466d99a3c7 100644 --- a/src/semi_empirical_int_debug.F +++ b/src/semi_empirical_int_debug.F @@ -71,7 +71,7 @@ SUBROUTINE check_rotmat_der(sepi, sepj, rjiv, ij_matrix, do_invert) IF (i == 1) matrix => matrix_p IF (i == 2) matrix => matrix_m r0 = rjiv + (-1.0_dp)**(i - 1)*x - r = SQRT(DOT_PRODUCT(r0, r0)) + r = NORM2(r0) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=do_invert) END DO ! SP @@ -218,7 +218,7 @@ SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, in x(imap(j)) = dx DO i = 1, 2 r0 = rijv + (-1.0_dp)**(i - 1)*x - r = SQRT(DOT_PRODUCT(r0, r0)) + r = NORM2(r0) CALL rotmat_create(matrix) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=invert) diff --git a/src/semi_empirical_int_gks.F b/src/semi_empirical_int_gks.F index f285735404..b6da8aa20d 100644 --- a/src/semi_empirical_int_gks.F +++ b/src/semi_empirical_int_gks.F @@ -270,7 +270,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -373,7 +373,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -590,7 +590,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) r1 = 1.0_dp/rr r2 = r1*r1 @@ -807,7 +807,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = SQRT(DOT_PRODUCT(v, v)) + rr = NORM2(v) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) diff --git a/src/semi_empirical_int_num.F b/src/semi_empirical_int_num.F index a541863a75..a5cbd768c6 100644 --- a/src/semi_empirical_int_num.F +++ b/src/semi_empirical_int_num.F @@ -619,7 +619,7 @@ CONTAINS (zaf*pai + zbf*pbj)*EXP(-apdg*(rij - dai - dbj)**2) + & (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2) - ELSEIF (itype == do_method_pchg) THEN + ELSE IF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp ELSE @@ -635,11 +635,11 @@ CONTAINS (sepj%z == 1 .AND. (sepi%z == 6 .OR. sepi%z == 7 .OR. sepi%z == 8))) THEN ! Special Case O-H or N-H or C-H scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) ELSE diff --git a/src/semi_empirical_par_utils.F b/src/semi_empirical_par_utils.F index 4ca22c5713..ec1302790b 100644 --- a/src/semi_empirical_par_utils.F +++ b/src/semi_empirical_par_utils.F @@ -261,16 +261,16 @@ CONTAINS ELSE IF (l == 0) THEN n = nqs(sep%z) - ELSEIF (l == 1) THEN + ELSE IF (l == 1) THEN ! Special case for Hydrogen.. If requested allow p-orbitals on it.. IF ((sep%z == 1) .AND. sep%p_orbitals_on_h) THEN n = 1 ELSE n = nqp(sep%z) END IF - ELSEIF (l == 2) THEN + ELSE IF (l == 2) THEN n = nqd(sep%z) - ELSEIF (l == 3) THEN + ELSE IF (l == 3) THEN n = nqf(sep%z) ELSE CPABORT("Invalid l quantum number !") @@ -535,24 +535,27 @@ CONTAINS z1 = sep%sto_exponents(0) z2 = sep%sto_exponents(1) z3 = sep%sto_exponents(2) - IF (z1 <= 0.0_dp) & + IF (z1 <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Trying to use s-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of s orbitals! ") + END IF amn = 0.0_dp nsp = nqs(sep%z) IF (sep%natorb >= 4) THEN - IF (z2 <= 0.0_dp) & + IF (z2 <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Trying to use p-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of p orbitals! ") + END IF amn(2) = amn_l_low(z1, z2, nsp, nsp, 1) amn(3) = amn_l_low(z2, z2, nsp, nsp, 2) IF (sep%dorb) THEN - IF (z3 <= 0.0_dp) & + IF (z3 <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Trying to use d-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of d orbitals! ") + END IF nd = nqd(sep%z) amn(4) = amn_l_low(z1, z3, nsp, nd, 2) amn(5) = amn_l_low(z2, z3, nsp, nd, 1) diff --git a/src/semi_empirical_store_int_types.F b/src/semi_empirical_store_int_types.F index f00537c0de..f878234b19 100644 --- a/src/semi_empirical_store_int_types.F +++ b/src/semi_empirical_store_int_types.F @@ -97,8 +97,9 @@ CONTAINS END IF ! Disk Storage disabled for semi-empirical methods - IF (store_int_env%memory_parameter%do_disk_storage) & + IF (store_int_env%memory_parameter%do_disk_storage) THEN CPABORT("Disk storage for SEMIEMPIRICAL methods disabled! ") + END IF ! Allocate containers/caches for integral storage if requested IF (.NOT. store_int_env%memory_parameter%do_all_on_the_fly .AND. store_int_env%compress) THEN diff --git a/src/semi_empirical_types.F b/src/semi_empirical_types.F index 806e85c01c..9157e5f5db 100644 --- a/src/semi_empirical_types.F +++ b/src/semi_empirical_types.F @@ -833,7 +833,7 @@ CONTAINS ADJUSTR("ACOUL"), "- "//" Slater parameter: ", sep%acoul WRITE (UNIT=output_unit, FMT="(T16,A11,T30,A,T69,I12)") & ADJUSTR("NR"), "- "//" Slater parameter: ", sep%nr - ELSEIF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN + ELSE IF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN ! Standard case DO i = 1, SIZE(sep%bfn1, 1) i_string = cp_to_string(i) diff --git a/src/semi_empirical_utils.F b/src/semi_empirical_utils.F index 5c9911931f..4cc9b5e0a9 100644 --- a/src/semi_empirical_utils.F +++ b/src/semi_empirical_utils.F @@ -305,10 +305,11 @@ CONTAINS END IF ! Check if the element has been defined.. - IF (.NOT. sep%defined) & + IF (.NOT. sep%defined) THEN CALL cp_abort(__LOCATION__, & "Semiempirical type ("//TRIM(sep%name)//") cannot be defined for "// & "the requested parameterization.") + END IF ! Fill 1 center - 2 electron integrals CALL setup_1c_2el_int(sep) diff --git a/src/shg_int/construct_shg.F b/src/shg_int/construct_shg.F index b63da9c9c1..9de93b969d 100644 --- a/src/shg_int/construct_shg.F +++ b/src/shg_int/construct_shg.F @@ -377,7 +377,8 @@ CONTAINS IF (ma - 1 >= 0) THEN Wamm(0:lamb, 1) = Waux_mat(1:lamb + 1, ipam - 1, ipb) IF (mb > 0) Wamm(0:lamb, 2) = Waux_mat(1:lamb + 1, ipam - 1, imb) - IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) !order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 + ! order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 + IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) IF (ma - 1 > 0 .AND. mb > 0) Wamm(0:lamb, 4) = Waux_mat(1:lamb + 1, imam + 1, imb) END IF !*** Wamp: la-1, ma+1 diff --git a/src/sirius_interface.F b/src/sirius_interface.F index c278a27ee1..9b94f8290b 100644 --- a/src/sirius_interface.F +++ b/src/sirius_interface.F @@ -327,7 +327,7 @@ CONTAINS symbol=element_symbol, & mass=REAL(mass/massunit, KIND=C_DOUBLE)) - ELSEIF (ASSOCIATED(gth_potential)) THEN + ELSE IF (ASSOCIATED(gth_potential)) THEN ! NULLIFY (atom_grid) CALL allocate_grid_atom(atom_grid) diff --git a/src/skala_gpw_features.F b/src/skala_gpw_features.F index 14a0b088a5..f791c73354 100644 --- a/src/skala_gpw_features.F +++ b/src/skala_gpw_features.F @@ -225,8 +225,9 @@ CONTAINS my_requires_grad = .FALSE. IF (PRESENT(requires_grad)) my_requires_grad = requires_grad my_requires_coordinate_grad = .FALSE. - IF (PRESENT(requires_coordinate_grad)) & + IF (PRESENT(requires_coordinate_grad)) THEN my_requires_coordinate_grad = requires_coordinate_grad + END IF my_requires_stress_grad = .FALSE. IF (PRESENT(requires_stress_grad)) my_requires_stress_grad = requires_stress_grad my_use_atom_chunks = .FALSE. @@ -595,8 +596,9 @@ CONTAINS END IF max_local_features = nflat_local - IF (my_atom_partition == skala_gpw_atom_partition_smooth) & + IF (my_atom_partition == skala_gpw_atom_partition_smooth) THEN max_local_features = nflat_local*natom + END IF ALLOCATE (local_owner(max_local_features), & local_source_points(max_local_features), & local_static(nstatic_per_point*max_local_features), & @@ -779,8 +781,9 @@ CONTAINS atom_position(owner) = atom_position(owner) + 1 source_global = global_source_points(ipt) cached_layout%feature_source_points(row) = source_global - IF (cached_layout%global_to_feature(source_global) == 0) & + IF (cached_layout%global_to_feature(source_global) == 0) THEN cached_layout%global_to_feature(source_global) = row + END IF static_base = nstatic_per_point*(ipt - 1) cached_layout%grid_coords(:, row) = global_static(static_base + 1:static_base + 3) cached_layout%grid_weights(row) = global_static(static_base + 4) @@ -1458,14 +1461,18 @@ CONTAINS IF (ALLOCATED(cache%chunk_feature_displs)) DEALLOCATE (cache%chunk_feature_displs) IF (ALLOCATED(cache%chunk_grad_counts)) DEALLOCATE (cache%chunk_grad_counts) IF (ALLOCATED(cache%chunk_grad_displs)) DEALLOCATE (cache%chunk_grad_displs) - IF (ALLOCATED(cache%route_grad_return_recv_counts)) & + IF (ALLOCATED(cache%route_grad_return_recv_counts)) THEN DEALLOCATE (cache%route_grad_return_recv_counts) - IF (ALLOCATED(cache%route_grad_return_recv_displs)) & + END IF + IF (ALLOCATED(cache%route_grad_return_recv_displs)) THEN DEALLOCATE (cache%route_grad_return_recv_displs) - IF (ALLOCATED(cache%route_grad_return_send_counts)) & + END IF + IF (ALLOCATED(cache%route_grad_return_send_counts)) THEN DEALLOCATE (cache%route_grad_return_send_counts) - IF (ALLOCATED(cache%route_grad_return_send_displs)) & + END IF + IF (ALLOCATED(cache%route_grad_return_send_displs)) THEN DEALLOCATE (cache%route_grad_return_send_displs) + END IF IF (ALLOCATED(cache%route_local_dest)) DEALLOCATE (cache%route_local_dest) IF (ALLOCATED(cache%chunk_return_positions)) DEALLOCATE (cache%chunk_return_positions) IF (ALLOCATED(cache%route_point_recv_counts)) DEALLOCATE (cache%route_point_recv_counts) @@ -1488,17 +1495,20 @@ CONTAINS IF (ALLOCATED(cache%local_feature_offsets)) DEALLOCATE (cache%local_feature_offsets) IF (ALLOCATED(cache%local_feature_points)) DEALLOCATE (cache%local_feature_points) IF (ALLOCATED(cache%local_feature_rows)) DEALLOCATE (cache%local_feature_rows) - IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) & + IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) THEN DEALLOCATE (cache%atomic_grid_size_bound_shape) - IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) & + END IF + IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) THEN DEALLOCATE (cache%chunk_atomic_grid_size_bound_shape) + END IF IF (ALLOCATED(cache%atomic_grid_weights)) DEALLOCATE (cache%atomic_grid_weights) IF (ALLOCATED(cache%chunk_atomic_grid_weights)) DEALLOCATE (cache%chunk_atomic_grid_weights) IF (ALLOCATED(cache%chunk_grid_weights)) DEALLOCATE (cache%chunk_grid_weights) IF (ALLOCATED(cache%grid_weights)) DEALLOCATE (cache%grid_weights) IF (ALLOCATED(cache%atom_coords)) DEALLOCATE (cache%atom_coords) - IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) & + IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) THEN DEALLOCATE (cache%chunk_coarse_0_atomic_coords) + END IF IF (ALLOCATED(cache%coarse_0_atomic_coords)) DEALLOCATE (cache%coarse_0_atomic_coords) IF (ALLOCATED(cache%chunk_grid_coords)) DEALLOCATE (cache%chunk_grid_coords) IF (ALLOCATED(cache%grid_coords)) DEALLOCATE (cache%grid_coords) @@ -1592,22 +1602,30 @@ CONTAINS IF (ALLOCATED(features%chunk_grad_counts)) DEALLOCATE (features%chunk_grad_counts) IF (ALLOCATED(features%chunk_grad_displs)) DEALLOCATE (features%chunk_grad_displs) IF (ALLOCATED(features%chunk_return_positions)) DEALLOCATE (features%chunk_return_positions) - IF (ALLOCATED(features%route_grad_return_recv_counts)) & + IF (ALLOCATED(features%route_grad_return_recv_counts)) THEN DEALLOCATE (features%route_grad_return_recv_counts) - IF (ALLOCATED(features%route_grad_return_recv_displs)) & + END IF + IF (ALLOCATED(features%route_grad_return_recv_displs)) THEN DEALLOCATE (features%route_grad_return_recv_displs) - IF (ALLOCATED(features%route_grad_return_send_counts)) & + END IF + IF (ALLOCATED(features%route_grad_return_send_counts)) THEN DEALLOCATE (features%route_grad_return_send_counts) - IF (ALLOCATED(features%route_grad_return_send_displs)) & + END IF + IF (ALLOCATED(features%route_grad_return_send_displs)) THEN DEALLOCATE (features%route_grad_return_send_displs) - IF (ALLOCATED(features%route_point_recv_counts)) & + END IF + IF (ALLOCATED(features%route_point_recv_counts)) THEN DEALLOCATE (features%route_point_recv_counts) - IF (ALLOCATED(features%route_point_recv_displs)) & + END IF + IF (ALLOCATED(features%route_point_recv_displs)) THEN DEALLOCATE (features%route_point_recv_displs) - IF (ALLOCATED(features%route_point_send_counts)) & + END IF + IF (ALLOCATED(features%route_point_send_counts)) THEN DEALLOCATE (features%route_point_send_counts) - IF (ALLOCATED(features%route_point_send_displs)) & + END IF + IF (ALLOCATED(features%route_point_send_displs)) THEN DEALLOCATE (features%route_point_send_displs) + END IF IF (ALLOCATED(features%route_send_local_rows)) DEALLOCATE (features%route_send_local_rows) IF (ALLOCATED(features%feature_index)) DEALLOCATE (features%feature_index) IF (ALLOCATED(features%local_feature_counts)) DEALLOCATE (features%local_feature_counts) @@ -1618,8 +1636,9 @@ CONTAINS IF (ALLOCATED(features%atomic_grid_weights)) DEALLOCATE (features%atomic_grid_weights) IF (ALLOCATED(features%atomic_grid_sizes)) DEALLOCATE (features%atomic_grid_sizes) IF (ALLOCATED(features%coarse_0_atomic_coords)) DEALLOCATE (features%coarse_0_atomic_coords) - IF (ALLOCATED(features%atomic_grid_size_bound_shape)) & + IF (ALLOCATED(features%atomic_grid_size_bound_shape)) THEN DEALLOCATE (features%atomic_grid_size_bound_shape) + END IF features%chunk_feature_count = 0 features%nflat = 0 features%nflat_local = 0 diff --git a/src/skala_gpw_functional.F b/src/skala_gpw_functional.F index ea71c9ead5..ab0d553178 100644 --- a/src/skala_gpw_functional.F +++ b/src/skala_gpw_functional.F @@ -109,7 +109,7 @@ CONTAINS END FUNCTION xc_section_uses_native_skala_grid ! ************************************************************************************************** -!> \brief Return true if the GAUXC subsection requests a Skala-style model. +!> \brief Return true if the GAUXC subsection requests a model evaluation. !> \param xc_section ... !> \return ... ! ************************************************************************************************** @@ -117,16 +117,20 @@ CONTAINS TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section LOGICAL :: uses_gauxc_model - CHARACTER(len=default_path_length) :: model_key, model_name + CHARACTER(len=default_path_length) :: model_key, model_name, xc_key, xc_name TYPE(section_vals_type), POINTER :: gauxc_section uses_gauxc_model = .FALSE. gauxc_section => get_gauxc_section(xc_section) IF (ASSOCIATED(gauxc_section)) THEN CALL section_vals_val_get(gauxc_section, "MODEL", c_val=model_name) + CALL section_vals_val_get(gauxc_section, "FUNCTIONAL", c_val=xc_name) model_key = ADJUSTL(model_name) + xc_key = ADJUSTL(xc_name) CALL uppercase(model_key) - uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") + CALL uppercase(xc_key) + uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & + TRIM(model_key) /= TRIM(xc_key)) END IF END FUNCTION xc_section_uses_gauxc_model @@ -1510,8 +1514,9 @@ CONTAINS CPASSERT(SUM(features%route_point_send_counts) == nroute_points) nroute_grad_per_point = ngrad_per_point - IF (features%uses_collapsed_rks_dynamic) & + IF (features%uses_collapsed_rks_dynamic) THEN nroute_grad_per_point = ncollapsed_grad_per_point + END IF ALLOCATE (send_grad_buffer(MAX(1, nroute_grad_per_point*features%chunk_feature_count)), & recv_grad_buffer(MAX(1, nroute_grad_per_point*nroute_points)), & route_grad_return_send_counts(SIZE(features%route_point_recv_counts)), & diff --git a/src/smeagol_control_types.F b/src/smeagol_control_types.F index 37cbe5c18a..7e63f52054 100644 --- a/src/smeagol_control_types.F +++ b/src/smeagol_control_types.F @@ -58,7 +58,7 @@ MODULE smeagol_control_types REAL(kind=dp) :: to_smeagol_energy_units = 2.0_dp !> number of cell images along i and j cell vectors - INTEGER, DIMENSION(2) :: n_cell_images = (/1, 1/) + INTEGER, DIMENSION(2) :: n_cell_images = [1, 1] !> what lead (bulk transport calculation) INTEGER :: lead_label = smeagol_bulklead_leftright diff --git a/src/smeagol_emtoptions.F b/src/smeagol_emtoptions.F index fc1ea616e3..adb1cc9417 100644 --- a/src/smeagol_emtoptions.F +++ b/src/smeagol_emtoptions.F @@ -179,7 +179,8 @@ MODULE smeagol_emtoptions smeagolglobal_emSTT = torqueflag smeagolglobal_emSTTLin = torquelin - ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, therefore 'EM.TimeReversal' is also enabled. + ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, + ! therefore 'EM.TimeReversal' is also enabled. ! In case of this CP2K+SMEAGOL interface, the default value of 'timereversal' variable is .FALSE. IF (smeagol_control%aux%timereversal) THEN CALL cp_warn(__LOCATION__, & @@ -328,7 +329,8 @@ MODULE smeagol_emtoptions ! current-induced forces ! The value of 'smeagol_control%emforces' is set in qs_energies(). - ! Calculation of forces is enabled automatically for certain run_types (energy_force, geo_opt, md) and disabled otherwise. + ! Calculation of forces is enabled automatically for certain run_types + ! (energy_force, geo_opt, md) and disabled otherwise. IF (smeagol_control%aux%curr_dist) THEN smeagol_control%emforces = .TRUE. END IF @@ -338,8 +340,9 @@ MODULE smeagol_emtoptions IF (.NOT. smeagol_control%aux%isexplicit_GetRhoSingleLead) smeagol_control%aux%GetRhoSingleLead = GetRhoSingleLeadDefault IF (smeagol_control%aux%MinChannelIndex < 1) smeagol_control%aux%MinChannelIndex = 1 - IF (smeagol_control%aux%MaxChannelIndex < 1) & + IF (smeagol_control%aux%MaxChannelIndex < 1) THEN smeagol_control%aux%MaxChannelIndex = smeagol_control%aux%MinChannelIndex + 4 + END IF IF (smeagolglobal_emSTT .AND. smeagolglobal_emSTTLin .AND. smeagol_control%aux%GetRhoSingleLead /= -3) THEN CALL cp_warn(__LOCATION__, & diff --git a/src/smeagol_interface.F b/src/smeagol_interface.F index 556e5b4e67..eccf01abec 100644 --- a/src/smeagol_interface.F +++ b/src/smeagol_interface.F @@ -731,11 +731,13 @@ CONTAINS ! first invocation of the subroutine : initialise md_iter_level and md_first_step variables smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "MD") - IF (smeagol_control%aux%md_iter_level <= 0) & + IF (smeagol_control%aux%md_iter_level <= 0) THEN smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "GEO_OPT") + END IF - IF (smeagol_control%aux%md_iter_level <= 0) & + IF (smeagol_control%aux%md_iter_level <= 0) THEN smeagol_control%aux%md_iter_level = 0 + END IF ! index of the first GEO_OPT / MD step IF (smeagol_control%aux%md_iter_level > 0) THEN diff --git a/src/smeagol_matrix_utils.F b/src/smeagol_matrix_utils.F index ad3ea6d6d8..1bf43236fc 100644 --- a/src/smeagol_matrix_utils.F +++ b/src/smeagol_matrix_utils.F @@ -72,7 +72,8 @@ MODULE smeagol_matrix_utils INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_send = 2 INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_dim2 = nelements_dbcsr_send - INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 ! 128 MiB (to limit memory usage for matrix redistribution) + ! 128 MiB (to limit memory usage for matrix redistribution) + INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_dp = max_mpi_packet_size_bytes/INT(dp_size, kind=int_8) ! a portable way to determine the upper bound for tag value is to call @@ -220,7 +221,8 @@ CONTAINS ! via subroutine arguments, an extra MPI_Allreduce operation is needed each time we call ! replicate_neighbour_list() / get_nnodes_local(). max_ijk_cell_image(3) = -1 - IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 ! bulk-transport calculation expects exactly 3 cell images along transport direction + ! bulk-transport calculation expects exactly 3 cell images along transport direction + IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 ! replicate pair-wise neighbour list. Identical non-zero matrix blocks from cell image along transport direction ! are grouped together if do_merge == .TRUE. @@ -502,8 +504,10 @@ CONTAINS END IF END IF - ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements (should be OK due to SMEAGOL limitation) - ! in principle, it is possible to overcome this limit by using derived datatypes (which will require additional wrapper functions, indeed). + ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements + ! (should be OK due to SMEAGOL limitation) + ! in principle, it is possible to overcome this limit by using derived datatypes + ! (which will require additional wrapper functions, indeed). ! ! pre-post non-blocking receive operations IF (n_nonzero_elements_siesta > 0) THEN @@ -685,10 +689,13 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) DEALLOCATE (offset_per_proc, n_packed_elements_per_proc) - ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, local row index, and column index (in this order). - ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, source MPI rank, and column index. + ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, + ! local row index, and column index (in this order). + ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, + ! source MPI rank, and column index. ! (column indices are in the ascending order within each (row index, source MPI rank) block). - ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : local row index, column index + ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : + ! local row index, column index IF (n_nonzero_elements_siesta > 0) THEN ALLOCATE (reorder_recv_buffer(n_nonzero_elements_siesta)) ALLOCATE (next_nonzero_element_offset(siesta_struct%nrows)) @@ -1023,7 +1030,8 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) - iproc = siesta_struct%gather_root ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root + ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root + iproc = siesta_struct%gather_root IF (n_nonzero_elements_dbcsr > 0) THEN DO inode_proc = 1, nnodes_proc n_image_ind = siesta_struct%n_dbcsr_cell_images_to_merge(inode_proc) @@ -1866,8 +1874,9 @@ CONTAINS ! there is no need to send data to the same MPI process IF (iproc /= mepos) THEN nrequests = nrequests + INT(nelements_per_proc(iproc)/max_nelements_per_packet) - IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) & + IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) THEN nrequests = nrequests + 1 + END IF END IF END DO END FUNCTION get_number_of_mpi_sendrecv_requests diff --git a/src/start/cp2k.F b/src/start/cp2k.F index 8d26c43ea1..15857c3c7d 100644 --- a/src/start/cp2k.F +++ b/src/start/cp2k.F @@ -167,8 +167,9 @@ PROGRAM cp2k INTEGER :: veclib_max_threads, ierr CALL get_environment_variable("VECLIB_MAXIMUM_THREADS", env_var, status=ierr) veclib_max_threads = 0 - IF (ierr == 0) & + IF (ierr == 0) THEN READ (env_var, *) veclib_max_threads + END IF IF (ierr == 1 .OR. (ierr == 0 .AND. veclib_max_threads > 1)) THEN CALL cp_warn(__LOCATION__, & "macOS' Accelerate framework has its own threading enabled which may interfere"// & @@ -236,8 +237,9 @@ PROGRAM cp2k DO inp_var_idx = 1, SIZE(initial_variables, 2) ! check whether the variable was already set, in this case, overwrite - IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) & + IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) THEN EXIT + END IF END DO IF (inp_var_idx > SIZE(initial_variables, 2)) THEN diff --git a/src/start/cp2k_runs.F b/src/start/cp2k_runs.F index 7287947c5d..c1d18cf537 100644 --- a/src/start/cp2k_runs.F +++ b/src/start/cp2k_runs.F @@ -314,8 +314,9 @@ CONTAINS method_name_id /= do_nnp .AND. & method_name_id /= do_embed .AND. & method_name_id /= do_fist .AND. & - method_name_id /= do_ipi) & + method_name_id /= do_ipi) THEN CPABORT("Energy/Force run not available for all methods ") + END IF sublogger => cp_get_default_logger() CALL cp_add_iter_level(sublogger%iter_info, "JUST_ENERGY", & @@ -324,8 +325,9 @@ CONTAINS ! loop over molecules to generate a molecular guess ! this procedure is initiated here to avoid passing globenv deep down ! the subroutine stack - IF (do_mol_loop(force_env=force_env)) & + IF (do_mol_loop(force_env=force_env)) THEN CALL loop_over_molecules(globenv, force_env) + END IF SELECT CASE (globenv%run_type_id) CASE (energy_run) @@ -347,8 +349,9 @@ CONTAINS CASE (do_tamc) CALL qs_tamc(force_env, globenv) CASE (real_time_propagation) - IF (method_name_id /= do_qs) & + IF (method_name_id /= do_qs) THEN CPABORT("Real time propagation needs METHOD QS. ") + END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .TRUE. SELECT CASE (dft_control%rtp_control%rtp_method) @@ -360,8 +363,9 @@ CONTAINS CALL rt_prop_setup(force_env) END SELECT CASE (ehrenfest) - IF (method_name_id /= do_qs) & + IF (method_name_id /= do_qs) THEN CPABORT("Ehrenfest dynamics needs METHOD QS ") + END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .FALSE. CALL qs_mol_dyn(force_env, globenv) @@ -369,8 +373,9 @@ CONTAINS CALL do_bsse_calculation(force_env, globenv) CASE (linear_response_run) IF (method_name_id /= do_qs .AND. & - method_name_id /= do_qmmm) & + method_name_id /= do_qmmm) THEN CPABORT("Property calculations by Linear Response only within the QS or QMMM program ") + END IF ! The Ground State is needed, it can be read from Restart CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., linres=.TRUE.) CALL linres_calculation(force_env) @@ -800,8 +805,9 @@ CONTAINS ! change to the new working directory CALL m_chdir(TRIM(farming_env%Job(i)%cwd), ierr) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CPABORT("Failed to change dir to: "//TRIM(farming_env%Job(i)%cwd)) + END IF ! generate a fresh call to cp2k_run IF (new_rank == 0) THEN diff --git a/src/start/cp2k_shell.F b/src/start/cp2k_shell.F index d1071bc108..6dd3ad5438 100644 --- a/src/start/cp2k_shell.F +++ b/src/start/cp2k_shell.F @@ -541,13 +541,13 @@ CONTAINS TYPE(cp2k_shell_type) :: shell CHARACTER(LEN=*), INTENT(IN) :: arg1 - INTEGER :: ierr, iostat, n_atom + INTEGER :: ierr, n_atom IF (.NOT. parse_env_id(arg1, shell)) RETURN CALL get_natom(shell%env_id, n_atom, ierr) IF (.NOT. my_assert(ierr == 0, 'get_natom failed', shell)) RETURN IF (shell%iw > 0) THEN - WRITE (shell%iw, '(i10)', iostat=iostat) n_atom + WRITE (shell%iw, '(i10)') n_atom CALL m_flush(shell%iw) END IF END SUBROUTINE get_natom_command diff --git a/src/start/libcp2k.F b/src/start/libcp2k.F index 85f39e3c5a..4ac0f6b73b 100755 --- a/src/start/libcp2k.F +++ b/src/start/libcp2k.F @@ -515,8 +515,9 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=nmo) END BLOCK try @@ -555,13 +556,15 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=norb) - IF (buf_len < norb*norb) & + IF (buf_len < norb*norb) THEN EXIT try + END IF DO i = 0, norb - 1 DO j = 0, norb - 1 @@ -602,8 +605,9 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF nze_count = INT(active_space_env%eri%eri(1)%csr_mat%nze_total, KIND(nze_count)) END BLOCK try @@ -646,12 +650,14 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) & + IF (.NOT. ASSOCIATED(active_space_env)) THEN EXIT try + END IF ASSOCIATE (nze => active_space_env%eri%eri(1)%csr_mat%nze_total) - IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) & + IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) THEN EXIT try + END IF CALL active_space_env%eri%eri_foreach(1, active_space_env%active_orbitals, eri2array(buf_coords, buf_values)) diff --git a/src/stm_images.F b/src/stm_images.F index d4e1ecb285..a0f6411fcc 100644 --- a/src/stm_images.F +++ b/src/stm_images.F @@ -309,8 +309,9 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) & + IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) THEN WRITE (output_unit, '(T4,A)') "Warning: EFermi+bias below lowest computed occupied MO" + END IF ELSE nmo = SIZE(evals(ispin)%array) DO imo = 1, nmo @@ -320,8 +321,9 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) & + IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) THEN WRITE (output_unit, '(T4,A)') "Warning: E-Fermi+bias above highest computed unoccupied MO" + END IF END IF istates = istates + nstates(ispin) END DO diff --git a/src/subsys/colvar_types.F b/src/subsys/colvar_types.F index b7c28982d7..1e390bc3ec 100644 --- a/src/subsys/colvar_types.F +++ b/src/subsys/colvar_types.F @@ -501,7 +501,7 @@ CONTAINS SUBROUTINE colvar_setup(colvar) TYPE(colvar_type), INTENT(INOUT) :: colvar - INTEGER :: i, idum, iend, ii, istart, j, np, stat + INTEGER :: i, idum, iend, ii, istart, j, np INTEGER, DIMENSION(:), POINTER :: list SELECT CASE (colvar%type_id) @@ -660,11 +660,12 @@ CONTAINS IF (colvar%plane_plane_angle_param%plane1%type_of_def == plane_def_atoms) np = np + 3 IF (colvar%plane_plane_angle_param%plane2%type_of_def == plane_def_atoms) np = np + 3 ! if np is equal to zero this means that this is not a COLLECTIVE variable.. - IF (np == 0) & + IF (np == 0) THEN CALL cp_abort(__LOCATION__, & "PLANE_PLANE_ANGLE Colvar defined using two normal vectors! This is "// & "not a COLLECTIVE VARIABLE! One of the two planes must be defined "// & "using atomic positions.") + END IF ! Number of real atoms involved in the colvar colvar%n_atom_s = 0 @@ -850,8 +851,8 @@ CONTAINS i = colvar%xyz_outerdiag_param%i_atoms(2) list(2) = i CASE (u_colvar_id) - np = 1; ALLOCATE (list(np), stat=stat) - CPASSERT(stat == 0) + np = 1 + ALLOCATE (list(np)) colvar%n_atom_s = np; list(1) = 1 CASE (Wc_colvar_id) np = 3 @@ -1034,8 +1035,9 @@ CONTAINS idum = idum + 1 i = i_oxygens(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) & + IF (ANY(i_hydrogens == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS and HYDROGENS list") + END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1046,10 +1048,12 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens) & + IF (i <= n_oxygens) THEN CPABORT("atoms doubled in OXYGENS list") - IF (i > n_oxygens) & + END IF + IF (i > n_oxygens) THEN CPABORT("atoms doubled in HYDROGENS list") + END IF END IF END DO END DO @@ -1113,17 +1117,20 @@ CONTAINS idum = idum + 1 i = i_oxygens_water(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) & + IF (ANY(i_hydrogens == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and HYDROGENS list") - IF (ANY(i_oxygens_acid == i)) & + END IF + IF (ANY(i_oxygens_acid == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and OXYGENS_ACID list") + END IF END DO DO ii = 1, n_oxygens_acid idum = idum + 1 i = i_oxygens_acid(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) & + IF (ANY(i_hydrogens == i)) THEN CPABORT("COLVAR: atoms doubled in OXYGENS_ACID and HYDROGENS list") + END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1134,12 +1141,15 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens_water) & + IF (i <= n_oxygens_water) THEN CPABORT("atoms doubled in OXYGENS_WATER list") - IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) & + END IF + IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) THEN CPABORT("atoms doubled in OXYGENS_ACID list") - IF (i > n_oxygens_water + n_oxygens_acid) & + END IF + IF (i > n_oxygens_water + n_oxygens_acid) THEN CPABORT("atoms doubled in HYDROGENS list") + END IF END IF END DO END DO @@ -1354,7 +1364,7 @@ CONTAINS TYPE(colvar_type), INTENT(IN) :: colvar_in INTEGER, INTENT(IN), OPTIONAL :: i_atom_offset - INTEGER :: i, my_offset, ndim, ndim2, stat + INTEGER :: i, my_offset, ndim, ndim2 my_offset = 0 IF (PRESENT(i_atom_offset)) my_offset = i_atom_offset @@ -1407,7 +1417,7 @@ CONTAINS ndim = SIZE(colvar_in%coord_param%c_kinds_to_b) ALLOCATE (colvar_out%coord_param%c_kinds_to_b(ndim)) colvar_out%coord_param%c_kinds_to_b = colvar_in%coord_param%c_kinds_to_b - ELSEIF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN + ELSE IF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN ! INDEX ndim = SIZE(colvar_in%coord_param%i_at_to_b) ALLOCATE (colvar_out%coord_param%i_at_to_b(ndim)) @@ -1615,11 +1625,11 @@ CONTAINS colvar_out%reaction_path_param%align_frames = colvar_in%reaction_path_param%align_frames colvar_out%reaction_path_param%subset = colvar_in%reaction_path_param%subset ndim = SIZE(colvar_in%reaction_path_param%i_rmsd) - ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim), stat=stat) + ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim)) colvar_out%reaction_path_param%i_rmsd = colvar_in%reaction_path_param%i_rmsd ndim = SIZE(colvar_in%reaction_path_param%r_ref, 1) ndim2 = SIZE(colvar_in%reaction_path_param%r_ref, 2) - ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2), stat=stat) + ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2)) colvar_out%reaction_path_param%r_ref = colvar_in%reaction_path_param%r_ref ELSE ndim = SIZE(colvar_in%reaction_path_param%colvar_p) @@ -1842,8 +1852,9 @@ CONTAINS IF (ASSOCIATED(colvar_p)) THEN DO i = 1, SIZE(colvar_p) - IF (ASSOCIATED(colvar_p(i)%colvar)) & + IF (ASSOCIATED(colvar_p(i)%colvar)) THEN CALL colvar_release(colvar_p(i)%colvar) + END IF END DO DEALLOCATE (colvar_p) END IF diff --git a/src/subsys/external_potential_types.F b/src/subsys/external_potential_types.F index dbdf0c557a..26bc3d047f 100644 --- a/src/subsys/external_potential_types.F +++ b/src/subsys/external_potential_types.F @@ -587,11 +587,13 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) name = potential%name - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN alpha_core_charge = potential%alpha_core_charge + END IF IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN core_charge_radius = potential%core_charge_radius + END IF IF (PRESENT(z)) z = potential%z IF (PRESENT(zeff)) zeff = potential%zeff IF (PRESENT(zeff_correction)) zeff_correction = potential%zeff_correction @@ -763,13 +765,15 @@ CONTAINS IF (PRESENT(name)) name = potential%name IF (PRESENT(aliases)) aliases = potential%aliases - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN alpha_core_charge = potential%alpha_core_charge + END IF IF (PRESENT(alpha_ppl)) alpha_ppl = potential%alpha_ppl IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge IF (PRESENT(cerf_ppl)) cerf_ppl = potential%cerf_ppl - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN core_charge_radius = potential%core_charge_radius + END IF IF (PRESENT(ppl_radius)) ppl_radius = potential%ppl_radius IF (PRESENT(ppnl_radius)) ppnl_radius = potential%ppnl_radius IF (PRESENT(soc_present)) soc_present = potential%soc @@ -1371,9 +1375,10 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1411,9 +1416,10 @@ CONTAINS IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r ELSE @@ -1557,9 +1563,10 @@ CONTAINS ! Read ngau and npol IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) ngau, npol CALL remove_word(line_att) @@ -1579,9 +1586,10 @@ CONTAINS DO igau = 1, ngau IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) alpha(igau), (cval(igau, ipol), ipol=1, npol) ELSE @@ -1775,9 +1783,10 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1818,9 +1827,10 @@ CONTAINS ! distribution and calculate the corresponding coefficient IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2157,9 +2167,10 @@ CONTAINS DO l = 0, lppnl IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2204,13 +2215,15 @@ CONTAINS END IF ELSE IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) & + IF (LEN_TRIM(line_att) /= 0) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) hprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2258,13 +2271,15 @@ CONTAINS ! Read non-local parameters for spin-orbit coupling DO i = 1, nprj_ppnl IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) & + IF (LEN_TRIM(line_att) /= 0) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) & + IF (.NOT. is_ok) THEN CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") + END IF CALL val_get(val, c_val=line_att) READ (line_att, *) kprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2443,11 +2458,13 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN potential%alpha_core_charge = alpha_core_charge + END IF IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN potential%core_charge_radius = core_charge_radius + END IF IF (PRESENT(z)) potential%z = z IF (PRESENT(zeff)) potential%zeff = zeff IF (PRESENT(zeff_correction)) potential%zeff_correction = zeff_correction @@ -2573,13 +2590,15 @@ CONTAINS POINTER :: hprj_ppnl, kprj_ppnl IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) & + IF (PRESENT(alpha_core_charge)) THEN potential%alpha_core_charge = alpha_core_charge + END IF IF (PRESENT(alpha_ppl)) potential%alpha_ppl = alpha_ppl IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge IF (PRESENT(cerf_ppl)) potential%cerf_ppl = cerf_ppl - IF (PRESENT(core_charge_radius)) & + IF (PRESENT(core_charge_radius)) THEN potential%core_charge_radius = core_charge_radius + END IF IF (PRESENT(ppl_radius)) potential%ppl_radius = ppl_radius IF (PRESENT(ppnl_radius)) potential%ppnl_radius = ppnl_radius IF (PRESENT(lppnl)) potential%lppnl = lppnl diff --git a/src/subsys/molecule_kind_types.F b/src/subsys/molecule_kind_types.F index 232123e92e..9943a66164 100644 --- a/src/subsys/molecule_kind_types.F +++ b/src/subsys/molecule_kind_types.F @@ -365,8 +365,9 @@ CONTAINS END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set)) THEN DO i = 1, SIZE(molecule_kind_set(imolecule_kind)%bend_kind_set) - IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) & + IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs) + END IF END DO DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set) END IF @@ -934,24 +935,30 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T9,A,I6,/,T9,A,(T30,5I10))") & "Number of molecules: ", nmolecule, "Molecule list:", & (molecule_kind%molecule_list(imolecule), imolecule=1, nmolecule) - IF (molecule_kind%nbond > 0) & + IF (molecule_kind%nbond > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bonds: ", molecule_kind%nbond - IF (molecule_kind%nbend > 0) & + "Number of bonds: ", molecule_kind%nbond + END IF + IF (molecule_kind%nbend > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bends: ", molecule_kind%nbend - IF (molecule_kind%nub > 0) & + "Number of bends: ", molecule_kind%nbend + END IF + IF (molecule_kind%nub > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of Urey-Bradley:", molecule_kind%nub - IF (molecule_kind%ntorsion > 0) & + "Number of Urey-Bradley:", molecule_kind%nub + END IF + IF (molecule_kind%ntorsion > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of torsions: ", molecule_kind%ntorsion - IF (molecule_kind%nimpr > 0) & + "Number of torsions: ", molecule_kind%ntorsion + END IF + IF (molecule_kind%nimpr > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of improper: ", molecule_kind%nimpr - IF (molecule_kind%nopbend > 0) & + "Number of improper: ", molecule_kind%nimpr + END IF + IF (molecule_kind%nopbend > 0) THEN WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of out opbends: ", molecule_kind%nopbend + "Number of out opbends: ", molecule_kind%nopbend + END IF END IF END IF END SUBROUTINE write_molecule_kind diff --git a/src/subsys/molecule_types.F b/src/subsys/molecule_types.F index f300b5d188..41d097f00c 100644 --- a/src/subsys/molecule_types.F +++ b/src/subsys/molecule_types.F @@ -212,11 +212,13 @@ CONTAINS DEALLOCATE (gci%colv_list) END IF - IF (ASSOCIATED(gci%g3x3_list)) & + IF (ASSOCIATED(gci%g3x3_list)) THEN DEALLOCATE (gci%g3x3_list) + END IF - IF (ASSOCIATED(gci%g4x6_list)) & + IF (ASSOCIATED(gci%g4x6_list)) THEN DEALLOCATE (gci%g4x6_list) + END IF ! Local information IF (ASSOCIATED(gci%lcolv)) THEN @@ -227,14 +229,17 @@ CONTAINS DEALLOCATE (gci%lcolv) END IF - IF (ASSOCIATED(gci%lg3x3)) & + IF (ASSOCIATED(gci%lg3x3)) THEN DEALLOCATE (gci%lg3x3) + END IF - IF (ASSOCIATED(gci%lg4x6)) & + IF (ASSOCIATED(gci%lg4x6)) THEN DEALLOCATE (gci%lg4x6) + END IF - IF (ASSOCIATED(gci%fixd_list)) & + IF (ASSOCIATED(gci%fixd_list)) THEN DEALLOCATE (gci%fixd_list) + END IF DEALLOCATE (gci) END IF diff --git a/src/surface_dipole.F b/src/surface_dipole.F index a4271394e8..ef35421cad 100644 --- a/src/surface_dipole.F +++ b/src/surface_dipole.F @@ -166,7 +166,7 @@ CONTAINS rhoavsurf(i) = accurate_sum(wf_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), i)) END DO - ELSEIF (idir_surfdip == 2) THEN + ELSE IF (idir_surfdip == 2) THEN isurf = 3 jsurf = 1 @@ -258,7 +258,7 @@ CONTAINS IF (idir_surfdip == 3) THEN vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) = & vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) + vdip - ELSEIF (idir_surfdip == 2) THEN + ELSE IF (idir_surfdip == 2) THEN IF (irho >= bo(1, 2) .AND. irho <= bo(2, 2)) THEN vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) = & vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) + vdip diff --git a/src/swarm/glbopt_history.F b/src/swarm/glbopt_history.F index 81cc126cca..a217a22a75 100644 --- a/src/swarm/glbopt_history.F +++ b/src/swarm/glbopt_history.F @@ -213,8 +213,9 @@ CONTAINS ALLOCATE (history%entries(k)%p) history%entries(k)%p = fingerprint - IF (PRESENT(id)) & + IF (PRESENT(id)) THEN history%entries(k)%id = id + END IF history%length = history%length + 1 IF (debug) THEN @@ -222,8 +223,9 @@ CONTAINS DO k = 1, history%length !WRITE(*,*) "history: ", k, "Epot",history%entries(k)%p%Epot IF (k > 1) THEN - IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) & + IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) THEN CPABORT("history_add: history in wrong order") + END IF END IF END DO END IF @@ -374,8 +376,9 @@ CONTAINS INTEGER :: i DO i = 1, history%length - IF (ASSOCIATED(history%entries(i)%p)) & + IF (ASSOCIATED(history%entries(i)%p)) THEN DEALLOCATE (history%entries(i)%p) + END IF END DO DEALLOCATE (history%entries) diff --git a/src/swarm/glbopt_mincrawl.F b/src/swarm/glbopt_mincrawl.F index ce6938ec53..bbb9eb7133 100644 --- a/src/swarm/glbopt_mincrawl.F +++ b/src/swarm/glbopt_mincrawl.F @@ -182,8 +182,9 @@ CONTAINS RETURN END IF - IF (TRIM(status) == "ok") & + IF (TRIM(status) == "ok") THEN CALL mincrawl_register_minima(this, report) + END IF IF (.FALSE.) CALL print_tempdist(best_minima) diff --git a/src/swarm/glbopt_minhop.F b/src/swarm/glbopt_minhop.F index 9bde51b2d7..53c4202532 100644 --- a/src/swarm/glbopt_minhop.F +++ b/src/swarm/glbopt_minhop.F @@ -217,8 +217,9 @@ CONTAINS ! new locally lowest IF (this%iw > 0) WRITE (this%iw, '(A)') " MINHOP| New locally lowest" this%worker_state(wid)%Epot_hop = report_Epot - IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) & + IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) THEN ALLOCATE (this%worker_state(wid)%pos_hop(SIZE(report_positions))) + END IF this%worker_state(wid)%pos_hop(:) = report_positions this%worker_state(wid)%fp_hop = report_fp END IF diff --git a/src/swarm/glbopt_worker.F b/src/swarm/glbopt_worker.F index 78e14d9927..bcb2f8134a 100644 --- a/src/swarm/glbopt_worker.F +++ b/src/swarm/glbopt_worker.F @@ -232,8 +232,9 @@ CONTAINS END DO CALL unpack_subsys_particles(worker%subsys, r=positions) - IF (n_fragments > 0 .AND. worker%iw > 0) & + IF (n_fragments > 0 .AND. worker%iw > 0) THEN WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Ran fix_fragmentation times:", n_fragments + END IF ! setup geometry optimization IF (worker%iw > 0) WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Starting local optimisation at trajectory frame ", iframe @@ -292,10 +293,10 @@ CONTAINS DO WHILE (stack_size > 0) i = stack(stack_size); stack_size = stack_size - 1 !pop DO j = 1, n_particles - IF (norm(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected + IF (NORM2(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected IF (.NOT. marked(j)) THEN marked(j) = .TRUE. - stack(stack_size + 1) = j; stack_size = stack_size + 1; !push + stack(stack_size + 1) = j; stack_size = stack_size + 1 !push END IF END IF END DO @@ -314,7 +315,7 @@ CONTAINS IF (marked(i)) CYCLE DO j = 1, n_particles IF (.NOT. marked(j)) CYCLE - d = norm(diff(positions, i, j)) + d = NORM2(diff(positions, i, j)) IF (d < min_dist) THEN min_dist = d cluster_edge = i @@ -324,7 +325,7 @@ CONTAINS END DO dr = diff(positions, cluster_edge, fragment_edge) - s = 1.0 - bondlength/norm(dr) + s = 1.0 - bondlength/NORM2(dr) DO i = 1, n_particles IF (marked(i)) CYCLE positions(3*i - 2:3*i) = positions(3*i - 2:3*i) - s*dr @@ -348,19 +349,6 @@ CONTAINS dr = positions(3*i - 2:3*i) - positions(3*j - 2:3*j) END FUNCTION diff -! ************************************************************************************************** -!> \brief Helper routine for fix_fragmentation, calculates vector norm -!> \param vec ... -!> \return ... -!> \author Ole Schuett -! ************************************************************************************************** - PURE FUNCTION norm(vec) RESULT(res) - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec - REAL(KIND=dp) :: res - - res = SQRT(DOT_PRODUCT(vec, vec)) - END FUNCTION norm - ! ************************************************************************************************** !> \brief Finalizes worker for global optimization !> \param worker ... diff --git a/src/swarm/swarm_master.F b/src/swarm/swarm_master.F index 703686c352..bd627a6d5d 100644 --- a/src/swarm/swarm_master.F +++ b/src/swarm/swarm_master.F @@ -261,8 +261,9 @@ CONTAINS IF (.NOT. master%should_stop) THEN CALL external_control(master%should_stop, "SWARM", master%globenv) - IF (master%should_stop .AND. master%iw > 0) & + IF (master%should_stop .AND. master%iw > 0) THEN WRITE (master%iw, *) " SWARM| Received stop from external_control. Quitting." + END IF END IF !IF(unit > 0) & diff --git a/src/swarm/swarm_message.F b/src/swarm/swarm_message.F index 96418c033a..79bc07e666 100644 --- a/src/swarm/swarm_message.F +++ b/src/swarm/swarm_message.F @@ -866,8 +866,9 @@ CONTAINS TYPE(message_entry_type), POINTER :: new_entry - IF (swarm_message_haskey(msg, key)) & + IF (swarm_message_haskey(msg, key)) THEN CPABORT("swarm_message_add_${label}$: key already exists: "//TRIM(key)) + END IF ALLOCATE (new_entry) new_entry%key = key @@ -920,8 +921,9 @@ CONTAINS curr_entry => msg%root DO WHILE (ASSOCIATED(curr_entry)) IF (TRIM(curr_entry%key) == TRIM(key)) THEN - IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) & + IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) THEN CPABORT("swarm_message_get_${label}$: value not associated key: "//TRIM(key)) + END IF #:if label.startswith("1d_") ALLOCATE (value(SIZE(curr_entry%value_${label}$))) #:endif diff --git a/src/swarm/swarm_mpi.F b/src/swarm/swarm_mpi.F index f1f4842ffe..db985c32f6 100644 --- a/src/swarm/swarm_mpi.F +++ b/src/swarm/swarm_mpi.F @@ -133,8 +133,9 @@ CONTAINS !WRITE (*,*) "this is worker ", worker_id, swarm_mpi%worker%mepos, swarm_mpi%worker%num_pe ! collect world-ranks of each worker groups rank-0 node - IF (swarm_mpi%worker%mepos == 0) & + IF (swarm_mpi%worker%mepos == 0) THEN swarm_mpi%wid2group(worker_id) = swarm_mpi%world%mepos + END IF END IF @@ -162,14 +163,16 @@ CONTAINS logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr swarm_mpi%master_output_path = output_unit2path(output_unit) - IF (output_unit /= default_output_unit) & + IF (output_unit /= default_output_unit) THEN CLOSE (output_unit) + END IF END IF CALL swarm_mpi%world%bcast(swarm_mpi%master_output_path) - IF (ASSOCIATED(swarm_mpi%master)) & + IF (ASSOCIATED(swarm_mpi%master)) THEN CALL error_add_new_logger(swarm_mpi%master, swarm_mpi%master_output_path) + END IF END SUBROUTINE logger_init_master ! ************************************************************************************************** @@ -183,8 +186,9 @@ CONTAINS CHARACTER(LEN=default_path_length) :: output_path output_path = "__STD_OUT__" - IF (output_unit /= default_output_unit) & + IF (output_unit /= default_output_unit) THEN INQUIRE (unit=output_unit, name=output_path) + END IF END FUNCTION output_unit2path ! ************************************************************************************************** @@ -245,9 +249,10 @@ CONTAINS IF (para_env%is_source()) THEN ! open output_unit according to output_path output_unit = default_output_unit - IF (output_path /= "__STD_OUT__") & + IF (output_path /= "__STD_OUT__") THEN CALL open_file(file_name=output_path, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", unit_number=output_unit) + END IF END IF old_logger => cp_get_default_logger() @@ -294,8 +299,9 @@ CONTAINS NULLIFY (logger, old_logger) logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr - IF (output_unit > 0 .AND. output_unit /= default_output_unit) & + IF (output_unit > 0 .AND. output_unit /= default_output_unit) THEN CALL close_file(output_unit) + END IF CALL cp_rm_default_logger() !pops the top-most logger old_logger => cp_get_default_logger() diff --git a/src/swarm/swarm_worker.F b/src/swarm/swarm_worker.F index 2b51172354..13c8f698e8 100644 --- a/src/swarm/swarm_worker.F +++ b/src/swarm/swarm_worker.F @@ -123,8 +123,9 @@ CONTAINS END SELECT END IF - IF (.NOT. swarm_message_haskey(report, "status")) & + IF (.NOT. swarm_message_haskey(report, "status")) THEN CALL swarm_message_add(report, "status", "ok") + END IF END SUBROUTINE swarm_worker_execute diff --git a/src/task_list_methods.F b/src/task_list_methods.F index f7983f47a6..5b467db21c 100644 --- a/src/task_list_methods.F +++ b/src/task_list_methods.F @@ -1682,8 +1682,7 @@ CONTAINS DO i = 1, desc%group_size ! At the moment we can only offload replicated tasks - IF (load_imbalance(i) > 0) & - load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) + IF (load_imbalance(i) > 0) load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) END DO ! simplest algorithm I can think of of is that the processor with the most @@ -1935,8 +1934,9 @@ CONTAINS DO igrid_level = 1, SIZE(rs_descs) IF (rs_descs(igrid_level)%rs_desc%distributed) THEN - IF (.NOT. skip_load_balance_distributed) & + IF (.NOT. skip_load_balance_distributed) THEN CALL load_balance_distributed(tasks, ntasks, rs_descs, igrid_level, natoms) + END IF CALL get_current_loads(loads(:, igrid_level), rs_descs, igrid_level, ntasks, & tasks, use_reordered_ranks=.FALSE.) @@ -1958,10 +1958,6 @@ CONTAINS END IF END DO - !IF (desc%my_pos==0) THEN - ! WRITE(*,*) "Total replicated load is ",replicated_load - !END IF - ! Now we adjust the rank ordering based on the current loads ! we leave the first distributed level and all the replicated levels in the default order IF (reorder_rs_grid_ranks) THEN @@ -2022,21 +2018,6 @@ CONTAINS ! Now we use the replicated tasks to balance out the rest of the load CALL load_balance_replicated(rs_descs, ntasks, tasks) - !total_loads = 0 - !DO igrid_level=1,SIZE(rs_descs) - ! CALL get_current_loads(loads(:,igrid_level), rs_descs, igrid_level, ntasks, & - ! tasks, use_reordered_ranks=.TRUE.) - ! total_loads = total_loads + loads(:, igrid_level) - !END DO - - !IF (desc%my_pos==0) THEN - ! WRITE(*,*) "" - ! WRITE(*,*) "At the end of the load balancing procedure" - ! WRITE(*,*) "Maximum load:",MAXVAL(total_loads) - ! WRITE(*,*) "Average load:",SUM(total_loads)/SIZE(total_loads) - ! WRITE(*,*) "Minimum load:",MINVAL(total_loads) - !ENDIF - ! given a list of tasks, this will do the needed reshuffle so that all tasks will be local CALL create_local_tasks(rs_descs, ntasks, tasks, ntasks_recv, tasks_recv) @@ -2046,13 +2027,6 @@ CONTAINS ! CALL get_atom_pair(atom_pair_send, tasks, ntasks=ntasks, send=.TRUE., symmetric=symmetric, rs_descs=rs_descs) - ! natom_send=SIZE(atom_pair_send) - ! CALL desc%group%sum(natom_send) - ! IF (desc%my_pos==0) THEN - ! WRITE(*,*) "" - ! WRITE(*,*) "Total number of atomic blocks to be send:",natom_send - ! ENDIF - CALL get_atom_pair(atom_pair_recv, tasks_recv, ntasks=ntasks_recv, send=.FALSE., symmetric=symmetric, rs_descs=rs_descs) ! cleanup, at this point we don't need the original tasks anymore @@ -2859,18 +2833,24 @@ CONTAINS tasks(itask)%subpatch_pattern = 0 ! encode the domain size for this task ! if the bit is set, we need to add the border in that direction - IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) & + IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 0) - IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) & + END IF + IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 1) - IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) & + END IF + IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 2) - IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) & + END IF + IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 3) - IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) & + END IF + IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 4) - IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) & + END IF + IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) THEN tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 5) + END IF itask = itask + 1 END DO END DO diff --git a/src/tblite_interface.F b/src/tblite_interface.F index c15de30544..fe2be3e8d6 100644 --- a/src/tblite_interface.F +++ b/src/tblite_interface.F @@ -180,8 +180,9 @@ CONTAINS nspin = SIZE(matrix_p, 1) nimg = SIZE(matrix_p, 2) IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN - IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) & + IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) THEN CALL dbcsr_deallocate_matrix_set(tb%rho_ao_kp_ref) + END IF END IF IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN CALL dbcsr_allocate_matrix_set(tb%rho_ao_kp_ref, nspin, nimg) @@ -337,8 +338,9 @@ CONTAINS info = tb%calc%variable_info() IF (info%charge > shell_resolved) CPABORT("tblite: no support for orbital resolved charge") IF (info%dipole > atom_resolved) CPABORT("tblite: no support for shell resolved dipole moment") - IF (info%quadrupole > atom_resolved) & + IF (info%quadrupole > atom_resolved) THEN CPABORT("tblite: no support shell resolved quadrupole moment") + END IF CALL new_wavefunction(tb%wfn, tb%mol%nat, tb%calc%bas%nsh, tb%calc%bas%nao, nSpin, 0.0_dp) CALL get_occupation(tb%mol, tb%calc%bas, tb%calc%h0, tb%wfn%nocc, tb%wfn%n0at, tb%wfn%n0sh) @@ -463,8 +465,9 @@ CONTAINS IF (omega0 <= 0.0_dp) CPABORT("tblite SCC mixer OMEGA0 must be positive") IF (min_weight <= 0.0_dp) CPABORT("tblite SCC mixer MIN_WEIGHT must be positive") IF (max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (max_weight < min_weight) & + IF (max_weight < min_weight) THEN CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") + END IF IF (weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") SELECT CASE (solver) CASE (tblite_solver_gvd, tblite_solver_gvr) @@ -1470,8 +1473,9 @@ CONTAINS END IF !compute multipole moments for gfn2 - IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) & + IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) THEN CALL tb_get_multipole(qs_env, tb) + END IF ! output overlap information NULLIFY (logger) @@ -1582,7 +1586,7 @@ CONTAINS CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_GRADIENT", debug_value, STATUS=debug_status) IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_gradient CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_POTENTIAL", debug_value, STATUS=debug_status) - IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_potential + IF (debug_status == 0) READ (debug_value, *) skip_scf_dispersion_potential #endif IF (dft_control%qs_control%do_ls_scf .OR. scf_control%use_ot) THEN use_native_mixer = .FALSE. @@ -1630,9 +1634,10 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSEIF (calculate_forces .AND. nspin > 1) THEN - IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) & + ELSE IF (calculate_forces .AND. nspin > 1) THEN + IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN CPABORT("Missing converged tblite density for UKS/LSD forces") + END IF matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -1923,7 +1928,7 @@ CONTAINS ! LS_SCF and OT optimize the electronic variables directly. Use the ! current shell/multipole response from that density without an ! extra SCC variable mixing step. - ELSEIF (nspin > 1) THEN + ELSE IF (nspin > 1) THEN n_mix_cols = nspin*max_shell IF (do_dipole) n_mix_cols = n_mix_cols + nspin*dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + nspin*quad_n @@ -1987,7 +1992,7 @@ CONTAINS skip_charge_mixing = use_no_mixer IF (skip_charge_mixing) THEN ! - ELSEIF (do_combined_mixing) THEN + ELSE IF (do_combined_mixing) THEN n_mix_cols = max_shell IF (do_dipole) n_mix_cols = n_mix_cols + dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + quad_n @@ -2118,10 +2123,12 @@ CONTAINS CALL tb%calc%coulomb%get_energy(tb%mol, tb%cache, tb%wfn, tb%e_es) END IF IF (ALLOCATED(tb%calc%dispersion)) THEN - IF (.NOT. skip_scf_dispersion_potential) & + IF (.NOT. skip_scf_dispersion_potential) THEN CALL tb%calc%dispersion%get_potential(tb%mol, tb%dcache, tb%wfn, tb%pot) - IF (.NOT. skip_scf_dispersion_energy) & + END IF + IF (.NOT. skip_scf_dispersion_energy) THEN CALL tb%calc%dispersion%get_energy(tb%mol, tb%dcache, tb%wfn, tb%e_scd) + END IF END IF IF (ALLOCATED(tb%calc%interactions)) THEN CALL tb%calc%interactions%get_potential(tb%mol, tb%icache, tb%wfn, tb%pot) @@ -3484,8 +3491,9 @@ CONTAINS kpoint_coordinate = REAL(2*ikp_axis - nkp_grid(i) - 1, KIND=dp)/ & REAL(2*nkp_grid(i), KIND=dp) + kp_shift(i) END IF - IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) & + IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) THEN mesh_has_gamma(i) = .TRUE. + END IF END DO END DO has_multipole_response = ASSOCIATED(tb%dipbra) .OR. ASSOCIATED(tb%quadbra) @@ -3493,7 +3501,7 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSEIF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN + ELSE IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -3933,8 +3941,9 @@ CONTAINS post_processing_output_file = "" IF (LEN_TRIM(ref%grad_file) > 0) grad_file = ref%grad_file IF (LEN_TRIM(ref%json_file) > 0) json_file = ref%json_file - IF (LEN_TRIM(ref%post_processing_output_file) > 0) & + IF (LEN_TRIM(ref%post_processing_output_file) > 0) THEN post_processing_output_file = ref%post_processing_output_file + END IF WRITE (charge_str, "(I0)") dft_control%charge spin = MAX(0, dft_control%multiplicity - 1) @@ -4026,8 +4035,9 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_min_weight_default, & ", while CP2K uses MIN_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_min_weight, "." - IF (ref%stop_on_error) & + IF (ref%stop_on_error) THEN CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MIN_WEIGHT") + END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_max_weight - & tblite_mixer_max_weight_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4036,8 +4046,9 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_max_weight_default, & ", while CP2K uses MAX_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_max_weight, "." - IF (ref%stop_on_error) & + IF (ref%stop_on_error) THEN CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MAX_WEIGHT") + END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_weight_factor - & tblite_mixer_weight_factor_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4047,19 +4058,22 @@ CONTAINS "The native reference run uses tblite's library default ", tblite_mixer_weight_factor_default, & ", while CP2K uses WEIGHT_FACTOR ", & dft_control%qs_control%xtb_control%tblite_mixer_weight_factor, "." - IF (ref%stop_on_error) & + IF (ref%stop_on_error) THEN CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/WEIGHT_FACTOR") + END IF END IF etemp = 300.0_dp - IF (ASSOCIATED(scf_control) .AND. ASSOCIATED(scf_control%smear)) THEN - IF (scf_control%smear%do_smear) THEN - etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") - IF (scf_control%smear%method /= smear_fermi_dirac) THEN - WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & - "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & - TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." - WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & - "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." + IF (ASSOCIATED(scf_control)) THEN + IF (ASSOCIATED(scf_control%smear)) THEN + IF (scf_control%smear%do_smear) THEN + etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") + IF (scf_control%smear%method /= smear_fermi_dirac) THEN + WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & + "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & + TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." + WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & + "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." + END IF END IF END IF END IF @@ -4072,13 +4086,15 @@ CONTAINS etemp_guess_str = " --etemp-guess "//TRIM(ADJUSTL(etemp_guess_val_str)) END IF param_str = "" - IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) & + IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) THEN param_str = " --param "//TRIM(tb_shell_quote(dft_control%qs_control%xtb_control%tblite_param_file)) + END IF spinpol_str = "" IF (dft_control%lsd) spinpol_str = " --spin-polarized" post_processing_str = "" - IF (LEN_TRIM(ref%post_processing) > 0) & + IF (LEN_TRIM(ref%post_processing) > 0) THEN post_processing_str = " --post-processing "//TRIM(tb_shell_quote(ref%post_processing)) + END IF post_processing_output_str = "" IF (LEN_TRIM(post_processing_output_file) > 0) THEN WRITE (UNIT=iounit, FMT="(/,T2,A)") & @@ -4089,8 +4105,9 @@ CONTAINS TRIM(tb_shell_quote(post_processing_output_file)) END IF restart_str = " --no-restart" - IF (LEN_TRIM(ref%restart_file) > 0) & + IF (LEN_TRIM(ref%restart_file) > 0) THEN restart_str = " --restart "//TRIM(tb_shell_quote(ref%restart_file)) + END IF CALL tb_write_reference_gen(qs_env, TRIM(gen_file)) @@ -4138,17 +4155,22 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,A)") "Guess: ", TRIM(guess) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Solver: ", TRIM(solver) WRITE (UNIT=iounit, FMT="(T2,A,L1)") "Spin-pol.: ", dft_control%lsd - IF (ref%efield_active) & + IF (ref%efield_active) THEN WRITE (UNIT=iounit, FMT="(T2,A,3ES16.8,A)") "Efield: ", ref%efield, " V/Angstrom" - IF (ref%solvation_active) & + END IF + IF (ref%solvation_active) THEN WRITE (UNIT=iounit, FMT="(T2,A,A,1X,A)") "Solvation: ", TRIM(solvation_model_name), & - TRIM(ref%solvation_solvent) - IF (LEN_TRIM(ref%post_processing) > 0) & + TRIM(ref%solvation_solvent) + END IF + IF (LEN_TRIM(ref%post_processing) > 0) THEN WRITE (UNIT=iounit, FMT="(T2,A,A)") "Post proc.: ", TRIM(ref%post_processing) - IF (LEN_TRIM(post_processing_output_file) > 0) & + END IF + IF (LEN_TRIM(post_processing_output_file) > 0) THEN WRITE (UNIT=iounit, FMT="(T2,A,A)") "PP output: ", TRIM(post_processing_output_file) - IF (ref%electronic_temperature_guess > 0.0_dp) & + END IF + IF (ref%electronic_temperature_guess > 0.0_dp) THEN WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") "Guess etemp:", etemp_guess, " K" + END IF WRITE (UNIT=iounit, FMT="(T2,A,A)") "Grad file: ", TRIM(grad_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "JSON file: ", TRIM(json_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Log file: ", TRIM(log_file) @@ -4351,8 +4373,9 @@ CONTAINS grad_str = "" IF (ref%guess_cli%grad) grad_str = " --grad" json_str = "" - IF (LEN_TRIM(ref%guess_cli%json_file) > 0) & + IF (LEN_TRIM(ref%guess_cli%json_file) > 0) THEN json_str = " --json "//TRIM(tb_shell_quote(ref%guess_cli%json_file)) + END IF log_file = TRIM(file_base)//".guess.log" command = TRIM(tb_shell_quote(ref%program_name))// & " guess --charge "//TRIM(ADJUSTL(charge_str))// & @@ -4367,38 +4390,44 @@ CONTAINS " "//TRIM(tb_shell_quote(guess_input))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "guess", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) & + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) THEN CALL tb_delete_file(ref%guess_cli%json_file) + END IF END IF IF (ref%param_cli%enabled) THEN method_str = "" - IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) & + IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) THEN method_str = " --method "// & TRIM(tb_reference_method_name(MERGE(ref%param_cli%method, & dft_control%qs_control%xtb_control%tblite_method, & ref%param_cli%method_explicit))) + END IF output_str = "" - IF (LEN_TRIM(ref%param_cli%output_file) > 0) & + IF (LEN_TRIM(ref%param_cli%output_file) > 0) THEN output_str = " --output "//TRIM(tb_shell_quote(ref%param_cli%output_file)) + END IF log_file = TRIM(file_base)//".param.log" command = TRIM(tb_shell_quote(ref%program_name))//" param"// & TRIM(method_str)// & TRIM(output_str) - IF (LEN_TRIM(ref%param_cli%input_file) > 0) & + IF (LEN_TRIM(ref%param_cli%input_file) > 0) THEN command = TRIM(command)//" "//TRIM(tb_shell_quote(ref%param_cli%input_file)) + END IF command = TRIM(command)//" > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "param", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) & + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) THEN CALL tb_delete_file(ref%param_cli%output_file) + END IF END IF IF (ref%fit_cli%enabled) THEN dry_run_str = "" IF (ref%fit_cli%dry_run) dry_run_str = " --dry-run" copy_str = "" - IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) & + IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN copy_str = " --copy "//TRIM(tb_shell_quote(ref%fit_cli%copy_file)) + END IF log_file = TRIM(file_base)//".fit.log" command = TRIM(tb_shell_quote(ref%program_name))//" fit"// & TRIM(dry_run_str)// & @@ -4407,8 +4436,9 @@ CONTAINS " "//TRIM(tb_shell_quote(ref%fit_cli%input_file))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "fit", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) & + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN CALL tb_delete_file(ref%fit_cli%copy_file) + END IF END IF IF (ref%tagdiff_cli%enabled) THEN @@ -4740,8 +4770,9 @@ CONTAINS CALL tb_delete_file(grad_file) CALL tb_delete_file(json_file) CALL tb_delete_file(log_file) - IF (LEN_TRIM(post_processing_output_file) > 0) & + IF (LEN_TRIM(post_processing_output_file) > 0) THEN CALL tb_delete_file(post_processing_output_file) + END IF END SUBROUTINE tb_reference_cleanup diff --git a/src/tblite_scc_mixer.F b/src/tblite_scc_mixer.F index 237f33576f..84a6bf6d4b 100644 --- a/src/tblite_scc_mixer.F +++ b/src/tblite_scc_mixer.F @@ -220,7 +220,7 @@ CONTAINS ALLOCATE (beta(MIN(memory, itn), MIN(memory, itn)), c(MIN(memory, itn), 1)) - omega(it1) = SQRT(DOT_PRODUCT(dq, dq)) + omega(it1) = NORM2(dq) IF (omega(it1) > (wfac/maxw)) THEN omega(it1) = wfac/omega(it1) ELSE @@ -229,7 +229,7 @@ CONTAINS IF (omega(it1) < minw) omega(it1) = minw df(:, it1) = dq - dqlast - inv = MAX(SQRT(DOT_PRODUCT(df(:, it1), df(:, it1))), EPSILON(1.0_wp)) + inv = MAX(NORM2(df(:, it1)), EPSILON(1.0_wp)) inv = 1.0_wp/inv df(:, it1) = inv*df(:, it1) diff --git a/src/tblite_types.F b/src/tblite_types.F index 5fb1e505c7..5ed92fa276 100644 --- a/src/tblite_types.F +++ b/src/tblite_types.F @@ -133,16 +133,21 @@ CONTAINS IF (ALLOCATED(tb_tblite%dcndr)) DEALLOCATE (tb_tblite%dcndr) IF (ALLOCATED(tb_tblite%dcndL)) DEALLOCATE (tb_tblite%dcndL) - IF (ASSOCIATED(tb_tblite%dipbra)) & + IF (ASSOCIATED(tb_tblite%dipbra)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%dipbra) - IF (ASSOCIATED(tb_tblite%dipket)) & + END IF + IF (ASSOCIATED(tb_tblite%dipket)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%dipket) - IF (ASSOCIATED(tb_tblite%quadbra)) & + END IF + IF (ASSOCIATED(tb_tblite%quadbra)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%quadbra) - IF (ASSOCIATED(tb_tblite%quadket)) & + END IF + IF (ASSOCIATED(tb_tblite%quadket)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%quadket) - IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) & + END IF + IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) THEN CALL dbcsr_deallocate_matrix_set(tb_tblite%rho_ao_kp_ref) + END IF #if defined(__TBLITE) IF (ALLOCATED(tb_tblite%mixer)) DEALLOCATE (tb_tblite%mixer) IF (ALLOCATED(tb_tblite%param)) DEALLOCATE (tb_tblite%param) diff --git a/src/tmc/tmc_analysis.F b/src/tmc/tmc_analysis.F index 574ef635c3..a8dfda06b5 100644 --- a/src/tmc/tmc_analysis.F +++ b/src/tmc/tmc_analysis.F @@ -118,13 +118,15 @@ CONTAINS CALL section_vals_val_get(tmc_ana_section, "DENSITY", i_vals=i_arr_tmp) IF (SIZE(i_arr_tmp(:)) == 3) THEN - IF (ANY(i_arr_tmp(:) <= 0)) & + IF (ANY(i_arr_tmp(:) <= 0)) THEN CALL cp_abort(__LOCATION__, "The amount of intervals in each "// & "direction has to be greater than 0.") + END IF nr_bins(:) = i_arr_tmp(:) ELSE IF (SIZE(i_arr_tmp(:)) == 1) THEN - IF (ANY(i_arr_tmp(:) <= 0)) & + IF (ANY(i_arr_tmp(:) <= 0)) THEN CPABORT("The amount of intervals has to be greater than 0.") + END IF nr_bins(:) = i_arr_tmp(1) ELSE IF (SIZE(i_arr_tmp(:)) == 0) THEN nr_bins(:) = 1 @@ -250,13 +252,15 @@ CONTAINS END IF ! init radial distribution function - IF (ASSOCIATED(ana_env%pair_correl)) & + IF (ASSOCIATED(ana_env%pair_correl)) THEN CALL ana_pair_correl_init(ana_pair_correl=ana_env%pair_correl, & atoms=ana_env%atoms, cell=ana_env%cell) + END IF ! init classical dipole moment calculations - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN CALL ana_dipole_moment_init(ana_dip_mom=ana_env%dip_mom, & atoms=ana_env%atoms) + END IF END SUBROUTINE analysis_init ! ************************************************************************************************** @@ -484,18 +488,21 @@ CONTAINS IF (weight_act > 0) THEN ! calculates the 3 dimensional distributed density - IF (ASSOCIATED(ana_env%density_3d)) & + IF (ASSOCIATED(ana_env%density_3d)) THEN CALL calc_density_3d(elem=ana_env%last_elem, & weight=weight_act, atoms=ana_env%atoms, & ana_env=ana_env) + END IF ! calculated the radial distribution function for each atom type - IF (ASSOCIATED(ana_env%pair_correl)) & + IF (ASSOCIATED(ana_env%pair_correl)) THEN CALL calc_paircorrelation(elem=ana_env%last_elem, weight=weight_act, & atoms=ana_env%atoms, ana_env=ana_env) + END IF ! calculates the classical dipole moments - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN CALL calc_dipole_moment(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) + END IF ! calculates the dipole moments analysis and dielectric constant IF (ASSOCIATED(ana_env%dip_ana)) THEN ! in symmetric case use also the dipoles @@ -504,64 +511,72 @@ CONTAINS ! (-x,y,z) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(3) = -ana_env%last_elem%dipole(3) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(3) = -ana_env%dip_mom%last_dip_cl(3) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(:) = -ana_env%last_elem%dipole(:) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(:) = -ana_env%dip_mom%last_dip_cl(:) + END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! back to (x,y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) & + IF (ASSOCIATED(ana_env%dip_mom)) THEN ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) + END IF END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) @@ -600,24 +615,29 @@ CONTAINS ! start the timing CALL timeset(routineN, handle) IF (ASSOCIATED(ana_env%density_3d)) THEN - IF (ana_env%density_3d%conf_counter > 0) & + IF (ana_env%density_3d%conf_counter > 0) THEN CALL print_density_3d(ana_env=ana_env) + END IF END IF IF (ASSOCIATED(ana_env%pair_correl)) THEN - IF (ana_env%pair_correl%conf_counter > 0) & + IF (ana_env%pair_correl%conf_counter > 0) THEN CALL print_paircorrelation(ana_env=ana_env) + END IF END IF IF (ASSOCIATED(ana_env%dip_mom)) THEN - IF (ana_env%dip_mom%conf_counter > 0) & + IF (ana_env%dip_mom%conf_counter > 0) THEN CALL print_dipole_moment(ana_env) + END IF END IF IF (ASSOCIATED(ana_env%dip_ana)) THEN - IF (ana_env%dip_ana%conf_counter > 0) & + IF (ana_env%dip_ana%conf_counter > 0) THEN CALL print_dipole_analysis(ana_env) + END IF END IF IF (ASSOCIATED(ana_env%displace)) THEN - IF (ana_env%displace%conf_counter > 0) & + IF (ana_env%displace%conf_counter > 0) THEN CALL print_average_displacement(ana_env) + END IF END IF ! end the timing @@ -691,16 +711,18 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=elem) END IF ! if there was no previous element, create a new temp element to write in - IF (.NOT. ASSOCIATED(elem)) & + IF (.NOT. ASSOCIATED(elem)) THEN CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem, & nr_dim=nr_dim) + END IF END DO conf_loop END IF ! close the files CALL analyse_files_close(tmc_ana=ana_env) - IF (ASSOCIATED(elem)) & + IF (ASSOCIATED(elem)) THEN CALL deallocate_sub_tree_node(tree_elem=elem) + END IF ! end the timing CALL timestop(handle) @@ -843,11 +865,12 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) & + IF (.NOT. flag) THEN WRITE (file_ptr, FMT='(A8,11A20)') "# conf_nr", "dens_act[g/cm^3]", & - "dens_average[g/cm^3]", "density_variance", & - "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & - "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" + "dens_average[g/cm^3]", "density_variance", & + "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & + "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" + END IF WRITE (file_ptr, FMT="(I8,11F20.10)") ana_env%density_3d%conf_counter + 1 - weight, & SUM(mass_bin(:, :, :))/vol_sub_box/SIZE(mass_bin(:, :, :)), & SUM(ana_env%density_3d%sum_density(:, :, :))/ & @@ -975,11 +998,12 @@ CONTAINS SIZE(ana_env%density_3d%sum_density(:, :, :))/ & REAL(ana_env%density_3d%conf_counter, KIND=dp))**2) WRITE (ana_env%io_unit, FMT="(/,T2,A)") REPEAT("-", 79) - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (ana_env%io_unit, *) "TMC|ANALYSIS_CELL_DENSITY_X= ", & - SUM(ana_env%density_3d%sum_density(:, :, :))/ & - SIZE(ana_env%density_3d%sum_density(:, :, :))/ & - REAL(ana_env%density_3d%conf_counter, KIND=dp) + SUM(ana_env%density_3d%sum_density(:, :, :))/ & + SIZE(ana_env%density_3d%sum_density(:, :, :))/ & + REAL(ana_env%density_3d%conf_counter, KIND=dp) + END IF ! end the timing CALL timestop(handle) END SUBROUTINE print_density_3d @@ -1175,12 +1199,13 @@ CONTAINS END DO CALL close_file(unit_number=file_ptr) - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (*, *) "TMC|ANALYSIS_G_R_"// & - TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & - TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & - SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & - voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) + TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & + TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & + SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & + voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) + END IF END DO ! end the timing @@ -1297,9 +1322,10 @@ CONTAINS SUBROUTINE print_dipole_moment(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (*, *) "TMC|ANALYSIS_FINAL_CLASS_CELL_DIPOLE_MOMENT_X= ", & - ana_env%dip_mom%last_dip_cl(:) + ana_env%dip_mom%last_dip_cl(:) + END IF END SUBROUTINE print_dipole_moment ! ************************************************************************************************** @@ -1327,8 +1353,9 @@ CONTAINS CPASSERT(ASSOCIATED(ana_env%dip_ana)) weight_act = weight - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN weight_act = weight_act/REAL(8.0, KIND=dp) + END IF ! get the volume ALLOCATE (scaled_cell) @@ -1521,12 +1548,14 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "temperature ", cp_to_string(ana_env%temperature) WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "used configurations ", & cp_to_string(REAL(ana_env%dip_ana%conf_counter, KIND=dp)) - IF (ana_env%dip_ana%ana_type == ana_type_ice) & + IF (ana_env%dip_ana%ana_type == ana_type_ice) THEN WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with directions of hexagonal structure" - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & + "ice analysis with directions of hexagonal structure" + END IF + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with symmetrized dipoles in each direction." + "ice analysis with symmetrized dipoles in each direction." + END IF WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "for product of 2 directions(per vol):" DO i = 1, 3 @@ -1607,8 +1636,9 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) & + IF (.NOT. flag) THEN WRITE (file_ptr, *) "# conf squared deviation of the cell" + END IF WRITE (file_ptr, *) elem%nr, disp CALL close_file(unit_number=file_ptr) END IF @@ -1638,9 +1668,10 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "cell root mean square deviation: ", & cp_to_string(SQRT(ana_env%displace%disp/ & REAL(ana_env%displace%conf_counter, KIND=dp))) - IF (ana_env%print_test_output) & + IF (ana_env%print_test_output) THEN WRITE (*, *) "TMC|ANALYSIS_AVERAGE_CELL_DISPLACEMENT_X= ", & - SQRT(ana_env%displace%disp/ & - REAL(ana_env%displace%conf_counter, KIND=dp)) + SQRT(ana_env%displace%disp/ & + REAL(ana_env%displace%conf_counter, KIND=dp)) + END IF END SUBROUTINE print_average_displacement END MODULE tmc_analysis diff --git a/src/tmc/tmc_analysis_types.F b/src/tmc/tmc_analysis_types.F index 140aeeeb15..49bd263e20 100644 --- a/src/tmc/tmc_analysis_types.F +++ b/src/tmc/tmc_analysis_types.F @@ -156,22 +156,28 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_ana)) - IF (ASSOCIATED(tmc_ana%dirs)) & + IF (ASSOCIATED(tmc_ana%dirs)) THEN DEALLOCATE (tmc_ana%dirs) + END IF - IF (ASSOCIATED(tmc_ana%density_3d)) & + IF (ASSOCIATED(tmc_ana%density_3d)) THEN CALL tmc_ana_dens_release(tmc_ana%density_3d) - IF (ASSOCIATED(tmc_ana%pair_correl)) & + END IF + IF (ASSOCIATED(tmc_ana%pair_correl)) THEN CALL tmc_ana_pair_correl_release(tmc_ana%pair_correl) + END IF - IF (ASSOCIATED(tmc_ana%dip_mom)) & + IF (ASSOCIATED(tmc_ana%dip_mom)) THEN CALL tmc_ana_dipole_moment_release(tmc_ana%dip_mom) + END IF - IF (ASSOCIATED(tmc_ana%dip_ana)) & + IF (ASSOCIATED(tmc_ana%dip_ana)) THEN CALL tmc_ana_dipole_analysis_release(tmc_ana%dip_ana) + END IF - IF (ASSOCIATED(tmc_ana%displace)) & + IF (ASSOCIATED(tmc_ana%displace)) THEN CALL tmc_ana_displacement_release(ana_disp=tmc_ana%displace) + END IF DEALLOCATE (tmc_ana) diff --git a/src/tmc/tmc_calculations.F b/src/tmc/tmc_calculations.F index e0d9a91e12..cb0b3bba1b 100644 --- a/src/tmc/tmc_calculations.F +++ b/src/tmc/tmc_calculations.F @@ -178,8 +178,9 @@ CONTAINS tmp_cell%hmat(:, 3) = tmp_cell%hmat(:, 3)*box_scale(3) CALL init_cell(cell=tmp_cell) - IF (PRESENT(scaled_hmat)) & + IF (PRESENT(scaled_hmat)) THEN scaled_hmat(:, :) = tmp_cell%hmat + END IF IF (PRESENT(vec)) THEN vec = pbc(r=vec, cell=tmp_cell) @@ -611,9 +612,10 @@ CONTAINS eff(:) = 0.0_dp DO i = 1, tmc_env%params%nr_temp - IF (tmc_env%m_env%tree_node_count(i) > 0) & + IF (tmc_env%m_env%tree_node_count(i) > 0) THEN eff(i) = tmc_env%params%move_types%mv_count(0, i)/ & (tmc_env%m_env%tree_node_count(i)*1.0_dp) + END IF eff(0) = eff(0) + tmc_env%params%move_types%mv_count(0, i)/ & (SUM(tmc_env%m_env%tree_node_count(1:))*1.0_dp) END DO diff --git a/src/tmc/tmc_cancelation.F b/src/tmc/tmc_cancelation.F index 086541c7ea..a0a5bf800a 100644 --- a/src/tmc/tmc_cancelation.F +++ b/src/tmc/tmc_cancelation.F @@ -97,8 +97,9 @@ CONTAINS //cp_to_string(elem%stat)) END SELECT ! set dot color - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=elem, tmc_params=tmc_env%params) + END IF ! add to list IF (need_to_cancel) THEN diff --git a/src/tmc/tmc_dot_tree.F b/src/tmc/tmc_dot_tree.F index b231aaa2af..936874ff42 100644 --- a/src/tmc/tmc_dot_tree.F +++ b/src/tmc/tmc_dot_tree.F @@ -339,10 +339,11 @@ CONTAINS END IF IF (.NOT. ASSOCIATED(new_element%parent)) THEN - IF (new_element%nr > 1) & + IF (new_element%nr > 1) THEN CALL cp_warn(__LOCATION__, & "try to create dot, but no parent on node "// & cp_to_string(new_element%nr)//"exists") + END IF ELSE CALL create_dot_branch(parent_nr=new_element%parent%nr, & child_nr=new_element%nr, & diff --git a/src/tmc/tmc_file_io.F b/src/tmc/tmc_file_io.F index 6aa7d1b0f0..71053815d2 100644 --- a/src/tmc/tmc_file_io.F +++ b/src/tmc/tmc_file_io.F @@ -301,10 +301,11 @@ CONTAINS CALL open_file(file_name=file_name, file_status="OLD", file_form="UNFORMATTED", & file_action="READ", unit_number=file_ptr) READ (file_ptr) temp_size - IF (temp_size /= SIZE(tmc_env%params%Temp)) & + IF (temp_size /= SIZE(tmc_env%params%Temp)) THEN CALL cp_abort(__LOCATION__, & "the actual specified temperatures does not "// & "fit in amount with the one from restart file ") + END IF ALLOCATE (tmp_temp(temp_size)) READ (file_ptr) tmp_temp(:), & tmc_env%m_env%gt_act%nr, & @@ -323,9 +324,10 @@ CONTAINS job_counts, & timings - IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) & + IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) THEN CALL cp_abort(__LOCATION__, "the temperatures differ from the previous calculation. "// & "There were the following temperatures used:") + END IF IF (ANY(mv_weight_tmp(:) /= tmc_env%params%move_types%mv_weight(:))) THEN CPWARN("The amount of mv types differs between the original and the restart run.") END IF @@ -722,13 +724,14 @@ CONTAINS ! write the different energies ! TODO if necessary - IF (files_conf_missmatch) & + IF (files_conf_missmatch) THEN CALL cp_warn(__LOCATION__, & 'there is a missmatch in the configuration numbering. '// & "Read number of lines (pos|cell|dip)"// & cp_to_string(tmc_ana%lc_traj)//"|"// & cp_to_string(tmc_ana%lc_cell)//"|"// & cp_to_string(tmc_ana%lc_dip)) + END IF ! end the timing CALL timestop(handle) @@ -769,20 +772,22 @@ CONTAINS c_tmp(:) = " " tmc_ana%lc_traj = tmc_ana%lc_traj + 1 READ (tmc_ana%id_traj, '(A)', IOSTAT=status) c_tmp(:) - IF (status > 0) & + IF (status > 0) THEN CALL cp_abort(__LOCATION__, & "configuration header read error at line: "// & cp_to_string(tmc_ana%lc_traj)//": "//c_tmp) + END IF IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK EXIT search_next_conf END IF IF (INDEX(c_tmp, "=") > 0) THEN READ (c_tmp(INDEX(c_tmp, "=") + 1:), *, IOSTAT=status) i_tmp ! read the configuration number - IF (status /= 0) & + IF (status /= 0) THEN CALL cp_abort(__LOCATION__, & "configuration header read error (for conf nr) at line: "// & cp_to_string(tmc_ana%lc_traj)) + END IF IF (i_tmp > conf_nr) THEN ! TODO we could also read the energy ... conf_nr = i_tmp @@ -914,8 +919,9 @@ CONTAINS IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK ELSE IF (status > 0) THEN - IF (status /= 0) & + IF (status /= 0) THEN CPABORT("configuration cell read error at line: "//cp_to_string(tmc_ana%lc_cell)) + END IF stat = TMC_STATUS_FAILED ELSE IF (elem%nr < 0) elem%nr = conf_nr diff --git a/src/tmc/tmc_master.F b/src/tmc/tmc_master.F index 20811cce10..b93d15d0eb 100644 --- a/src/tmc/tmc_master.F +++ b/src/tmc/tmc_master.F @@ -135,9 +135,10 @@ CONTAINS CPASSERT(stat /= TMC_STATUS_FAILED) CPASSERT(work_list(wg)%elem%stat /= status_calc_approx_ener) - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: cancel group "//cp_to_string(wg) + "TMC|master: cancel group "//cp_to_string(wg) + END IF CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=para_env, tmc_params=tmc_env%params) work_list(wg)%canceled = .TRUE. @@ -247,8 +248,9 @@ CONTAINS walltime_offset = 20 ! default value the whole program needs to finalize ! initialize the different modules - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL init_draw_trees(tmc_params=tmc_env%params) + END IF !-- initialize variables ! nr_of_job: counting the different task send / received @@ -284,10 +286,11 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_params=tmc_env%params, & elem=init_conf, success=flag, wait_for_message=.TRUE.) - IF (stat /= TMC_STAT_START_CONF_RESULT) & + IF (stat /= TMC_STAT_START_CONF_RESULT) THEN CALL cp_abort(__LOCATION__, & "receiving start configuration failed, received stat "// & cp_to_string(stat)) + END IF ! get the atom names from first energy worker CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & @@ -299,10 +302,11 @@ CONTAINS CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%move_types, & mol_array=init_conf%mol) - IF (ASSOCIATED(tmc_env%params%nmc_move_types)) & + IF (ASSOCIATED(tmc_env%params%nmc_move_types)) THEN CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%nmc_move_types, & mol_array=init_conf%mol) + END IF ! set initial configuration ! set initial random number generator seed (rng seed) @@ -348,15 +352,17 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=init_conf) ! regtest output - IF (tmc_env%params%print_test_output .OR. DEBUG > 0) & + IF (tmc_env%params%print_test_output .OR. DEBUG > 0) THEN WRITE (tmc_env%m_env%io_unit, *) "TMC|first_global_tree_rnd_nr_X= ", & - tmc_env%m_env%gt_head%rnd_nr + tmc_env%m_env%gt_head%rnd_nr + END IF ! calculate the approx energy of the first element (later the exact) IF (tmc_env%m_env%gt_head%conf(1)%elem%stat == status_calc_approx_ener) THEN wg = 1 - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN wg = tmc_env%tmc_comp_set%group_ener_nr + 1 + END IF stat = TMC_STAT_APPROX_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -391,27 +397,30 @@ CONTAINS IF (flag .EQV. .FALSE.) EXIT worker_request_loop ! messages from worker group could be faster then the canceling request IF (worker_info(wg)%canceled .AND. (stat /= TMC_CANCELING_RECEIPT)) THEN - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: recv stat "//cp_to_string(stat)// & - " of canceled worker group" + "TMC|master: recv stat "//cp_to_string(stat)// & + " of canceled worker group" + END IF CYCLE worker_request_loop END IF ! in case of parallel tempering canceled element could be reactivated, ! calculated faster and deleted - IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) & + IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) THEN CALL cp_abort(__LOCATION__, & "no tree elem exist when receiving stat "// & cp_to_string(stat)//"of group"//cp_to_string(wg)) + END IF - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: received stat "//cp_to_string(stat)// & - " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & - " elem"//cp_to_string(worker_info(wg)%elem%nr)// & - " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & - " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled + "TMC|master: received stat "//cp_to_string(stat)// & + " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & + " elem"//cp_to_string(worker_info(wg)%elem%nr)// & + " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & + " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled + END IF SELECT CASE (stat) ! -- FAILED -------------------------- CASE (TMC_STATUS_FAILED) @@ -539,8 +548,9 @@ CONTAINS worker_info(wg)%start_time = m_walltime() - worker_info(wg)%start_time CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay) - IF (.NOT. worker_info(wg)%canceled) & + IF (.NOT. worker_info(wg)%canceled) THEN worker_info(wg)%busy = .FALSE. + END IF ! the first node in tree is always accepted.!. IF (ASSOCIATED(worker_info(wg)%elem, init_conf)) THEN !-- distribute energy of first element to all subtrees @@ -555,9 +565,10 @@ CONTAINS init_conf => NULL() ELSE worker_info(wg)%elem%stat = status_calculated - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(worker_info(wg)%elem, & tmc_params=tmc_env%params) + END IF ! check acceptance of depending nodes ! first (initial) configuration do not have to be checked CALL check_acceptance_of_depending_subtree_nodes(tree_elem=worker_info(wg)%elem, & @@ -578,11 +589,12 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & cancel_count=cancel_count) - IF (DEBUG >= 9) & + IF (DEBUG >= 9) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: handled energy result of sub tree ", & - worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & - " with stat", worker_info(wg)%elem%stat + "TMC|master: handled energy result of sub tree ", & + worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & + " with stat", worker_info(wg)%elem%stat + END IF worker_info(wg)%elem => NULL() !-- SCF ENERGY ----------------------- @@ -610,11 +622,12 @@ CONTAINS !-- do tree update (check new results) CALL tree_update(tmc_env=tmc_env, result_acc=flag, & something_updated=l_update_tree) - IF (DEBUG >= 2 .AND. l_update_tree) & + IF (DEBUG >= 2 .AND. l_update_tree) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: tree updated "//cp_to_string(l_update_tree)// & - " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & - " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) + "TMC|master: tree updated "//cp_to_string(l_update_tree)// & + " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & + " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) + END IF CALL send_analysis_tasks(ana_list=tmc_env%m_env%analysis_list, & ana_worker_info=ana_worker_info, & @@ -642,13 +655,15 @@ CONTAINS "(incl. delay", walltime_delay, "and offset", walltime_offset, ") left" ELSE ! calculations finished - IF (tmc_env%params%print_test_output) & + IF (tmc_env%params%print_test_output) THEN WRITE (tmc_env%m_env%io_unit, *) "Total energy: ", & - tmc_env%m_env%result_list(1)%elem%potential + tmc_env%m_env%result_list(1)%elem%potential + END IF END IF - IF (tmc_env%m_env%restart_out_step /= 0) & + IF (tmc_env%m_env%restart_out_step /= 0) THEN CALL print_restart_file(tmc_env=tmc_env, job_counts=nr_of_job, & timings=worker_timings_aver) + END IF EXIT task_loop END IF @@ -656,9 +671,10 @@ CONTAINS ! update the rest of the tree (canceling and deleting elements) ! ======================================================================= IF (l_update_tree) THEN - IF (DEBUG >= 2) & + IF (DEBUG >= 2) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: start remove elem and cancel calculation" + "TMC|master: start remove elem and cancel calculation" + END IF !-- CLEANING tree nodes beside the path through the tree from ! end_of_clean_tree to tree_ptr ! --> getting back the end of clean tree @@ -680,13 +696,15 @@ CONTAINS worker_counter = worker_counter + 1 wg = MODULO(worker_counter, tmc_env%tmc_comp_set%para_env_m_w%num_pe - 1) + 1 - IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) & + IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) THEN WRITE (tmc_env%m_env%io_unit, *) "all workers are busy" + END IF IF (.NOT. worker_info(wg)%busy) THEN - IF (DEBUG >= 13) & + IF (DEBUG >= 13) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: search new task for worker ", wg + "TMC|master: search new task for worker ", wg + END IF ! no group separation IF (tmc_env%tmc_comp_set%group_cc_nr <= 0) THEN ! search next element to calculate the energy @@ -698,7 +716,7 @@ CONTAINS new_elem=gt_elem_tmp, & reactivation_cc_count=reactivation_cc_count) END IF - ELSEIF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN + ELSE IF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN ! specialized groups (groups for exact energy and groups for configurational change) ! creating new element (configurational change group) !-- crate new node, configurational change is handled in tmc_tree module @@ -707,8 +725,9 @@ CONTAINS reactivation_cc_count=reactivation_cc_count) ! element could be already created, hence CC worker has nothing to do for this element ! in next round he will get a task - IF (stat == status_created .OR. stat == status_calculate_energy) & + IF (stat == status_created .OR. stat == status_calculate_energy) THEN stat = TMC_STATUS_WAIT_FOR_NEW_TASK + END IF ELSE ! search next element to calculate the energy CALL search_next_energy_calc(gt_head=tmc_env%m_env%gt_act, & @@ -716,10 +735,11 @@ CONTAINS react_count=reactivation_ener_count) END IF - IF (DEBUG >= 10) & + IF (DEBUG >= 10) THEN WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: send task with elem stat "//cp_to_string(stat)// & - " to group "//cp_to_string(wg) + "TMC|master: send task with elem stat "//cp_to_string(stat)// & + " to group "//cp_to_string(wg) + END IF ! MESSAGE settings: status informations and task for communication SELECT CASE (stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -741,9 +761,10 @@ CONTAINS ! in case of parallel tempering the node can be already be calculating (related to another global tree node !-- send task to calculate system property gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem%stat = status_calculate_energy - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF stat = TMC_STAT_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -809,27 +830,30 @@ CONTAINS WRITE (tmc_env%m_env%io_unit, FMT=*) & "ener prepared ", tree_elem_counters END IF - IF (tmc_env%params%SPECULATIVE_CANCELING) & + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN WRITE (tmc_env%m_env%io_unit, *) & - "canceled cc|E: ", nr_of_job(5:6), & - ", reactivated: cc ", & - reactivation_cc_count, & - ", reactivated: E ", & - reactivation_ener_count + "canceled cc|E: ", nr_of_job(5:6), & + ", reactivated: cc ", & + reactivation_cc_count, & + ", reactivated: E ", & + reactivation_ener_count + END IF WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & " Average time for cc/ener calc ", & worker_timings_aver(1), worker_timings_aver(2) - IF (tmc_env%params%SPECULATIVE_CANCELING) & + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & - " Average time until cancel cc/ener calc ", & - worker_timings_aver(3), worker_timings_aver(4) - IF (tmc_env%params%esimate_acc_prob) & + " Average time until cancel cc/ener calc ", & + worker_timings_aver(3), worker_timings_aver(4) + END IF + IF (tmc_env%params%esimate_acc_prob) THEN WRITE (tmc_env%m_env%io_unit, *) & - "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & - tmc_env%m_env%estim_corr_wrong(1), & - tmc_env%m_env%estim_corr_wrong(3), " | ", & - tmc_env%m_env%estim_corr_wrong(2), & - tmc_env%m_env%estim_corr_wrong(4) + "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & + tmc_env%m_env%estim_corr_wrong(1), & + tmc_env%m_env%estim_corr_wrong(3), " | ", & + tmc_env%m_env%estim_corr_wrong(2), & + tmc_env%m_env%estim_corr_wrong(4) + END IF WRITE (tmc_env%m_env%io_unit, *) & "Time: ", INT(m_walltime() - run_time_start), "of", & INT(tmc_env%m_env%walltime - walltime_delay - walltime_offset), & @@ -869,10 +893,11 @@ CONTAINS " (MC elements/calculated configuration) global:", & efficiency(0), " sub tree(s): ", efficiency(1:) DEALLOCATE (efficiency) - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & - " (MC elements/created configuration) :", & - tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) + " (MC elements/created configuration) :", & + tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) + END IF WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & " (MC elements/energy calculated configuration):", & tmc_env%m_env%result_count(:)/REAL(nr_of_job(4), KIND=dp) @@ -909,8 +934,9 @@ CONTAINS CALL free_cancelation_list(tmc_env%m_env%cancelation_list) ! -- write final configuration - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL finalize_draw_tree(tmc_params=tmc_env%params) + END IF WRITE (tmc_env%m_env%io_unit, *) "TMC master: all work done." diff --git a/src/tmc/tmc_messages.F b/src/tmc/tmc_messages.F index 82b36f4bdb..26ae8e290c 100644 --- a/src/tmc/tmc_messages.F +++ b/src/tmc/tmc_messages.F @@ -88,8 +88,9 @@ CONTAINS CPASSERT(ASSOCIATED(para_env)) master = .FALSE. - IF (para_env%mepos == MASTER_COMM_ID) & + IF (para_env%mepos == MASTER_COMM_ID) THEN master = .TRUE. + END IF END FUNCTION check_if_group_master ! ************************************************************************************************** @@ -211,11 +212,12 @@ CONTAINS CPABORT("Unable to send message when m_send%info(4) > 0") !TODO send characters CALL para_env%send(m_send%task_char, dest, message_tag) END IF - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " send element info to ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:), " with comm ", & - para_env%get_handle(), " and tag ", message_tag + " send element info to ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:), " with comm ", & + para_env%get_handle(), " and tag ", message_tag + END IF IF (m_send%info(2) > 0) DEALLOCATE (m_send%task_int) IF (m_send%info(3) > 0) DEALLOCATE (m_send%task_real) IF (m_send%info(4) > 0) DEALLOCATE (m_send%task_char) @@ -290,10 +292,11 @@ CONTAINS ! first get message type and sizes CALL para_env%recv(m_send%info, dest, message_tag) END IF - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " recv element info from ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:) + " recv element info from ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:) + END IF !-- receive message integer part IF (m_send%info(2) > 0) THEN ALLOCATE (m_send%task_int(m_send%info(2))) @@ -350,14 +353,16 @@ CONTAINS CASE (TMC_STAT_ENERGY_REQUEST, TMC_STAT_APPROX_ENERGY_REQUEST) CALL read_energy_request_message(elem, m_send, tmc_params) CASE (TMC_STAT_ENERGY_RESULT) - IF (PRESENT(elem_array)) & + IF (PRESENT(elem_array)) THEN CALL read_energy_result_message(elem_array(dest)%elem, m_send, tmc_params) + END IF CASE (TMC_STAT_NMC_REQUEST, TMC_STAT_NMC_BROADCAST, & TMC_STAT_MD_REQUEST, TMC_STAT_MD_BROADCAST) CALL read_NMC_request_massage(msg_type, elem, m_send, tmc_params) CASE (TMC_STAT_NMC_RESULT, TMC_STAT_MD_RESULT) - IF (PRESENT(elem_array)) & + IF (PRESENT(elem_array)) THEN CALL read_NMC_result_massage(msg_type, elem_array(dest)%elem, m_send, tmc_params) + END IF CASE (TMC_STATUS_FAILED, TMC_STATUS_STOP_RECEIPT) ! if task is failed, handle situation in outer routine CASE (TMC_STAT_SCF_STEP_ENER_RECEIVE) @@ -1075,8 +1080,9 @@ CONTAINS counter = 0 !then float array with pos, (vel), random number seed, subbox_center msg_size_real = 1 + SIZE(elem%pos) + 1 + SIZE(elem%rng_seed) + 1 + SIZE(elem%subbox_center(:)) + 1 - IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) & - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) ! the velocities + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) THEN + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + END IF ! the velocities IF (tmc_params%pressure >= 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) ! box size for NpT ALLOCATE (m_send%task_real(msg_size_real)) @@ -1214,9 +1220,10 @@ CONTAINS + 1 + SIZE(tmc_params%nmc_move_types%mv_count) & + 1 + SIZE(tmc_params%nmc_move_types%acc_count) + 1 IF (DEBUG > 0) msg_size_int = msg_size_int + 1 + 1 + 1 + 1 - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN msg_size_int = msg_size_int + 1 + SIZE(tmc_params%nmc_move_types%subbox_count) & + 1 + SIZE(tmc_params%nmc_move_types%subbox_acc_count) + END IF ALLOCATE (m_send%task_int(msg_size_int)) counter = 1 @@ -1270,8 +1277,9 @@ CONTAINS + 1 ! check bit IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_RESULT .OR. & - msg_type == TMC_STAT_MD_BROADCAST) & - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 ! for MD also: vel, e_kin_befor_md, ekin + msg_type == TMC_STAT_MD_BROADCAST) THEN + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 + END IF ! for MD also: vel, e_kin_befor_md, ekin ALLOCATE (m_send%task_real(msg_size_real)) ! pos @@ -1400,8 +1408,9 @@ CONTAINS msg_type == TMC_STAT_MD_BROADCAST) THEN elem%vel = m_send%task_real(counter + 1:counter + NINT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) - IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) & + IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) THEN elem%ekin_before_md = m_send%task_real(counter + 1) + END IF counter = counter + 2 elem%ekin = m_send%task_real(counter + 1) counter = counter + 2 @@ -1415,8 +1424,9 @@ CONTAINS END IF DEALLOCATE (mv_counter, acc_counter) - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN DEALLOCATE (subbox_counter, subbox_acc_counter) + END IF CPASSERT(counter == m_send%info(3)) CPASSERT(m_send%task_int(m_send%info(2)) == message_end_flag) CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) @@ -1564,7 +1574,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env CHARACTER(LEN=default_string_length), & - ALLOCATABLE, DIMENSION(:) :: msg(:) + ALLOCATABLE, DIMENSION(:) :: msg INTEGER :: i CPASSERT(ASSOCIATED(para_env)) diff --git a/src/tmc/tmc_move_handle.F b/src/tmc/tmc_move_handle.F index 6354703e49..cfa8ab5b31 100644 --- a/src/tmc/tmc_move_handle.F +++ b/src/tmc/tmc_move_handle.F @@ -114,22 +114,25 @@ CONTAINS CALL section_vals_get(nmc_section, explicit=explicit) IF (explicit) THEN ! check the approx potential file, already read - IF (tmc_params%NMC_inp_file == "") & + IF (tmc_params%NMC_inp_file == "") THEN CPABORT("Please specify a valid approximate potential.") + END IF CALL section_vals_val_get(nmc_section, "NR_NMC_STEPS", & i_val=nmc_steps) - IF (nmc_steps <= 0) & + IF (nmc_steps <= 0) THEN CPABORT("Please specify a valid amount of NMC steps (NR_NMC_STEPS {INTEGER}).") + END IF CALL section_vals_val_get(nmc_section, "PROB", r_val=nmc_prob) CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", & r_val=nmc_init_acc_prob) - IF (nmc_init_acc_prob <= 0.0_dp) & + IF (nmc_init_acc_prob <= 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for INIT_ACC_PROB") + END IF move_type_section => section_vals_get_subs_vals(nmc_section, "MOVE_TYPE") CALL section_vals_get(move_type_section, n_repetition=n_NMC_items) @@ -150,10 +153,11 @@ CONTAINS ! initilaize the move array with related sizes, probs, etc. CALL move_types_create(tmc_params%move_types, tmc_params%nr_temp) - IF (mv_prob_sum <= 0.0) & + IF (mv_prob_sum <= 0.0) THEN CALL cp_abort(__LOCATION__, & "The probabilities to perform the moves are "// & "in total less equal 0") + END IF ! get the sizes, probs, etc. for each move type and convert units DO i_tmp = 1, n_items + n_NMC_items @@ -188,16 +192,18 @@ CONTAINS ! move sizes are checked afterwards, because not all moves require a valid move size CALL section_vals_val_get(move_type_section, "PROB", i_rep_section=i_rep, & r_val=mv_prob) - IF (mv_prob < 0.0_dp) & + IF (mv_prob < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid move probability (>0.0) "// & "for the move type "//inp_kind_name) + END IF CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", i_rep_section=i_rep, & r_val=init_acc_prob) - IF (init_acc_prob < 0.0_dp) & + IF (init_acc_prob < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for the move type "//inp_kind_name) + END IF ! set the related index and perform unit conversion of move sizes SELECT CASE (inp_kind_name) ! atom / molecule translation @@ -278,8 +284,9 @@ CONTAINS CALL section_vals_val_get(move_type_section, "ATOMS", & i_rep_section=i_rep, i_rep_val=i, & c_vals=move_types%atom_lists(i)%atoms) - IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) & + IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) THEN CPABORT("ATOM_SWAP requires minimum two atom kinds selected. ") + END IF END DO END IF ! gaussian adaptation @@ -290,10 +297,11 @@ CONTAINS CPABORT("A unknown move type is selected: "//inp_kind_name) END SELECT ! check for valid move sizes - IF (delta_x < 0.0_dp) & + IF (delta_x < 0.0_dp) THEN CALL cp_abort(__LOCATION__, & "Please select a valid move size (>0.0) "// & "for the move type "//inp_kind_name) + END IF ! check if not already set IF (move_types%mv_weight(ind) > 0.0) THEN CPABORT("TMC: Each move type can be set only once. ") @@ -341,11 +349,12 @@ CONTAINS move_types%mv_weight(mv_type_mol_rot) > 0.0_dp) THEN ! if there is no molecule information available, ! molecules moves can not be performed - IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) & + IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) THEN CALL cp_abort(__LOCATION__, & "molecule move: there is no molecule "// & "information available. Please specify molecules when "// & "using molecule moves.") + END IF END IF ! for the atom swap move @@ -363,11 +372,12 @@ CONTAINS EXIT ref_loop END IF END DO ref_loop - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "ATOM_SWAP: The selected atom type ("// & TRIM(move_types%atom_lists(list_i)%atoms(atom_j))// & ") is not contained in the system. ") + END IF ! check if not be swapped with the same atom type IF (ANY(move_types%atom_lists(list_i)%atoms(atom_j) == & move_types%atom_lists(list_i)%atoms(atom_j + 1:))) THEN @@ -389,10 +399,11 @@ CONTAINS END IF END DO ref_lop END IF - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "The system contains only a single atom type,"// & " atom_swap is not possible.") + END IF END IF END IF END SUBROUTINE check_moves @@ -408,8 +419,9 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_params)) CALL move_types_release(tmc_params%move_types) - IF (ASSOCIATED(tmc_params%nmc_move_types)) & + IF (ASSOCIATED(tmc_params%nmc_move_types)) THEN CALL move_types_release(tmc_params%nmc_move_types) + END IF END SUBROUTINE finalize_mv_types ! ************************************************************************************************** @@ -760,8 +772,9 @@ CONTAINS CPASSERT(PRESENT(acc)) IF (PRESENT(subbox)) THEN ! only update subbox acceptance - IF (acc) & + IF (acc) THEN move_types%subbox_acc_count(mv_type, conf_moved) = move_types%subbox_acc_count(mv_type, conf_moved) + 1 + END IF move_types%subbox_count(mv_type, conf_moved) = move_types%subbox_count(mv_type, conf_moved) + 1 ! No more to do change_type = 0 @@ -790,8 +803,9 @@ CONTAINS END IF IF (conf_moved > 0) move_types%mv_count(0, conf_moved) = move_types%mv_count(0, conf_moved) + ABS(change_res) - IF (mv_type >= 0 .AND. conf_moved > 0) & + IF (mv_type >= 0 .AND. conf_moved > 0) THEN move_types%mv_count(mv_type, conf_moved) = move_types%mv_count(mv_type, conf_moved) + ABS(change_type) + END IF IF (prob_opt) THEN WHERE (move_types%mv_count > 0) & diff --git a/src/tmc/tmc_moves.F b/src/tmc/tmc_moves.F index 3f24f4def5..a6e1aec153 100644 --- a/src/tmc/tmc_moves.F +++ b/src/tmc/tmc_moves.F @@ -124,8 +124,9 @@ CONTAINS ! rng_seed=elem%rng_seed, rng_seed_last_acc=last_acc_elem%rng_seed) !-- atom translation CASE (mv_type_atom_trans) - IF (act_nr_elem_mv == 0) & + IF (act_nr_elem_mv == 0) THEN act_nr_elem_mv = SIZE(elem%pos)/tmc_params%dim_per_elem + END IF ALLOCATE (elem_center(tmc_params%dim_per_elem)) i = 1 move_elements_loop: DO @@ -167,8 +168,9 @@ CONTAINS CASE (mv_type_mol_trans) nr_molec = MAXVAL(elem%mol(:)) ! if all particles should be displaced, set the amount of molecules - IF (act_nr_elem_mv == 0) & + IF (act_nr_elem_mv == 0) THEN act_nr_elem_mv = nr_molec + END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -181,8 +183,9 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) & + ) THEN mol_in_sb(m) = status_ok + END IF END DO ! displace the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -242,8 +245,9 @@ CONTAINS !-- molecule rotation CASE (mv_type_mol_rot) nr_molec = MAXVAL(elem%mol(:)) - IF (act_nr_elem_mv == 0) & + IF (act_nr_elem_mv == 0) THEN act_nr_elem_mv = nr_molec + END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -256,8 +260,9 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) & + ) THEN mol_in_sb(m) = status_ok + END IF END DO ! rotate the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -703,16 +708,18 @@ CONTAINS CALL find_nearest_proton_acceptor_donator(elem=elem, mol=mol, & donor_acceptor=donor_acceptor, tmc_params=tmc_params, & rng_stream=rng_stream) - IF (ANY(mol_arr(:) == mol)) & + IF (ANY(mol_arr(:) == mol)) THEN EXIT chain_completition_loop + END IF mol_arr(counter) = mol END DO chain_completition_loop counter = counter - 1 ! last searched element is equal to one other in list ! just take the loop of molecules out of the chain DO k = 1, counter - IF (mol_arr(k) == mol) & + IF (mol_arr(k) == mol) THEN EXIT + END IF END DO mol_arr(1:counter - k + 1) = mol_arr(k:counter) counter = counter - k + 1 diff --git a/src/tmc/tmc_setup.F b/src/tmc/tmc_setup.F index 5c6ec41642..f110e1c573 100644 --- a/src/tmc/tmc_setup.F +++ b/src/tmc/tmc_setup.F @@ -239,8 +239,9 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_energy_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CPABORT("creating force env result in error "//cp_to_string(ierr)) + END IF END IF ! worker for configurational change IF (tmc_env%params%NMC_inp_file /= "" .AND. & @@ -253,15 +254,18 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_NMC_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) & + IF (ierr /= 0) THEN CPABORT("creating approx force env result in error "//cp_to_string(ierr)) + END IF END IF CALL do_tmc_worker(tmc_env=tmc_env) ! start the worker routine - IF (tmc_env%w_env%env_id_ener > 0) & + IF (tmc_env%w_env%env_id_ener > 0) THEN CALL destroy_force_env(tmc_env%w_env%env_id_ener, ierr) - IF (tmc_env%w_env%env_id_approx > 0) & + END IF + IF (tmc_env%w_env%env_id_approx > 0) THEN CALL destroy_force_env(tmc_env%w_env%env_id_approx, ierr) + END IF CALL cp_rm_default_logger() CALL cp_logger_release(logger_sub) @@ -296,8 +300,9 @@ CONTAINS END DO CALL do_tmc_worker(tmc_env=tmc_env, ana_list=tmc_ana_env_list) ! start the worker routine for analysis DO i = 1, tmc_env%params%nr_temp - IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) & + IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=tmc_ana_env_list(i)%temp%last_elem) + END IF CALL tmc_ana_env_release(tmc_ana_env_list(i)%temp) END DO DEALLOCATE (tmc_ana_env_list) @@ -401,16 +406,19 @@ CONTAINS CALL analysis_init(ana_env=ana_list(temp)%temp, nr_dim=nr_dim) ! to allocate the dipole array in tree elements IF (ana_list(temp)%temp%costum_dip_file_name /= & - tmc_default_unspecified_name) & + tmc_default_unspecified_name) THEN tmc_env%params%print_dipole = .TRUE. + END IF - IF (.NOT. ASSOCIATED(elem)) & + IF (.NOT. ASSOCIATED(elem)) THEN CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=elem, nr_dim=nr_dim) + END IF CALL analysis_restart_read(ana_env=ana_list(temp)%temp, & elem=elem) - IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) & + IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CPABORT("uncorrect initialization of the initial configuration") + END IF ! do for all directories DO dir_ind = 1, SIZE(ana_list(temp)%temp%dirs) WRITE (output_unit, FMT='(T2,A,"| ",A,T41,A40)') "TMC_ANA", & @@ -424,25 +432,31 @@ CONTAINS ! remove the last saved element to start with a new file ! there is no weight for this element IF (dir_ind < SIZE(ana_list(temp)%temp%dirs) .AND. & - ASSOCIATED(ana_list(temp)%temp%last_elem)) & + ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + END IF + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN ana_list(temp)%temp%conf_offset = ana_list(temp)%temp%conf_offset & + ana_list(temp)%temp%last_elem%nr + END IF END DO CALL finalize_tmc_analysis(ana_env=ana_list(temp)%temp) ! write analysis restart file ! if there is something to write ! shifts the last element to actual element - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL analysis_restart_print(ana_env=ana_list(temp)%temp) - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + END IF + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - IF (ASSOCIATED(elem)) & + END IF + IF (ASSOCIATED(elem)) THEN CALL deallocate_sub_tree_node(tree_elem=elem) + END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) + END IF CALL tmc_ana_env_release(ana_list(temp)%temp) END DO @@ -499,8 +513,9 @@ CONTAINS CALL section_vals_val_get(tmc_section, "NR_TEMPERATURE", i_val=nr_temp) CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) & + IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) THEN CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") + END IF IF (nr_temp == 1) THEN nr_temp = SIZE(inp_Temp) ALLOCATE (Temps(nr_temp)) @@ -513,9 +528,10 @@ CONTAINS DO t_act = 2, SIZE(Temps) Temps(t_act) = Temps(t_act - 1) + (tmax - tmin)/(SIZE(Temps) - 1.0_dp) END DO - IF (ANY(Temps < 0.0_dp)) & + IF (ANY(Temps < 0.0_dp)) THEN CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") + END IF END IF ! get multiple directories @@ -596,13 +612,15 @@ CONTAINS CALL section_vals_val_get(tmc_section, "GROUP_ENERGY_NR", i_val=tmc_env%tmc_comp_set%group_ener_nr) CALL section_vals_val_get(tmc_section, "GROUP_CC_SIZE", i_val=tmc_env%tmc_comp_set%group_cc_size) CALL section_vals_val_get(tmc_section, "GROUP_ANALYSIS_NR", i_val=itmp) - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) & + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) THEN tmc_env%tmc_comp_set%ana_on_the_fly = itmp - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) & + END IF + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) THEN CALL cp_abort(__LOCATION__, & "analysing on the fly is up to now not supported for multiple cores. "// & "Restart file witing for this case and temperature "// & "distribution has to be solved.!.") + END IF CALL section_vals_val_get(tmc_section, "RESULT_LIST_IN_MEMORY", l_val=tmc_env%params%USE_REDUCED_TREE) ! swap the variable, because of oposit meaning tmc_env%params%USE_REDUCED_TREE = .NOT. tmc_env%params%USE_REDUCED_TREE @@ -615,21 +633,24 @@ CONTAINS CPABORT("no or a valid NMC input file has to be specified ") ELSE IF (tmc_env%params%NMC_inp_file == "") THEN ! no keyword - IF (tmc_env%tmc_comp_set%group_cc_size > 0) & + IF (tmc_env%tmc_comp_set%group_cc_size > 0) THEN CALL cp_warn(__LOCATION__, & "The configurational groups are deactivated, "// & "because no approximated energy input is specified.") + END IF tmc_env%tmc_comp_set%group_cc_size = 0 ELSE ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%NMC_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) & + IF (.NOT. flag .OR. itmp /= 0) THEN CPABORT("a valid NMC input file has to be specified") + END IF END IF CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) & + IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) THEN CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") + END IF IF (tmc_env%params%nr_temp == 1) THEN tmc_env%params%nr_temp = SIZE(inp_Temp) ALLOCATE (tmc_env%params%Temp(tmc_env%params%nr_temp)) @@ -642,9 +663,10 @@ CONTAINS DO itmp = 2, SIZE(tmc_env%params%Temp) tmc_env%params%Temp(itmp) = tmc_env%params%Temp(itmp - 1) + (tmax - tmin)/(SIZE(tmc_env%params%Temp) - 1.0_dp) END DO - IF (ANY(tmc_env%params%Temp < 0.0_dp)) & + IF (ANY(tmc_env%params%Temp < 0.0_dp)) THEN CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") + END IF END IF CALL section_vals_val_get(tmc_section, "TASK_TYPE", explicit=explicit_key) @@ -711,13 +733,14 @@ CONTAINS tmc_env%m_env%restart_out_file_name = tmc_default_restart_out_file_name tmc_env%m_env%restart_out_step = HUGE(tmc_env%m_env%restart_out_step) END IF - IF (tmc_env%m_env%restart_out_step < 0) & + IF (tmc_env%m_env%restart_out_step < 0) THEN CALL cp_abort(__LOCATION__, & "Please specify a valid value for the frequency "// & "to write restart files (RESTART_OUT #). "// & "# > 0 to define the amount of Markov chain elements in between, "// & "or 0 to deactivate the restart file writing. "// & "Lonely keyword writes restart file only at the end of the run.") + END IF CALL section_vals_val_get(tmc_section, "INFO_OUT_STEP_SIZE", i_val=tmc_env%m_env%info_out_step_size) CALL section_vals_val_get(tmc_section, "DOT_TREE", c_val=tmc_env%params%dot_file_name) @@ -734,13 +757,15 @@ CONTAINS ! the NMC_FILE_NAME is already read in tmc_preread_input CALL section_vals_val_get(tmc_section, "ENERGY_FILE_NAME", c_val=tmc_env%params%energy_inp_file) ! file name keyword without file name - IF (tmc_env%params%energy_inp_file == "") & + IF (tmc_env%params%energy_inp_file == "") THEN CPABORT("a valid exact energy input file has to be specified ") + END IF ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%energy_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) & + IF (.NOT. flag .OR. itmp /= 0) THEN CALL cp_abort(__LOCATION__, "a valid exact energy input file has to be specified, "// & TRIM(tmc_env%params%energy_inp_file)//" does not exist.") + END IF CALL section_vals_val_get(tmc_section, "NUM_MV_ELEM_IN_CELL", i_val=tmc_env%params%nr_elem_mv) @@ -751,10 +776,12 @@ CONTAINS CALL section_vals_val_get(tmc_section, "SUB_BOX", r_vals=r_arr_tmp) IF (SIZE(r_arr_tmp) > 1) THEN - IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) & + IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) THEN CPABORT("The entered sub box sizes does not fit in number of dimensions.") - IF (ANY(r_arr_tmp <= 0.0_dp)) & + END IF + IF (ANY(r_arr_tmp <= 0.0_dp)) THEN CPABORT("The entered sub box lengths should be greater than 0.") + END IF DO itmp = 1, SIZE(tmc_env%params%sub_box_size) tmc_env%params%sub_box_size(itmp) = r_arr_tmp(itmp)/au2a END DO @@ -774,14 +801,17 @@ CONTAINS CALL section_vals_val_get(tmc_section, "PRINT_ONLY_ACC", l_val=tmc_env%params%print_only_diff_conf) CALL section_vals_val_get(tmc_section, "PRINT_COORDS", l_val=tmc_env%params%print_trajectory) CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", l_val=tmc_env%params%print_dipole) + END IF CALL section_vals_val_get(tmc_section, "PRINT_FORCES", explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL section_vals_val_get(tmc_section, "PRINT_FORCES", l_val=tmc_env%params%print_forces) + END IF CALL section_vals_val_get(tmc_section, "PRINT_CELL", explicit=explicit) - IF (explicit) & + IF (explicit) THEN CALL section_vals_val_get(tmc_section, "PRINT_CELL", l_val=tmc_env%params%print_cell) + END IF CALL section_vals_val_get(tmc_section, "PRINT_ENERGIES", l_val=tmc_env%params%print_energies) END SUBROUTINE tmc_read_input @@ -850,9 +880,10 @@ CONTAINS - tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr)/ & REAL(tmc_comp_set%group_cc_size, KIND=dp)) - IF (tmc_comp_set%group_cc_nr < 1) & + IF (tmc_comp_set%group_cc_nr < 1) THEN CALL cp_warn(__LOCATION__, & "There are not enougth cores left for creating groups for configurational change.") + END IF IF (flag) success = .FALSE. END IF @@ -1010,9 +1041,10 @@ CONTAINS WRITE (file_nr, FMT=fmt_my) plabel, "cores per group (ener|cc) ", & cp_to_string(tmc_env%tmc_comp_set%group_ener_size)//" | "// & cp_to_string(tmc_env%tmc_comp_set%group_cc_size) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN WRITE (file_nr, FMT=fmt_my) plabel, "Analysis groups ", & - cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) + cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) + END IF IF (SIZE(tmc_env%params%Temp(:)) <= 7) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" @@ -1026,18 +1058,20 @@ CONTAINS cp_to_string(tmc_env%m_env%num_MC_elem) WRITE (file_nr, FMT=fmt_my) plabel, "exact potential input file:", & TRIM(tmc_env%params%energy_inp_file) - IF (tmc_env%params%NMC_inp_file /= "") & + IF (tmc_env%params%NMC_inp_file /= "") THEN WRITE (file_nr, FMT=fmt_my) plabel, "approximate potential input file:", & - TRIM(tmc_env%params%NMC_inp_file) + TRIM(tmc_env%params%NMC_inp_file) + END IF IF (ANY(tmc_env%params%sub_box_size > 0.0_dp)) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" WRITE (c_tmp, FMT="(1000F8.2)") tmc_env%params%sub_box_size(:)*au2a WRITE (file_nr, FMT=fmt_tmp) plabel, "Sub box size [A]", TRIM(c_tmp) END IF - IF (tmc_env%params%pressure > 0.0_dp) & + IF (tmc_env%params%pressure > 0.0_dp) THEN WRITE (file_nr, FMT=fmt_my) plabel, "Pressure [bar]: ", & - cp_to_string(tmc_env%params%pressure*au2bar) + cp_to_string(tmc_env%params%pressure*au2bar) + END IF WRITE (file_nr, FMT=fmt_my) plabel, "Numbers of atoms/molecules moved " WRITE (file_nr, FMT=fmt_my) plabel, " within one conf. change", & cp_to_string(tmc_env%params%nr_elem_mv) diff --git a/src/tmc/tmc_tree_acceptance.F b/src/tmc/tmc_tree_acceptance.F index 939f31563c..8a72ab56e6 100644 --- a/src/tmc/tmc_tree_acceptance.F +++ b/src/tmc/tmc_tree_acceptance.F @@ -490,9 +490,10 @@ CONTAINS END IF END IF - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot_color(gt_tree_element=tmp_gt_list_ptr%gt_elem, & tmc_params=tmc_env%params) + END IF END IF tmp_gt_list_ptr => tmp_gt_list_ptr%next END DO @@ -546,8 +547,9 @@ CONTAINS cp_to_string(stat)) END SELECT - IF (tmc_params%DRAW_TREE) & + IF (tmc_params%DRAW_TREE) THEN CALL create_dot_color(tree_element=ptr, tmc_params=tmc_params) + END IF END IF ! end the timing @@ -685,8 +687,9 @@ CONTAINS !-- hence new configurations can be created on basis of this configuration CASE (status_calculate_MD, status_calculate_NMC_steps, status_calculate_energy, & status_created, status_calc_approx_ener) - IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) & + IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) THEN gt_act_elem%stat = gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat + END IF CASE (status_calculated) CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -754,9 +757,10 @@ CONTAINS tmc_env%m_env%result_count(gt_act_elem%mv_conf) + 1 ! in case of swapped also count the result for ! the other swapped temperature - IF (gt_act_elem%swaped) & + IF (gt_act_elem%swaped) THEN tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) = & - tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 + tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 + END IF ! count also for global tree Markov Chain tmc_env%m_env%result_count(0) = tmc_env%m_env%result_count(0) + 1 @@ -816,14 +820,16 @@ CONTAINS END IF ! result acceptance check !====================================================================== !-- set status accepted or rejected of certain subtree elements - IF (.NOT. gt_act_elem%swaped) & + IF (.NOT. gt_act_elem%swaped) THEN CALL subtree_configuration_stat_change(gt_ptr=gt_act_elem, & stat=gt_act_elem%stat, & tmc_params=tmc_env%params) + END IF - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot_color(gt_tree_element=gt_act_elem, & tmc_params=tmc_env%params) + END IF ! probability update CALL prob_update(move_types=tmc_env%params%move_types, & @@ -835,11 +841,12 @@ CONTAINS result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf, accepted=result_acc, & tmc_params=tmc_env%params) - IF (gt_act_elem%swaped) & + IF (gt_act_elem%swaped) THEN CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf + 1, accepted=result_acc, & tmc_params=tmc_env%params) + END IF ! save for analysis IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe > 1 .AND. result_acc) THEN @@ -879,8 +886,9 @@ CONTAINS ready = .FALSE. IF ((elem%scf_energies_count >= 4) & .AND. (elem%stat /= status_deleted) .AND. (elem%stat /= status_deleted_result) & - .AND. (elem%stat /= status_canceled_ener)) & + .AND. (elem%stat /= status_canceled_ener)) THEN ready = .TRUE. + END IF END FUNCTION ready_for_update_acc_prob ! ************************************************************************************************** @@ -1032,9 +1040,10 @@ CONTAINS IF (tmp_prob >= 0.0_dp) THEN tmp_pt_ptr%gt_elem%prob_acc = tmp_prob !-- speculative canceling for the related direction - IF (tmc_env%params%SPECULATIVE_CANCELING) & + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN CALL search_canceling_elements(pt_elem_in=tmp_pt_ptr%gt_elem, & prob=tmp_pt_ptr%gt_elem%prob_acc, tmc_env=tmc_env) + END IF END IF ! get next related global tree pointer diff --git a/src/tmc/tmc_tree_build.F b/src/tmc/tmc_tree_build.F index cea018160d..62a319f9c0 100644 --- a/src/tmc/tmc_tree_build.F +++ b/src/tmc/tmc_tree_build.F @@ -364,10 +364,11 @@ CONTAINS ! simulated annealing start temperature global_tree%Temp = tmc_env%params%Temp(1) - IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) & + IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "there is no parallel tempering implementation for simulated annealing implemented "// & "(just one Temp per global tree element.") + END IF !-- IF program is restarted, read restart file IF (tmc_env%m_env%restart_in_file_name /= "") THEN @@ -440,10 +441,12 @@ CONTAINS !-- distribute energy of first element to all subtrees DO i = 1, SIZE(gt_tree_ptr%conf) gt_tree_ptr%conf(i)%elem%stat = status_accepted_result - IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) & + IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) THEN gt_tree_ptr%conf(i)%elem%dipole = gt_tree_ptr%conf(1)%elem%dipole - IF (tmc_env%m_env%restart_in_file_name == "") & + END IF + IF (tmc_env%m_env%restart_in_file_name == "") THEN gt_tree_ptr%conf(i)%elem%potential = gt_tree_ptr%conf(1)%elem%potential + END IF END DO IF (tmc_env%m_env%restart_in_file_name == "") THEN @@ -538,10 +541,12 @@ CONTAINS ((.NOT. n_acc) .AND. ASSOCIATED(tmp_elem%nacc))) THEN !set pointer to the actual element - IF (n_acc) & + IF (n_acc) THEN new_elem => tmp_elem%acc - IF (.NOT. n_acc) & + END IF + IF (.NOT. n_acc) THEN new_elem => tmp_elem%nacc + END IF ! check for existing subtree element CPASSERT(ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem)) @@ -570,10 +575,11 @@ CONTAINS CASE (mv_type_MD) new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_MD CASE (mv_type_NMC_moves) - IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) & + IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) THEN CALL cp_warn(__LOCATION__, & "reactivating tree element with wrong status"// & cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat)) + END IF new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_NMC_steps !IF(DEBUG>=1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", & @@ -599,12 +605,14 @@ CONTAINS !-- set pointers to and from element one level up !-- paste new gt tree node element at right end IF (n_acc) THEN - IF (ASSOCIATED(tmp_elem%acc)) & + IF (ASSOCIATED(tmp_elem%acc)) THEN CPABORT("creating new subtree element on an occupied acc branch") + END IF tmp_elem%acc => new_elem ELSE - IF (ASSOCIATED(tmp_elem%nacc)) & + IF (ASSOCIATED(tmp_elem%nacc)) THEN CPABORT("creating new subtree element on an occupied nacc branch") + END IF tmp_elem%nacc => new_elem END IF new_elem%parent => tmp_elem @@ -687,9 +695,10 @@ CONTAINS new_elem%prob_acc = tmc_env%params%move_types%acc_prob( & mv_type_swap_conf, new_elem%mv_conf) CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) + END IF ! nothing to do for the workers stat = status_calculated keep_on = .FALSE. @@ -710,10 +719,11 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) + END IF END IF ELSE !-- check if child element in REJECTED direction already exist @@ -725,10 +735,11 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) + END IF END IF END IF ! set approximate probability of acceptance @@ -738,9 +749,10 @@ CONTAINS new_elem%conf(new_elem%mv_conf)%elem%move_type, new_elem%mv_conf) ! add refence and dot CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) + END IF END IF ! swap or no swap END IF ! global tree node already exist. Hence the Subtree node also (it is speculative canceled) END IF ! keep on (checking and creating) @@ -749,8 +761,9 @@ CONTAINS IF (new_elem%stat == status_accepted_result .OR. & new_elem%stat == status_accepted .OR. & new_elem%stat == status_rejected .OR. & - new_elem%stat == status_rejected_result) & + new_elem%stat == status_rejected_result) THEN CPABORT("selected existing RESULT gt node") + END IF !-- set status of global tree element for decision in master routine SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%stat) CASE (status_rejected_result, status_rejected, status_accepted, & @@ -758,16 +771,18 @@ CONTAINS ! energy is already calculated new_elem%stat = status_calculated stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF CASE (status_calc_approx_ener) new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF END IF CASE (status_calculate_MD, status_calculate_energy, & status_calculate_NMC_steps, status_created) @@ -775,9 +790,10 @@ CONTAINS new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF END IF CASE (status_cancel_ener, status_canceled_ener) ! configuration is already created, @@ -787,9 +803,10 @@ CONTAINS ! creation complete, handle energy calculation at a different position ! (for different worker group) stat = status_calculated - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF CASE (status_cancel_nmc, status_canceled_nmc) ! reactivation canceled element (but with new global tree element) new_elem%conf(new_elem%mv_conf)%elem%stat = & @@ -797,9 +814,10 @@ CONTAINS new_elem%stat = status_calculate_NMC_steps stat = new_elem%conf(new_elem%mv_conf)%elem%stat reactivation_cc_count = reactivation_cc_count + 1 - IF (tmc_env%params%DRAW_TREE) & + IF (tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) + END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & "unknown stat "// & @@ -953,8 +971,9 @@ CONTAINS new_elem%stat = status_calculated ELSE new_elem%stat = status_created - IF (tmc_env%params%NMC_inp_file /= "") & + IF (tmc_env%params%NMC_inp_file /= "") THEN new_elem%stat = status_calc_approx_ener + END IF END IF CASE (mv_type_gausian_adapt) ! still could be implemented @@ -1004,8 +1023,9 @@ CONTAINS ELSE gt_ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN CALL create_global_tree_dot_color(gt_tree_element=gt_ptr, tmc_params=tmc_env%params) + END IF !remove pointer from tree parent IF (ASSOCIATED(gt_ptr%parent)) THEN @@ -1060,12 +1080,13 @@ CONTAINS ! if there is still e reference to a global tree pointer, do not deallocate element IF (ASSOCIATED(ptr%gt_nodes_references)) THEN - IF (ASSOCIATED(ptr%parent)) & + IF (ASSOCIATED(ptr%parent)) THEN CALL cp_warn(__LOCATION__, & "try to deallocate subtree element"// & cp_to_string(ptr%sub_tree_nr)//cp_to_string(ptr%nr)// & " still with global tree element references e.g."// & cp_to_string(ptr%gt_nodes_references%gt_elem%nr)) + END IF CPASSERT(ASSOCIATED(ptr%gt_nodes_references%gt_elem)) ELSE SELECT CASE (ptr%stat) @@ -1095,8 +1116,9 @@ CONTAINS ELSE ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN CALL create_dot_color(tree_element=ptr, tmc_params=tmc_env%params) + END IF !remove pointer from tree parent IF (ASSOCIATED(ptr%parent)) THEN @@ -1276,19 +1298,21 @@ CONTAINS ! delete element IF (remove_this) THEN !-- mark as deleted and draw it in tree - IF (.NOT. ASSOCIATED(begin_ptr%parent)) & + IF (.NOT. ASSOCIATED(begin_ptr%parent)) THEN CALL cp_abort(__LOCATION__, & "try to remove unused subtree element "// & cp_to_string(begin_ptr%sub_tree_nr)//" "// & cp_to_string(begin_ptr%nr)// & " but parent does not exist") + END IF tmp_ptr => begin_ptr ! check if a working group is still working on this element removed = .TRUE. DO i = 1, SIZE(working_elem_list(:)) IF (ASSOCIATED(working_elem_list(i)%elem)) THEN - IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) & + IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) THEN removed = .FALSE. + END IF END IF END DO IF (removed) THEN @@ -1333,10 +1357,11 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) & + IF (ASSOCIATED(actual_ptr%parent)) THEN CALL remove_result_g_tree(end_of_clean_tree=end_of_clean_tree, & actual_ptr=actual_ptr%parent, & tmc_env=tmc_env) + END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN !-- deallocate node @@ -1376,9 +1401,10 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) & + IF (ASSOCIATED(actual_ptr%parent)) THEN CALL remove_result_s_tree(end_of_clean_tree, actual_ptr%parent, & tmc_env) + END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN @@ -1446,8 +1472,9 @@ CONTAINS actual_ptr=tmp_gt_ptr, tmc_env=tmc_env) !check if something changed, if not no deallocation of result subtree necessary - IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) & + IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) THEN change_trajec = .TRUE. + END IF tmc_env%m_env%gt_head => tmc_env%m_env%gt_clean_end CPASSERT(.NOT. ASSOCIATED(tmc_env%m_env%gt_head%parent)) !IF (DEBUG>=20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr @@ -1459,8 +1486,9 @@ CONTAINS ! get last checked element in trajectory related to the subtree (resultlist order is NOT subtree order) conf_loop: DO i = 1, SIZE(tmc_env%m_env%result_list) last_acc_st_elem => tmc_env%m_env%result_list(i)%elem - IF (last_acc_st_elem%sub_tree_nr == tree) & + IF (last_acc_st_elem%sub_tree_nr == tree) THEN EXIT conf_loop + END IF END DO conf_loop CPASSERT(last_acc_st_elem%sub_tree_nr == tree) CALL remove_unused_s_tree(begin_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, & diff --git a/src/tmc/tmc_tree_search.F b/src/tmc/tmc_tree_search.F index 5de61a8f44..a2371f3447 100644 --- a/src/tmc/tmc_tree_search.F +++ b/src/tmc/tmc_tree_search.F @@ -721,10 +721,12 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) & + IF (ASSOCIATED(ptr%acc)) THEN CALL count_nodes_in_global_tree(ptr%acc, counter) - IF (ASSOCIATED(ptr%nacc)) & + END IF + IF (ASSOCIATED(ptr%nacc)) THEN CALL count_nodes_in_global_tree(ptr%nacc, counter) + END IF END SUBROUTINE count_nodes_in_global_tree ! ************************************************************************************************** @@ -741,9 +743,11 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) & + IF (ASSOCIATED(ptr%acc)) THEN CALL count_nodes_in_tree(ptr%acc, counter) - IF (ASSOCIATED(ptr%nacc)) & + END IF + IF (ASSOCIATED(ptr%nacc)) THEN CALL count_nodes_in_tree(ptr%nacc, counter) + END IF END SUBROUTINE count_nodes_in_tree END MODULE tmc_tree_search diff --git a/src/tmc/tmc_types.F b/src/tmc/tmc_types.F index 02292e1c68..b7884be56f 100644 --- a/src/tmc/tmc_types.F +++ b/src/tmc/tmc_types.F @@ -216,22 +216,28 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env%params)) DEALLOCATE (tmc_env%params%sub_box_size) - IF (ASSOCIATED(tmc_env%params%Temp)) & + IF (ASSOCIATED(tmc_env%params%Temp)) THEN DEALLOCATE (tmc_env%params%Temp) - IF (ASSOCIATED(tmc_env%params%cell)) & + END IF + IF (ASSOCIATED(tmc_env%params%cell)) THEN DEALLOCATE (tmc_env%params%cell) - IF (ASSOCIATED(tmc_env%params%atoms)) & + END IF + IF (ASSOCIATED(tmc_env%params%atoms)) THEN CALL deallocate_tmc_atom_type(tmc_env%params%atoms) + END IF DEALLOCATE (tmc_env%params) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_sub_group) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_w) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_first_w) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & + END IF + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_ana) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) & + END IF + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) THEN CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_only) + END IF DEALLOCATE (tmc_env%tmc_comp_set) @@ -281,8 +287,9 @@ CONTAINS DO i = 1, tmc_env%params%nr_temp tmc_env%m_env%st_heads(i)%elem => NULL() tmc_env%m_env%st_clean_ends(i)%elem => NULL() - IF (tmc_env%params%USE_REDUCED_TREE) & + IF (tmc_env%params%USE_REDUCED_TREE) THEN tmc_env%m_env%result_list(i)%elem => NULL() + END IF END DO tmc_env%m_env%gt_head => NULL() tmc_env%m_env%gt_clean_end => NULL() diff --git a/src/tmc/tmc_worker.F b/src/tmc/tmc_worker.F index 2e2204d988..bdc50bb514 100644 --- a/src/tmc/tmc_worker.F +++ b/src/tmc/tmc_worker.F @@ -167,13 +167,15 @@ CONTAINS END IF ! set the communicator in the external control for receiving exit tags ! and sending additional information (e.g. the intermediate scf energies) - IF (tmc_env%params%use_scf_energy_info) & + IF (tmc_env%params%use_scf_energy_info) THEN CALL set_intermediate_info_comm(env_id=itmp, & comm=tmc_env%tmc_comp_set%para_env_m_w) - IF (tmc_env%params%SPECULATIVE_CANCELING) & + END IF + IF (tmc_env%params%SPECULATIVE_CANCELING) THEN CALL set_external_comm(comm=tmc_env%tmc_comp_set%para_env_m_w, & in_external_master_id=MASTER_COMM_ID, & in_exit_tag=TMC_CANCELING_MESSAGE) + END IF END IF !-- WORKING LOOP --! master_work_time: DO @@ -187,9 +189,10 @@ CONTAINS result_count=ana_restart_conf, & tmc_params=tmc_env%params, elem=conf) - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN WRITE (tmc_env%w_env%io_unit, *) "worker: group master of group ", & - tmc_env%tmc_comp_set%group_nr, "got task ", work_stat + tmc_env%tmc_comp_set%group_nr, "got task ", work_stat + END IF calc_stat = TMC_STATUS_CALCULATING SELECT CASE (work_stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -208,9 +211,10 @@ CONTAINS para_env=para_env_m_w, & tmc_params=tmc_env%params) CASE (TMC_STATUS_FAILED) - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%w_env%io_unit, *) "master worker of group", & - tmc_env%tmc_comp_set%group_nr, " exit work time." + tmc_env%tmc_comp_set%group_nr, " exit work time." + END IF EXIT master_work_time !-- group master read the CP2K input file, and write data to master CASE (TMC_STAT_START_CONF_REQUEST) @@ -230,10 +234,11 @@ CONTAINS tmc_params=tmc_env%params, elem=conf, & wait_for_message=.TRUE.) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & para_env=tmc_env%tmc_comp_set%para_env_m_first_w) + END IF !-- calculate the approximate energy CASE (TMC_STAT_APPROX_ENERGY_REQUEST) CPASSERT(tmc_env%w_env%env_id_approx > 0) @@ -267,7 +272,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -339,10 +344,11 @@ CONTAINS res_exist=flag, ierr=ierr) IF (.NOT. flag) tmc_env%params%print_dipole = .FALSE. ! TODO maybe let run with the changed option, but inform user properly - IF (.NOT. flag) & + IF (.NOT. flag) THEN CALL cp_abort(__LOCATION__, & "TMC: The requested dipoles are not porvided by the "// & "force environment.") + END IF END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -358,10 +364,11 @@ CONTAINS END SELECT !-- send information back to master - IF (DEBUG >= 1) & + IF (DEBUG >= 1) THEN WRITE (tmc_env%w_env%io_unit, *) "worker group ", & - tmc_env%tmc_comp_set%group_nr, & - "calculations done, send result energy", conf%potential + tmc_env%tmc_comp_set%group_nr, & + "calculations done, send result energy", conf%potential + END IF itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & @@ -386,9 +393,10 @@ CONTAINS CALL analysis_init(ana_env=ana_list(itmp)%temp, nr_dim=num_dim) ana_list(itmp)%temp%print_test_output = tmc_env%params%print_test_output - IF (.NOT. ASSOCIATED(conf)) & + IF (.NOT. ASSOCIATED(conf)) THEN CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=conf, nr_dim=num_dim) + END IF CALL analysis_restart_read(ana_env=ana_list(itmp)%temp, & elem=conf) !check if we have the read the file @@ -438,12 +446,14 @@ CONTAINS cp_to_string(work_stat)) END SELECT - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN WRITE (tmc_env%w_env%io_unit, *) "worker: group ", & - tmc_env%tmc_comp_set%group_nr, & - "send back status:", work_stat - IF (ASSOCIATED(conf)) & + tmc_env%tmc_comp_set%group_nr, & + "send back status:", work_stat + END IF + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=conf) + END IF END DO master_work_time !-- every other group paricipants---------------------------------------- ELSE @@ -489,7 +499,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -516,8 +526,9 @@ CONTAINS "group participant got unknown working type "// & cp_to_string(work_stat)) END SELECT - IF (ASSOCIATED(conf)) & + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=conf) + END IF END DO worker_work_time END IF ! -------------------------------------------------------------------- @@ -525,8 +536,9 @@ CONTAINS IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN DO itmp = 1, tmc_env%params%nr_temp CALL analysis_restart_print(ana_env=ana_list(itmp)%temp) - IF (ASSOCIATED(conf)) & + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=ana_list(itmp)%temp%last_elem) + END IF CALL finalize_tmc_analysis(ana_list(itmp)%temp) END DO END IF @@ -546,9 +558,10 @@ CONTAINS CALL remove_intermediate_info_comm(env_id=itmp) END IF END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) & + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) THEN CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_sub_group, & tmc_params=tmc_env%params) + END IF work_stat = TMC_STATUS_STOP_RECEIPT itmp = MASTER_COMM_ID @@ -563,10 +576,11 @@ CONTAINS tmc_params=tmc_env%params) END IF - IF (DEBUG >= 5) & + IF (DEBUG >= 5) THEN WRITE (tmc_env%w_env%io_unit, *) "worker ", & - tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & - tmc_env%tmc_comp_set%group_nr, "stops working!" + tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & + tmc_env%tmc_comp_set%group_nr, "stops working!" + END IF IF (PRESENT(ana_list)) THEN DO itmp = 1, tmc_env%params%nr_temp @@ -574,8 +588,9 @@ CONTAINS ana_list(itmp)%temp%cell => NULL() END DO END IF - IF (ASSOCIATED(conf)) & + IF (ASSOCIATED(conf)) THEN CALL deallocate_sub_tree_node(tree_elem=conf) + END IF IF (ASSOCIATED(ana_restart_conf)) DEALLOCATE (ana_restart_conf) ! end the timing @@ -872,10 +887,11 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN CALL cp_abort(__LOCATION__, & "the intermediate SCF energy request can not be set "// & "employing this force environment! ") + END IF ! set the information values(1) = REAL(comm%get_handle(), KIND=dp) @@ -910,10 +926,11 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN CALL cp_abort(__LOCATION__, & "the SCF intermediate energy communicator can not be "// & "removed! ") + END IF description = "[EXT_SCF_ENER_COMM]" diff --git a/src/topology.F b/src/topology.F index b82782ec0a..e482a1cb4c 100644 --- a/src/topology.F +++ b/src/topology.F @@ -548,11 +548,12 @@ CONTAINS "connectivity type.") END SELECT END DO - IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) & + IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) THEN CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") + END IF ! Merge defined structures section => section_vals_get_subs_vals(subsys_section, "TOPOLOGY%MOL_SET%MERGE_MOLECULES") @@ -660,8 +661,9 @@ CONTAINS i_val=topology%natoms) CALL timestop(handle2) ! Check on atom numbers - IF (topology%natoms <= 0) & + IF (topology%natoms <= 0) THEN CPABORT("No atomic coordinates have been found! ") + END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & "PRINT%TOPOLOGY_INFO") diff --git a/src/topology_amber.F b/src/topology_amber.F index 8f9bbc4361..10425ea382 100644 --- a/src/topology_amber.F +++ b/src/topology_amber.F @@ -184,8 +184,9 @@ CONTAINS END DO ! Trigger error IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) & + IF (j /= natom) THEN CPABORT("Error while reading CRD file. Unexpected end of file.") + END IF ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom j = natom @@ -230,10 +231,11 @@ CONTAINS END DO setup_velocities = .TRUE. IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) & + IF (j /= natom) THEN CALL cp_warn(__LOCATION__, & "No VELOCITY information found in CRD file. Ignoring BOX information. "// & "Please provide the BOX information directly from the main CP2K input! ") + END IF setup_velocities = .FALSE. ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom @@ -257,10 +259,11 @@ CONTAINS IF (my_end) THEN CPWARN_IF(j /= natom, "BOX information missing in CRD file.") ELSE - IF (j /= natom) & + IF (j /= natom) THEN CALL cp_warn(__LOCATION__, & "BOX information found in CRD file. They will be ignored. "// & "Please provide the BOX information directly from the main CP2K input!") + END IF END IF CALL parser_release(parser) CALL cp_print_key_finished_output(iw, logger, subsys_section, & @@ -1060,16 +1063,18 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i1 ! ************************************************************************************************** @@ -1096,26 +1101,30 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i3 ! ************************************************************************************************** @@ -1143,31 +1152,36 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i4 ! ************************************************************************************************** @@ -1197,36 +1211,42 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) !array5 - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array5(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_i5 ! ************************************************************************************************** @@ -1250,16 +1270,18 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i), lower_to_upper=.TRUE.) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_c1 ! ************************************************************************************************** @@ -1283,16 +1305,18 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") & + IF (parser_test_next_token(parser) == "EOL") THEN CALL parser_get_next_line(parser, 1, at_end=my_end) + END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) & + IF (my_end .AND. (i <= dim)) THEN CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") + END IF END SUBROUTINE rd_amber_section_r1 ! ************************************************************************************************** @@ -1321,8 +1345,9 @@ CONTAINS section = TRIM(parser%input_line(indflag:)) ! Input format CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) & + IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) THEN CPABORT("Expecting %FORMAT. Not found! Abort reading of AMBER topology file!") + END IF start_f = INDEX(parser%input_line, "(") end_f = INDEX(parser%input_line, ")") @@ -1346,10 +1371,11 @@ CONTAINS LOGICAL :: found_AMBER_V8 CALL parser_search_string(parser, "%VERSION ", .TRUE., found_AMBER_V8, begin_line=.TRUE.) - IF (.NOT. found_AMBER_V8) & + IF (.NOT. found_AMBER_V8) THEN CALL cp_abort(__LOCATION__, & "This is not an AMBER V.8 PRMTOP format file. Cannot interpret older "// & "AMBER file formats. ") + END IF IF (output_unit > 0) WRITE (output_unit, '(" AMBER_INFO| ",A)') "Amber PrmTop V.8 or greater.", & TRIM(parser%input_line) diff --git a/src/topology_cif.F b/src/topology_cif.F index 0100632559..eb3f9250f3 100644 --- a/src/topology_cif.F +++ b/src/topology_cif.F @@ -249,9 +249,10 @@ CONTAINS CALL parser_search_string(parser, "_space_group_symop_operation_xyz", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) END IF - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_warn(__LOCATION__, "The fields (_symmetry_equiv_pos_as_xyz) or "// & "(_space_group_symop_operation_xyz) were not found in CIF file!") + END IF IF (iw > 0) WRITE (iw, '(A,I0)') " CIF_INFO| Number of atoms before applying symmetry operations :: ", natom IF (iw > 0) WRITE (iw, '(A10,1X,3F12.6)') (TRIM(id2str(atom_info%id_atmname(ii))), atom_info%r(1:3, ii), ii=1, natom) isym = 0 @@ -290,7 +291,6 @@ CONTAINS DO jj = 1, natom r2 = atom_info%r(1:3, jj) r = pbc(r1 - r2, cell) - ! SQRT(DOT_PRODUCT(r, r)) <= threshold IF (DOT_PRODUCT(r, r) <= (threshold*threshold)) THEN check = .FALSE. EXIT diff --git a/src/topology_connectivity_util.F b/src/topology_connectivity_util.F index 8506ee4119..7518b6dfc0 100644 --- a/src/topology_connectivity_util.F +++ b/src/topology_connectivity_util.F @@ -74,7 +74,7 @@ CONTAINS inter_bends, inter_bonds, inter_imprs, inter_torsions, inter_ubs, intra_bends, & intra_bonds, intra_imprs, intra_torsions, intra_ubs, inum, ires, istart_mol, istart_typ, & itorsion, ityp, iub, iw, j, j1, j2, j3, j4, jind, last, min_index, natom, nelectron, & - nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit, stat + nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit INTEGER, DIMENSION(:), POINTER :: c_var_a, c_var_b, c_var_c, c_var_d, c_var_type, & first_list, last_list, map_atom_mol, map_atom_type, map_cvar_mol, map_cvars, map_var_mol, & map_vars, molecule_list @@ -225,7 +225,7 @@ CONTAINS found = .TRUE. found_last = .FALSE. imol = ABS(map_atom_mol(i)) - ELSEIF (ikind == topology%nmol_type) THEN + ELSE IF (ikind == topology%nmol_type) THEN found = .TRUE. found_last = .TRUE. imol = ABS(map_atom_mol(natom)) @@ -1057,9 +1057,8 @@ CONTAINS END IF molecule_kind => molecule_kind_set(i) nval_tot2 = nval_tot2 + iimpr*SIZE(molecule_kind%molecule_list) - ALLOCATE (impr_list(iimpr), STAT=stat) - ALLOCATE (opbend_list(iimpr), STAT=stat) - CPASSERT(stat == 0) + ALLOCATE (impr_list(iimpr)) + ALLOCATE (opbend_list(iimpr)) iimpr = 0 DO j = bnd_type(1, i), bnd_type(2, i) IF (j == 0) CYCLE diff --git a/src/topology_constraint_util.F b/src/topology_constraint_util.F index b7d07a8b12..2980507f15 100644 --- a/src/topology_constraint_util.F +++ b/src/topology_constraint_util.F @@ -241,11 +241,13 @@ CONTAINS END IF END IF CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", n_rep_val=nrep) - IF (nrep /= 0) & + IF (nrep /= 0) THEN CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", c_vals=atom_typeh) + END IF CALL section_vals_val_get(hbonds_section, "TARGETS", n_rep_val=nrep) - IF (nrep /= 0) & + IF (nrep /= 0) THEN CALL section_vals_val_get(hbonds_section, "TARGETS", r_vals=hdist) + END IF IF (ASSOCIATED(hdist)) THEN CPASSERT(SIZE(hdist) == SIZE(atom_typeh)) END IF @@ -342,7 +344,7 @@ CONTAINS IF (ishbond) THEN nhdist = nhdist + 1 rvec = particle_set(offset + bond_list(k)%a)%r - particle_set(offset + bond_list(k)%b)%r - rmod = SQRT(DOT_PRODUCT(rvec, rvec)) + rmod = NORM2(rvec) IF (ASSOCIATED(hdist)) THEN IF (SIZE(hdist) > 0) THEN IF (bond_list(k)%a == j) atomic_kind => atom_list(bond_list(k)%b)%atomic_kind @@ -750,13 +752,13 @@ CONTAINS IF (fix_fixed_atom) THEN fixd_list(kk)%restraint%active = cons_info%fixed_restraint(k2loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_k0(k2loc) - ELSEIF (fix_atom_qm) THEN + ELSE IF (fix_atom_qm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_qm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_qm_k0 - ELSEIF (fix_atom_mm) THEN + ELSE IF (fix_atom_mm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_mm_k0 - ELSEIF (fix_atom_molname) THEN + ELSE IF (fix_atom_molname) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mol_restraint(k1loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_mol_k0(k1loc) ELSE @@ -813,8 +815,9 @@ CONTAINS CASE (use_perd_xyz) CPASSERT(SIZE(r) == 3) fixd_list(kk)%coord(1:3) = r(1:3) - IF (ASSOCIATED(topology%cell_muc)) & + IF (ASSOCIATED(topology%cell_muc)) THEN CALL cell_transform_input_cartesian(topology%cell_muc, fixd_list(kk)%coord) + END IF END SELECT ELSE ! Write coord0 value for restraint @@ -1338,11 +1341,12 @@ CONTAINS ! Intramolecular constraint IF (const_mol(i) /= 0) THEN k = const_mol(i) - IF (k > SIZE(molecule_kind_set)) & + IF (k > SIZE(molecule_kind_set)) THEN CALL cp_abort(__LOCATION__, & "A constraint has been specified providing the molecule index. But the"// & " molecule index ("//cp_to_string(k)//") is out of range of the possible"// & " molecule kinds ("//cp_to_string(SIZE(molecule_kind_set))//").") + END IF isize = SIZE(constr_x_mol(k)%constr) CALL reallocate(constr_x_mol(k)%constr, 1, isize + 1) constr_x_mol(k)%constr(isize + 1) = i @@ -1379,13 +1383,14 @@ CONTAINS LOGICAL, INTENT(IN) :: found CHARACTER(LEN=*), INTENT(IN) :: name - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_warn(__LOCATION__, & " MOLNAME ("//TRIM(name)//") was defined for constraints, but this molecule name "// & "is not defined. Please check carefully your PDB, PSF (has priority over PDB) or "// & "input driven CP2K coordinates. In case you may not find the reason for this warning "// & "it may be a good idea to print all molecule information (including kind name) activating "// & "the print_key MOLECULES specific of the SUBSYS%PRINT section. ") + END IF END SUBROUTINE print_warning_molname diff --git a/src/topology_coordinate_util.F b/src/topology_coordinate_util.F index e2a1b91768..63584a9429 100644 --- a/src/topology_coordinate_util.F +++ b/src/topology_coordinate_util.F @@ -198,8 +198,9 @@ CONTAINS CALL reallocate(mass, 1, counter) CALL reallocate(id_element, 1, counter) CALL reallocate(charge, 1, counter) - IF (iw > 0) & + IF (iw > 0) THEN WRITE (iw, '(5X,A,I3)') "Total Number of Atomic Kinds = ", topology%natom_type + END IF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -338,10 +339,11 @@ CONTAINS END DO my_ignore_outside_box = .FALSE. IF (PRESENT(ignore_outside_box)) my_ignore_outside_box = ignore_outside_box - IF (.NOT. my_ignore_outside_box .AND. .NOT. check) & + IF (.NOT. my_ignore_outside_box .AND. .NOT. check) THEN CALL cp_abort(__LOCATION__, & "A non-periodic calculation has been requested but the system size "// & "exceeds the cell size in at least one of the non-periodic directions!") + END IF IF (do_center) THEN CALL section_vals_val_get(subsys_section, & "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT", explicit=explicit) @@ -636,20 +638,23 @@ CONTAINS ! copy of data, not copy of pointer exclusions(iatom)%list_onfo = ex_onfo_list(iatom)%array1 IF (iw > 0) THEN - IF (ASSOCIATED(list)) & + IF (ASSOCIATED(list)) THEN WRITE (iw, *) "exclusion list_vdw :: ", & - "atom num :", iatom, "exclusion list ::", & - list - IF (topology%exclude_vdw /= topology%exclude_ei) THEN - IF (ASSOCIATED(list2)) & - WRITE (iw, *) "exclusion list_ei :: ", & "atom num :", iatom, "exclusion list ::", & - list2 + list END IF - IF (ASSOCIATED(exclusions(iatom)%list_onfo)) & + IF (topology%exclude_vdw /= topology%exclude_ei) THEN + IF (ASSOCIATED(list2)) THEN + WRITE (iw, *) "exclusion list_ei :: ", & + "atom num :", iatom, "exclusion list ::", & + list2 + END IF + END IF + IF (ASSOCIATED(exclusions(iatom)%list_onfo)) THEN WRITE (iw, *) "onfo list :: ", & - "atom num :", iatom, "onfo list ::", & - exclusions(iatom)%list_onfo + "atom num :", iatom, "onfo list ::", & + exclusions(iatom)%list_onfo + END IF END IF END DO ! deallocate onfo diff --git a/src/topology_generate_util.F b/src/topology_generate_util.F index 718c42ac9b..5e17f4df5a 100644 --- a/src/topology_generate_util.F +++ b/src/topology_generate_util.F @@ -1669,7 +1669,7 @@ CONTAINS nvar=nvar, & Ilist=Ilist) Ilist(it_levl) = -1 - ELSEIF (it_levl == max_levl) THEN + ELSE IF (it_levl == max_levl) THEN IF (Ilist(1) > ind) CYCLE Ilist(it_levl) = ind nvar = nvar + 1 diff --git a/src/topology_gromos.F b/src/topology_gromos.F index d3ddfa9858..743d890308 100644 --- a/src/topology_gromos.F +++ b/src/topology_gromos.F @@ -607,10 +607,12 @@ CONTAINS DEALLOCATE (na) DEALLOCATE (am) DEALLOCATE (ac) - IF (ASSOCIATED(ba)) & + IF (ASSOCIATED(ba)) THEN DEALLOCATE (ba) - IF (ASSOCIATED(bb)) & + END IF + IF (ASSOCIATED(bb)) THEN DEALLOCATE (bb) + END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & diff --git a/src/topology_input.F b/src/topology_input.F index 4aa95dfb4b..6aad5946ca 100644 --- a/src/topology_input.F +++ b/src/topology_input.F @@ -64,8 +64,9 @@ CONTAINS CALL section_vals_val_get(topology_section, "CHARGE_BETA", l_val=topology%charge_beta) CALL section_vals_val_get(topology_section, "CHARGE_EXTENDED", l_val=topology%charge_extended) ival = COUNT([topology%charge_occup, topology%charge_beta, topology%charge_extended]) - IF (ival > 1) & + IF (ival > 1) THEN CPABORT("Only one between can be defined! ") + END IF CALL section_vals_val_get(topology_section, "PARA_RES", l_val=topology%para_res) CALL section_vals_val_get(topology_section, "GENERATE%REORDER", l_val=topology%reorder_atom) CALL section_vals_val_get(topology_section, "GENERATE%CREATE_MOLECULES", l_val=topology%create_molecules) diff --git a/src/topology_multiple_unit_cell.F b/src/topology_multiple_unit_cell.F index bd93f27785..771768035e 100644 --- a/src/topology_multiple_unit_cell.F +++ b/src/topology_multiple_unit_cell.F @@ -65,19 +65,21 @@ CONTAINS i_vals=multiple_unit_cell) ! Fail is one of the value is set to zero.. - IF (ANY(multiple_unit_cell <= 0)) & + IF (ANY(multiple_unit_cell <= 0)) THEN CALL cp_abort(__LOCATION__, "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL accepts "// & "only integer values greater than zero.") + END IF IF (ANY(multiple_unit_cell /= 1)) THEN ! Check that the setup between CELL and TOPOLOGY is the same CALL section_vals_val_get(subsys_section, "CELL%MULTIPLE_UNIT_CELL", & i_vals=iwork) - IF (ANY(iwork /= multiple_unit_cell)) & + IF (ANY(iwork /= multiple_unit_cell)) THEN CALL cp_abort(__LOCATION__, "The input parameters for "// & "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL and "// & "SUBSYS%CELL%MULTIPLE_UNIT_CELL have to agree.") + END IF cell => topology%cell_muc natoms = topology%natoms*PRODUCT(multiple_unit_cell) @@ -88,9 +90,10 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(work_section, '_DEFAULT_KEYWORD_', n_rep_val=nrep) check = nrep == natoms - IF (.NOT. check) & + IF (.NOT. check) THEN CALL cp_abort(__LOCATION__, "The number of available entries in the "// & "VELOCITY section is not compatible with the number of atoms.") + END IF END IF CALL reallocate(topology%atom_info%id_molname, 1, natoms) diff --git a/src/topology_pdb.F b/src/topology_pdb.F index 481169411a..f995d732a2 100644 --- a/src/topology_pdb.F +++ b/src/topology_pdb.F @@ -185,12 +185,20 @@ CONTAINS ELSE atom_info%id_resname(natom) = id0 END IF + ! Some information is not always given, so we mark it as used to prevent linters from crying + ! regarding never a never used variable 'istat' READ (UNIT=line(23:26), FMT=*, IOSTAT=istat) atom_info%resid(natom) + MARK_USED(istat) READ (UNIT=line(31:38), FMT=*, IOSTAT=istat) atom_info%r(1, natom) + MARK_USED(istat) READ (UNIT=line(39:46), FMT=*, IOSTAT=istat) atom_info%r(2, natom) + MARK_USED(istat) READ (UNIT=line(47:54), FMT=*, IOSTAT=istat) atom_info%r(3, natom) + MARK_USED(istat) READ (UNIT=line(55:60), FMT=*, IOSTAT=istat) atom_info%occup(natom) + MARK_USED(istat) READ (UNIT=line(61:66), FMT=*, IOSTAT=istat) atom_info%beta(natom) + MARK_USED(istat) READ (UNIT=line(73:76), FMT=*, IOSTAT=istat) strtmp IF (istat == 0) THEN atom_info%id_molname(natom) = str2id(s2s(strtmp)) @@ -209,7 +217,7 @@ CONTAINS IF (topology%charge_occup) atom_info%atm_charge(natom) = atom_info%occup(natom) IF (topology%charge_beta) atom_info%atm_charge(natom) = atom_info%beta(natom) IF (topology%charge_extended) THEN - READ (UNIT=line(81:), FMT=*, IOSTAT=istat) atom_info%atm_charge(natom) + READ (UNIT=line(81:), FMT=*) atom_info%atm_charge(natom) END IF IF (atom_info%id_element(natom) == id0) THEN @@ -310,8 +318,9 @@ CONTAINS CALL section_vals_val_get(print_key, "CHARGE_BETA", l_val=charge_beta) CALL section_vals_val_get(print_key, "CHARGE_EXTENDED", l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) & + IF (i > 1) THEN CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected") + END IF atom_info => topology%atom_info record = cp_print_key_generate_filename(logger, print_key, & @@ -371,8 +380,9 @@ CONTAINS END IF IF (ASSOCIATED(atom_info%atm_charge)) THEN IF (ANY([charge_occup, charge_beta, charge_extended]) .AND. & - (atom_info%atm_charge(i) == -HUGE(0.0_dp))) & + (atom_info%atm_charge(i) == -HUGE(0.0_dp))) THEN CPABORT("No atomic charges found yet (after the topology setup)") + END IF IF (charge_occup) THEN WRITE (UNIT=line(55:60), FMT="(F6.2)") atom_info%atm_charge(i) ELSE IF (charge_beta) THEN diff --git a/src/topology_psf.F b/src/topology_psf.F index 91aaec84e7..ce03e59dae 100644 --- a/src/topology_psf.F +++ b/src/topology_psf.F @@ -113,9 +113,10 @@ CONTAINS c_int = 'I8' label = 'PSF' CALL parser_search_string(parser, label, .TRUE., found, begin_line=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CALL cp_abort(__LOCATION__, & "Missing PSF specification line in <"//TRIM(filename)//">") + END IF DO WHILE (parser_test_next_token(parser) /= "EOL") CALL parser_get_object(parser, field) SELECT CASE (field(1:3)) @@ -147,11 +148,12 @@ CONTAINS natom = 0 ELSE CALL parser_get_object(parser, natom) - IF (natom_prev + natom > topology%natoms) & + IF (natom_prev + natom > topology%natoms) THEN CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") + END IF IF (iw > 0) WRITE (iw, '(T2,A,'//TRIM(c_int)//')') 'PSF_INFO| NATOM = ', natom !malloc the memory that we need CALL reallocate(atom_info%id_molname, 1, natom_prev + natom) diff --git a/src/topology_types.F b/src/topology_types.F index 440becf6d0..6300d6809b 100644 --- a/src/topology_types.F +++ b/src/topology_types.F @@ -68,12 +68,13 @@ MODULE topology_types REAL(KIND=dp) :: hbonds_k0 = -1.0_dp ! Restraints control ! Fixed Atoms INTEGER :: nfixed_atoms = -1 - INTEGER, POINTER :: fixed_atoms(:) => NULL(), fixed_type(:) => NULL(), fixed_mol_type(:) => NULL() - LOGICAL, POINTER :: fixed_restraint(:) => NULL() ! Restraints control - REAL(KIND=dp), POINTER :: fixed_k0(:) => NULL() ! Restraints control + INTEGER, DIMENSION(:), POINTER :: fixed_atoms => NULL(), fixed_type => NULL(), fixed_mol_type => NULL() + LOGICAL, DIMENSION(:), POINTER :: fixed_restraint => NULL() ! Restraints control + REAL(KIND=dp), DIMENSION(:), POINTER :: fixed_k0 => NULL() ! Restraints control ! Freeze QM or MM INTEGER :: freeze_qm = -1, freeze_mm = -1, freeze_qm_type = -1, freeze_mm_type = -1 - LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. ! Restraints control + ! Restraints control + LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. REAL(KIND=dp) :: fixed_mm_k0 = -1.0_dp, fixed_qm_k0 = -1.0_dp ! Restraints control ! Freeze with molnames LOGICAL, POINTER :: fixed_mol_restraint(:) => NULL() ! Restraints control @@ -524,8 +525,9 @@ CONTAINS !----------------------------------------------------------------------------- ! 3. DEALLOCATE things in topology%cons_info !----------------------------------------------------------------------------- - IF (ASSOCIATED(topology%cons_info)) & + IF (ASSOCIATED(topology%cons_info)) THEN CALL deallocate_constraint(topology%cons_info) + END IF !----------------------------------------------------------------------------- ! 4. DEALLOCATE things in topology !----------------------------------------------------------------------------- diff --git a/src/topology_util.F b/src/topology_util.F index b53ba161c7..0a042423bb 100644 --- a/src/topology_util.F +++ b/src/topology_util.F @@ -1207,11 +1207,12 @@ CONTAINS END IF ! This is clearly a user error - IF (.NOT. found .AND. defined_kind_section) & + IF (.NOT. found .AND. defined_kind_section) THEN CALL cp_abort(__LOCATION__, "Element <"//TRIM(element_symbol)// & "> provided for KIND <"//TRIM(atom_name_in)//"> "// & "which cannot be mapped with any standard element label. Please correct your "// & "input file!") + END IF ! Last chance.. are these atom_kinds of AMBER or CHARMM or GROMOS FF ? CALL uppercase(element_symbol) diff --git a/src/topology_xtl.F b/src/topology_xtl.F index 42f6839993..29b87259ff 100644 --- a/src/topology_xtl.F +++ b/src/topology_xtl.F @@ -144,8 +144,9 @@ CONTAINS ! Check for _cell_length_a CALL parser_search_string(parser, "CELL", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field CELL was not found in XTL file! ") + END IF CALL parser_get_next_line(parser, 1) ! CELL LENGTH A CALL parser_get_object(parser, cell_lengths(1)) @@ -178,13 +179,15 @@ CONTAINS ! Check for _atom_site_label CALL parser_search_string(parser, "ATOMS", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field ATOMS was not found in XTL file! ") + END IF CALL parser_get_next_line(parser, 1) ! Paranoic syntax check.. if this fails one should improve the description of XTL files found = (INDEX(parser%input_line, "NAME X Y Z") /= 0) - IF (.NOT. found) & + IF (.NOT. found) THEN CPABORT("The field ATOMS in XTL file, is not followed by name and coordinates tags! ") + END IF CALL parser_get_next_line(parser, 1) ! Parse real info natom = 0 diff --git a/src/topology_xyz.F b/src/topology_xyz.F index b01a1cab08..6f881238c9 100644 --- a/src/topology_xyz.F +++ b/src/topology_xyz.F @@ -151,11 +151,12 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) my_end = my_end .OR. (LEN_TRIM(parser%input_line) == 0) IF (my_end) THEN - IF (j /= natom) & + IF (j /= natom) THEN CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format. Very probably the line with title is missing or is empty."// & " Please check the XYZ file and rerun your job!") + END IF EXIT Frames END IF END DO diff --git a/src/torch_c_api.cpp b/src/torch_c_api.cpp index 9349653ebf..9293fd6425 100644 --- a/src/torch_c_api.cpp +++ b/src/torch_c_api.cpp @@ -7,6 +7,7 @@ #if defined(__LIBTORCH) +#include #include #include #include @@ -16,6 +17,7 @@ #include #include +#include #include #include #include @@ -47,7 +49,38 @@ private: ******************************************************************************/ static bool use_cuda_if_available = true; +static bool get_positive_int_env(const char *name, int &value) { + const char *raw = std::getenv(name); + if (raw == nullptr || raw[0] == '\0') { + return false; + } + char *end = nullptr; + const long parsed = std::strtol(raw, &end, 10); + if (end == raw || *end != '\0' || parsed <= 0 || parsed > INT_MAX) { + return false; + } + value = static_cast(parsed); + return true; +} + +static void initialize_torch_threads_from_env() { + static bool initialized = false; + if (initialized) { + return; + } + initialized = true; + + int num_threads = 0; + if (get_positive_int_env("CP2K_TORCH_NUM_THREADS", num_threads)) { + at::set_num_threads(num_threads); + } + if (get_positive_int_env("CP2K_TORCH_NUM_INTEROP_THREADS", num_threads)) { + at::set_num_interop_threads(num_threads); + } +} + static torch::Device get_device() { + initialize_torch_threads_from_env(); if (!use_cuda_if_available || !torch::cuda::is_available()) { return torch::kCPU; } @@ -107,6 +140,7 @@ static torch_c_tensor_t *tensor_from_array(const torch::Dtype dtype, const bool req_grad, const int ndims, const int64_t sizes[], void *source) { + initialize_torch_threads_from_env(); const auto opts = torch::TensorOptions().dtype(dtype).requires_grad(req_grad); const auto sizes_ref = c10::IntArrayRef(sizes, ndims); return new torch_c_tensor_t(torch::from_blob(source, sizes_ref, opts)); diff --git a/src/transport.F b/src/transport.F index fd9cc1ef24..f13949bfea 100644 --- a/src/transport.F +++ b/src/transport.F @@ -381,10 +381,11 @@ CONTAINS CALL timeset(routineN, handle) CALL C_F_PROCPOINTER(transport_env%ext_c_method_ptr, c_method) - IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) & + IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) THEN CALL cp_abort(__LOCATION__, & "MISSING C/C++ ROUTINE: The TRANSPORT section is meant to be used together with an external "// & "program, e.g. the quantum transport code OMEN, that provides CP2K with a density matrix.") + END IF transport_env%params%n_occ = nelectron_spin transport_env%params%n_atoms = natoms diff --git a/src/wannier90.F b/src/wannier90.F index 24c5901510..79dcc46327 100644 --- a/src/wannier90.F +++ b/src/wannier90.F @@ -672,7 +672,7 @@ CONTAINS counter = counter + 1 lmn(1, counter) = l; lmn(2, counter) = m; lmn(3, counter) = n pos = MATMUL(lmn(:, counter), recip_lattice) - dist(counter) = SQRT(DOT_PRODUCT(pos, pos)) + dist(counter) = NORM2(pos) END DO END DO END DO @@ -776,8 +776,8 @@ CONTAINS DO loop_s = 1, num_shells DO loop_b = 1, multi(shell_list(loop_s)) delta = DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_b, loop_s))/ & - SQRT(DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_bn, cur_shell))* & - DOT_PRODUCT(bvector(:, loop_b, loop_s), bvector(:, loop_b, loop_s))) + NORM2(bvector(:, loop_bn, cur_shell))* & + NORM2(bvector(:, loop_b, loop_s)) IF (ABS(ABS(delta) - 1.0_dp) < eps6) lpar = .TRUE. END DO END DO @@ -871,7 +871,7 @@ CONTAINS IF (.NOT. b1sat) THEN IF (shell < search_shells .AND. iprint >= 3) THEN WRITE (stdout, '(1x,a,24x,a1)') '| B1 condition is not satisfied: Adding another shell', '|' - ELSEIF (shell == search_shells) THEN + ELSE IF (shell == search_shells) THEN WRITE (stdout, *) ' ' WRITE (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', search_shells, ' shells' WRITE (stdout, '(1x,a)') 'Your cell might be very long, or you may have an irregular MP grid' diff --git a/src/xas_methods.F b/src/xas_methods.F index 8258506b41..f14f3915eb 100644 --- a/src/xas_methods.F +++ b/src/xas_methods.F @@ -316,7 +316,7 @@ CONTAINS WRITE (UNIT=output_unit, FMT="( A , I7, A, I7)") " The sub-set contains states from ", & qs_loc_env%localized_wfn_control%lu_bound_states(1, my_spin), " to ", & qs_loc_env%localized_wfn_control%lu_bound_states(2, my_spin) - ELSEIF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN + ELSE IF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN WRITE (UNIT=output_unit, FMT="( A )") " The sub-set contains states given in the input list" END IF @@ -431,8 +431,9 @@ CONTAINS CALL get_mo_set(mos(my_spin), nmo=nmo) CALL get_xas_env(xas_env, occ_estate=occ_estate, xas_nelectron=xas_nelectron) tmp = xas_nelectron + 1.0_dp - occ_estate - IF (nmo < tmp) & + IF (nmo < tmp) THEN CPABORT("CLS: the required method needs added_mos to the ground state") + END IF ! If the restart file for this atom exists, the mos and the ! occupation numbers are overwritten ! It is necessary that the restart is for the same xas method @@ -724,31 +725,31 @@ CONTAINS nele = REAL(nelectron, dp) - 0.5_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSEIF (xas_control%xas_method == xas_tp_xhh) THEN + ELSE IF (xas_control%xas_method == xas_tp_xhh) THEN occ_estate = 0.5_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 0.5_dp - ELSEIF (xas_control%xas_method == xas_tp_fh) THEN + ELSE IF (xas_control%xas_method == xas_tp_fh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) - 1.0_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSEIF (xas_control%xas_method == xas_tp_xfh) THEN + ELSE IF (xas_control%xas_method == xas_tp_xfh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSEIF (xas_control%xas_method == xes_tp_val) THEN + ELSE IF (xas_control%xas_method == xes_tp_val) THEN occ_estate = xas_control%xes_core_occupation nele = REAL(nelectron, dp) - xas_control%xes_core_occupation occ_homo = xas_control%xes_homo_occupation - ELSEIF (xas_control%xas_method == xas_dscf) THEN + ELSE IF (xas_control%xas_method == xas_dscf) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSEIF (xas_control%xas_method == xas_tp_flex) THEN + ELSE IF (xas_control%xas_method == xas_tp_flex) THEN nele = REAL(xas_control%nel_tot, dp) occ_estate = REAL(xas_control%xas_core_occupation, dp) IF (nele < 0.0_dp) nele = REAL(nelectron, dp) - (1.0_dp - occ_estate) @@ -857,7 +858,7 @@ CONTAINS "xas_env%ostrength_sm-"//TRIM(ADJUSTL(cp_to_string(i)))) CALL dbcsr_set(xas_env%ostrength_sm(i)%matrix, 0.0_dp) END DO - ELSEIF (xas_control%dipole_form == xas_dip_vel) THEN + ELSE IF (xas_control%dipole_form == xas_dip_vel) THEN ! ! prepare for allocation natom = SIZE(particle_set, 1) @@ -918,31 +919,31 @@ CONTAINS IF (xas_control%state_type == xas_1s_type) THEN nq(1) = 1 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_2s_type) THEN + ELSE IF (xas_control%state_type == xas_2s_type) THEN nq(1) = 2 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_2p_type) THEN + ELSE IF (xas_control%state_type == xas_2p_type) THEN nq(1) = 2 lq(1) = 1 - ELSEIF (xas_control%state_type == xas_3s_type) THEN + ELSE IF (xas_control%state_type == xas_3s_type) THEN nq(1) = 3 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_3p_type) THEN + ELSE IF (xas_control%state_type == xas_3p_type) THEN nq(1) = 3 lq(1) = 1 - ELSEIF (xas_control%state_type == xas_3d_type) THEN + ELSE IF (xas_control%state_type == xas_3d_type) THEN nq(1) = 3 lq(1) = 2 - ELSEIF (xas_control%state_type == xas_4s_type) THEN + ELSE IF (xas_control%state_type == xas_4s_type) THEN nq(1) = 4 lq(1) = 0 - ELSEIF (xas_control%state_type == xas_4p_type) THEN + ELSE IF (xas_control%state_type == xas_4p_type) THEN nq(1) = 4 lq(1) = 1 - ELSEIF (xas_control%state_type == xas_4d_type) THEN + ELSE IF (xas_control%state_type == xas_4d_type) THEN nq(1) = 4 lq(1) = 2 - ELSEIF (xas_control%state_type == xas_4f_type) THEN + ELSE IF (xas_control%state_type == xas_4f_type) THEN nq(1) = 4 lq(1) = 3 ELSE @@ -1659,7 +1660,8 @@ CONTAINS END DO END IF - CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) ! Scales down the 2d-array to the minimal size + ! Scales down the 2d-array to the minimal size + CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) ELSE ! Manually selected orbital indices diff --git a/src/xas_restart.F b/src/xas_restart.F index 6ecc1dda59..42864330d3 100644 --- a/src/xas_restart.F +++ b/src/xas_restart.F @@ -183,12 +183,14 @@ CONTAINS READ (rst_unit) nexc_search_read, nexc_atoms_read, occ_estate_read, xas_nelectron_read READ (rst_unit) xas_estate_read - IF (xas_method_read /= xas_method) & + IF (xas_method_read /= xas_method) THEN CPABORT("READ XAS RESTART: restart with different XAS method is not possible.") - IF (nexc_atoms_read /= nexc_atoms) & + END IF + IF (nexc_atoms_read /= nexc_atoms) THEN CALL cp_abort(__LOCATION__, & "READ XAS RESTART: restart with different excited atoms "// & "is not possible. Start instead a new XAS run with the new set of atoms.") + END IF END IF CALL para_env%bcast(xas_estate_read) @@ -206,8 +208,9 @@ CONTAINS CALL cp_fm_set_all(mo_coeff, 0.0_dp) IF (para_env%is_source()) THEN READ (rst_unit) nao_read, nmo_read - IF (nao /= nao_read) & + IF (nao /= nao_read) THEN CPABORT("To change basis is not possible. ") + END IF ALLOCATE (eig_read(nmo_read), occ_read(nmo_read)) eig_read = 0.0_dp occ_read = 0.0_dp @@ -216,10 +219,11 @@ CONTAINS eigenvalues(1:nmo) = eig_read(1:nmo) occupation_numbers(1:nmo) = occ_read(1:nmo) IF (nmo_read > nmo) THEN - IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) & + IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) THEN CALL cp_warn(__LOCATION__, & "The number of occupied MOs on the restart unit is larger than "// & "the allocated MOs.") + END IF END IF DEALLOCATE (eig_read, occ_read) diff --git a/src/xas_tdp_atom.F b/src/xas_tdp_atom.F index 87df1c0f2a..faa3fe4633 100644 --- a/src/xas_tdp_atom.F +++ b/src/xas_tdp_atom.F @@ -1186,7 +1186,7 @@ CONTAINS ! Point to the rho_set densities rhoa => rho_set%rhoa rhob => rho_set%rhob - rhoa = 0.0_dp; rhob = 0.0_dp; + rhoa = 0.0_dp; rhob = 0.0_dp IF (do_gga) THEN DO dir = 1, 3 rho_set%drhoa(dir)%array = 0.0_dp diff --git a/src/xas_tdp_correction.F b/src/xas_tdp_correction.F index 91aa6cd919..05fc8df3b9 100644 --- a/src/xas_tdp_correction.F +++ b/src/xas_tdp_correction.F @@ -1880,7 +1880,7 @@ CONTAINS !The SOC corrected KS eigenvalues ALLOCATE (tmp_shifts(ndo_mo, 2)) - ialpha = 1; ibeta = 1; + ialpha = 1; ibeta = 1 DO ido_mo = 1, ndo_so !need to find out whether the eigenvalue corresponds to an alpha or beta spin-orbtial alpha_tot_contrib = REAL(DOT_PRODUCT(evecs(1:ndo_mo, ido_mo), evecs(1:ndo_mo, ido_mo))) diff --git a/src/xas_tdp_kernel.F b/src/xas_tdp_kernel.F index 8524077535..4c4890a407 100644 --- a/src/xas_tdp_kernel.F +++ b/src/xas_tdp_kernel.F @@ -164,7 +164,8 @@ CONTAINS ! Broadcast the integrals to all procs (deleted after all donor states for this atoms are treated) lb = 1; IF (do_sf .AND. .NOT. do_sc) lb = 4 - ub = 2; IF (do_sc) ub = 3; IF (do_sf) ub = 4 + ub = 2; IF (do_sc) ub = 3 + IF (do_sf) ub = 4 DO i = lb, ub IF (.NOT. ASSOCIATED(xas_tdp_env%ri_fxc(ri_atom, i)%array)) THEN ALLOCATE (xas_tdp_env%ri_fxc(ri_atom, i)%array(nsgfp, nsgfp)) @@ -1368,9 +1369,9 @@ CONTAINS ! If on-diagonal quadrants only, can skip jso < iso IF (.NOT. quadrants(2) .AND. jso < iso) CYCLE - i = iso; j = jso; + i = iso; j = jso IF (my_mt) THEN - i = jso; j = iso; + i = jso; j = iso END IF ! Take the product lhs*rhs^T diff --git a/src/xas_tdp_methods.F b/src/xas_tdp_methods.F index 4b35c3fb8c..5383697020 100644 --- a/src/xas_tdp_methods.F +++ b/src/xas_tdp_methods.F @@ -800,8 +800,9 @@ CONTAINS IF (do_uks) nspins = 2 !in roks, same MOs for both spins ! by default, all (doubly occupied) homo are localized - IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) & + IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) THEN xas_tdp_control%n_search = MINVAL(homo) + END IF CALL qs_loc_control_init(qs_loc_env, loc_section, do_homo=.TRUE., do_xas=.TRUE., & nloc_xas=xas_tdp_control%n_search, spin_xas=1) @@ -2649,9 +2650,11 @@ CONTAINS DO ispin = 1, 2 CALL duplicate_mo_set(restart_mos(ispin), mos(1)) - ! Set the new occupation number in the case of spin-independent based calculation since the restart is spin-depedent - IF (SIZE(mos) == 1) & + ! Set the new occupation number in the case of spin-independent based calculation + ! since the restart is spin-depedent + IF (SIZE(mos) == 1) THEN restart_mos(ispin)%occupation_numbers = mos(1)%occupation_numbers/2 + END IF END DO CALL cp_fm_to_fm_submat(msource=lr_coeffs, mtarget=restart_mos(1)%mo_coeff, nrow=nao, & diff --git a/src/xas_tp_scf.F b/src/xas_tp_scf.F index cfe95963c8..6ddd2c0d29 100644 --- a/src/xas_tp_scf.F +++ b/src/xas_tp_scf.F @@ -545,8 +545,9 @@ CONTAINS END IF END DO ! istate - IF (my_state == 0) & + IF (my_state == 0) THEN CPABORT("Could not identify the core state to be excited") + END IF xas_estate = my_state CALL get_mo_set(mos(my_spin), mo_coeff=mo_coeff) CALL cp_fm_get_submatrix(mo_coeff, vecbuffer, 1, xas_estate, & diff --git a/src/xc/xc.F b/src/xc/xc.F index dde7ee5893..d7c24f7e27 100644 --- a/src/xc/xc.F +++ b/src/xc/xc.F @@ -277,7 +277,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -312,7 +312,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -349,7 +349,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -378,7 +378,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSEIF (my_rho < rho_smooth_cutoff_2) THEN + ELSE IF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -990,8 +990,9 @@ CONTAINS needs = xc_functionals_get_needs(xc_fun_section, lsd, .TRUE.) IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) & + IF (.NOT. ASSOCIATED(tau1_r)) THEN CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") + END IF ALLOCATE (v_xc_tau(nspins)) DO ispin = 1, nspins CALL pw_pool%create_pw(v_xc_tau(ispin)) @@ -2165,8 +2166,9 @@ CONTAINS END DO END IF - IF (laplace_f .AND. my_gapw) & + IF (laplace_f .AND. my_gapw) THEN CPABORT("Laplace-dependent functional not implemented with GAPW!") + END IF IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) CALL allocate_pw(virial_pw, pw_pool, bo) @@ -3416,8 +3418,7 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) & - tau => tau_r + IF (PRESENT(tau_r)) tau => tau_r IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 2, & @@ -3481,8 +3482,7 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) & - tau => tau_r + IF (PRESENT(tau_r)) tau => tau_r my_do_sf = .FALSE. IF (PRESENT(do_sf)) my_do_sf = do_sf @@ -3590,8 +3590,9 @@ CONTAINS CPABORT("Normalization of derivative requires any of norm_drhob or drhob!") END IF CASE (deriv_rho, deriv_tau, deriv_laplace_rho) - IF (lsd) & + IF (lsd) THEN CPABORT(TRIM(id_to_desc(split_desc(idesc)))//" not handled in lsd!'") + END IF CASE (deriv_rhoa, deriv_rhob, deriv_tau_a, deriv_tau_b, deriv_laplace_rhoa, deriv_laplace_rhob) CASE default CPABORT("Unknown derivative id") diff --git a/src/xc/xc_derivative_set_types.F b/src/xc/xc_derivative_set_types.F index a7227a7135..3c696c4fbe 100644 --- a/src/xc/xc_derivative_set_types.F +++ b/src/xc/xc_derivative_set_types.F @@ -121,8 +121,9 @@ CONTAINS derivative_set%pw_pool => pw_pool CALL pw_pool%retain() IF (PRESENT(local_bounds)) THEN - IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) & + IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) THEN CPABORT("incompatible local_bounds and pw_pool") + END IF END IF ELSE !FM ugly hack, should be replaced by a pool only for 3d arrays diff --git a/src/xc/xc_derivatives.F b/src/xc/xc_derivatives.F index 431bb25b6e..16702c65f9 100644 --- a/src/xc/xc_derivatives.F +++ b/src/xc/xc_derivatives.F @@ -11,7 +11,9 @@ MODULE xc_derivatives USE input_section_types, ONLY: section_vals_get_subs_vals2,& section_vals_type,& section_vals_val_get - USE kinds, ONLY: dp + USE kinds, ONLY: default_string_length,& + dp + USE string_utilities, ONLY: uppercase USE xc_b97, ONLY: b97_lda_eval,& b97_lda_info,& b97_lsd_eval,& @@ -281,9 +283,14 @@ CONTAINS CALL pbe_lda_info(functional, reference, shortform, needs, max_deriv) END IF CASE ("GAUXC") - CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) - ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F - ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) + IF (gauxc_model_none_selected(functional)) THEN + CALL gauxc_model_none_xc_info(functional, lsd, reference, shortform, & + needs, max_deriv, print_warn) + ELSE + CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) + ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F + ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) + END IF CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_info(reference, shortform, needs, max_deriv) @@ -507,7 +514,11 @@ CONTAINS CALL pbe_lda_eval(rho_set, deriv_set, deriv_order, functional) END IF CASE ("GAUXC") - CPABORT(abort_message_skala) + IF (gauxc_model_none_selected(functional)) THEN + CALL gauxc_model_none_xc_eval(functional, lsd, rho_set, deriv_set, deriv_order) + ELSE + CPABORT(abort_message_skala) + END IF CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_eval(rho_set, deriv_set, deriv_order, functional) @@ -552,6 +563,155 @@ 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 933ead184a..ac52974c52 100644 --- a/src/xc/xc_functionals_utilities.F +++ b/src/xc/xc_functionals_utilities.F @@ -259,16 +259,20 @@ CONTAINS IF (m >= 2) fx(ip, 3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(ip, 4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) & + IF (m >= 0) THEN fx(ip, 1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - IF (m >= 1) & + END IF + IF (m >= 1) THEN fx(ip, 2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - IF (m >= 2) & + END IF + IF (m >= 2) THEN fx(ip, 3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - IF (m >= 3) & + END IF + IF (m >= 3) THEN fx(ip, 4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) + END IF END IF END IF END DO @@ -314,16 +318,20 @@ CONTAINS IF (m >= 2) fx(3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) & + IF (m >= 0) THEN fx(1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - IF (m >= 1) & + END IF + IF (m >= 1) THEN fx(2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - IF (m >= 2) & + END IF + IF (m >= 2) THEN fx(3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - IF (m >= 3) & + END IF + IF (m >= 3) THEN fx(4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) + END IF END IF END IF diff --git a/src/xc/xc_gauxc_cache.F b/src/xc/xc_gauxc_cache.F new file mode 100644 index 0000000000..0d83d432e7 --- /dev/null +++ b/src/xc/xc_gauxc_cache.F @@ -0,0 +1,475 @@ +!--------------------------------------------------------------------------------------------------! +! 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 3c12631d2f..2a850d6def 100644 --- a/src/xc/xc_gauxc_functional.F +++ b/src/xc/xc_gauxc_functional.F @@ -49,6 +49,9 @@ MODULE xc_gauxc_functional qs_rho_type USE qs_scf_types, ONLY: qs_scf_env_type USE string_utilities, ONLY: uppercase + USE xc_gauxc_cache, ONLY: cp_gauxc_cache_params,& + cp_gauxc_cache_type,& + gauxc_cache_init USE xc_gauxc_interface, ONLY: & cp_gauxc_basisset_type, cp_gauxc_grid_type, cp_gauxc_integrator_type, & cp_gauxc_molecule_type, cp_gauxc_status_type, cp_gauxc_xc_gradient_type, cp_gauxc_xc_type, & @@ -117,24 +120,26 @@ CONTAINS !> \brief ... !> \param dbcsr_mat ... !> \param dense_mat ... +!> \param para_env ... ! ************************************************************************************************** - SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat) - USE cp_dbcsr_api, ONLY: dbcsr_get_info, dbcsr_get_matrix_type, dbcsr_iterator_type, & - dbcsr_iterator_start, dbcsr_iterator_next_block, dbcsr_iterator_blocks_left, & - dbcsr_iterator_stop, dbcsr_type_antisymmetric, dbcsr_type_symmetric + SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat, para_env) + USE cp_dbcsr_api, ONLY: dbcsr_distribution_get, dbcsr_distribution_type, dbcsr_get_info, & + dbcsr_get_matrix_type, dbcsr_get_readonly_block_p, & + dbcsr_get_stored_coordinates, dbcsr_type_antisymmetric, & + dbcsr_type_symmetric TYPE(dbcsr_p_type), INTENT(IN) :: dbcsr_mat REAL(c_double), ALLOCATABLE, DIMENSION(:, :), & INTENT(INOUT) :: dense_mat + TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env CHARACTER :: matrix_type - INTEGER :: col, col_end, col_start, icol, irow, & - nblkcols_total, nblkrows_total, ncols, & - nrows, row, row_end, row_start + INTEGER :: col, col_end, col_start, icol, irow, mynode, nblkcols_total, nblkrows_total, & + ncols, nrows, numnodes, owner, row, row_end, row_start INTEGER, ALLOCATABLE, DIMENSION(:) :: c_offset, r_offset INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size - LOGICAL :: transposed + LOGICAL :: found REAL(c_double), POINTER :: block(:, :) - TYPE(dbcsr_iterator_type) :: iter + TYPE(dbcsr_distribution_type) :: dist CALL dbcsr_get_info(dbcsr_mat%matrix, & row_blk_size=row_blk_size, & @@ -142,7 +147,9 @@ CONTAINS nblkrows_total=nblkrows_total, & nblkcols_total=nblkcols_total, & nfullrows_total=nrows, & - nfullcols_total=ncols) + nfullcols_total=ncols, & + distribution=dist) + CALL dbcsr_distribution_get(dist, mynode=mynode, numnodes=numnodes) matrix_type = dbcsr_get_matrix_type(dbcsr_mat%matrix) IF (.NOT. ALLOCATED(dense_mat)) THEN @@ -166,23 +173,19 @@ CONTAINS c_offset(col) = c_offset(col - 1) + col_blk_size(col - 1) END DO - CALL dbcsr_iterator_start(iter, dbcsr_mat%matrix) - DO WHILE (dbcsr_iterator_blocks_left(iter)) - CALL dbcsr_iterator_next_block(iter, irow, icol, block, transposed=transposed) - row_start = r_offset(irow) - row_end = row_start + row_blk_size(irow) - 1 - col_start = c_offset(icol) - col_end = col_start + col_blk_size(icol) - 1 - IF (transposed) THEN - dense_mat(row_start:row_end, col_start:col_end) = TRANSPOSE(block) - IF (irow /= icol) THEN - IF (matrix_type == dbcsr_type_symmetric) THEN - dense_mat(col_start:col_end, row_start:row_end) = block - ELSE IF (matrix_type == dbcsr_type_antisymmetric) THEN - dense_mat(col_start:col_end, row_start:row_end) = -block - END IF - END IF - ELSE + ! Replicated DBCSR blocks must enter the following MPI sum exactly once. + DO irow = 1, nblkrows_total + DO icol = 1, nblkcols_total + IF (numnodes == 1 .AND. para_env%num_pe > 1 .AND. para_env%mepos /= 0) CYCLE + CALL dbcsr_get_stored_coordinates(dbcsr_mat%matrix, irow, icol, owner) + IF (owner /= mynode) CYCLE + CALL dbcsr_get_readonly_block_p(matrix=dbcsr_mat%matrix, row=irow, col=icol, & + block=block, found=found) + IF (.NOT. found) CYCLE + row_start = r_offset(irow) + row_end = row_start + row_blk_size(irow) - 1 + col_start = c_offset(icol) + col_end = col_start + col_blk_size(icol) - 1 dense_mat(row_start:row_end, col_start:col_end) = block IF (irow /= icol) THEN IF (matrix_type == dbcsr_type_symmetric) THEN @@ -191,9 +194,8 @@ CONTAINS dense_mat(col_start:col_end, row_start:row_end) = -TRANSPOSE(block) END IF END IF - END IF + END DO END DO - CALL dbcsr_iterator_stop(iter) DEALLOCATE (r_offset, c_offset) @@ -572,7 +574,8 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & gauxc_status, & - mpi_comm=mp_comm_self%get_handle()) + mpi_comm=mp_comm_self%get_handle(), & + force_new_runtime=.TRUE.) CALL gauxc_check_status(gauxc_status) gauxc_integrator_fd = gauxc_create_integrator( & TRIM(xc_fun_name), & @@ -895,31 +898,36 @@ CONTAINS INTEGER, INTENT(out), OPTIONAL :: max_deriv CHARACTER(len=default_path_length) :: model_key, model_name - CHARACTER(len=default_string_length) :: xc_fun_name + CHARACTER(len=default_string_length) :: xc_fun_key, xc_fun_name LOGICAL :: native_grid CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) CALL section_vals_val_get(functional, "MODEL", c_val=model_name) CALL section_vals_val_get(functional, "NATIVE_GRID", l_val=native_grid) model_key = ADJUSTL(model_name) + xc_fun_key = ADJUSTL(xc_fun_name) CALL uppercase(model_key) + CALL uppercase(xc_fun_key) IF (PRESENT(reference)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & + TRIM(model_key) == TRIM(xc_fun_key)) THEN reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" ELSE reference = "Functional computed by GauXC Skala model "//TRIM(model_name) END IF END IF IF (PRESENT(shortform)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & + TRIM(model_key) == TRIM(xc_fun_key)) THEN shortform = "GAUXC ("//TRIM(xc_fun_name)//")" ELSE shortform = "GAUXC Skala" END IF END IF IF (PRESENT(needs)) THEN - IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "") THEN + IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "" .AND. & + TRIM(model_key) /= TRIM(xc_fun_key)) THEN IF (lsd) THEN needs%rho_spin = .TRUE. needs%drho_spin = .TRUE. @@ -961,26 +969,21 @@ CONTAINS REAL(KIND=dp), PARAMETER :: gapw_fd_gradient_dx = 1.0E-4_dp CHARACTER(len=default_path_length) :: model_key, model_name, output_path - CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, grid_key, & - grid_type, int_exec_space, lb_exec_space, lwd_kernel, pruning_key, pruning_scheme, & - radial_quadrature, skala_runtime, skala_runtime_key, xc_fun_name - INTEGER :: atom_chunk_size, batch_size, env_status, & - img, ispin, natom, nimages, nspins + CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, & + grid_key, pruning_key, skala_runtime, & + skala_runtime_key, xc_fun_key + INTEGER :: atom_chunk_size, env_status, img, ispin, & + nimages LOGICAL :: atom_chunk_size_explicit, do_kpoints, gapw_method, gapw_paw_pseudopotentials, & gapw_pseudopotentials, grid_explicit, hdf5_output, is_periodic, molecular_virial, & molecular_virial_debug, need_xc_gradient, periodic_reference, pruning_explicit, & - use_fd_gradient, use_gauxc_model, use_gradient_mpi_runtime, use_gradient_self_runtime, & - use_self_runtime, use_skala_model, write_hdf5_output - REAL(KIND=dp) :: device_runtime_fill_fraction, & - molecular_virial_debug_dx + use_skala_model, write_hdf5_output + REAL(KIND=dp) :: molecular_virial_debug_dx REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: density_scalar, density_zeta TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell - TYPE(cp_gauxc_basisset_type) :: gauxc_basis - TYPE(cp_gauxc_grid_type) :: gauxc_gradient_grid_result, & - gauxc_grid_result - TYPE(cp_gauxc_integrator_type) :: gauxc_gradient_integrator_result, gauxc_integrator_result - TYPE(cp_gauxc_molecule_type) :: gauxc_mol + TYPE(cp_gauxc_cache_params) :: params + TYPE(cp_gauxc_cache_type), POINTER :: cache TYPE(cp_gauxc_status_type) :: gauxc_status TYPE(cp_gauxc_xc_gradient_type) :: exc_grad TYPE(cp_gauxc_xc_type) :: gauxc_xc_result @@ -1023,7 +1026,7 @@ CONTAINS energy=energy, & ks_env=ks_env, & matrix_vxc=matrix_vxc, & - natom=natom, & + natom=params%natom, & atomic_kind_set=atomic_kind_set, & force=force, & para_env=para_env, & @@ -1050,7 +1053,7 @@ CONTAINS rho_ao_kp=rho_ao) nimages = dft_control%nimages - nspins = dft_control%nspins + params%nspins = dft_control%nspins is_periodic = .FALSE. IF (ASSOCIATED(cell)) is_periodic = ANY(cell%perd /= 0) @@ -1065,7 +1068,7 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "FUNCTIONAL", & - c_val=xc_fun_name) + c_val=params%xc_fun_name) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL", & @@ -1073,25 +1076,25 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "GRID", & - c_val=grid_type, & + c_val=params%grid_type, & explicit=grid_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "RADIAL_QUADRATURE", & - c_val=radial_quadrature) + c_val=params%radial_quadrature) CALL section_vals_val_get( & gauxc_functional_section, & "PRUNING_SCHEME", & - c_val=pruning_scheme, & + c_val=params%pruning_scheme, & explicit=pruning_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "BATCH_SIZE", & - i_val=batch_size) + i_val=params%batch_size) CALL section_vals_val_get( & gauxc_functional_section, & "DEVICE_RUNTIME_FILL_FRACTION", & - r_val=device_runtime_fill_fraction) + r_val=params%device_runtime_fill_fraction) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL_ATOM_CHUNK_SIZE", & @@ -1116,15 +1119,15 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "LB_EXECUTION_SPACE", & - c_val=lb_exec_space) + c_val=params%lb_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "INT_EXECUTION_SPACE", & - c_val=int_exec_space) + c_val=params%int_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "LWD_KERNEL", & - c_val=lwd_kernel) + c_val=params%lwd_kernel) CALL section_vals_val_get( & gauxc_functional_section, & "SKALA_RUNTIME", & @@ -1140,20 +1143,21 @@ CONTAINS model_key = ADJUSTL(model_name) CALL uppercase(model_key) + xc_fun_key = ADJUSTL(params%xc_fun_name) + CALL uppercase(xc_fun_key) skala_runtime_key = ADJUSTL(skala_runtime) CALL uppercase(skala_runtime_key) gradient_runtime_key = ADJUSTL(gradient_runtime) CALL uppercase(gradient_runtime_key) - use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") + params%use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & + TRIM(model_key) /= TRIM(xc_fun_key)) use_skala_model = (INDEX(TRIM(model_key), "SKALA") > 0) - IF (gapw_pseudopotentials .AND. .NOT. use_gauxc_model) THEN - CALL cp_abort(__LOCATION__, & - "GauXC with METHOD GAPW/GAPW_XC and pseudopotentials is supported only for "// & - "Skala-style models that replace the molecular XC term. "// & - "Use POTENTIAL ALL for local/semi-local GauXC GAPW validation or METHOD GPW "// & - "with pseudopotentials.") + params%model_eval_name = model_name + IF (.NOT. params%use_gauxc_model) THEN + ! MODEL NONE and MODEL equal to FUNCTIONAL select conventional GauXC. + params%model_eval_name = "NONE" END IF - IF (gapw_pseudopotentials .AND. use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & + IF (gapw_pseudopotentials .AND. params%use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & .NOT. gapw_paw_pseudopotentials .AND. para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1163,7 +1167,7 @@ CONTAINS "XC correction is used for those regular-grid kinds.") END IF END IF - IF (device_runtime_fill_fraction <= 0.0_dp .OR. device_runtime_fill_fraction > 1.0_dp) THEN + IF (params%device_runtime_fill_fraction <= 0.0_dp .OR. params%device_runtime_fill_fraction > 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "GAUXC%DEVICE_RUNTIME_FILL_FRACTION must be > 0 and <= 1.") END IF @@ -1191,21 +1195,21 @@ CONTAINS END IF END IF END IF - IF (use_gauxc_model) THEN + IF (params%use_gauxc_model) THEN IF (has_nlcc(qs_kind_set)) THEN CALL cp_abort(__LOCATION__, & "GauXC Skala with NLCC pseudopotentials is not implemented. "// & "The frozen core density would need a SKALA-consistent feature definition.") END IF END IF - IF (use_gauxc_model) THEN + IF (params%use_gauxc_model) THEN CALL set_gauxc_model_atom_chunk_env( & atom_chunk_size, atom_chunk_size_explicit) - IF (.NOT. grid_explicit) grid_type = "SUPERFINE" - IF (.NOT. pruning_explicit) pruning_scheme = "UNPRUNED" + IF (.NOT. grid_explicit) params%grid_type = "SUPERFINE" + IF (.NOT. pruning_explicit) params%pruning_scheme = "UNPRUNED" - grid_key = ADJUSTL(grid_type) - pruning_key = ADJUSTL(pruning_scheme) + grid_key = ADJUSTL(params%grid_type) + pruning_key = ADJUSTL(params%pruning_scheme) CALL uppercase(grid_key) CALL uppercase(pruning_key) IF (use_skala_model .AND. need_xc_gradient .AND. & @@ -1220,35 +1224,36 @@ CONTAINS IF (env_status /= 0 .OR. LEN_TRIM(model_name) == 0) THEN CPABORT("MODEL SKALA requires the GAUXC_SKALA_MODEL environment variable") END IF + params%model_eval_name = model_name END IF END IF SELECT CASE (TRIM(skala_runtime_key)) CASE ("AUTO") - use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. nspins > 1 + params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. params%nspins > 1 CASE ("MPI") - use_self_runtime = .FALSE. + params%use_self_runtime = .FALSE. CASE ("SELF") - use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 + params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%SKALA_RUNTIME value.") END SELECT - IF (.NOT. use_skala_model) use_self_runtime = .FALSE. + IF (.NOT. use_skala_model) params%use_self_runtime = .FALSE. SELECT CASE (TRIM(gradient_runtime_key)) CASE ("AUTO", "SELF") - use_gradient_mpi_runtime = .FALSE. - use_gradient_self_runtime = need_xc_gradient .AND. use_gauxc_model .AND. & - para_env%num_pe > 1 .AND. .NOT. use_self_runtime + params%use_gradient_mpi_runtime = .FALSE. + params%use_gradient_self_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. & + para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime CASE ("MPI") - use_gradient_mpi_runtime = need_xc_gradient .AND. use_gauxc_model .AND. para_env%num_pe > 1 - use_gradient_self_runtime = .FALSE. + params%use_gradient_mpi_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. para_env%num_pe > 1 + params%use_gradient_self_runtime = .FALSE. CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%MODEL_GRADIENT_RUNTIME value.") END SELECT - IF (.NOT. use_gauxc_model) THEN - use_gradient_mpi_runtime = .FALSE. - use_gradient_self_runtime = .FALSE. + IF (.NOT. params%use_gauxc_model) THEN + params%use_gradient_mpi_runtime = .FALSE. + params%use_gradient_self_runtime = .FALSE. END IF - IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. use_self_runtime .AND. & + IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime .AND. & para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1259,15 +1264,19 @@ CONTAINS END IF END IF - gauxc_mol = gauxc_create_molecule( & - particle_set, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) - gauxc_basis = gauxc_create_basisset( & - qs_kind_set, & - particle_set, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) + ! After creating the basisset, we will have to check max_l>3 as a further condition + params%use_fd_gradient = gapw_method .AND. need_xc_gradient + + 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) + hdf5_output = (TRIM(output_path) /= "") write_hdf5_output = hdf5_output .AND. para_env%mepos == 0 IF (write_hdf5_output .AND. ASSOCIATED(scf_env)) THEN @@ -1275,98 +1284,20 @@ CONTAINS END IF IF (write_hdf5_output) THEN CALL gauxc_write_molecule_hdf5( & - gauxc_mol, & + cache%molecule, & output_path, & "molecule.h5", & "molecule", & gauxc_status) CALL gauxc_check_status(gauxc_status) CALL gauxc_write_basisset_hdf5( & - gauxc_basis, & + cache%basisset, & output_path, & "basisset.h5", & "basisset", & gauxc_status) CALL gauxc_check_status(gauxc_status) END IF - use_fd_gradient = gapw_method .AND. need_xc_gradient .AND. (gauxc_basis%max_l > 3) - IF (use_fd_gradient) use_gradient_mpi_runtime = .FALSE. - IF (use_gradient_mpi_runtime) THEN - use_gradient_self_runtime = .FALSE. - END IF - IF (use_fd_gradient .AND. para_env%mepos == 0) THEN - CALL cp_warn( & - __LOCATION__, & - "Using finite-difference GauXC XC gradients for METHOD GAPW/GAPW_XC with "// & - "basis functions beyond f shells. The upstream analytical GauXC gradient path is "// & - "not yet reliable for this case.") - END IF - IF (use_self_runtime) THEN - ! SKALA currently needs a replicated molecular runtime for reproducible - ! open-shell densities across CP2K MPI ranks. - gauxc_grid_result = gauxc_create_grid( & - gauxc_mol, & - gauxc_basis, & - grid_type, & - radial_quadrature, & - pruning_scheme, & - lb_exec_space, & - batch_size, & - device_runtime_fill_fraction, & - gauxc_status, & - mpi_comm=mp_comm_self%get_handle()) - ELSE - ! Use the QS force-evaluation communicator rather than GauXC's global - ! runtime. In mixed CDFT the diabatic states can be built on disjoint - ! MPI subgroups; using the global communicator would make GauXC wait - ! for ranks that are working on another state. - gauxc_grid_result = gauxc_create_grid( & - gauxc_mol, & - gauxc_basis, & - grid_type, & - radial_quadrature, & - pruning_scheme, & - lb_exec_space, & - batch_size, & - device_runtime_fill_fraction, & - gauxc_status, & - mpi_comm=para_env%get_handle()) - END IF - CALL gauxc_check_status(gauxc_status) - gauxc_integrator_result = gauxc_create_integrator( & - TRIM(xc_fun_name), & - gauxc_grid_result, & - int_exec_space, & - lwd_kernel, & - nspins, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) - - IF (use_gradient_self_runtime) THEN - ! Upstream GauXC does not yet support Skala nuclear gradients - ! on an MPI runtime. Keep the energy/VXC path on the normal MPI - ! runtime and use an isolated runtime only for the replicated gradient. - gauxc_gradient_grid_result = gauxc_create_grid( & - gauxc_mol, & - gauxc_basis, & - grid_type, & - radial_quadrature, & - pruning_scheme, & - lb_exec_space, & - batch_size, & - device_runtime_fill_fraction, & - gauxc_status, & - mpi_comm=mp_comm_self%get_handle()) - CALL gauxc_check_status(gauxc_status) - gauxc_gradient_integrator_result = gauxc_create_integrator( & - TRIM(xc_fun_name), & - gauxc_gradient_grid_result, & - int_exec_space, & - lwd_kernel, & - nspins, & - gauxc_status) - CALL gauxc_check_status(gauxc_status) - END IF IF (qs_env%run_rtp) THEN CPABORT("GAUXC XC energy currently does not support real-time propagation") @@ -1375,46 +1306,46 @@ CONTAINS energy%exc = 0 IF (ASSOCIATED(matrix_vxc)) CALL dbcsr_deallocate_matrix_set(matrix_vxc) - CALL dbcsr_allocate_matrix_set(matrix_vxc, nspins) + CALL dbcsr_allocate_matrix_set(matrix_vxc, params%nspins) DO img = 1, nimages IF (img > 1) THEN CPABORT("UNIMPLEMENTED: Handling nimg>1 in k-point integration") END IF - CALL dbcsr_to_dense(rho_ao(1, img), density_scalar) + CALL dbcsr_to_dense(rho_ao(1, img), density_scalar, para_env) CALL para_env%sum(density_scalar) - IF (nspins == 1) THEN + IF (params%nspins == 1) THEN gauxc_xc_result = gauxc_compute_xc( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & - nspins=nspins, & + nspins=params%nspins, & status=gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (use_fd_gradient) THEN + IF (params%use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, nspins, model_name, & - xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & + params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad) - ELSE IF (use_gradient_self_runtime) THEN + ELSE IF (params%use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - gauxc_gradient_integrator_result, & + cache%gradient_integrator, & density_scalar, & - nspins=nspins, & - natom=natom, & + nspins=params%nspins, & + natom=params%natom, & status=gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & - nspins=nspins, & - natom=natom, & + nspins=params%nspins, & + natom=params%natom, & status=gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1429,19 +1360,19 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & - model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & + params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) END IF DEALLOCATE (exc_grad%exc_grad) END IF ELSE - CPASSERT(nspins == 2) + CPASSERT(params%nspins == 2) ! In here: ! scalar <- rho_ao(1, :) + rho_ao(2, :) ! zeta <- rho_ao(1, :) - rho_ao(2, :) - CALL dbcsr_to_dense(rho_ao(2, img), density_zeta) + CALL dbcsr_to_dense(rho_ao(2, img), density_zeta, para_env) CALL para_env%sum(density_zeta) ! Do NOT reorder the following lines! density_scalar(:, :) = density_scalar(:, :) + density_zeta(:, :) @@ -1451,39 +1382,39 @@ CONTAINS ! This style lowers memory footprint. density_zeta(:, :) = density_scalar(:, :) - 2.0_dp*density_zeta(:, :) gauxc_xc_result = gauxc_compute_xc( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & density_zeta, & - nspins, & + params%nspins, & gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (use_fd_gradient) THEN + IF (params%use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, nspins, model_name, & - xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & + params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad, density_zeta=density_zeta) - ELSE IF (use_gradient_self_runtime) THEN + ELSE IF (params%use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - gauxc_gradient_integrator_result, & + cache%gradient_integrator, & density_scalar, & density_zeta, & - nspins, & - natom, & + params%nspins, & + params%natom, & gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - gauxc_integrator_result, & + cache%integrator, & density_scalar, & density_zeta, & - nspins, & - natom, & + params%nspins, & + params%natom, & gauxc_status, & - model=TRIM(model_name)) + model=TRIM(params%model_eval_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1498,10 +1429,10 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & - model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & - lb_exec_space, int_exec_space, lwd_kernel, batch_size, & - device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & + params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & + params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & + params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & density_zeta=density_zeta) END IF DEALLOCATE (exc_grad%exc_grad) @@ -1510,14 +1441,14 @@ CONTAINS energy%exc = energy%exc + gauxc_xc_result%exc - IF (nspins == 1) THEN + IF (params%nspins == 1) THEN IF (img == 1) THEN matrix_vxc(1) = dense_to_dbcsr(gauxc_xc_result%vxc_scalar, rho_ao(1, img)) ELSE CPABORT("UNIMPLEMENTED: Handling multiple result matrices in k-point integration") END IF ELSE - CPASSERT(nspins == 2) + CPASSERT(params%nspins == 2) ! Transform derivatives from total/spin density back to alpha/beta channels. vxc_zeta_tmp = dense_to_dbcsr(gauxc_xc_result%vxc_zeta, rho_ao(1, img)) IF (img == 1) THEN @@ -1544,25 +1475,10 @@ CONTAINS IF (ALLOCATED(gauxc_xc_result%vxc_zeta)) DEALLOCATE (gauxc_xc_result%vxc_zeta) CALL set_ks_env(ks_env, matrix_vxc=matrix_vxc) - DO ispin = 1, nspins + DO ispin = 1, params%nspins CALL dbcsr_finalize(matrix_vxc(ispin)%matrix) END DO - IF (use_gradient_self_runtime) THEN - CALL gauxc_destroy_integrator(gauxc_gradient_integrator_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_grid(gauxc_gradient_grid_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - END IF - CALL gauxc_destroy_integrator(gauxc_integrator_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_grid(gauxc_grid_result, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_basisset(gauxc_basis, gauxc_status) - CALL gauxc_check_status(gauxc_status) - CALL gauxc_destroy_molecule(gauxc_mol, gauxc_status) - CALL gauxc_check_status(gauxc_status) - END SUBROUTINE apply_gauxc END MODULE xc_gauxc_functional diff --git a/src/xc/xc_gauxc_interface.F b/src/xc/xc_gauxc_interface.F index ed1356ebde..e79a8fdd87 100644 --- a/src/xc/xc_gauxc_interface.F +++ b/src/xc/xc_gauxc_interface.F @@ -506,6 +506,7 @@ CONTAINS !> \param device_runtime_fill_fraction ... !> \param status ... !> \param mpi_comm optional communicator for a grid-local GauXC runtime +!> \param force_new_runtime force creation of a grid-local GauXC runtime !> \return ... ! ************************************************************************************************** FUNCTION gauxc_create_grid( & @@ -518,7 +519,8 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & status, & - mpi_comm) RESULT(res) + mpi_comm, & + force_new_runtime) RESULT(res) TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule TYPE(cp_gauxc_basisset_type), INTENT(in) :: basis @@ -528,13 +530,14 @@ CONTAINS REAL(c_double), INTENT(IN) :: device_runtime_fill_fraction TYPE(cp_gauxc_status_type), INTENT(OUT) :: status INTEGER, INTENT(IN), OPTIONAL :: mpi_comm + LOGICAL, INTENT(IN), OPTIONAL :: force_new_runtime TYPE(cp_gauxc_grid_type) :: res #ifdef __GAUXC INTEGER(c_int) :: grid_type_local, int_exec_space_local, & lb_exec_space_local, & pruning_scheme_local, radial_quad_local - LOGICAL :: use_device_runtime + LOGICAL :: force_new_runtime_local, use_device_runtime grid_type_local = read_atomic_grid_size(grid_type) radial_quad_local = read_radial_quad(radial_quadrature) @@ -542,6 +545,8 @@ CONTAINS lb_exec_space_local = read_execution_space(lb_exec_space) int_exec_space_local = read_execution_space("host") use_device_runtime = (lb_exec_space_local == gauxc_executionspace%device) + force_new_runtime_local = .FALSE. + IF (PRESENT(force_new_runtime)) force_new_runtime_local = force_new_runtime res%owns_rt = .FALSE. IF (use_device_runtime) THEN @@ -570,7 +575,8 @@ CONTAINS IF (PRESENT(mpi_comm)) THEN ! Reuse the global runtime when the requested communicator matches ! the communicator used during gauxc_init. - IF (.NOT. rt_has_mpi_comm .OR. mpi_comm /= rt_mpi_comm) THEN + IF (force_new_runtime_local .OR. .NOT. rt_has_mpi_comm .OR. & + mpi_comm /= rt_mpi_comm) THEN res%rt = gauxc_runtime_environment_new(status%status, mpi_comm) GAUXC_RETURN_IF_ERROR(status) res%owns_rt = .TRUE. @@ -578,6 +584,7 @@ CONTAINS END IF #else MARK_USED(mpi_comm) + MARK_USED(force_new_runtime) #endif END IF @@ -637,6 +644,7 @@ CONTAINS MARK_USED(grid_type) MARK_USED(lb_exec_space) MARK_USED(mpi_comm) + MARK_USED(force_new_runtime) MARK_USED(molecule) MARK_USED(pruning_scheme) MARK_USED(radial_quadrature) diff --git a/src/xc/xc_libxc.F b/src/xc/xc_libxc.F index 3faed929f3..6b0340a0bf 100644 --- a/src/xc/xc_libxc.F +++ b/src/xc/xc_libxc.F @@ -307,9 +307,11 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) + SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & + func_name_override) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -317,6 +319,7 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -326,8 +329,13 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -398,6 +406,7 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & @@ -415,9 +424,11 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) + SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & + func_name_override) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -425,6 +436,7 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -434,8 +446,13 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -508,6 +525,7 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are "// & "asking for a functional of the LibXC library, "// & @@ -542,14 +560,16 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params) + SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lda_eval' @@ -574,15 +594,23 @@ CONTAINS NULLIFY (dummy) NULLIFY (rho, norm_drho, laplace_rho, tau) - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_UNPOLARIZED) xc_info = xc_f03_func_get_info(xc_func) - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + no_exc = .FALSE. + IF (.NOT. PRESENT(func_name_override)) THEN + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + END IF CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rho=rho, norm_drho=norm_drho, laplace_rho=laplace_rho, & @@ -762,6 +790,7 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & "you have to download and install the library!") @@ -777,14 +806,16 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) +!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params) + SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lsd_eval' @@ -823,15 +854,23 @@ CONTAINS NULLIFY (rhoa, rhob, norm_drho, norm_drhoa, norm_drhob, laplace_rhoa, & laplace_rhob, tau_a, tau_b) - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + IF (PRESENT(func_name_override)) THEN + func_name = func_name_override + func_scale = 1.0_dp + ELSE + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) + END IF IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_POLARIZED) xc_info = xc_f03_func_get_info(xc_func) - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + no_exc = .FALSE. + IF (.NOT. PRESENT(func_name_override)) THEN + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) + END IF CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, & @@ -1290,6 +1329,7 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) + MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & diff --git a/src/xc/xc_libxc_wrap.F b/src/xc/xc_libxc_wrap.F index b8c0ed8962..e070d9f6f3 100644 --- a/src/xc/xc_libxc_wrap.F +++ b/src/xc/xc_libxc_wrap.F @@ -105,9 +105,10 @@ MODULE xc_libxc_wrap section_release, & section_type, section_vals_type, section_vals_val_get #include "../base/base_uses.f90" - +#endif IMPLICIT NONE PRIVATE +#if defined (__LIBXC) CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xc_libxc_wrap' diff --git a/src/xc/xc_pade.F b/src/xc/xc_pade.F index 2be8e39fa3..2a2b413b26 100644 --- a/src/xc/xc_pade.F +++ b/src/xc/xc_pade.F @@ -118,8 +118,9 @@ CONTAINS END IF IF (PRESENT(needs)) THEN - IF (.NOT. PRESENT(lsd)) & + IF (.NOT. PRESENT(lsd)) THEN CPABORT("Arguments mismatch.") + END IF IF (lsd) THEN needs%rho_spin = .TRUE. ELSE diff --git a/src/xc/xc_perdew86.F b/src/xc/xc_perdew86.F index 386c1bd48e..559927a21e 100644 --- a/src/xc/xc_perdew86.F +++ b/src/xc/xc_perdew86.F @@ -36,8 +36,6 @@ MODULE xc_perdew86 PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_perdew_zunger.F b/src/xc/xc_perdew_zunger.F index eede7b4efa..c5870410fd 100644 --- a/src/xc/xc_perdew_zunger.F +++ b/src/xc/xc_perdew_zunger.F @@ -296,7 +296,7 @@ CONTAINS dummy => a e_0 => dummy - ea => dummy; + ea => dummy eaa => dummy; eab => dummy; ebb => dummy eaaa => dummy; eaab => dummy; eabb => dummy; ebbb => dummy diff --git a/src/xc/xc_rho_set_types.F b/src/xc/xc_rho_set_types.F index f44aaf8ce4..da711debed 100644 --- a/src/xc/xc_rho_set_types.F +++ b/src/xc/xc_rho_set_types.F @@ -620,8 +620,9 @@ CONTAINS do_sf = .FALSE. IF (PRESENT(spinflip)) do_sf = spinflip - IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) & + IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) THEN CPABORT("pw_pool cr3d have different size than expected") + END IF nspins = SIZE(rho_r) rho_set%local_bounds = rho_r(1)%pw_grid%bounds_local rho_cutoff = 0.5*rho_set%rho_cutoff diff --git a/src/xc/xc_tfw.F b/src/xc/xc_tfw.F index c46167a7d2..57f1d74478 100644 --- a/src/xc/xc_tfw.F +++ b/src/xc/xc_tfw.F @@ -16,6 +16,7 @@ MODULE xc_tfw USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_norm_drho,& deriv_norm_drhoa,& deriv_norm_drhob,& @@ -37,8 +38,6 @@ MODULE xc_tfw PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_thomas_fermi.F b/src/xc/xc_thomas_fermi.F index 61765ad154..32584bd0ae 100644 --- a/src/xc/xc_thomas_fermi.F +++ b/src/xc/xc_thomas_fermi.F @@ -18,6 +18,7 @@ MODULE xc_thomas_fermi USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& deriv_rhob @@ -36,8 +37,6 @@ MODULE xc_thomas_fermi PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_vwn.F b/src/xc/xc_vwn.F index 528117d098..29739a1179 100644 --- a/src/xc/xc_vwn.F +++ b/src/xc/xc_vwn.F @@ -200,13 +200,13 @@ CONTAINS CALL xc_derivative_get(deriv, deriv_data=e_rho) CALL vwn_lda_01(rho, x, e_0, e_rho, npoints, sc) - ELSEIF (order >= 0) THEN + ELSE IF (order >= 0) THEN deriv => xc_dset_get_derivative(deriv_set, [INTEGER::], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_0) CALL vwn_lda_0(rho, x, e_0, npoints, sc) - ELSEIF (order == -1) THEN + ELSE IF (order == -1) THEN deriv => xc_dset_get_derivative(deriv_set, [deriv_rho], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_rho) diff --git a/src/xc/xc_xalpha.F b/src/xc/xc_xalpha.F index 8c260959e5..e9a0912979 100644 --- a/src/xc/xc_xalpha.F +++ b/src/xc/xc_xalpha.F @@ -21,6 +21,7 @@ MODULE xc_xalpha USE input_section_types, ONLY: section_vals_type,& section_vals_val_get USE kinds, ONLY: dp + USE mathconstants, ONLY: pi USE pw_types, ONLY: pw_r3d_rs_type USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& @@ -40,8 +41,6 @@ MODULE xc_xalpha PRIVATE ! *** Global parameters *** - - REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13 diff --git a/src/xc_adiabatic_utils.F b/src/xc_adiabatic_utils.F index 7a304c6770..f50f1f790a 100644 --- a/src/xc_adiabatic_utils.F +++ b/src/xc_adiabatic_utils.F @@ -134,10 +134,11 @@ CONTAINS CASE (do_adiabatic_hybrid_mcy3) SELECT CASE (adiabatic_model) CASE (do_adiabatic_model_pade) - IF (n_rep_hf /= 2) & + IF (n_rep_hf /= 2) THEN CALL cp_abort(__LOCATION__, & "For this kind of adiababatic hybrid functional 2 HF sections have to be provided. "// & "Please check your input file.") + END IF CALL rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & adiabatic_omega, scale_dEx1, scale_ddW0, scale_dDFA, & scale_dEx2, total_energy_xc) diff --git a/src/xc_pot_saop.F b/src/xc_pot_saop.F index 186d29c5d6..2034fd550c 100644 --- a/src/xc_pot_saop.F +++ b/src/xc_pot_saop.F @@ -855,29 +855,35 @@ CONTAINS IF (lsd) THEN DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) & + IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) THEN vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rhoa(ia, ir, 1) - IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) & + END IF + IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) THEN vxc_GLLB_h(ia, ir, 2) = vxc_GLLB_h(ia, ir, 2) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 2)/rho_set_h%rhob(ia, ir, 1) - IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) & + END IF + IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) THEN vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rhoa(ia, ir, 1) - IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) & + END IF + IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) THEN vxc_GLLB_s(ia, ir, 2) = vxc_GLLB_s(ia, ir, 2) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 2)/rho_set_s%rhob(ia, ir, 1) + END IF END DO END DO ELSE DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) & + IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) THEN vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rho(ia, ir, 1) - IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) & + END IF + IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) THEN vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rho(ia, ir, 1) + END IF END DO END DO END IF diff --git a/src/xtb_coulomb.F b/src/xtb_coulomb.F index f079817d9b..a95fdcede7 100644 --- a/src/xtb_coulomb.F +++ b/src/xtb_coulomb.F @@ -709,7 +709,7 @@ CONTAINS IF (rab < 1.e-6_dp) THEN ! on site terms gmat(:, :) = eta(:, :) - ELSEIF (rab > rcut) THEN + ELSE IF (rab > rcut) THEN ! do nothing ELSE rk = rab**kg @@ -777,7 +777,7 @@ CONTAINS IF (rab < 1.e-6) THEN ! on site terms dgmat(:, :) = 0.0_dp - ELSEIF (rab > rcut) THEN + ELSE IF (rab > rcut) THEN dgmat(:, :) = 0.0_dp ELSE eta = eta**(-kg) diff --git a/src/xtb_hcore.F b/src/xtb_hcore.F index 0e182950b3..8b7565eb05 100644 --- a/src/xtb_hcore.F +++ b/src/xtb_hcore.F @@ -156,7 +156,7 @@ CONTAINS CALL get_atomic_kind(atomic_kind_set(ikind), z=za) IF (metal(za)) THEN kcnlk(0:3, ikind) = 0.0_dp - ELSEIF (early3d(za)) THEN + ELSE IF (early3d(za)) THEN kcnlk(0, ikind) = kcns kcnlk(1, ikind) = kcnp kcnlk(2, ikind) = 0.005_dp @@ -278,7 +278,7 @@ CONTAINS ELSE km = km*kdiff END IF - ELSEIF (zb == 1 .AND. nb == 2) THEN + ELSE IF (zb == 1 .AND. nb == 2) THEN km = km*kdiff END IF kijab(i, j, ikind, jkind) = km diff --git a/src/xtb_ks_matrix.F b/src/xtb_ks_matrix.F index 527f5f20b0..b9725df4fe 100644 --- a/src/xtb_ks_matrix.F +++ b/src/xtb_ks_matrix.F @@ -190,9 +190,10 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge equilibration energy: ", energy%eeq, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield @@ -441,12 +442,14 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge fluctuation energy: ", energy%hartree, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%xb_interaction) & + IF (dft_control%qs_control%xtb_control%xb_interaction) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - IF (dft_control%qs_control%xtb_control%do_nonbonded) & + "Correction for halogen bonding: ", energy%xtb_xb_inter + END IF + IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + END IF IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield diff --git a/src/xtb_parameters.F b/src/xtb_parameters.F index 0c79a46c19..67bb511bd2 100644 --- a/src/xtb_parameters.F +++ b/src/xtb_parameters.F @@ -69,9 +69,11 @@ MODULE xtb_parameters 0.98_dp, 1.57_dp, 2.04_dp, 2.55_dp, 3.04_dp, 3.44_dp, 3.98_dp, 4.50_dp, & ! 10 0.93_dp, 1.31_dp, 1.61_dp, 1.90_dp, 2.19_dp, 2.58_dp, 3.16_dp, 3.50_dp, & ! 18 0.82_dp, 1.00_dp, 1.36_dp, 1.54_dp, 1.63_dp, 1.66_dp, 1.55_dp, 1.83_dp, & - 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, 2.96_dp, 3.00_dp, & ! 36 + 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, & + 2.96_dp, 3.00_dp, & ! 36 0.82_dp, 0.95_dp, 1.22_dp, 1.33_dp, 1.60_dp, 2.16_dp, 1.90_dp, 2.20_dp, & - 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, 2.66_dp, 2.60_dp, & ! 54 + 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, & + 2.66_dp, 2.60_dp, & ! 54 0.79_dp, 0.89_dp, 1.10_dp, & 1.12_dp, 1.13_dp, 1.14_dp, 1.15_dp, 1.17_dp, 1.18_dp, 1.20_dp, 1.21_dp, & 1.22_dp, 1.23_dp, 1.24_dp, 1.25_dp, 1.26_dp, 1.27_dp, & ! Lanthanides @@ -116,9 +118,11 @@ MODULE xtb_parameters 1.30_dp, 0.99_dp, 0.84_dp, 0.75_dp, 0.71_dp, 0.64_dp, 0.60_dp, 0.62_dp, & ! 10 1.60_dp, 1.40_dp, 1.24_dp, 1.14_dp, 1.09_dp, 1.04_dp, 1.00_dp, 1.01_dp, & ! 18 2.00_dp, 1.74_dp, 1.59_dp, 1.48_dp, 1.44_dp, 1.30_dp, 1.29_dp, 1.24_dp, & - 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, 1.17_dp, 1.16_dp, & ! 36 + 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, & + 1.17_dp, 1.16_dp, & ! 36 2.15_dp, 1.90_dp, 1.76_dp, 1.64_dp, 1.56_dp, 1.46_dp, 1.38_dp, 1.36_dp, & - 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, 1.36_dp, 1.36_dp, & ! 54 + 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, & + 1.36_dp, 1.36_dp, & ! 54 2.38_dp, 2.06_dp, 1.94_dp, & 1.84_dp, 1.90_dp, 1.88_dp, 1.86_dp, 1.85_dp, 1.83_dp, 1.82_dp, 1.81_dp, & 1.80_dp, 1.79_dp, 1.77_dp, 1.77_dp, 1.78_dp, 1.74_dp, & ! Lanthanides @@ -138,9 +142,11 @@ MODULE xtb_parameters 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 10 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 18 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 36 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & + 1.25_dp, 1.00_dp, & ! 36 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 54 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & + 1.25_dp, 1.00_dp, & ! 54 1.05_dp, 2.05_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & ! Lanthanides @@ -646,14 +652,14 @@ CONTAINS CASE (78) kab = 0.80_dp END SELECT - ELSEIF (za == 5 .OR. zb == 5) THEN + ELSE IF (za == 5 .OR. zb == 5) THEN ! Boron z = za + zb - 5 SELECT CASE (z) CASE (15) kab = 0.97_dp END SELECT - ELSEIF (za == 7 .OR. zb == 7) THEN + ELSE IF (za == 7 .OR. zb == 7) THEN ! Nitrogen z = za + zb - 7 SELECT CASE (z) @@ -662,21 +668,21 @@ CONTAINS ! in the paper this is Kab for B-Si kab = 1.01_dp END SELECT - ELSEIF (za > 20 .AND. za < 30) THEN + ELSE IF (za > 20 .AND. za < 30) THEN ! 3d IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 1.10_dp - ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 0.50_dp*(1.20_dp + 1.10_dp) END IF - ELSEIF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN + ELSE IF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN ! 4d/5d/4f IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 0.50_dp*(1.20_dp + 1.10_dp) - ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 1.20_dp END IF diff --git a/src/xtb_potentials.F b/src/xtb_potentials.F index 36028812aa..07dab22561 100644 --- a/src/xtb_potentials.F +++ b/src/xtb_potentials.F @@ -807,10 +807,11 @@ CONTAINS ((name_atm_a) == (nonbonded%pot(ingp)%pot%at2)))) THEN CALL pair_potential_single_copy(nonbonded%pot(ingp)%pot, pot) ! multiple potential not implemented, simply overwriting - IF (found) & + IF (found) THEN CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") + END IF !IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. END IF diff --git a/src/xtb_types.F b/src/xtb_types.F index 51240aabdf..9ec859eae6 100644 --- a/src/xtb_types.F +++ b/src/xtb_types.F @@ -99,8 +99,9 @@ CONTAINS TYPE(xtb_atom_type), POINTER :: xtb_parameter - IF (ASSOCIATED(xtb_parameter)) & + IF (ASSOCIATED(xtb_parameter)) THEN CALL deallocate_xtb_atom_param(xtb_parameter) + END IF ALLOCATE (xtb_parameter) diff --git a/tests/Fist/regtest-mace/TEST_FILES.toml b/tests/Fist/regtest-mace/TEST_FILES.toml new file mode 100644 index 0000000000..4e86987486 --- /dev/null +++ b/tests/Fist/regtest-mace/TEST_FILES.toml @@ -0,0 +1,3 @@ +# Test of MACE using libtorch https://pytorch.org/cppdocs/installing.html +"mace_test.inp" = [{matcher="M011", tol=1.0E-9, ref=-1532.363300232407482}] +#EOF \ No newline at end of file diff --git a/tests/Fist/regtest-mace/mace-test.xyz b/tests/Fist/regtest-mace/mace-test.xyz new file mode 100644 index 0000000000..de5d503ae3 --- /dev/null +++ b/tests/Fist/regtest-mace/mace-test.xyz @@ -0,0 +1,34 @@ +32 +Lattice="7.23 0.0 0.0 0.0 7.23 0.0 0.0 0.0 7.23" Properties=species:S:1:pos:R:3 pbc="T T T" +Cu 7.19929385 0.07184150 7.15208419 +Cu 7.14664045 2.10236709 2.01651087 +Cu 1.82143618 0.04226192 1.92285339 +Cu 1.99446521 1.95857840 7.03556683 +Cu 0.04124875 0.03433693 3.81793753 +Cu 0.13296440 1.50725440 5.36672362 +Cu 2.05785380 7.16421454 5.34153878 +Cu 1.87904775 2.29484159 3.46181587 +Cu 7.14343690 3.63361819 0.04539203 +Cu 0.07856581 5.42264104 2.00907147 +Cu 1.70046840 3.49032697 1.45196525 +Cu 1.52838588 5.29338639 0.08402179 +Cu 7.04010983 3.63297407 3.45547313 +Cu 0.04993241 5.06858718 5.39256856 +Cu 1.57620067 3.46938961 5.22644546 +Cu 1.85045246 5.47919762 3.50191702 +Cu 3.66469285 0.20246133 0.01048150 +Cu 3.65200112 1.80572076 1.95822174 +Cu 5.62157919 7.09211077 1.57513403 +Cu 5.42582769 1.92125447 7.13092135 +Cu 3.74438701 7.22849521 3.62250140 +Cu 3.71553234 1.93544475 5.27911967 +Cu 5.41897600 6.88436492 5.32462967 +Cu 5.23975470 1.60760854 3.77619340 +Cu 3.72354623 3.71850028 0.15023152 +Cu 3.53953689 5.32915887 1.66932471 +Cu 5.31356798 3.64843433 1.81519742 +Cu 5.24884208 5.54500604 0.06504144 +Cu 3.76661054 3.88873128 3.46537226 +Cu 3.74258866 5.40276336 5.55936212 +Cu 5.45073160 3.94041922 5.40526077 +Cu 5.72305460 5.42694152 3.73428797 diff --git a/tests/Fist/regtest-mace/mace_test.inp b/tests/Fist/regtest-mace/mace_test.inp new file mode 100644 index 0000000000..feabc680c5 --- /dev/null +++ b/tests/Fist/regtest-mace/mace_test.inp @@ -0,0 +1,41 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT mace_test + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD FIST + #STRESS_TENSOR ANALYTICAL + &MM + &FORCEFIELD + &NONBONDED + &MACE + ATOMS Cu + POT_FILE_NAME MACE/MACE_scratch_run-3.model-cp2k.pth + &END MACE + &END NONBONDED + &END FORCEFIELD + &POISSON + &EWALD + EWALD_TYPE none + &END EWALD + &END POISSON + &END MM + &PRINT + &FORCES ON + &END FORCES + #&STRESS_TENSOR ON + #&END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + CELL_FILE_FORMAT XYZ + CELL_FILE_NAME ./mace-test.xyz + &END CELL + &TOPOLOGY + COORD_FILE_FORMAT XYZ + COORD_FILE_NAME ./mace-test.xyz + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md index c7e9b8747a..b369135c48 100644 --- a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md +++ b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md @@ -20,6 +20,8 @@ used to move towards making accurate XC integration the GAPW default in a future | DC-DFT/Energy Correction | `regtest-acc-2/HF-ec1.inp`, `HF-ec2.inp`, `HF-ec3.inp` | `HF-ec4.inp`, `HF-ec5.inp`, `HF-ec6.inp`, and `HF-ec7.inp` now also use explicit accurate integration | | TDDFPT forces | `regtest-acc-5/h2o_f01.inp` | `regtest-acc-5/h2o_f01_fine.inp` | | ADMM-GAPW TDDFPT response | `regtest-acc-5/ft3.inp` | `regtest-acc-5/ft3_fine.inp` | +| UZH basis/potential data | all-electron UZH HF force-debug tests in `regtest-acc-1` | GAPW all-electron and GAPW/GAPW_XC GTH finite-difference force and stress checks with `BASIS_MOLOPT_UZH` and `POTENTIAL_UZH` | +| def2-ECP data | def2-SVP ECP GAPW energy checks in `regtest-ecp` and `regtest-ecp-2` | GAPW mixed all-electron/ECP and GAPW_XC ECP-only finite-difference force and stress checks | | XAS/RT response | XAS_TDP and RTBSE coverage in `regtest-xastdp` and `regtest-rtbse` | open-shell GAPW XAS_TDP and GAPW RTBSE smoke tests in `regtest-acc-3` | | KG embedding | existing `regtest-kg` GPW cases | GAPW/GAPW_XC energy and stress checks for libxc KG, meta-GGA/tau KG, and RI embedding | | KG atomic potential | `regtest-kg/H2_KG-1.inp` | GAPW/GAPW_XC energy and stress checks for `TNADD_METHOD ATOMIC` | @@ -55,6 +57,16 @@ Finite-difference checks with `STOP_ON_MISMATCH` are included for: is kept diagonal in the targeted debug tests above. - GAPW_XC forces and diagonal stress: `regtest-acc-1/h2o-gapw_xc-force-1.inp`, `regtest-acc-1/h2o-gapw_xc-stress-debug-1.inp`. +- UZH all-electron GAPW forces and analytical stress smoke: + `regtest-acc-1/h2o-uzh-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp`. +- UZH GTH GAPW/GAPW_XC forces and analytical stress smoke: + `regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp`, + `regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp`, and + `regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp`. +- ECP GAPW/GAPW_XC targeted force and analytical stress smoke checks: + `regtest-ecp/ICl_lanl2dz_gapw_force.inp`, `ICl_lanl2dz_gapw_stress.inp`, + `ICl_lanl2dz_gapw_xc_force.inp`, and `ICl_lanl2dz_gapw_xc_stress.inp`; the def2-ECP energy path + remains covered by `regtest-ecp/SbH3_def2_gapw.inp`. - ADMM-GAPW forces: `regtest-acc-1/HF-d5.inp`, `regtest-acc-5/ft3_fine.inp`. - ADMM-GAPW diagonal stress: `regtest-acc-2/h2o-admm-gapw-stress-debug-1.inp`, `regtest-acc-2/h2o-admm-gapw-pbe-stress-debug-1.inp`. diff --git a/tests/QS/regtest-acc-1/TEST_FILES.toml b/tests/QS/regtest-acc-1/TEST_FILES.toml index 41e4817c71..d26801d538 100644 --- a/tests/QS/regtest-acc-1/TEST_FILES.toml +++ b/tests/QS/regtest-acc-1/TEST_FILES.toml @@ -36,4 +36,10 @@ "h2o-gapw_xc-stress-debug-1.inp" = [] "h2o-gapw_xc-full-stress-1.inp" = [{matcher="M011", tol=1e-08, ref=-17.256333793570239}, {matcher="M031", tol=1e-08, ref=3.91898639036E+03}] +"h2o-uzh-gapw-force-1.inp" = [] +"h2o-uzh-gapw-stress-debug-1.inp" = [] +"h2o-uzh-gth-gapw-force-1.inp" = [] +"h2o-uzh-gth-gapw-stress-debug-1.inp" = [] +"h2o-uzh-gth-gapw_xc-force-1.inp" = [] +"h2o-uzh-gth-gapw_xc-stress-debug-1.inp" = [] #EOF diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp new file mode 100644 index 0000000000..9e6684b46a --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp @@ -0,0 +1,63 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gapw-force-1 + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &KIND O + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp new file mode 100644 index 0000000000..920bbbf7a1 --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp @@ -0,0 +1,60 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gapw-stress-debug-1 + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &KIND O + BASIS_SET SVP-MOLOPT-PBE-ae + POTENTIAL ALL + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp new file mode 100644 index 0000000000..924f9670d2 --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp @@ -0,0 +1,67 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw-force-1 + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp new file mode 100644 index 0000000000..3c80d1546e --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp @@ -0,0 +1,64 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw-stress-debug-1 + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp new file mode 100644 index 0000000000..412457eafe --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp @@ -0,0 +1,69 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw_xc-force-1 + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp new file mode 100644 index 0000000000..5bceffa537 --- /dev/null +++ b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp @@ -0,0 +1,66 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT h2o-uzh-gth-gapw_xc-stress-debug-1 + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH + POTENTIAL_FILE_NAME POTENTIAL_UZH + &MGRID + CUTOFF 240 + NGRIDS 5 + REL_CUTOFF 40 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-10 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + O 0.110000 0.170000 -0.045587 + H 0.260000 -0.627136 0.570545 + H -0.180000 0.897136 0.440545 + &END COORD + &KIND H + BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q1 + RADIAL_GRID 50 + &END KIND + &KIND O + BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 + LEBEDEV_GRID 50 + POTENTIAL GTH-PBE-q6 + RADIAL_GRID 50 + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-admm-libxc/TEST_FILES.toml b/tests/QS/regtest-admm-libxc/TEST_FILES.toml index 640bfb052e..548bfe1fbe 100644 --- a/tests/QS/regtest-admm-libxc/TEST_FILES.toml +++ b/tests/QS/regtest-admm-libxc/TEST_FILES.toml @@ -2,8 +2,8 @@ "H2O-BP-OPTX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.173082884557527}] "H2O-BP-BECKEX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172192115148068}] "H2O-BP-Coul.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172925552133442}] -"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689018060}] +"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689027640}] "H2O-BP-lr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.689871565334784}] -"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754585429}] -"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992387993}] +"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754561230}] +"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992363387}] #EOF diff --git a/tests/QS/regtest-debug-3/TEST_FILES.toml b/tests/QS/regtest-debug-3/TEST_FILES.toml index f5340fcf68..150a32d80b 100644 --- a/tests/QS/regtest-debug-3/TEST_FILES.toml +++ b/tests/QS/regtest-debug-3/TEST_FILES.toml @@ -6,8 +6,8 @@ "h2o_pbe0.inp" = [{matcher="M060", tol=1e-05, ref=0.411901963703}] "h2o_pbe0_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.426369189904}] # -"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.436263865396}] -"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.381688458912}] +"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.445432754543}] +"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.442023635799}] #h2o_B88_mixcl.inp functional B88_LR 60 1e-05 0.000000000000E+00 #h2o_B88_mixcl_admm.inp functional B88_LR 60 1e-05 0.000000000000E+00 "h2o_pbe0TC.inp" = [{matcher="M060", tol=1e-05, ref=0.430192264863}] diff --git a/tests/QS/regtest-debug-3/h2o_HSE06.inp b/tests/QS/regtest-debug-3/h2o_HSE06.inp index 8330db4771..c57938acb0 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06.inp @@ -21,7 +21,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 + CUTOFF 150 &END MGRID &PRINT &MOMENTS ON @@ -80,7 +80,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 5.0 5.0 5.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp index a96d0a06ff..c46674b366 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp @@ -28,7 +28,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 200 + CUTOFF 150 &END MGRID &PRINT &MOMENTS ON @@ -87,7 +87,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 5.0 5.0 5.0 + ABC [angstrom] 4.0 4.0 4.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp new file mode 100644 index 0000000000..35a8618cc7 --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp @@ -0,0 +1,62 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_force + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp new file mode 100644 index 0000000000..aa73463cd3 --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp @@ -0,0 +1,59 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_stress + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + GAPW_ACCURATE_XCINT T + METHOD GAPW + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 5.0 0.0 0.0 + B 0.25 5.1 0.0 + C 0.15 0.35 5.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp new file mode 100644 index 0000000000..a1fd01ce1e --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp @@ -0,0 +1,64 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_xc_force + RUN_TYPE DEBUG +&END GLOBAL + +&DEBUG + CHECK_ATOM_FORCE 1 x + DEBUG_FORCES T + DEBUG_STRESS_TENSOR F + DX 0.0005 + MAX_RELATIVE_ERROR 0.10 + STOP_ON_MISMATCH T +&END DEBUG + +&FORCE_EVAL + METHOD Quickstep + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &SUBSYS + &CELL + A 6.0 0.0 0.0 + B 0.25 6.1 0.0 + C 0.15 0.35 6.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp new file mode 100644 index 0000000000..b94b1a47a1 --- /dev/null +++ b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp @@ -0,0 +1,61 @@ +&GLOBAL + PRINT_LEVEL LOW + PROJECT ICl_lanl2dz_gapw_xc_stress + RUN_TYPE ENERGY_FORCE +&END GLOBAL + +&FORCE_EVAL + METHOD Quickstep + STRESS_TENSOR ANALYTICAL + &DFT + BASIS_SET_FILE_NAME ./ECP_BASIS_POT + POTENTIAL_FILE_NAME ./ECP_BASIS_POT + &MGRID + CUTOFF 160 + NGRIDS 4 + REL_CUTOFF 30 + &END MGRID + &QS + ALPHA_WEIGHTS 6.5 + EPS_DEFAULT 1.0E-9 + FORCE_PAW + GAPW_1C_BASIS EXT_SMALL + GAPW_ACCURATE_XCINT T + METHOD GAPW_XC + &END QS + &SCF + EPS_SCF 1.0E-7 + MAX_SCF 80 + SCF_GUESS ATOMIC + &END SCF + &XC + DENSITY_CUTOFF 1.0E-11 + &XC_FUNCTIONAL PBE + &END XC_FUNCTIONAL + &END XC + &END DFT + &PRINT + &STRESS_TENSOR + COMPONENTS + &END STRESS_TENSOR + &END PRINT + &SUBSYS + &CELL + A 6.0 0.0 0.0 + B 0.25 6.1 0.0 + C 0.15 0.35 6.2 + &END CELL + &COORD + Cl 0.000000 0.000000 0.000000 + I 0.250000 0.100000 2.490000 + &END COORD + &KIND Cl + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &KIND I + BASIS_SET LANL2DZ + POTENTIAL ECP LANL2DZ_ECP + &END KIND + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/TEST_FILES.toml b/tests/QS/regtest-ecp/TEST_FILES.toml index 77e7b87d8e..914bf20fb4 100644 --- a/tests/QS/regtest-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-ecp/TEST_FILES.toml @@ -3,3 +3,7 @@ "SbH3_def2_gapw.inp" = [{matcher="M011", tol=1.0E-11, ref=-241.414769303399083}] "HCl_ccECP.inp" = [{matcher="M011", tol=1.0E-12, ref=-15.457709431781252}] "HCl_force.inp" = [] +"ICl_lanl2dz_gapw_force.inp" = [] +"ICl_lanl2dz_gapw_stress.inp" = [] +"ICl_lanl2dz_gapw_xc_force.inp" = [] +"ICl_lanl2dz_gapw_xc_stress.inp" = [] diff --git a/tests/QS/regtest-gauxc-api/TEST_FILES.toml b/tests/QS/regtest-gauxc-api/TEST_FILES.toml index c03ead6223..e9ee7d1cee 100644 --- a/tests/QS/regtest-gauxc-api/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-api/TEST_FILES.toml @@ -1,7 +1,7 @@ "1H2_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163125608332391}] "1H2_GAUXC_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] -"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121899608445}] +"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] "NH3_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722432805445091}] -"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722558568119791}] +"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722557896081605}] "OH_GAUXC_MODEL_PBE_UKS.inp" = [{matcher="E_total", tol=5e-6, ref=-16.541584062034670}] "CH4_DIMER_GAUXC_PBE_D3.inp" = [{matcher="M033", tol=1e-14, ref=-0.00355123783846}] diff --git a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml index 3bd87ffe71..db816e3a27 100644 --- a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml @@ -1,11 +1,11 @@ "H2_PBE_CDFT_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157232743213941}, {matcher="M071", tol=1e-8, ref=0.197625731046}] -"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229554329094}, +"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229340943540}, {matcher="M071", tol=1e-8, ref=0.197624070585}] "H2_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.216557647288}] "H2_GAPW_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.217417757774}] "H2_PBE_CDFT_CI_REFERENCE.inp" = [{matcher="M073", tol=1e-8, ref=345.364329058819}, {matcher="M077", tol=1e-8, ref=-1.16295181842678}] -"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325437357859}, - {matcher="M077", tol=1e-8, ref=-1.16294823026735}] +"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325380057211}, + {matcher="M077", tol=1e-8, ref=-1.16294801624740}] "H2_SKALA_CDFT_CI.inp" = [{matcher="M077", tol=5e-8, ref=-1.39020335005227}] diff --git a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml index 274511571a..babec12d78 100644 --- a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml @@ -1,8 +1,8 @@ "HCl_GAPW_SKALA_ECP_ENERGY.inp" = [{matcher="E_total", tol=5e-6, ref=-15.464581508021762}] -"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.45263701}] +"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44142596263930}] "HCl_NATIVE_SKALA_GAPW_GPWTYPE_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36078871}] -"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36291913}] +"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.35170807520943}] "H2_NATIVE_SKALA_GAPW_ECP_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=6e-1, ref=0.0}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] diff --git a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml index 80fac5377e..dea40ed44e 100644 --- a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml @@ -1,3 +1,3 @@ -"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] diff --git a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml index 300b8bb9d2..fbeaab6fca 100644 --- a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml @@ -1,8 +1,8 @@ -"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833172}] -"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833169}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] "H2_NATIVE_SKALA_GAPW_GPWTYPE_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="M072", tol=1e-4, ref=5.37252718E-05}, {matcher="M031", tol=1e-5, ref=-8.58976831594E+04}] -"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9698629747}] +"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.94877811114650}] "H2_NATIVE_SKALA_GAPW_GTH_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=2e-1, ref=0.0}] "H2_NATIVE_SKALA_GAPW_GTH_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=2e-1, ref=0.0}] diff --git a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp index 683adc123c..d2a3f65b34 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp +++ b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp @@ -27,7 +27,7 @@ &SCF EPS_SCF 1.0E-5 IGNORE_CONVERGENCE_FAILURE T - MAX_SCF 1 + MAX_SCF 2 SCF_GUESS ATOMIC &DIAGONALIZATION &END DIAGONALIZATION diff --git a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml index d1858ded5d..5899459292 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml @@ -2,7 +2,7 @@ "H2_NATIVE_SKALA_GPW_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=5e-3, ref=0.0}] "H2P_NATIVE_SKALA_GPW_UKS_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=1e-3, ref=0.0}] "H2_NATIVE_SKALA_GPW_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] -"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] +"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-1.04111543882624}] "H2_NATIVE_SKALA_GPW_SMOOTH.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="SKALA_GPW_feature_electrons", tol=1e-8, ref=2.00000875882}, {matcher="SKALA_GPW_feature_spin_moment", tol=1e-12, ref=0.0}, diff --git a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml index 15a43ace67..e821736011 100644 --- a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml +++ b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml @@ -12,10 +12,10 @@ {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53343196E+00}] "test04.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102641E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53056622E+00}] -"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101974E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53306556E+00}] -"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102171E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.52845348E+00}] +"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101772E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53053109E+00}] +"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102040E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.51211743E+00}] "test07.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101792E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.55939759E+00}] "test08.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.103120E+01}, diff --git a/tests/QS/regtest-tddfpt-4/test05.inp b/tests/QS/regtest-tddfpt-4/test05.inp index ca5adb36c1..a52cb822b3 100644 --- a/tests/QS/regtest-tddfpt-4/test05.inp +++ b/tests/QS/regtest-tddfpt-4/test05.inp @@ -11,8 +11,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 200 - REL_CUTOFF 60 + CUTOFF 120 + REL_CUTOFF 50 &END MGRID &POISSON PERIODIC NONE diff --git a/tests/QS/regtest-tddfpt-4/test06.inp b/tests/QS/regtest-tddfpt-4/test06.inp index 8ac7bef886..7e9dbaa5e7 100644 --- a/tests/QS/regtest-tddfpt-4/test06.inp +++ b/tests/QS/regtest-tddfpt-4/test06.inp @@ -19,8 +19,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 200 - REL_CUTOFF 40 + CUTOFF 120 + REL_CUTOFF 30 &END MGRID &POISSON PERIODIC NONE diff --git a/tests/TEST_DIRS b/tests/TEST_DIRS index 268a1b191e..4bcedaf889 100644 --- a/tests/TEST_DIRS +++ b/tests/TEST_DIRS @@ -3,6 +3,7 @@ # Directories have been reordered according the execution time needed for a gfortran pdbg run using 2 MPI tasks # in case a new directory is added just add it at the top of the list.. # the order will be regularly checked and modified... +Fist/regtest-mace libtorch QS/regtest-floquet QS/regtest-dft-d4-auto-ref libdftd4 libint !ifx QS/regtest-dft-d2-auto-ref libint !ifx @@ -218,7 +219,7 @@ Fist/regtest-1-3 QS/regtest-md-extrap Fist/regtest-15 xTB/regtest-3 -xTB/regtest-3-spglib spglib +xTB/regtest-3-spglib spglib tblite QS/regtest-debug-3 libint libxc !ifx QS/regtest-lrigpw-2 QS/regtest-hybrid-4 libint libxc !ifx diff --git a/tools/conventions/conventions.supp b/tools/conventions/conventions.supp index cc7033ad48..758c77d9a2 100644 --- a/tools/conventions/conventions.supp +++ b/tools/conventions/conventions.supp @@ -95,7 +95,6 @@ kpsym.F: Found GOTO statement in procedure "primlatt" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "remove" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "sppt2" https://cp2k.org/conv#c201 libcp2k.F: Found type eri2array without initializer https://cp2k.org/conv#c016 -libgrpp_integrals.F: Module "libgrpp" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 libint_wrapper.F: Found type cp_libint_t without initializer https://cp2k.org/conv#c016 libint_wrapper.F: Module "libint_f" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 library_tests.F: Found CALL RANDOM_NUMBER in procedure "copy_test" https://cp2k.org/conv#c104 @@ -153,7 +152,6 @@ message_passing.F: Module "pmpi_f08" USEd without ONLY clause or not PRIVATE htt message_passing.F: USE statement at (1) has no ONLY qualifier [-Wuse-without-only] message_passing.fypp: Type mismatch between actual argument at (1) and actual argument at (2) (COMPLEX(8)/COMPLEX(4)). mltfftsg_tools.F: Found WRITE statement with hardcoded unit in "ctrig" https://cp2k.org/conv#c012 -mode_selective.F: Found READ with unchecked STAT in "bfgs_guess" https://cp2k.org/conv#c001 mp_perf_test.F: Module "mpi_f08" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 negf_methods.F: Found CALL with NULL() as argument in procedure "converge_density" https://cp2k.org/conv#c007 negf_methods.F: Found CALL with NULL() as argument in procedure "guess_fermi_level" https://cp2k.org/conv#c007 @@ -171,7 +169,6 @@ ps_wavelet_kernel.F: Found WRITE statement with hardcoded unit in "indices" http ps_wavelet_scaling_function.F: Found WRITE statement with hardcoded unit in "ftest" https://cp2k.org/conv#c012 pwdft_environment_types.F: Module "sirius" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 pw_grids.F: Found WRITE statement with hardcoded unit in "pw_grid_sort" https://cp2k.org/conv#c012 -qcschema.F: Module "hdf5_wrapper" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 qs_active_space_methods.F: Found type eri_fcidump_checksum without initializer https://cp2k.org/conv#c016 qs_active_space_methods.F: Found type eri_fcidump_print without initializer https://cp2k.org/conv#c016 qs_charge_mixing.F: Module "mctc_env" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 diff --git a/tools/docker/scripts/test_misc.sh b/tools/docker/scripts/test_misc.sh index fe39415cc9..d3fc3dc645 100755 --- a/tools/docker/scripts/test_misc.sh +++ b/tools/docker/scripts/test_misc.sh @@ -44,6 +44,7 @@ run_test ./tools/pao-ml/pao-validate.py --threshold=1e-5 --model="tests/QS/regte run_test ./tools/vibronic_spec/main.py ./tools/vibronic_spec/example/example_config.toml run_test mypy --strict ./tools/pao-ml/ +run_test mypy --strict ./tools/mace/create_cp2k_model.py run_test mypy --strict ./tools/minimax_tools/minimax_to_fortran_source.py run_test mypy --strict ./tools/dashboard/generate_dashboard.py run_test mypy --strict ./tools/regtesting/optimize_test_dirs.py diff --git a/tools/mace/create_cp2k_model.py b/tools/mace/create_cp2k_model.py new file mode 100644 index 0000000000..16b097b0ce --- /dev/null +++ b/tools/mace/create_cp2k_model.py @@ -0,0 +1,190 @@ +# pylint: disable=wrong-import-position +""" +Export a trained MACE model to a TorchScript file that can be loaded by CP2K. + +The export script must be executed in an environment where MACE is installed. + +Required packages: + * torch: required for loading and converting the model. + * e3nn: required by MACE for JIT compilation. + * mace-torch: required because the trained MACE model is loaded using + torch and its original model classes must be available. + +The MACE version used for export should be compatible with the version +used for training the model. + +After exporting, the CP2K-compatible `.pth` file can be loaded by CP2K +through the LibTorch interface. No MACE, e3nn, or Python installation is +required during CP2K simulations. + +Usage: + python create_cp2k_model.py my_mace.model --dtype float64 --head default + -> writes my_mace.model-cp2k.pth +""" + +import argparse +import os +from typing import Any, Dict, Optional + +os.environ["TORCH_FORCE_NO_WEIGHTS_ONLY_LOAD"] = "1" + +import torch +from e3nn.util import jit # type: ignore +from e3nn.util.jit import compile_mode # type: ignore + +# Z -> chemical symbol table (index == atomic number). Covers the dummy X plus +# all 118 known elements, matching CP2K's src/common/periodic_table.F. +chemical_symbols = ["X"] + """ + H He Li Be B C N O F Ne Na Mg Al Si P S Cl Ar K Ca Sc Ti V Cr Mn Fe Co + Ni Cu Zn Ga Ge As Se Br Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb + Te I Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu Hf Ta W Re Os + Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm + Md No Lr Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og +""".split() + + +@compile_mode("script") +class CP2K_MACE(torch.nn.Module): + """MACE model wrapped for CP2K's single-dictionary libtorch interface.""" + + head: torch.Tensor + + def __init__(self, model: Any, head: Optional[str] = None) -> None: + super().__init__() + self.model = model + self.register_buffer("atomic_numbers", model.atomic_numbers) + self.register_buffer("r_max", model.r_max) + self.register_buffer("num_interactions", model.num_interactions) + self.num_types: int = int(model.atomic_numbers.shape[0]) + + if not hasattr(model, "heads"): + model.heads = [None] + if head is not None and head in model.heads: + head_idx = model.heads.index(head) + else: + head_idx = len(model.heads) - 1 + self.register_buffer( + "head", torch.tensor(head_idx, dtype=torch.long).unsqueeze(0) + ) + + for param in self.model.parameters(): + param.requires_grad = False + + def forward( + self, data: Dict[str, torch.Tensor] + ) -> Dict[str, Optional[torch.Tensor]]: + pos = data["pos"] + edge_index = data["edge_index"] + unit_shifts = data["edge_cell_shift"] + cell = data["cell"].view(3, 3) + atom_types = data["atom_types"].to(torch.long) + n_atoms = pos.shape[0] + + # one-hot node attributes expected by MACE + node_attrs = torch.nn.functional.one_hot( + atom_types, num_classes=self.num_types + ).to(pos.dtype) + + # real-space edge shift vectors: unit_shifts @ cell (Angstrom) + shifts = torch.matmul(unit_shifts, cell) + + batch = torch.zeros(n_atoms, dtype=torch.long, device=pos.device) + ptr = torch.tensor([0, n_atoms], dtype=torch.long, device=pos.device) + + mace_in: Dict[str, torch.Tensor] = { + "positions": pos, + "node_attrs": node_attrs, + "edge_index": edge_index, + "shifts": shifts, + "unit_shifts": unit_shifts, + "cell": cell, + "batch": batch, + "ptr": ptr, + "head": self.head, + } + + out = self.model( + mace_in, + training=False, + compute_force=True, + compute_virials=True, + compute_stress=False, + compute_displacement=True, + ) + + node_energy = out["node_energy"] + forces = out["forces"] + virials = out["virials"] + + atomic_energy: Optional[torch.Tensor] = None + if node_energy is not None: + atomic_energy = node_energy.unsqueeze(-1) + + virial: Optional[torch.Tensor] = None + if virials is not None: + virial = virials.view(3, 3) + + return { + "atomic_energy": atomic_energy, + "forces": forces, + "virial": virial, + } + + +def build_metadata(model: Any, dtype: str) -> Dict[str, str]: + z = model.atomic_numbers.to(torch.long).tolist() + type_names = " ".join(chemical_symbols[int(zi)] for zi in z) + return { + "num_types": str(len(z)), + "r_max": repr(float(model.r_max)), + "type_names": type_names, + "model_dtype": dtype, + "allow_tf32": "0", + # MACE uses a single global cutoff; leave per-edge-type cutoffs empty so + # CP2K's reader falls back to filling the cutoff matrix with r_max**2. + "per_edge_type_cutoff": "", + } + + +def parse_args() -> argparse.Namespace: + p = argparse.ArgumentParser(description=__doc__) + p.add_argument("model_path", help="Path to the trained MACE .model file") + p.add_argument( + "--head", default=None, help="Model head to export (multi-head models)" + ) + p.add_argument("--dtype", choices=["float64", "float32"], default="float64") + p.add_argument( + "--output", default=None, help="Output path (default: -cp2k.pth)" + ) + return p.parse_args() + + +def main() -> None: + args = parse_args() + model = torch.load(args.model_path, map_location="cpu") + if args.dtype == "float64": + model = model.double() + else: + print("Converting model to float32, this may cause loss of precision.") + model = model.float() + model = model.to("cpu") + + wrapper = CP2K_MACE(model, head=args.head) + wrapper.eval() + + scripted = jit.compile(wrapper) + + metadata = build_metadata(model, args.dtype) + extra_files = {k: v.encode("utf-8") for k, v in metadata.items()} + + out_path = args.output or (args.model_path + "-cp2k.pth") + scripted.save(out_path, _extra_files=extra_files) + + print(f"Wrote CP2K MACE model to: {out_path}") + print("Metadata:") + for k, v in metadata.items(): + print(f" {k}: {v}") + + +if __name__ == "__main__": + main() diff --git a/tools/pao-ml/requirements.txt b/tools/pao-ml/requirements.txt index fedca401bb..179df2da5d 100644 --- a/tools/pao-ml/requirements.txt +++ b/tools/pao-ml/requirements.txt @@ -1,6 +1,6 @@ e3nn==0.6.0 nequip==0.17.1 -torch==2.11.0 +torch==2.13.0 #EOF diff --git a/tools/precommit/fortitude.toml b/tools/precommit/fortitude.toml index 71813b713f..f613397e65 100644 --- a/tools/precommit/fortitude.toml +++ b/tools/precommit/fortitude.toml @@ -7,39 +7,51 @@ ignore = [ "non-standard-file-extension", "implicit-external-procedures", # requires Fortran 2018 "missing-intent", + "bad-quote-string", + "literal-kind", "assumed-size", "assumed-size-character-intent", - "external-procedure", - "literal-kind", "interface-implicit-typing", - "implicit-typing", - "missing-accessibility-statement", + "missing-default-case", + "external-procedure", + "trailing-backslash", ] # ============================================================================== # The following files can not be parsed by Fortitude. # Usually because Fortran statements are inter-leafed with pre-processor macros. exclude = [ - "pw_methods.F", "local_gemm_api.F", - "cp_fm_diag.F", - "cp_fm_cholesky.F", - "cp_fm_basic_linalg.F", - "cp_cfm_diag.F", - "cp_cfm_cholesky.F", - "cp_cfm_basic_linalg.F", - "dbt_split.F", - "dbt_tas_util.F", - "dbt_array_list_methods.F", - "xc_libxc_wrap.F", - "ai_contraction_sphi.F", "smeagol_control_types.F", + "ai_contraction_sphi.F", + "qs_loc_states.F", + "dbt_array_list_methods.F", + "cp_cfm_basic_linalg.F", + "cp_cfm_diag.F", + "cp_fm_basic_linalg.F", + "cp_fm_cholesky.F", + "cp_fm_diag.F", + "message_passing.F", + "dbt_split.F", + "cp_cfm_cholesky.F", + "pw_methods.F", + "xc_libxc_wrap.F", + "dbt_tas_util.F", ] # ============================================================================== [check.per-file-ignores] -"semi_empirical_int_debug.F" = ["procedure-not-in-module"] -"gopt_f77_methods.F" = ["procedure-not-in-module"] +"environment.F" = ["line-too-long"] +"libgint_wrapper.F" = ["trailing-backslash"] +"qs_block_davidson_types.F" = ["trailing-backslash"] +"qs_linres_current.F" = ["trailing-backslash"] +"qs_local_properties.F" = ["unreachable-statement"] +"qs_tddfpt2_subgroups.F" = ["trailing-backslash"] +"semi_empirical_int_ana.F" = ["misleading-inline-if-semicolon"] "pilaenv_hack.F" = ["procedure-not-in-module"] +"semi_empirical_int_debug.F" = ["procedure-not-in-module"] +"eri_mme_lattice_summation.F" = ["trailing-whitespace"] +"gopt_f77_methods.F" = ["procedure-not-in-module"] +"fftw3_lib.F" = ["misleading-inline-if-semicolon"] #EOF diff --git a/tools/precommit/requirements.txt b/tools/precommit/requirements.txt index efef9f6b05..ff1aa191ec 100644 --- a/tools/precommit/requirements.txt +++ b/tools/precommit/requirements.txt @@ -4,7 +4,7 @@ click==8.3.1 cmake-format==0.6.13 cmakelang==0.6.13 Flask==3.1.3 -fortitude-lint==0.7.5 +fortitude-lint==0.9.0 gunicorn==25.1.0 itsdangerous==2.2.0 Jinja2==3.1.6 diff --git a/tools/spack/cp2k_deps_p.yaml b/tools/spack/cp2k_deps_p.yaml index 81c2bb12fa..894db1cdb2 100644 --- a/tools/spack/cp2k_deps_p.yaml +++ b/tools/spack/cp2k_deps_p.yaml @@ -184,7 +184,7 @@ spack: repos: builtin: - commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 + commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 specs: # Build tools @@ -215,7 +215,7 @@ spack: - "libsmeagol@1.2" - "libvdwxc@0.5.0" - "libvori@220621" - - "libxc@7.0.0" + - "libxc@7.1.2" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/spack/cp2k_deps_s-static.yaml b/tools/spack/cp2k_deps_s-static.yaml index 0fcbfba865..3f3ef30670 100644 --- a/tools/spack/cp2k_deps_s-static.yaml +++ b/tools/spack/cp2k_deps_s-static.yaml @@ -96,7 +96,7 @@ spack: repos: builtin: - commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 + commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 specs: # Build tools @@ -113,7 +113,7 @@ spack: - "libfci@0.1.0" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.0.0" + - "libxc@7.1.2" - "libxs@1.0.0" - "libxsmm@2.0.0" - "openblas@0.3.33" diff --git a/tools/spack/cp2k_deps_s.yaml b/tools/spack/cp2k_deps_s.yaml index 8cbf31adc4..f284738378 100644 --- a/tools/spack/cp2k_deps_s.yaml +++ b/tools/spack/cp2k_deps_s.yaml @@ -117,7 +117,7 @@ spack: repos: builtin: - commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 + commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 specs: # Build tools @@ -138,7 +138,7 @@ spack: # - "libgint@release_v1" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.0.0" + - "libxc@7.1.2" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/toolchain/scripts/stage3/install_libxc.sh b/tools/toolchain/scripts/stage3/install_libxc.sh index c08347ebb0..712612cce9 100755 --- a/tools/toolchain/scripts/stage3/install_libxc.sh +++ b/tools/toolchain/scripts/stage3/install_libxc.sh @@ -6,8 +6,8 @@ [ "${BASH_SOURCE[0]}" ] && SCRIPT_NAME="${BASH_SOURCE[0]}" || SCRIPT_NAME=$0 SCRIPT_DIR="$(cd "$(dirname "$SCRIPT_NAME")/.." && pwd -P)" -libxc_ver="7.0.0" -libxc_sha256="e9ae69f8966d8de6b7585abd9fab588794ada1fab8f689337959a35abbf9527d" +libxc_ver="7.1.2" +libxc_sha256="3915fac94416e4c415534223ea492ad2663f928acf27e98662c861b094a6c306" source "${SCRIPT_DIR}"/common_vars.sh source "${SCRIPT_DIR}"/tool_kit.sh source "${SCRIPT_DIR}"/signal_trap.sh @@ -34,34 +34,23 @@ case "$with_libxc" in cd libxc-${libxc_ver} mkdir build cd build - - # Lower the optimization level of KXC functionals for GCC to reduce time cost - # LXC functionals are not used so ignore them - if [ "${with_gcc}" != "__DONTUSE__" ]; then - if [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then - MAPLE2C_DIR="../src/maple2c" - for f in "$MAPLE2C_DIR"/gga_exc/*.c "$MAPLE2C_DIR"/mgga_exc/*.c "$MAPLE2C_DIR"/lda_exc/*.c; do - [ -f "$f" ] || continue - if grep -q "^func_kxc_" "$f" && ! grep -q "__attribute__((optimize" "$f"; then - sed -i 's/^func_kxc_/__attribute__((optimize("O1"))) func_kxc_/' "$f" - fi - done - LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" - else - LIBXC_CFLAGS="${CFLAGS}" - fi + if [ "${with_gcc}" != "__DONTUSE__" ] && + [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then + # Turn off variable tracking + LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" + else + LIBXC_CFLAGS="" fi - - # CP2K does not make use of fourth derivatives, so skip their compilation with -DDISABLE_KXC=OFF - # Add "-DCMAKE_POLICY_VERSION_MINIMUM=3.5" to keep legacy compatibility for CMake version 4.x + # CP2K make use of third derivatives in libxc CFLAGS="${LIBXC_CFLAGS}" cmake \ + -DCMAKE_BUILD_TYPE="RelWithDebInfo" \ -DCMAKE_INSTALL_PREFIX="${pkg_install_dir}" \ - -DCMAKE_INSTALL_LIBDIR=lib \ + -DCMAKE_INSTALL_LIBDIR="lib" \ -DCMAKE_VERBOSE_MAKEFILE=ON \ + -DBUILD_SHARED_LIBS=OFF \ -DBUILD_TESTING=OFF \ -DENABLE_FORTRAN=ON \ - -DDISABLE_KXC=OFF \ - -DCMAKE_POLICY_VERSION_MINIMUM=3.5 \ + -DMAXORDER=3 \ .. > configure.log 2>&1 || tail_excerpt configure.log make -j $(get_nprocs) > make.log 2>&1 || tail_excerpt make.log make install > install.log 2>&1 || tail_excerpt install.log