diff --git a/CMakeLists.txt b/CMakeLists.txt index e5e5b846e5..075f91973c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -10,15 +10,6 @@ cmake_minimum_required(VERSION 3.24) # include our cmake snippets set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} ${CMAKE_CURRENT_SOURCE_DIR}/cmake) -# Require out-of-source builds -file(TO_CMAKE_PATH "${CMAKE_BINARY_DIR}/CMakeLists.txt" LOC_PATH) -if(EXISTS "${LOC_PATH}") - message( - FATAL_ERROR - "You cannot build in a source directory (or any directory with a CMakeLists.txt file). " - "Please make a build subdirectory.") -endif() - # ================================================================================================= # PROJECT AND VERSION include(CMakeDependentOption) @@ -40,6 +31,15 @@ project( list(APPEND CMAKE_MODULE_PATH "${PROJECT_SOURCE_DIR}/cmake/modules") +# Require out-of-source builds +file(TO_CMAKE_PATH "${PROJECT_BINARY_DIR}/CMakeLists.txt" LOC_PATH) +if(EXISTS "${LOC_PATH}") + message( + FATAL_ERROR + "You cannot build in a source directory (or any directory with a CMakeLists.txt file). Please make a build subdirectory." + ) +endif() + # set language and standard. # # cmake does not provide any mechanism to set the fortran standard. Adding the @@ -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 "Enable Nvidia NVHPC kit" OFF - "CP2K_USE_ACCEL MATCHES \"CUDA\"" OFF) +cmake_dependent_option(CP2K_USE_NVHPC OFF "Enable Nvidia NVHPC kit" + "(NOT CP2K_USE_ACCEL MATCHES \"CUDA\")" OFF) cmake_dependent_option( - CP2K_USE_SPLA_GEMM_OFFLOADING - "Enable SpLA dgemm offloading (only valid with GPU support on)" ON - "CP2K_USE_ACCEL MATCHES \"HIP|CUDA\" AND CP2K_USE_SPLA" OFF) + CP2K_USE_SPLA_GEMM_OFFLOADING ON + "Enable SpLA dgemm offloading (only valid with GPU support on)" + "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_SPLA)" OFF) cmake_dependent_option( - CP2K_USE_CRAY_PM_ACCEL_ENERGY - "Enable CRAY power management framework with gpu support" ON - "CP2K_USE_ACCEL MATCHES \"OPENCL|HIP|CUDA\" AND CP2K_USE_CRAY_PM_ENERGY" OFF) + CP2K_USE_CRAY_PM_ACCEL_ENERGY ON + "Enable CRAY power management framework with gpu support" + "(NOT CP2K_USE_ACCEL MATCHES \"NONE\") AND (CP2K_USE_CRAY_PM_ENERGY)" OFF) cmake_dependent_option( CP2K_USE_LIBGINT "Enable LibGint support" ${CP2K_USE_EVERYTHING} diff --git a/REVISION b/REVISION new file mode 100644 index 0000000000..1b83965aea --- /dev/null +++ b/REVISION @@ -0,0 +1 @@ +git:c92cc08 diff --git a/data/MACE/MACE_scratch_run-3.model-cp2k.pth b/data/MACE/MACE_scratch_run-3.model-cp2k.pth deleted file mode 100644 index f0ff697cb9..0000000000 Binary files a/data/MACE/MACE_scratch_run-3.model-cp2k.pth and /dev/null differ diff --git a/docs/generate_input_reference.py b/docs/generate_input_reference.py index 7db6276aa0..9a51f77e42 100755 --- a/docs/generate_input_reference.py +++ b/docs/generate_input_reference.py @@ -342,28 +342,20 @@ def render_keyword( output += [f":module: {section_xref}"] else: output += [":noindex:"] - output += [""] - - # Render keyword properties as compact, unbulleted lines instead of placing the - # type and default value in the object signature. - metadata = [f"**Type:** {escape_markdown(data_type + n_var_brackets)}"] + output += [f":type: '{data_type}{n_var_brackets}'"] if default_value or default_unit: - default = default_value - if default_unit: - default += f" [{default_unit}]" - metadata += [f"**Default:** {escape_markdown(default.strip())}"] + default_unit_bracketed = f"[{default_unit}]" if default_unit else "" + output += [f":value: '{default_value} {default_unit_bracketed}'"] + output += [""] if repeats: - metadata += ["**Repeatable:** yes"] + output += ["**Keyword can be repeated.**", ""] if len(keyword_names) > 1: - aliases = ", ".join(keyword_names[1:]) - metadata += [f"**Aliases:** {escape_markdown(aliases)}"] + aliases = " ,".join(keyword_names[1:]) + output += [f"**Aliases:** {escape_markdown(aliases)}", ""] if lone_keyword_value: - metadata += [f"**Lone keyword:** {escape_markdown(lone_keyword_value)}"] + output += [f"**Lone keyword:** `{escape_markdown(lone_keyword_value)}`", ""] if usage: - metadata += [f"**Usage:** _{escape_markdown(usage)}_"] - output += [" \n".join(metadata), ""] - if description: - output += [f"**Description:** {escape_markdown(description)}", ""] + output += [f"**Usage:** _{escape_markdown(usage)}_", ""] if data_type == "enum": output += ["**Valid values:**"] for item in keyword.findall("DATA_TYPE/ENUMERATION/ITEM"): @@ -377,6 +369,7 @@ def render_keyword( if mentions: mentions_list = ", ".join([f"⭐[](project:{m})" for m in mentions]) output += [f"**Mentions:** {mentions_list}", ""] + output += [escape_markdown(description)] if github: output += [github_link(location)] output += ["", "```", ""] # Close py:data directive. diff --git a/docs/methods/machine_learning/index.md b/docs/methods/machine_learning/index.md index f3ae029b1e..004f3c7a6e 100644 --- a/docs/methods/machine_learning/index.md +++ b/docs/methods/machine_learning/index.md @@ -6,7 +6,6 @@ titlesonly: maxdepth: 2 --- nequip -mace nnp pao-ml deepmd diff --git a/docs/methods/machine_learning/mace.md b/docs/methods/machine_learning/mace.md deleted file mode 100644 index 7e3bf66da5..0000000000 --- a/docs/methods/machine_learning/mace.md +++ /dev/null @@ -1,60 +0,0 @@ -# MACE - -MACE is a framework for building interatomic potentials using higher-order equivariant -message-passing neural networks. The methodology is described in detail in the literature by Batatia -et al. (2022). - -**Note:** Running MACE requires a CP2K build with LibTorch support - -Like the [NequIP/Allegro](https://manual.cp2k.org/trunk/methods/machine_learning/nequip.html) -interface, CP2K runs MACE models through the generic LibTorch interface: a trained MACE model is -exported once to a self-contained TorchScript file (`.pth`), which CP2K then loads and evaluates at -runtime. No Python interpreter is involved during the simulation. - -## Exporting a MACE model for CP2K - -Wraps a trained MACE model (`.model`) and compiles it to CP2K-loadable TorchScrip file with the -helper script `cp2k/tools/mace/create_cp2k_model.py`: - -```shell -python create_cp2k_model.py my_mace.model --dtype float64 -# -> writes my_mace.model-cp2k.pth -``` - -This conversion only needs to be performed once on a machine with both `torch` and `mace` installed. -The resulting `*.pth` file uses the same tensor and metadata format as the NequIP interface (inputs -`pos`, `edge_index`, `edge_cell_shift`, `cell`, `atom_types`; outputs `atomic_energy`, `forces`, -`virial`) and embeds the metadata (`num_types`, `r_max`, `type_names`, `model_dtype`) that CP2K -reads to build the neighbour graph. The `torch` version used for export must be compatible with the -LibTorch version linked into CP2K. - -## Input Section - -Inference is configured through the [MACE](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE) -section within the `&NONBONDED` forcefield parameters: - -```text -&FORCEFIELD - &NONBONDED - &MACE - ATOMS Cu - POT_FILE_NAME MACE/my_mace.model-cp2k.pth - &END MACE - &END NONBONDED -&END FORCEFIELD -``` - -- [ATOMS](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE.ATOMS): a list of elements/kinds; the - mapping to the model type list must be consistent with the coordinates in `&COORDS`/`&TOPOLOGY`. -- [POT_FILE_NAME](#CP2K_INPUT.FORCE_EVAL.MM.FORCEFIELD.NONBONDED.MACE.POT_FILE_NAME): path to the - exported MACE model. - -MACE is a message-passing model with a non-local receptive field. As with NequIP, the interface -evaluates the full system on every MPI rank and divides the energy, forces, and virial by the number -of ranks. - -## Further Resources - -- **MACE:** Paper [](#Batatia2022) and source code at - [github.com/ACEsuit/mace](https://github.com/ACEsuit/mace). -- **e3nn:** For an introduction to Euclidean neural networks, visit [e3nn.org](https://e3nn.org). diff --git a/docs/technologies/libraries.md b/docs/technologies/libraries.md index 86a2cb3451..2e5bf4ebbf 100644 --- a/docs/technologies/libraries.md +++ b/docs/technologies/libraries.md @@ -220,8 +220,8 @@ of each atom. ## Torch (PyTorch C++ library) -LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP and MACE interfaces and for -GauXC Skala models. +LibTorch is the C++ distribution of PyTorch. CP2K uses it for the NequIP interface and for GauXC +Skala models. - LibTorch can be downloaded from the [PyTorch installation page](https://pytorch.org/get-started/locally/). diff --git a/docs/versions.md b/docs/versions.md index 923bdbb73d..48f5f78b15 100644 --- a/docs/versions.md +++ b/docs/versions.md @@ -5,7 +5,6 @@ maxdepth: 1 titlesonly: --- -2026.2 2026.1 2025.2 2025.1 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a016d826a6..21439a11e8 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -329,7 +329,6 @@ list( kpoint_k_r_trafo_simple.F kpoint_methods.F kpoint_mo_dump.F - kpoint_mo_symmetry_methods.F kpoint_transitional.F kpoint_types.F kpsym.F @@ -355,7 +354,7 @@ list( manybody_deepmd.F manybody_gal21.F manybody_gal.F - manybody_e3nn.F + manybody_nequip.F manybody_potential.F manybody_siepmann.F manybody_tersoff.F @@ -1379,7 +1378,6 @@ list( xc/xc.F xc/xc_functionals_utilities.F xc/xc_fxc_kernel.F - xc/xc_gauxc_cache.F xc/xc_gauxc_functional.F xc/xc_gauxc_interface.F xc/xc_hcth.F diff --git a/src/accint_weights_forces.F b/src/accint_weights_forces.F index f56be20318..b5d9376e9b 100644 --- a/src/accint_weights_forces.F +++ b/src/accint_weights_forces.F @@ -412,7 +412,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_g_base, rho_r, rho_g) - ELSE IF (ASSOCIATED(rho_r_base)) THEN + ELSEIF (ASSOCIATED(rho_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho_r_base, rho_r, rho_g) ELSE CPABORT("Fine Grid in xc_density requires rho_r or rho_g") @@ -420,7 +420,7 @@ CONTAINS IF (rho_tau_valid) THEN IF (rho_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau_g_base, tau_r, tau_g) - ELSE IF (ASSOCIATED(tau_r_base)) THEN + ELSEIF (ASSOCIATED(tau_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau_r_base, tau_r, tau_g) ELSE CPABORT("Fine Grid in xc_density requires tau_r or tau_g") @@ -482,7 +482,7 @@ CONTAINS NULLIFY (rho1_r, rho1_g, tau1_r, tau1_g) IF (rho1_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho1_g_base, rho1_r, rho1_g) - ELSE IF (ASSOCIATED(rho1_r_base)) THEN + ELSEIF (ASSOCIATED(rho1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho1_r_base, rho1_r, rho1_g) ELSE CPABORT("Fine Grid in xc_density requires rho1_r or rho1_g") @@ -490,7 +490,7 @@ CONTAINS IF (rho1_tau_valid) THEN IF (rho1_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau1_g_base, tau1_r, tau1_g) - ELSE IF (ASSOCIATED(tau1_r_base)) THEN + ELSEIF (ASSOCIATED(tau1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau1_r_base, tau1_r, tau1_g) ELSE CPABORT("Fine Grid in xc_density requires tau1_r or tau1_g") @@ -518,7 +518,7 @@ CONTAINS NULLIFY (rho1_r, rho1_g, tau1_r, tau1_g) IF (rho1_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho1_g_base, rho1_r, rho1_g) - ELSE IF (ASSOCIATED(rho1_r_base)) THEN + ELSEIF (ASSOCIATED(rho1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho1_r_base, rho1_r, rho1_g) ELSE CPABORT("Fine Grid in xc_density requires rho1_r or rho1_g") @@ -526,7 +526,7 @@ CONTAINS IF (rho1_tau_valid) THEN IF (rho1_tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau1_g_base, tau1_r, tau1_g) - ELSE IF (ASSOCIATED(tau1_r_base)) THEN + ELSEIF (ASSOCIATED(tau1_r_base)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau1_r_base, tau1_r, tau1_g) ELSE CPABORT("Fine Grid in xc_density requires tau1_r or tau1_g") @@ -574,9 +574,8 @@ CONTAINS DEALLOCATE (vxc_rho) END IF IF (ASSOCIATED(vxc_tau)) THEN - IF (.NOT. ASSOCIATED(tau1_r)) THEN + IF (.NOT. ASSOCIATED(tau1_r)) & CPABORT("Tau response density required for mGGA xc_density") - END IF DO ispin = 1, nspins CALL pw_multiply_with(vxc_tau(ispin), tau1_r(ispin)) CALL pw_axpy(vxc_tau(ispin), exc, 1.0_dp) diff --git a/src/admm_dm_methods.F b/src/admm_dm_methods.F index a2c56f3155..7d046cdca3 100644 --- a/src/admm_dm_methods.F +++ b/src/admm_dm_methods.F @@ -76,9 +76,8 @@ CONTAINS CPABORT("admm_dm_calc_rho_aux: unknown method") END SELECT - IF (admm_dm%purify) THEN + IF (admm_dm%purify) & CALL purify_mcweeny(qs_env) - END IF CALL update_rho_aux(qs_env) @@ -121,9 +120,8 @@ CONTAINS CPABORT("admm_dm_merge_ks_matrix: unknown method") END SELECT - IF (admm_dm%purify) THEN + IF (admm_dm%purify) & CALL dbcsr_deallocate_matrix_set(matrix_ks_merge) - END IF CALL timestop(handle) @@ -219,9 +217,8 @@ CONTAINS IF (admm_dm%block_map(iatom, jatom) == 1) THEN CALL dbcsr_get_block_p(rho_ao_aux(ispin)%matrix, & row=iatom, col=jatom, BLOCK=sparse_block_aux, found=found) - IF (found) THEN + IF (found) & sparse_block_aux = sparse_block - END IF END IF END DO CALL dbcsr_iterator_stop(iter) @@ -336,9 +333,8 @@ CONTAINS CALL dbcsr_iterator_start(iter, matrix_ks_merge(ispin)%matrix) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, iatom, jatom, sparse_block) - IF (admm_dm%block_map(iatom, jatom) == 0) THEN + IF (admm_dm%block_map(iatom, jatom) == 0) & sparse_block = 0.0_dp - END IF END DO CALL dbcsr_iterator_stop(iter) CALL dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_merge(ispin)%matrix, 1.0_dp, 1.0_dp) diff --git a/src/admm_dm_types.F b/src/admm_dm_types.F index 90183cb8a4..2ca1e1d4d7 100644 --- a/src/admm_dm_types.F +++ b/src/admm_dm_types.F @@ -105,9 +105,8 @@ CONTAINS DEALLOCATE (admm_dm%matrix_a) END IF - IF (ASSOCIATED(admm_dm%block_map)) THEN + IF (ASSOCIATED(admm_dm%block_map)) & DEALLOCATE (admm_dm%block_map) - END IF DEALLOCATE (admm_dm%mcweeny_history) DEALLOCATE (admm_dm) diff --git a/src/admm_methods.F b/src/admm_methods.F index 9715ce9516..42d3850230 100644 --- a/src/admm_methods.F +++ b/src/admm_methods.F @@ -226,13 +226,12 @@ CONTAINS END IF - IF (admm_env%purification_method == do_admm_purify_cauchy) THEN + IF (admm_env%purification_method == do_admm_purify_cauchy) & CALL purify_dm_cauchy(admm_env, & mo_set=mos_aux_fit(ispin), & density_matrix=rho_ao_aux(ispin)%matrix, & ispin=ispin, & blocked=admm_env%block_dm) - END IF !GPW is the default, PW density is computed using the AUX_FIT basis and task_list !If GAPW, the we use the AUX_FIT_SOFT basis and task list @@ -2181,15 +2180,13 @@ CONTAINS IF (my_kpgrp) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux, work_aux_aux, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) THEN + IF (.NOT. use_real_wfn) & CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, work_aux_aux2, & para_env, info(indx, 2)) - END IF ELSE CALL cp_fm_start_copy_general(admm_env%work_aux_aux, fmdummy, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) THEN + IF (.NOT. use_real_wfn) & CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, fmdummy, para_env, info(indx, 2)) - END IF END IF END DO END DO @@ -2987,14 +2984,12 @@ CONTAINS IF (my_kpgrp) THEN CALL cp_fm_start_copy_general(admm_env%work_aux_aux, work_aux_aux, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) THEN + IF (.NOT. use_real_wfn) & CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, work_aux_aux2, para_env, info(indx, 2)) - END IF ELSE CALL cp_fm_start_copy_general(admm_env%work_aux_aux, fmdummy, para_env, info(indx, 1)) - IF (.NOT. use_real_wfn) THEN + IF (.NOT. use_real_wfn) & CALL cp_fm_start_copy_general(admm_env%work_aux_aux2, fmdummy, para_env, info(indx, 2)) - END IF END IF END DO END DO diff --git a/src/admm_types.F b/src/admm_types.F index e02e1ba93f..3aefcb365e 100644 --- a/src/admm_types.F +++ b/src/admm_types.F @@ -382,15 +382,12 @@ CONTAINS admm_env%aux_x_param(:) = admm_control%aux_x_param(:) !ADMMP, ADMMQ, ADMMS - IF ((.NOT. admm_env%charge_constrain) .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) THEN + IF ((.NOT. admm_env%charge_constrain) .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & admm_env%do_admmp = .TRUE. - END IF - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) THEN + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_none)) & admm_env%do_admmq = .TRUE. - END IF - IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) THEN + IF (admm_env%charge_constrain .AND. (admm_env%scaling_model == do_admm_exch_scaling_merlot)) & admm_env%do_admms = .TRUE. - END IF IF ((admm_control%method == do_admm_blocking_purify_full) .OR. & (admm_control%method == do_admm_blocked_projection)) THEN @@ -486,16 +483,13 @@ CONTAINS DEALLOCATE (admm_env%eigvals_lambda) DEALLOCATE (admm_env%eigvals_P_to_be_purified) - IF (ASSOCIATED(admm_env%block_map)) THEN + IF (ASSOCIATED(admm_env%block_map)) & DEALLOCATE (admm_env%block_map) - END IF - IF (ASSOCIATED(admm_env%xc_section_primary)) THEN + IF (ASSOCIATED(admm_env%xc_section_primary)) & CALL section_vals_release(admm_env%xc_section_primary) - END IF - IF (ASSOCIATED(admm_env%xc_section_aux)) THEN + IF (ASSOCIATED(admm_env%xc_section_aux)) & CALL section_vals_release(admm_env%xc_section_aux) - END IF IF (ASSOCIATED(admm_env%admm_gapw_env)) CALL admm_gapw_env_release(admm_env%admm_gapw_env) IF (ASSOCIATED(admm_env%admm_dm)) CALL admm_dm_release(admm_env%admm_dm) diff --git a/src/almo_scf.F b/src/almo_scf.F index c01f6f1a07..b005bb02e6 100644 --- a/src/almo_scf.F +++ b/src/almo_scf.F @@ -1400,6 +1400,7 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_delocalization' INTEGER :: handle, ispin, unit_nr + LOGICAL :: almo_experimental TYPE(cp_logger_type), POINTER :: logger TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: no_quench TYPE(optimizer_options_type) :: arbitrary_optimizer @@ -1461,6 +1462,25 @@ CONTAINS !!!! are commented out at the moment because some of their !!!! routines have not been thoroughly tested. + !!!! if we have virtuals pre-optimize and truncate them + !!!IF (almo_scf_env%need_virtuals) THEN + !!! SELECT CASE (almo_scf_env%deloc_truncate_virt) + !!! CASE (virt_full) + !!! ! simply copy virtual orbitals from matrix_v_full_blk to matrix_v_blk + !!! DO ispin=1,almo_scf_env%nspins + !!! CALL dbcsr_copy(almo_scf_env%matrix_v_blk(ispin),& + !!! almo_scf_env%matrix_v_full_blk(ispin)) + !!! ENDDO + !!! CASE (virt_number,virt_occ_size) + !!! CALL split_v_blk(almo_scf_env) + !!! !CALL truncate_subspace_v_blk(qs_env,almo_scf_env) + !!! CASE DEFAULT + !!! CPErrorMessage(cp_failure_level,routineP,"illegal method for virtual space truncation") + !!! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) + !!! END SELECT + !!!ENDIF + !!!CALL harris_foulkes_correction(qs_env,almo_scf_env) + IF (almo_scf_env%xalmo_update_algorithm == almo_scf_pcg) THEN CALL almo_scf_xalmo_pcg(qs_env=qs_env, & @@ -1565,6 +1585,18 @@ CONTAINS perturbation_only=.FALSE., & special_case=xalmo_case_normal) + ! RZK-warning THIS IS A HACK TO GET ORBITAL ENERGIES + almo_experimental = .FALSE. + IF (almo_experimental) THEN + almo_scf_env%perturbative_delocalization = .TRUE. + !DO ispin=1,almo_scf_env%nspins + ! CALL dbcsr_copy(almo_scf_env%matrix_t(ispin),& + ! almo_scf_env%matrix_t_blk(ispin)) + !ENDDO + CALL almo_scf_xalmo_eigensolver(qs_env, almo_scf_env, & + arbitrary_optimizer) + END IF ! experimental + ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CALL almo_scf_xalmo_trustr(qs_env=qs_env, & @@ -2590,9 +2622,8 @@ CONTAINS ALLOCATE (almo_scf_env%matrix_p_blk(nspins)) ALLOCATE (almo_scf_env%matrix_ks(nspins)) ALLOCATE (almo_scf_env%matrix_ks_blk(nspins)) - IF (almo_scf_env%need_previous_ks) THEN + IF (almo_scf_env%need_previous_ks) & ALLOCATE (almo_scf_env%matrix_ks_0deloc(nspins)) - END IF DO ispin = 1, nspins ! RZK-warning copy with symmery but remember that this might cause problems CALL dbcsr_create(almo_scf_env%matrix_p(ispin), & diff --git a/src/almo_scf_diis_types.F b/src/almo_scf_diis_types.F index 75341d7de5..d776ff9d8b 100644 --- a/src/almo_scf_diis_types.F +++ b/src/almo_scf_diis_types.F @@ -258,9 +258,8 @@ CONTAINS ! update the buffer length old_buffer_length = diis_env%buffer_length diis_env%buffer_length = diis_env%buffer_length + 1 - IF (diis_env%buffer_length > diis_env%max_buffer_length) THEN + IF (diis_env%buffer_length > diis_env%max_buffer_length) & diis_env%buffer_length = diis_env%max_buffer_length - END IF !!!! resize B matrix !!!IF (old_buffer_length.lt.diis_env%buffer_length) THEN @@ -403,12 +402,24 @@ CONTAINS ! use the eigensystem to invert (implicitly) B matrix ! and compute the extrapolation coefficients + !! ALLOCATE(tmp1(diis_env%buffer_length+1,1)) + !! ALLOCATE(coeff(diis_env%buffer_length+1,1)) + !! tmp1(:,1)=-1.0_dp*m_b_copy(1,:)/eigenvalues(:) + !! coeff=MATMUL(m_b_copy,tmp1) + !! DEALLOCATE(tmp1) ALLOCATE (tmp1(diis_env%buffer_length + 1)) ALLOCATE (coeff(diis_env%buffer_length + 1)) tmp1(:) = -1.0_dp*m_b_copy(1, :)/eigenvalues(:) coeff(:) = MATMUL(m_b_copy, tmp1) DEALLOCATE (tmp1) + !IF (unit_nr.gt.0) THEN + ! DO im=1,diis_env%buffer_length+1 + ! WRITE(unit_nr,*) diis_env%m_b(idomain)%mdata(im,:) + ! ENDDO + ! WRITE (unit_nr,*) coeff(:,1) + !ENDIF + ! extrapolate the variable checksum = 0.0_dp IF (diis_env%diis_env_type == diis_env_dbcsr) THEN @@ -430,6 +441,7 @@ CONTAINS checksum = checksum + coeff(im + 1) END DO END IF + !WRITE(*,*) checksum DEALLOCATE (coeff) diff --git a/src/almo_scf_env_methods.F b/src/almo_scf_env_methods.F index adb25ed0f3..06a3d9f70f 100644 --- a/src/almo_scf_env_methods.F +++ b/src/almo_scf_env_methods.F @@ -364,6 +364,108 @@ CONTAINS almo_scf_env%activate = 0 END IF + !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_AOS",& + ! i_val=almo_scf_env%domain_layout_aos) + !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_MOS",& + ! i_val=almo_scf_env%domain_layout_mos) + !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_AOS",& + ! i_val=almo_scf_env%mat_distr_aos) + !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_MOS",& + ! i_val=almo_scf_env%mat_distr_mos) + !CALL section_vals_val_get(almo_scf_section,"CONSTRAINT_TYPE",& + ! i_val=almo_scf_env%constraint_type) + !CALL section_vals_val_get(almo_scf_section,"MU",& + ! r_val=almo_scf_env%mu) + !CALL section_vals_val_get(almo_scf_section,"FIXED_MU",& + ! l_val=almo_scf_env%fixed_mu) + !CALL section_vals_val_get(almo_scf_section,"EPS_USE_PREV_AS_GUESS",& + ! r_val=almo_scf_env%eps_prev_guess) + !CALL section_vals_val_get(almo_scf_section,"MIXING_FRACTION",& + ! r_val=almo_scf_env%mixing_fraction) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_TENSOR_TYPE",& + ! i_val=almo_scf_env%deloc_cayley_tensor_type) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_CONJUGATOR",& + ! i_val=almo_scf_env%deloc_cayley_conjugator) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_MAX_ITER",& + ! i_val=almo_scf_env%deloc_cayley_max_iter) + !CALL section_vals_val_get(almo_scf_section,"DELOC_USE_OCC_ORBS",& + ! l_val=almo_scf_env%deloc_use_occ_orbs) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_USE_VIRT_ORBS",& + ! l_val=almo_scf_env%deloc_cayley_use_virt_orbs) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_LINEAR",& + ! l_val=almo_scf_env%deloc_cayley_linear) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_EPS_CONVERGENCE",& + ! r_val=almo_scf_env%deloc_cayley_eps_convergence) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_OCC_PRECOND",& + ! l_val=almo_scf_env%deloc_cayley_occ_precond) + !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_VIR_PRECOND",& + ! l_val=almo_scf_env%deloc_cayley_vir_precond) + !CALL section_vals_val_get(almo_scf_section,"ALMO_UPDATE_ALGORITHM_BD",& + ! i_val=almo_scf_env%almo_update_algorithm) + !CALL section_vals_val_get(almo_scf_section,"DELOC_TRUNCATE_VIRTUALS",& + ! i_val=almo_scf_env%deloc_truncate_virt) + !CALL section_vals_val_get(almo_scf_section,"DELOC_VIRT_PER_DOMAIN",& + ! i_val=almo_scf_env%deloc_virt_per_domain) + ! + !CALL section_vals_val_get(almo_scf_section,"OPT_K_EPS_CONVERGENCE",& + ! r_val=almo_scf_env%opt_k_eps_convergence) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_MAX_ITER",& + ! i_val=almo_scf_env%opt_k_max_iter) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_OUTER_MAX_ITER",& + ! i_val=almo_scf_env%opt_k_outer_max_iter) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE",& + ! r_val=almo_scf_env%opt_k_trial_step_size) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJUGATOR",& + ! i_val=almo_scf_env%opt_k_conjugator) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE_MULTIPLIER",& + ! r_val=almo_scf_env%opt_k_trial_step_size_multiplier) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_START",& + ! i_val=almo_scf_env%opt_k_conj_iter_start) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_START",& + ! i_val=almo_scf_env%opt_k_prec_iter_start) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_FREQ_RESET",& + ! i_val=almo_scf_env%opt_k_conj_iter_freq) + !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_FREQ_UPDATE",& + ! i_val=almo_scf_env%opt_k_prec_iter_freq) + ! + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_RADIUS_TYPE",& + ! i_val=almo_scf_env%quencher_radius_type) + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_FACTOR",& + ! r_val=almo_scf_env%quencher_r0_factor) + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_FACTOR",& + ! r_val=almo_scf_env%quencher_r1_factor) + !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_SHIFT",& + !! r_val=almo_scf_env%quencher_r0_shift) + !! + !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_SHIFT",& + !! r_val=almo_scf_env%quencher_r1_shift) + !! + !!almo_scf_env%quencher_r0_shift = cp_unit_to_cp2k(& + !! almo_scf_env%quencher_r0_shift,"angstrom") + !!almo_scf_env%quencher_r1_shift = cp_unit_to_cp2k(& + !! almo_scf_env%quencher_r1_shift,"angstrom") + ! + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_0",& + ! r_val=almo_scf_env%quencher_s0) + !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_1",& + ! r_val=almo_scf_env%quencher_s1) + + !CALL section_vals_val_get(almo_scf_section,"ENVELOPE_AMPLITUDE",& + ! r_val=almo_scf_env%envelope_amplitude) + + !! how to read lists + !CALL section_vals_val_get(almo_scf_section,"INT_LIST01", & + ! n_rep_val=n_rep) + !counter_i = 0 + !DO k = 1,n_rep + ! CALL section_vals_val_get(almo_scf_section,"INT_LIST01",& + ! i_rep_val=k,i_vals=tmplist) + ! DO jj = 1,SIZE(tmplist) + ! counter_i=counter_i+1 + ! almo_scf_env%charge_of_domain(counter_i)=tmplist(jj) + ! ENDDO + !ENDDO + almo_scf_env%domain_layout_aos = almo_domain_layout_molecular almo_scf_env%domain_layout_mos = almo_domain_layout_molecular almo_scf_env%mat_distr_aos = almo_mat_distr_molecular diff --git a/src/almo_scf_methods.F b/src/almo_scf_methods.F index 67c4a367cf..fdcc864590 100644 --- a/src/almo_scf_methods.F +++ b/src/almo_scf_methods.F @@ -1620,9 +1620,8 @@ CONTAINS my_algorithm = 0 IF (PRESENT(algorithm)) my_algorithm = algorithm - IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) THEN + IF (my_algorithm == 1 .AND. (.NOT. PRESENT(para_env) .OR. .NOT. PRESENT(blacs_env))) & CPABORT("PARA and BLACS env are necessary for cholesky algorithm") - END IF use_sigma_inv_guess = .FALSE. IF (PRESENT(use_guess)) THEN @@ -2093,6 +2092,7 @@ CONTAINS ALLOCATE (subm_in(ndomains)) ALLOCATE (subm_temp(ndomains)) ALLOCATE (subm_out(ndomains)) + !!!TRIM ALLOCATE(subm_trimmer(ndomains)) CALL init_submatrices(subm_in) CALL init_submatrices(subm_temp) CALL init_submatrices(subm_out) @@ -2100,6 +2100,11 @@ CONTAINS CALL construct_submatrices(matrix_in, subm_in, & dpattern, map, node_of_domain, select_row) + !!!TRIM IF (matrix_trimmer_required) THEN + !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& + !!!TRIM dpattern,map,node_of_domain,select_row) + !!!TRIM ENDIF + IF (my_action == 0) THEN ! for example, apply preconditioner CALL multiply_submatrices('N', 'N', 1.0_dp, operator1, & @@ -2252,10 +2257,16 @@ CONTAINS ALLOCATE (subm_main(ndomains)) CALL init_submatrices(subm_main) + !!!TRIM ALLOCATE(subm_trimmer(ndomains)) CALL construct_submatrices(matrix_main, subm_main, & dpattern, map, node_of_domain, select_row_col) + !!!TRIM IF (matrix_trimmer_required) THEN + !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& + !!!TRIM dpattern,map,node_of_domain,select_row) + !!!TRIM ENDIF + IF (my_action == -1) THEN ! project out the local occupied space !tmp=MATMUL(subm_r(idomain)%mdata,Minv) @@ -2304,9 +2315,38 @@ CONTAINS END DO naos = subm_main(idomain)%nrows + !WRITE(*,*) "Domain, mo_self_and_neig, ao_domain: ", idomain, n_domain_mos, naos ALLOCATE (Minv(naos, naos)) + !!!TRIM IF (my_use_trimmer) THEN + !!!TRIM ! THIS IS SUPER EXPENSIVE (ELIMINATE) + !!!TRIM ! trim the main matrix before inverting + !!!TRIM ! assume that the trimmer columns are different (i.e. the main matrix is different for each MO) + !!!TRIM allocate(tmp(naos,nmos(idomain))) + !!!TRIM DO ii=1, nmos(idomain) + !!!TRIM ! transform the main matrix using the trimmer for the current MO + !!!TRIM DO jj=1, naos + !!!TRIM DO kk=1, naos + !!!TRIM Mstore(jj,kk)=sumb_main(idomain)%mdata(jj,kk)*& + !!!TRIM subm_trimmer(idomain)%mdata(jj,ii)*& + !!!TRIM subm_trimmer(idomain)%mdata(kk,ii) + !!!TRIM ENDDO + !!!TRIM ENDDO + !!!TRIM ! invert the main matrix (exclude some eigenvalues, shift some) + !!!TRIM CALL pseudo_invert_matrix(A=Mstore,Ainv=Minv,N=naos,method=1,& + !!!TRIM !range1_thr=1.0E-9_dp,range2_thr=1.0E-9_dp,& + !!!TRIM shift=1.0E-5_dp,& + !!!TRIM range1=nmos(idomain),range2=nmos(idomain),& + !!!TRIM + !!!TRIM ! apply the inverted matrix + !!!TRIM ! RZK-warning this is only possible when the preconditioner is applied + !!!TRIM tmp(:,ii)=MATMUL(Minv,subm_in(idomain)%mdata(:,ii)) + !!!TRIM ENDDO + !!!TRIM subm_out=MATMUL(tmp,sigma) + !!!TRIM deallocate(tmp) + !!!TRIM ELSE + IF (PRESENT(bad_modes_projector_down)) THEN ALLOCATE (proj_array(naos, naos)) CALL pseudo_invert_matrix(A=subm_main(idomain)%mdata, Ainv=Minv, N=naos, method=1, & @@ -2320,6 +2360,7 @@ CONTAINS CALL pseudo_invert_matrix(A=subm_main(idomain)%mdata, Ainv=Minv, N=naos, method=1, & range1=nmos(idomain), range2=n_domain_mos) END IF + !!!TRIM ENDIF CALL copy_submatrices(subm_main(idomain), preconditioner(idomain), .FALSE.) CALL copy_submatrix_data(Minv, preconditioner(idomain)) @@ -2594,6 +2635,24 @@ CONTAINS unit_nr = -1 END IF + !CALL dpotrf('L', N, Ainv, N, INFO ) + !IF( INFO/=0 ) THEN + ! CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) + !END IF + !CALL dpotri('L', N, Ainv, N, INFO ) + !IF( INFO/=0 ) THEN + ! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) + !END IF + !! complete the matrix + !DO ii=1,N + ! DO jj=ii+1,N + ! Ainv(ii,jj)=Ainv(jj,ii) + ! ENDDO + ! !WRITE(*,'(100F13.9)') Ainv(ii,:) + !ENDDO + ! diagonalize first ALLOCATE (eigenvalues(N)) ! Query the optimal workspace for dsyev @@ -2630,6 +2689,21 @@ CONTAINS DEALLOCATE (eigenvalues) +!!! ! compute the error +!!! allocate(test(N,N)) +!!! test=MATMUL(Ainv,A) +!!! DO ii=1,N +!!! test(ii,ii)=test(ii,ii)-1.0_dp +!!! ENDDO +!!! test_error=0.0_dp +!!! DO ii=1,N +!!! DO jj=1,N +!!! test_error=test_error+test(jj,ii)*test(jj,ii) +!!! ENDDO +!!! ENDDO +!!! WRITE(*,*) "Inversion error: ", SQRT(test_error) +!!! deallocate(test) + CALL timestop(handle) END SUBROUTINE matrix_sqrt @@ -2842,6 +2916,21 @@ CONTAINS END SELECT + !! compute the inversion error + !allocate(temp1(N,N)) + !temp1=MATMUL(Ainv,A) + !DO ii=1,N + ! temp1(ii,ii)=temp1(ii,ii)-1.0_dp + !ENDDO + !temp1_error=0.0_dp + !DO ii=1,N + ! DO jj=1,N + ! temp1_error=temp1_error+temp1(jj,ii)*temp1(jj,ii) + ! ENDDO + !ENDDO + !WRITE(*,*) "Inversion error: ", SQRT(temp1_error) + !deallocate(temp1) + CALL timestop(handle) END SUBROUTINE pseudo_invert_matrix diff --git a/src/almo_scf_optimizer.F b/src/almo_scf_optimizer.F index 8325511ab0..b516dcac0c 100644 --- a/src/almo_scf_optimizer.F +++ b/src/almo_scf_optimizer.F @@ -72,7 +72,8 @@ MODULE almo_scf_optimizer ct_step_env_init,& ct_step_env_set,& ct_step_env_type - USE domain_submatrix_methods, ONLY: construct_submatrices,& + USE domain_submatrix_methods, ONLY: add_submatrices,& + construct_submatrices,& copy_submatrices,& init_submatrices,& maxnorm_submatrices,& @@ -225,11 +226,11 @@ CONTAINS ! get error_norm: choose the largest of the two spins prev_error_norm = error_norm DO ispin = 1, nspin + !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm_ispin = dbcsr_maxabs(almo_scf_env%matrix_err_blk(ispin)) IF (ispin == 1) error_norm = error_norm_ispin - IF (ispin > 1 .AND. error_norm_ispin > error_norm) THEN + IF (ispin > 1 .AND. error_norm_ispin > error_norm) & error_norm = error_norm_ispin - END IF END DO IF (error_norm < almo_scf_env%eps_prev_guess) THEN @@ -252,9 +253,8 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) THEN + IF (optimizer%early_stopping_on .AND. iscf == 1) & prepare_to_exit = .FALSE. - END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix @@ -294,7 +294,21 @@ CONTAINS local_nocc_of_domain(:) = almo_scf_env%nocc_of_domain(:, ispin) local_mu(:) = almo_scf_env%mu_of_domain(:, ispin) + ! RZK UPDATE! the update algorithm is removed because + ! RZK UPDATE! it requires updating core LS_SCF routines + ! RZK UPDATE! (the code exists in the CVS version) CPABORT("Density_matrix_sign has not been tested yet") + ! RZK UPDATE! CALL density_matrix_sign(almo_scf_env%matrix_p_blk(ispin),& + ! RZK UPDATE! local_mu,& + ! RZK UPDATE! almo_scf_env%fixed_mu,& + ! RZK UPDATE! almo_scf_env%matrix_ks_blk(ispin),& + ! RZK UPDATE! !matrix_mixing_old_blk(ispin),& + ! RZK UPDATE! almo_scf_env%matrix_s_blk(1), & + ! RZK UPDATE! almo_scf_env%matrix_s_blk_inv(1), & + ! RZK UPDATE! local_nocc_of_domain,& + ! RZK UPDATE! almo_scf_env%eps_filter,& + ! RZK UPDATE! almo_scf_env%domain_index_of_ao) + ! RZK UPDATE! almo_scf_env%mu_of_domain(:, ispin) = local_mu(:) END DO @@ -483,6 +497,13 @@ CONTAINS dpattern=almo_scf_env%quench_t(ispin), & map=almo_scf_env%domain_map(ispin), & node_of_domain=almo_scf_env%cpu_of_domain) + ! TRY: construct s_inv + !CALL construct_domain_s_inv(& + ! matrix_s=almo_scf_env%matrix_s(1),& + ! subm_s_inv=almo_scf_env%domain_s_inv(:,ispin),& + ! dpattern=almo_scf_env%quench_t(ispin),& + ! map=almo_scf_env%domain_map(ispin),& + ! node_of_domain=almo_scf_env%cpu_of_domain) ! construct the domain template for the occupied orbitals DO ispin = 1, nspin @@ -503,6 +524,27 @@ CONTAINS CALL init_submatrices(submatrix_mixing_old_blk) ALLOCATE (almo_diis(nspin)) + ! TRY: construct block-projector + !ALLOCATE(submatrix_tmp(almo_scf_env%ndomains)) + !DO ispin=1,nspin + ! CALL init_submatrices(submatrix_tmp) + ! CALL construct_domain_r_down(& + ! matrix_t=almo_scf_env%matrix_t_blk(ispin),& + ! matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& + ! matrix_s=almo_scf_env%matrix_s(1),& + ! subm_r_down=submatrix_tmp(:),& + ! dpattern=almo_scf_env%quench_t(ispin),& + ! map=almo_scf_env%domain_map(ispin),& + ! node_of_domain=almo_scf_env%cpu_of_domain,& + ! filter_eps=almo_scf_env%eps_filter) + ! CALL multiply_submatrices('N','N',1.0_dp,& + ! submatrix_tmp(:),& + ! almo_scf_env%domain_s_inv(:,1),0.0_dp,& + ! almo_scf_env%domain_r_down_up(:,ispin)) + ! CALL release_submatrices(submatrix_tmp) + !ENDDO + !DEALLOCATE(submatrix_tmp) + DO ispin = 1, nspin ! use s_sqrt since they are already properly constructed ! and have the same distributions as domain_err and domain_ks_xx @@ -536,6 +578,7 @@ CONTAINS ! check convergence converged = .TRUE. DO ispin = 1, nspin + !error_norm=dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) error_norm = dbcsr_maxabs(almo_scf_env%matrix_err_xx(ispin)) CALL maxnorm_submatrices(almo_scf_env%domain_err(:, ispin), & norm=error_norm_0) @@ -553,18 +596,28 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf == 1) THEN + IF (optimizer%early_stopping_on .AND. iscf == 1) & prepare_to_exit = .FALSE. - END IF IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix ! perform mixing of KS matrices IF (iscf /= 1) THEN - DO ispin = 1, nspin - CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & - d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) - END DO + IF (.FALSE.) THEN ! use diis instead of mixing + DO ispin = 1, nspin + CALL add_submatrices( & + almo_scf_env%mixing_fraction, & + almo_scf_env%domain_ks_xx(:, ispin), & + 1.0_dp - almo_scf_env%mixing_fraction, & + submatrix_mixing_old_blk(:, ispin), & + 'N') + END DO + ELSE + DO ispin = 1, nspin + CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & + d_extr_var=almo_scf_env%domain_ks_xx(:, ispin)) + END DO + END IF END IF ! save the new matrix for the future mixing DO ispin = 1, nspin @@ -641,6 +694,64 @@ CONTAINS denergy_tot = denergy_tot + denergy_spin(ispin) + ! RZK-warning Energy correction can be evaluated using matrix_x + ! as shown in the attempt below and in the PCG procedure. + ! Using matrix_x allows immediate decomposition of the energy + ! lowering into 2-body components for EDA. However, it does not + ! work here because the diagonalization routine does not necessarily + ! produce orbitals with the same sign as the block-diagonal ALMOs + ! Any fixes?! + + !CALL dbcsr_init(matrix_x) + !CALL dbcsr_create(matrix_x,& + ! template=almo_scf_env%matrix_t(ispin)) + ! + !CALL dbcsr_init(matrix_tmp_no) + !CALL dbcsr_create(matrix_tmp_no,& + ! template=almo_scf_env%matrix_t(ispin)) + ! + !CALL dbcsr_copy(matrix_x,& + ! almo_scf_env%matrix_t_blk(ispin)) + !CALL dbcsr_add(matrix_x,almo_scf_env%matrix_t(ispin),& + ! -1.0_dp,1.0_dp) + + !CALL dbcsr_dot(matrix_x, almo_scf_env%matrix_err_xx(ispin),denergy) + + !denergy=denergy*spin_factor + + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "_ENERGY-0: ", almo_scf_env%almo_scf_energy + ! WRITE(unit_nr,*) "_ENERGY-D: ", denergy + ! WRITE(unit_nr,*) "_ENERGY-F: ", almo_scf_env%almo_scf_energy+denergy + !ENDIF + !! RZK-warning update will not work since the energy is overwritten almost immediately + !!CALL almo_scf_update_ks_energy(qs_env,& + !! almo_scf_env%almo_scf_energy+denergy) + !! + + !! print out the results of the decomposition analysis + !CALL dbcsr_hadamard_product(matrix_x,& + ! almo_scf_env%matrix_err_xx(ispin),& + ! matrix_tmp_no) + !CALL dbcsr_scale(matrix_tmp_no,spin_factor) + !CALL dbcsr_filter(matrix_tmp_no,almo_scf_env%eps_filter) + ! + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) + ! WRITE(unit_nr,'(T2,A)') "DECOMPOSITION OF THE DELOCALIZATION ENERGY" + !ENDIF + + !mynode=dbcsr_mp_mynode(dbcsr_distribution_mp(& + ! dbcsr_distribution(matrix_tmp_no))) + !WRITE(mynodestr,'(I6.6)') mynode + !mylogfile='EDA.'//TRIM(ADJUSTL(mynodestr)) + !OPEN (iunit,file=mylogfile,status='REPLACE') + !CALL print_block_sum(matrix_tmp_no,iunit) + !CLOSE(iunit) + ! + !CALL dbcsr_release(matrix_tmp_no) + !CALL dbcsr_release(matrix_x) + END IF ! iscf.eq.1 END DO @@ -844,11 +955,13 @@ CONTAINS eps_skip_gradients = almo_scf_env%real01 ! penalty amplitude adjusts the strength of volume conservation - energy_coeff = 1.0_dp - localiz_coeff = 0.0_dp - penalty_amplitude = 0.0_dp - penalty_occ_vol = .FALSE. - penalty_occ_local = .FALSE. + energy_coeff = 1.0_dp !optimizer%opt_penalty%energy_coeff + localiz_coeff = 0.0_dp !optimizer%opt_penalty%occ_loc_coeff + penalty_amplitude = 0.0_dp !optimizer%opt_penalty%occ_vol_coeff + penalty_occ_vol = .FALSE. !( optimizer%opt_penalty%occ_vol_method & + !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) + penalty_occ_local = .FALSE. !( optimizer%opt_penalty%occ_loc_method & + !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) normalize_orbitals = penalty_occ_vol .OR. penalty_occ_local ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) ALLOCATE (penalty_occ_vol_h_prefactor(nspins)) @@ -1209,6 +1322,9 @@ CONTAINS DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im + !CALL matrix_qs_to_almo(op_sm_set_qs(reim, idim0)%matrix, + ! op_sm_set_almo(reim, idim0)%matrix, & + ! almo_scf_env%mat_distr_aos) CALL dbcsr_multiply("N", "N", 1.0_dp, & op_sm_set_almo(reim, idim0)%matrix, & matrix_t_out(ispin), & @@ -1263,9 +1379,8 @@ CONTAINS ! save the previous gradient to compute beta ! do it only if the previous grad was computed ! for .NOT.line_search - IF (line_search_iteration == 0 .AND. iteration /= 0) THEN + IF (line_search_iteration == 0 .AND. iteration /= 0) & CALL dbcsr_copy(prev_grad(ispin), grad(ispin)) - END IF END DO ! ispin @@ -1379,13 +1494,11 @@ CONTAINS prepare_to_exit = .TRUE. END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. just_started) THEN + IF (optimizer%early_stopping_on .AND. just_started) & prepare_to_exit = .FALSE. - END IF - IF (grad_norm < almo_scf_env%eps_prev_guess) THEN + IF (grad_norm < almo_scf_env%eps_prev_guess) & use_guess = .TRUE. - END IF ! it is not time to exit just yet IF (.NOT. prepare_to_exit) THEN @@ -1467,6 +1580,10 @@ CONTAINS ! update the step direction IF (.NOT. line_search) THEN + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....updating step direction...." + !ENDIF + cg_iteration = cg_iteration + 1 ! save the previous step @@ -1546,6 +1663,10 @@ CONTAINS END DO ! ispin END IF ! compute_prec + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....applying precomputed preconditioner...." + !ENDIF + IF (my_special_case == xalmo_case_block_diag .OR. & my_special_case == xalmo_case_fully_deloc) THEN @@ -1579,6 +1700,16 @@ CONTAINS filter_eps=almo_scf_env%eps_filter) CALL dbcsr_scale(step(ispin), -1.0_dp) + !CALL dbcsr_copy(m_tmp_no_3,& + ! quench_t(ispin)) + !CALL inverse_of_elements(m_tmp_no_3) + !CALL dbcsr_copy(m_tmp_no_2,step) + !CALL dbcsr_hadamard_product(& + ! m_tmp_no_2,& + ! m_tmp_no_3,& + ! step) + !CALL dbcsr_copy(m_tmp_no_3,quench_t(ispin)) + END DO ! ispin END IF ! special case @@ -1631,6 +1762,10 @@ CONTAINS CALL dbcsr_copy(prev_minus_prec_grad(ispin), step(ispin)) + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....final beta....", beta + !ENDIF + ! conjugate the step direction CALL dbcsr_add(step(ispin), prev_step(ispin), 1.0_dp, beta) @@ -1659,6 +1794,10 @@ CONTAINS step_size = next_step_size_guess*1.05_dp END IF END IF + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,3F12.5)') & + ! "EG", e0, g0, step_size + !ENDIF next_step_size_guess = step_size ELSE IF (fixed_line_search_niter == 0) THEN @@ -1671,6 +1810,10 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,7F12.5)') & + ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der + !ENDIF step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -1681,6 +1824,11 @@ CONTAINS e1 = energy_new appr_sec_der = 2.0*((e1 - e0)/step_size - g0)/step_size g1 = appr_sec_der*step_size + g0 + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,7F12.5)') & + ! "EG", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der + !ENDIF + !appr_sec_der=(g1-g0)/step_size step_size = -g1/appr_sec_der e0 = e1 g0 = g1 @@ -1996,7 +2144,7 @@ CONTAINS ALLOCATE (m_B0(1, dim_op, nspins)) !m_B0 first dim is 1 now! DO idim0 = 1, dim_op - DO reim = 1, 1 + DO reim = 1, 1 !SIZE(op_sm_set_qs, 1) DO ispin = 1, nspins CALL dbcsr_create(m_B0(reim, idim0, ispin), & template=m_theta(ispin), & @@ -2010,6 +2158,8 @@ CONTAINS ! penalty amplitude adjusts the strenght of volume conservation penalty_amplitude = optimizer%opt_penalty%penalty_strength + !penalty_occ_vol = ( optimizer%opt_penalty%occ_vol_method /= penalty_type_none ) + !penalty_local = ( optimizer%opt_penalty%occ_loc_method /= penalty_type_none ) ! preconditioner control prec_type = optimizer%preconditioner @@ -2303,6 +2453,7 @@ CONTAINS DO ispin = 1, nspins CALL compute_obj_nlmos( & + !obj_function_ispin=obj_function_ispin, & localization_obj_function_ispin=localization_obj_function_ispin, & penalty_func_ispin=penalty_func_ispin, & overlap_determinant=overlap_determinant, & @@ -2479,6 +2630,30 @@ CONTAINS ! TODO: write preconditioner code later ! For now, create matrix filled with 1.0 here CALL fill_matrix_with_ones(approx_inv_hessian(ispin)) + !CALL compute_preconditioner(& + ! m_prec_out=approx_hessian(ispin),& + ! m_ks=almo_scf_env%matrix_ks(ispin),& + ! m_s=matrix_s,& + ! m_siginv=almo_scf_env%template_matrix_sigma(ispin),& + ! m_quench_t=quench_t(ispin),& + ! m_FTsiginv=FTsiginv(ispin),& + ! m_siginvTFTsiginv=siginvTFTsiginv(ispin),& + ! m_ST=ST(ispin),& + ! para_env=almo_scf_env%para_env,& + ! blacs_env=almo_scf_env%blacs_env,& + ! nocc_of_domain=almo_scf_env%nocc_of_domain(:,ispin),& + ! domain_s_inv=almo_scf_env%domain_s_inv(:,ispin),& + ! domain_r_down=domain_r_down(:,ispin),& + ! cpu_of_domain=almo_scf_env%cpu_of_domain,& + ! domain_map=almo_scf_env%domain_map(ispin),& + ! assume_t0_q0x=assume_t0_q0x,& + ! penalty_occ_vol=penalty_occ_vol,& + ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin),& + ! eps_filter=eps_filter,& + ! neg_thr=0.5_dp,& + ! spin_factor=spin_factor,& + ! special_case=my_special_case) + !CALL invert hessian END DO ! ispin END IF @@ -2637,14 +2812,18 @@ CONTAINS ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size + !IF (unit_nr > 0) THEN + ! WRITE (unit_nr, '(A2,7F12.5)') & + ! "DT", e0, e1, g0, g1, appr_sec_der, step_size, -g1/appr_sec_der + !ENDIF step_size = -g1/appr_sec_der ELSE IF (linear_search_type == 2) THEN ! alternative method for finding step size ! do not use quadratic approximation, only gradient signs IF (g1sign /= g0sign) THEN - step_size = -step_size/2.0 + step_size = -step_size/2.0; ELSE - step_size = step_size*1.5 + step_size = step_size*1.5; END IF END IF ! end alternative LS types @@ -3247,6 +3426,7 @@ CONTAINS proj_in_template=almo_scf_env%matrix_ov(ispin), & eps_filter=almo_scf_env%eps_filter, & sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin)) + !sig_inv_template=almo_scf_env%matrix_sigma_inv(ispin),& ! save initial retained virtuals CALL dbcsr_create(vr_fixed, & @@ -3279,6 +3459,17 @@ CONTAINS ! project retained virtuals out of discarded block-by-block ! (1-Q^VR_ALMO)|ALMO_vd> ! this is probably not necessary, do it just to be safe + !CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin),& + ! psi_out=almo_scf_env%matrix_v_disc(ispin),& + ! psi_projector=almo_scf_env%matrix_v_blk(ispin),& + ! metric=almo_scf_env%matrix_s_blk(1),& + ! project_out=.TRUE.,& + ! psi_projector_orthogonal=.FALSE.,& + ! proj_in_template=almo_scf_env%matrix_k_tr(ispin),& + ! eps_filter=almo_scf_env%eps_filter,& + ! sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin)) + !CALL dbcsr_copy(almo_scf_env%matrix_v_disc_blk(ispin),& + ! almo_scf_env%matrix_v_disc(ispin)) ! construct discarded virtuals (1-R)|ALMO_vd> CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin), & @@ -3301,11 +3492,57 @@ CONTAINS CALL dbcsr_create(k_vr_index_down, & template=almo_scf_env%matrix_sigma_vv_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_copy(k_vr_index_down,& + ! almo_scf_env%matrix_sigma_vv_blk(ispin)) + + !CALL get_overlap(bra=almo_scf_env%matrix_v_blk(ispin),& + ! ket=almo_scf_env%matrix_v_blk(ispin),& + ! overlap=k_vr_index_down,& + ! metric=almo_scf_env%matrix_s_blk(1),& + ! retain_overlap_sparsity=.FALSE.,& + ! eps_filter=almo_scf_env%eps_filter) !! create the up metric in the discarded k-subspace CALL dbcsr_create(k_vd_index_down, & template=almo_scf_env%matrix_vv_disc_blk(ispin), & matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_init(k_vd_index_up) + !CALL dbcsr_create(k_vd_index_up,& + ! template=almo_scf_env%matrix_vv_disc_blk(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_copy(k_vd_index_down,& + ! almo_scf_env%matrix_vv_disc_blk(ispin)) + + !CALL get_overlap(bra=almo_scf_env%matrix_v_disc_blk(ispin),& + ! ket=almo_scf_env%matrix_v_disc_blk(ispin),& + ! overlap=k_vd_index_down,& + ! metric=almo_scf_env%matrix_s_blk(1),& + ! retain_overlap_sparsity=.FALSE.,& + ! eps_filter=almo_scf_env%eps_filter) + + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "Inverting blocked overlap matrix of discarded virtuals" + !ENDIF + !CALL invert_Hotelling(k_vd_index_up,& + ! k_vd_index_down,& + ! almo_scf_env%eps_filter) + !IF (safe_mode) THEN + ! CALL dbcsr_init(matrix_tmp1) + ! CALL dbcsr_create(matrix_tmp1,template=k_vd_index_down,& + ! matrix_type=dbcsr_type_no_symmetry) + ! CALL dbcsr_multiply("N","N",1.0_dp,k_vd_index_up,& + ! k_vd_index_down,& + ! 0.0_dp, matrix_tmp1,& + ! filter_eps=almo_scf_env%eps_filter) + ! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp1) + ! CALL dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) + ! frob_matrix=dbcsr_frobenius_norm(matrix_tmp1) + ! IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "Error for (inv(SIG)*SIG-I)",& + ! frob_matrix/frob_matrix_base + ! ENDIF + ! CALL dbcsr_release(matrix_tmp1) + !ENDIF ! init matrices necessary for optimization of truncated virts ! init blocked gradient before setting K to zero @@ -3369,6 +3606,15 @@ CONTAINS template=almo_scf_env%matrix_k_blk(ispin)) CALL dbcsr_set(prev_grad, 0.0_dp) + !CALL dbcsr_init(sigma_oo_guess) + !CALL dbcsr_create(sigma_oo_guess,& + ! template=almo_scf_env%matrix_sigma(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_set(sigma_oo_guess,0.0_dp) + !CALL dbcsr_add_on_diag(sigma_oo_guess,1.0_dp) + !CALL dbcsr_filter(sigma_oo_guess,almo_scf_env%eps_filter) + !CALL dbcsr_print(sigma_oo_guess) + END IF ! done constructing discarded virtuals ! init variables @@ -3406,6 +3652,9 @@ CONTAINS END IF ! decompose the overlap matrix of the current retained orbitals + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "decompose the active VV overlap matrix" + !ENDIF CALL get_overlap(bra=almo_scf_env%matrix_v(ispin), & ket=almo_scf_env%matrix_v(ispin), & overlap=almo_scf_env%matrix_sigma_vv(ispin), & @@ -3478,6 +3727,8 @@ CONTAINS CALL matrix_sqrt_Newton_Schulz(sigma_vv_sqrt, & sigma_vv_sqrt_inv, & almo_scf_env%matrix_sigma_vv(ispin), & + !matrix_sqrt_inv_guess=sigma_vv_sqrt_inv_guess,& + !matrix_sqrt_guess=sigma_vv_sqrt_guess,& threshold=almo_scf_env%eps_filter, & order=almo_scf_env%order_lanczos, & eps_lanczos=almo_scf_env%eps_lanczos, & @@ -3577,6 +3828,9 @@ CONTAINS +1.0_dp, +1.0_dp) ! calculate current occupied overlap + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "Inverting current occ overlap matrix" + !ENDIF CALL get_overlap(bra=t_curr, & ket=t_curr, & overlap=sigma_oo_curr, & @@ -3593,6 +3847,7 @@ CONTAINS sigma_oo_curr, & threshold=almo_scf_env%eps_filter, & use_inv_as_guess=.TRUE.) + !CALL dbcsr_copy(sigma_oo_guess,sigma_oo_curr_inv) END IF IF (safe_mode) THEN CALL dbcsr_create(matrix_tmp1, template=sigma_oo_curr, & @@ -3604,6 +3859,8 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) + !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) + !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (SIG*inv(SIG)-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3620,6 +3877,8 @@ CONTAINS frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1) CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp1) + !CALL dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) + !CALL dbcsr_print(matrix_tmp1) IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Error for (inv(SIG)*SIG-I)", & frob_matrix/frob_matrix_base, frob_matrix_base @@ -3682,6 +3941,7 @@ CONTAINS tmp1_n_vr, & 0.0_dp, grad, & retain_sparsity=.TRUE.) + !filter_eps=almo_scf_env%eps_filter,& ! keep tmp2_n_o for the next step ! keep tmp4_o_vr for the preconditioner @@ -3731,6 +3991,21 @@ CONTAINS IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Computing preconditioner" END IF + !CALL opt_k_create_preconditioner(prec,& + ! almo_scf_env%matrix_v_disc(ispin),& + ! almo_scf_env%matrix_ks_0deloc(ispin),& + ! almo_scf_env%matrix_x(ispin),& + ! tmp4_o_vr,& + ! almo_scf_env%matrix_s(1),& + ! grad,& + ! !almo_scf_env%matrix_v_disc_blk(ispin),& + ! vd_fixed,& + ! t_curr,& + ! k_vd_index_up,& + ! k_vr_index_down,& + ! tmp1_n_vr,& + ! spin_factor,& + ! almo_scf_env%eps_filter) CALL opt_k_create_preconditioner_blk(almo_scf_env, & almo_scf_env%matrix_v_disc(ispin), & tmp4_o_vr, & @@ -3746,6 +4021,7 @@ CONTAINS ! compute the new step CALL opt_k_apply_preconditioner_blk(almo_scf_env, & step, grad, ispin) + !CALL dbcsr_hadamard_product(prec,grad,step) CALL dbcsr_scale(step, -1.0_dp) ! check whether we need to reset conjugate directions @@ -3760,6 +4036,9 @@ CONTAINS ELSE ! check for the errors in the cg algorithm + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) CALL dbcsr_dot(grad, prev_minus_prec_grad, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) conjugacy_error = numer/denom @@ -3797,32 +4076,63 @@ CONTAINS CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_fletcher_reeves) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) + !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) beta = numer/denom CASE (cg_polak_ribiere) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(prev_grad,tmp_k_blk,denom) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_fletcher) + !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !CALL dbcsr_dot(prev_grad,prev_step,denom) + !beta=-1.0_dp*numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_dot(prev_grad, prev_step, denom) beta = numer/denom CASE (cg_liu_storey) CALL dbcsr_dot(prev_grad, prev_step, denom) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(tmp_k_blk,grad,numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, step, numer) beta = numer/denom CASE (cg_dai_yuan) + !CALL dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL dbcsr_dot(grad,tmp_k_blk,numer) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_dot(prev_grad,prev_step,denom) + !beta=numer/denom CALL dbcsr_dot(grad, step, numer) CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) beta = -1.0_dp*numer/denom CASE (cg_hager_zhang) + !CALL dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL dbcsr_dot(prev_grad,prev_step,denom) + !CALL dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL dbcsr_dot(tmp_k_blk,prev_grad,numer) + !kappa=2.0_dp*numer/denom + !CALL dbcsr_dot(tmp_k_blk,grad,numer) + !tau=numer/denom + !CALL dbcsr_dot(prev_step,grad,numer) + !beta=tau-kappa*numer/denom CALL dbcsr_copy(tmp_k_blk, grad) CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp) CALL dbcsr_dot(tmp_k_blk, prev_step, denom) @@ -3854,6 +4164,7 @@ CONTAINS IF (reset_conjugator) THEN beta = 0.0_dp + !reset_step_size=.TRUE. IF (unit_nr > 0) THEN WRITE (unit_nr, *) "(Re)-setting conjugator to zero" @@ -4079,11 +4390,13 @@ CONTAINS "K iter CG", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun0, line_search_error, beta, conjugacy_error, t2a - t1a + !(flop1+flop2)/(1.0E6_dp*(t2-t1)) ELSE WRITE (unit_nr, '(T6,A,1X,I3,1X,E12.3,F16.10,F16.10,E12.3,E12.3,E12.3,F8.3,F8.3,F10.3)') & "K iter LS", iteration, step_size, & energy_correction(ispin), delta_obj_function, grad_norm, & gfun1, line_search_error, beta, conjugacy_error, t2a - t1a + !(flop1+flop2)/(1.0E6_dp*(t2-t1)) END IF END IF CALL m_flush(unit_nr) @@ -4240,6 +4553,7 @@ CONTAINS IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN CALL dbcsr_release(k_vr_index_down) CALL dbcsr_release(k_vd_index_down) + !CALL dbcsr_release(k_vd_index_up) CALL dbcsr_release(matrix_k_central) CALL dbcsr_release(vr_fixed) CALL dbcsr_release(vd_fixed) @@ -4364,6 +4678,8 @@ CONTAINS ! just get the energy correction CALL ct_step_env_get(ct_step_env, & energy_correction=energy_correction(ispin)) + !copy_da_energy_matrix=matrix_eda(ispin),& + !copy_da_charge_matrix=matrix_cta(ispin),& CALL ct_step_env_clean(ct_step_env) @@ -4384,6 +4700,18 @@ CONTAINS END IF energy_correction_final = energy_correction_final + energy_correction(ispin) + !!! print out the results of decomposition analysis + !!IF (unit_nr>0) THEN + !! WRITE(unit_nr,*) + !! WRITE(unit_nr,'(T2,A)') "ENERGY DECOMPOSITION" + !!ENDIF + !!CALL print_block_sum(eda_matrix(ispin), unit_nr=6) + !!IF (unit_nr>0) THEN + !! WRITE(unit_nr,*) + !! WRITE(unit_nr,'(T2,A)') "CHARGE DECOMPOSITION" + !!ENDIF + !!CALL print_block_sum(cta_matrix(ispin), unit_nr=6) + ! obtain density matrix from updated MOs ! RZK-later sigma and sigma_inv are lost here CALL almo_scf_t_to_proj(t=almo_scf_env%matrix_t(ispin), & @@ -4403,10 +4731,9 @@ CONTAINS para_env=almo_scf_env%para_env, & blacs_env=almo_scf_env%blacs_env) - IF (almo_scf_env%nspins == 1) THEN + IF (almo_scf_env%nspins == 1) & CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) - END IF END DO @@ -4452,6 +4779,17 @@ CONTAINS END IF + DO ispin = 1, nspin + ! RZK-warning the preconditioner is very important + ! IF (.FALSE.) THEN + ! CALL apply_matrix_preconditioner(almo_scf_env%matrix_ks(ispin),& + ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& + ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) + ! ENDIF + !CALL dbcsr_filter(almo_scf_env%matrix_ks(ispin),& + ! almo_scf_env%eps_filter) + END DO + ALLOCATE (matrix_p_almo_scf_converged(nspin)) DO ispin = 1, nspin CALL dbcsr_create(matrix_p_almo_scf_converged(ispin), & @@ -4464,19 +4802,50 @@ CONTAINS DO ispin = 1, nspin nelectron_spin_real(1) = almo_scf_env%nelectrons_spin(ispin) - IF (almo_scf_env%nspins == 1) THEN + IF (almo_scf_env%nspins == 1) & nelectron_spin_real(1) = nelectron_spin_real(1)/2 - END IF local_mu(1) = SUM(almo_scf_env%mu_of_domain(:, ispin))/almo_scf_env%ndomains fake(1) = 123523 + ! RZK UPDATE! the update algorithm is removed because + ! RZK UPDATE! it requires updating core LS_SCF routines + ! RZK UPDATE! (the code exists in the CVS version) CPABORT("CVS only: density_matrix_sign has not been updated in SVN") + ! RZK UPDATE!CALL density_matrix_sign(almo_scf_env%matrix_p(ispin),& + ! RZK UPDATE! local_mu,& + ! RZK UPDATE! almo_scf_env%fixed_mu,& + ! RZK UPDATE! almo_scf_env%matrix_ks_0deloc(ispin),& + ! RZK UPDATE! almo_scf_env%matrix_s(1), & + ! RZK UPDATE! almo_scf_env%matrix_s_inv(1), & + ! RZK UPDATE! nelectron_spin_real,& + ! RZK UPDATE! almo_scf_env%eps_filter,& + ! RZK UPDATE! fake) + ! RZK UPDATE! + almo_scf_env%mu = local_mu(1) - IF (almo_scf_env%nspins == 1) THEN + !IF (almo_scf_env%has_s_preconditioner) THEN + ! CALL apply_matrix_preconditioner(& + ! almo_scf_env%matrix_p_blk(ispin),& + ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& + ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) + !ENDIF + !CALL dbcsr_filter(almo_scf_env%matrix_p(ispin),& + ! almo_scf_env%eps_filter) + + IF (almo_scf_env%nspins == 1) & CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), & spin_factor) - END IF + + !CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin),& + ! almo_scf_env%matrix_p(ispin),& + ! energy_correction(ispin)) + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) + ! WRITE(unit_nr,'(T2,A,I6,F20.9)') "EFAKE",ispin,& + ! energy_correction(ispin) + ! WRITE(unit_nr,*) + !ENDIF CALL dbcsr_add(matrix_p_almo_scf_converged(ispin), & almo_scf_env%matrix_p(ispin), -1.0_dp, 1.0_dp) CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin), & @@ -4589,6 +4958,13 @@ CONTAINS tmp1_n_vr, tmp2_n_vr, tmp_n_vd, & tmp_vd_vd_blk, tmp_vr_vr_blk +! init diag blocks outside +! init diag blocks otside +!INTEGER :: iblock_row, iblock_col,& +! nblkrows_tot, nblkcols_tot +!REAL(KIND=dp), DIMENSION(:, :), POINTER :: p_new_block +!INTEGER :: mynode, hold, row, col + CALL timeset(routineN, handle) ! initialize a matrix to 1.0 @@ -4986,6 +5362,562 @@ CONTAINS END SUBROUTINE opt_k_apply_preconditioner_blk +!! ************************************************************************************************** +!!> \brief Reduce the number of virtual orbitals by rotating them within +!!> a domain. The rotation is such that minimizes the frobenius norm of +!!> the Fov domain-blocks of the discarded virtuals +!!> \par History +!!> 2011.08 created [Rustam Z Khaliullin] +!!> \author Rustam Z Khaliullin +!! ************************************************************************************************** +! SUBROUTINE truncate_subspace_v_blk(qs_env,almo_scf_env) +! +! TYPE(qs_environment_type), POINTER :: qs_env +! TYPE(almo_scf_env_type) :: almo_scf_env +! +! CHARACTER(len=*), PARAMETER :: routineN = 'truncate_subspace_v_blk', & +! routineP = moduleN//':'//routineN +! +! INTEGER :: handle, ispin, iblock_row, & +! iblock_col, iblock_row_size, & +! iblock_col_size, retained_v, & +! iteration, line_search_step, & +! unit_nr, line_search_step_last +! REAL(KIND=dp) :: t1, obj_function, grad_norm,& +! c0, b0, a0, obj_function_new,& +! t2, alpha, ff1, ff2, step1,& +! step2,& +! frob_matrix_base,& +! frob_matrix +! LOGICAL :: safe_mode, converged, & +! prepare_to_exit, failure +! TYPE(cp_logger_type), POINTER :: logger +! TYPE(dbcsr_type) :: Fon, Fov, Fov_filtered, & +! temp1_oo, temp2_oo, Fov_original, & +! temp0_ov, U_blk_tot, U_blk, & +! grad_blk, step_blk, matrix_filter, & +! v_full_new,v_full_tmp,& +! matrix_sigma_vv_full,& +! matrix_sigma_vv_full_sqrt,& +! matrix_sigma_vv_full_sqrt_inv,& +! matrix_tmp1,& +! matrix_tmp2 +! +! REAL(kind=dp), DIMENSION(:, :), POINTER :: data_p, p_new_block +! TYPE(dbcsr_iterator_type) :: iter +! +! +!REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: eigenvalues, WORK +!REAL(kind=dp), DIMENSION(:,:), ALLOCATABLE :: data_copy, left_vectors, right_vectors +!INTEGER :: LWORK, INFO +!TYPE(dbcsr_type) :: temp_u_v_full_blk +! +! CALL timeset(routineN,handle) +! +! safe_mode=.TRUE. +! +! ! get a useful output_unit +! logger => cp_get_default_logger() +! IF (logger%para_env%is_source()) THEN +! unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) +! ELSE +! unit_nr=-1 +! ENDIF +! +! DO ispin=1,almo_scf_env%nspins +! +! t1 = m_walltime() +! +! !!!!!!!!!!!!!!!!! +! ! 0. Orthogonalize virtuals +! ! Unfortunately, we have to do it in the FULL V subspace :( +! +! CALL dbcsr_init(v_full_new) +! CALL dbcsr_create(v_full_new,& +! template=almo_scf_env%matrix_v_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! project the occupied subspace out +! CALL almo_scf_p_out_from_v(almo_scf_env%matrix_v_full_blk(ispin),& +! v_full_new,almo_scf_env%matrix_ov_full(ispin),& +! ispin,almo_scf_env) +! +! ! init overlap and its functions +! CALL dbcsr_init(matrix_sigma_vv_full) +! CALL dbcsr_init(matrix_sigma_vv_full_sqrt) +! CALL dbcsr_init(matrix_sigma_vv_full_sqrt_inv) +! CALL dbcsr_create(matrix_sigma_vv_full,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_create(matrix_sigma_vv_full_sqrt,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_create(matrix_sigma_vv_full_sqrt_inv,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! construct VV overlap +! CALL almo_scf_mo_to_sigma(v_full_new,& +! matrix_sigma_vv_full,& +! almo_scf_env%matrix_s(1),& +! almo_scf_env%eps_filter) +! +! IF (unit_nr>0) THEN +! WRITE(unit_nr,*) "sqrt and inv(sqrt) of the FULL virtual MO overlap" +! ENDIF +! +! ! construct orthogonalization matrices +! CALL matrix_sqrt_Newton_Schulz(matrix_sigma_vv_full_sqrt,& +! matrix_sigma_vv_full_sqrt_inv,& +! matrix_sigma_vv_full,& +! threshold=almo_scf_env%eps_filter,& +! order=almo_scf_env%order_lanczos,& +! eps_lanczos=almo_scf_env%eps_lanczos,& +! max_iter_lanczos=almo_scf_env%max_iter_lanczos) +! IF (safe_mode) THEN +! CALL dbcsr_init(matrix_tmp1) +! CALL dbcsr_create(matrix_tmp1,template=matrix_sigma_vv_full,& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_init(matrix_tmp2) +! CALL dbcsr_create(matrix_tmp2,template=matrix_sigma_vv_full,& +! matrix_type=dbcsr_type_no_symmetry) +! +! CALL dbcsr_multiply("N","N",1.0_dp,matrix_sigma_vv_full_sqrt_inv,& +! matrix_sigma_vv_full,& +! 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& +! matrix_sigma_vv_full_sqrt_inv,& +! 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) +! +! frob_matrix_base=dbcsr_frobenius_norm(matrix_tmp2) +! CALL dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) +! frob_matrix=dbcsr_frobenius_norm(matrix_tmp2) +! IF (unit_nr>0) THEN +! WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",frob_matrix/frob_matrix_base +! ENDIF +! +! CALL dbcsr_release(matrix_tmp1) +! CALL dbcsr_release(matrix_tmp2) +! ENDIF +! +! ! discard unnecessary overlap functions +! CALL dbcsr_release(matrix_sigma_vv_full) +! CALL dbcsr_release(matrix_sigma_vv_full_sqrt) +! +!! this can be re-written because we have (1-P)|v> +! +! !!!!!!!!!!!!!!!!!!! +! ! 1. Compute F_ov +! CALL dbcsr_init(Fon) +! CALL dbcsr_create(Fon,& +! template=almo_scf_env%matrix_v_full_blk(ispin)) +! CALL dbcsr_init(Fov) +! CALL dbcsr_create(Fov,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! CALL dbcsr_init(Fov_filtered) +! CALL dbcsr_create(Fov_filtered,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! CALL dbcsr_init(temp1_oo) +! CALL dbcsr_create(temp1_oo,& +! template=almo_scf_env%matrix_sigma(ispin),& +! !matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_init(temp2_oo) +! CALL dbcsr_create(temp2_oo,& +! template=almo_scf_env%matrix_sigma(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& +! almo_scf_env%matrix_ks_0deloc(ispin),& +! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& +! almo_scf_env%matrix_v_full_blk(ispin),& +! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& +! almo_scf_env%matrix_t_blk(ispin),& +! 0.0_dp,temp1_oo,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,temp1_oo,& +! almo_scf_env%matrix_sigma_inv(ispin),& +! 0.0_dp,temp2_oo,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_release(temp1_oo) +! +! CALL dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& +! almo_scf_env%matrix_s(1),& +! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fon,& +! almo_scf_env%matrix_v_full_blk(ispin),& +! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_release(Fon) +! +! CALL dbcsr_multiply("N","N",-1.0_dp,temp2_oo,& +! Fov_filtered,& +! 1.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_release(temp2_oo) +! +! CALL dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_sigma_inv(ispin),& +! Fov,0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_multiply("N","N",1.0_dp,Fov_filtered,& +! matrix_sigma_vv_full_sqrt_inv,& +! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! !CALL dbcsr_copy(Fov,Fov_filtered) +!CALL dbcsr_print(Fov) +! +! IF (safe_mode) THEN +! CALL dbcsr_init(Fov_original) +! CALL dbcsr_create(Fov_original,template=Fov) +! CALL dbcsr_copy(Fov_original,Fov) +! ENDIF +! +!!! remove diagonal blocks +!!CALL dbcsr_iterator_start(iter,Fov) +!!DO WHILE (dbcsr_iterator_blocks_left(iter)) +!! +!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +!! row_size=iblock_row_size,col_size=iblock_col_size) +!! +!! IF (iblock_row.eq.iblock_col) data_p(:,:)=0.0_dp +!! +!!ENDDO +!!CALL dbcsr_iterator_stop(iter) +!!CALL dbcsr_finalize(Fov) +! +!!! perform svd of blocks +!!!!! THIS ROUTINE WORKS ONLY ON ONE CPU AND ONLY FOR 2 MOLECULES !!! +!!CALL dbcsr_init(temp_u_v_full_blk) +!!CALL dbcsr_create(temp_u_v_full_blk,& +!! template=almo_scf_env%matrix_vv_full_blk(ispin),& +!! matrix_type=dbcsr_type_no_symmetry) +!! +!!CALL dbcsr_work_create(temp_u_v_full_blk,& +!! work_mutable=.TRUE.) +!!CALL dbcsr_iterator_start(iter,Fov) +!!DO WHILE (dbcsr_iterator_blocks_left(iter)) +!! +!! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +!! row_size=iblock_row_size,col_size=iblock_col_size) +!! +!! IF (iblock_row.ne.iblock_col) THEN +!! +!! ! Prepare data +!! allocate(eigenvalues(min(iblock_row_size,iblock_col_size))) +!! allocate(data_copy(iblock_row_size,iblock_col_size)) +!! allocate(left_vectors(iblock_row_size,iblock_row_size)) +!! allocate(right_vectors(iblock_col_size,iblock_col_size)) +!! data_copy(:,:)=data_p(:,:) +!! +!! ! Query the optimal workspace for dgesvd +!! LWORK = -1 +!! allocate(WORK(MAX(1,LWORK))) +!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& +!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& +!! right_vectors,iblock_col_size,WORK,LWORK,INFO) +!! LWORK = INT(WORK( 1 )) +!! deallocate(WORK) +!! +!! ! Allocate the workspace and perform svd +!! allocate(WORK(MAX(1,LWORK))) +!! CALL DGESVD('N','A',iblock_row_size,iblock_col_size,data_copy,& +!! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& +!! right_vectors,iblock_col_size,WORK,LWORK,INFO) +!! deallocate(WORK) +!! IF( INFO/=0 ) THEN +!! CPABORT("DGESVD failed") +!! END IF +!! +!! ! copy right singular vectors into a unitary matrix +!! CALL dbcsr_put_block(temp_u_v_full_blk,iblock_col,iblock_col,right_vectors) +!! +!! deallocate(eigenvalues) +!! deallocate(data_copy) +!! deallocate(left_vectors) +!! deallocate(right_vectors) +!! +!! ENDIF +!!ENDDO +!!CALL dbcsr_iterator_stop(iter) +!!CALL dbcsr_finalize(temp_u_v_full_blk) +!!!CALL dbcsr_print(temp_u_v_full_blk) +!!CALL dbcsr_multiply("N","T",1.0_dp,Fov,temp_u_v_full_blk,& +!! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +!! +!!CALL dbcsr_copy(Fov,Fov_filtered) +!!CALL dbcsr_print(Fov) +! +! !!!!!!!!!!!!!!!!!!! +! ! 2. Initialize variables +! +! ! temp space +! CALL dbcsr_init(temp0_ov) +! CALL dbcsr_create(temp0_ov,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! +! ! current unitary matrix +! CALL dbcsr_init(U_blk) +! CALL dbcsr_create(U_blk,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! unitary matrix accumulator +! CALL dbcsr_init(U_blk_tot) +! CALL dbcsr_create(U_blk_tot,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_add_on_diag(U_blk_tot,1.0_dp) +! +!!CALL dbcsr_add_on_diag(U_blk,1.0_dp) +!!CALL dbcsr_multiply("N","T",1.0_dp,U_blk,temp_u_v_full_blk,& +!! 0.0_dp,U_blk_tot,filter_eps=almo_scf_env%eps_filter) +!! +!!CALL dbcsr_release(temp_u_v_full_blk) +! +! ! init gradient +! CALL dbcsr_init(grad_blk) +! CALL dbcsr_create(grad_blk,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! init step matrix +! CALL dbcsr_init(step_blk) +! CALL dbcsr_create(step_blk,& +! template=almo_scf_env%matrix_vv_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! +! ! "retain discarded" filter (0.0 - retain, 1.0 - discard) +! CALL dbcsr_init(matrix_filter) +! CALL dbcsr_create(matrix_filter,& +! template=almo_scf_env%matrix_ov_full(ispin)) +! ! copy Fov into the filter matrix temporarily +! ! so we know which blocks contain significant elements +! CALL dbcsr_copy(matrix_filter,Fov) +! +! ! fill out filter elements block-by-block +! CALL dbcsr_iterator_start(iter,matrix_filter) +! DO WHILE (dbcsr_iterator_blocks_left(iter)) +! +! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +! row_size=iblock_row_size,col_size=iblock_col_size) +! +! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) +! +! data_p(:,1:retained_v)=0.0_dp +! data_p(:,(retained_v+1):iblock_col_size)=1.0_dp +! +! ENDDO +! CALL dbcsr_iterator_stop(iter) +! CALL dbcsr_finalize(matrix_filter) +! +! ! apply the filter +! CALL dbcsr_hadamard_product(Fov,matrix_filter,Fov_filtered) +! +! !!!!!!!!!!!!!!!!!!!!! +! ! 3. start iterative minimization of the elements to be discarded +! iteration=0 +! converged=.FALSE. +! prepare_to_exit=.FALSE. +! DO +! +! iteration=iteration+1 +! +! !!!!!!!!!!!!!!!!!!!!!!!!! +! ! 4. compute the gradient +! CALL dbcsr_set(grad_blk,0.0_dp) +! ! create the diagonal blocks only +! CALL dbcsr_add_on_diag(grad_blk,1.0_dp) +! +! CALL dbcsr_multiply("T","N",2.0_dp,Fov_filtered,Fov,& +! 0.0_dp,grad_blk,retain_sparsity=.TRUE.,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_multiply("T","N",-2.0_dp,Fov,Fov_filtered,& +! 1.0_dp,grad_blk,retain_sparsity=.TRUE.,& +! filter_eps=almo_scf_env%eps_filter) +! +! !!!!!!!!!!!!!!!!!!!!!!! +! ! 5. check convergence +! obj_function = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 +! grad_norm = dbcsr_frobenius_norm(grad_blk) +! converged=(grad_norm.lt.almo_scf_env%truncate_v_eps_convergence) +! IF (converged.OR.(iteration.ge.almo_scf_env%truncate_v_max_iter)) THEN +! prepare_to_exit=.TRUE. +! ENDIF +! +! IF (.NOT.prepare_to_exit) THEN +! +! !!!!!!!!!!!!!!!!!!!!!!! +! ! 6. perform steps in the direction of the gradient +! ! a. first, perform a trial step to "see" the parameters +! ! of the parabola along the gradient: +! ! a0 * x^2 + b0 * x + c0 +! ! b. then perform the step to the bottom of the parabola +! +! ! get c0 +! c0 = obj_function +! ! get b0 <= d_f/d_alpha along grad +! !!!CALL dbcsr_multiply("N","N",4.0_dp,Fov,grad_blk,& +! !!! 0.0_dp,temp0_ov,& +! !!! filter_eps=almo_scf_env%eps_filter) +! !!!CALL dbcsr_dot(Fov_filtered,temp0_ov,b0) +! +! alpha=almo_scf_env%truncate_v_trial_step_size +! +! line_search_step_last=3 +! DO line_search_step=1,line_search_step_last +! CALL dbcsr_copy(step_blk,grad_blk) +! CALL dbcsr_scale(step_blk,-1.0_dp*alpha) +! CALL generator_to_unitary(step_blk,U_blk,& +! almo_scf_env%eps_filter) +! CALL dbcsr_multiply("N","N",1.0_dp,Fov,U_blk,0.0_dp,temp0_ov,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& +! Fov_filtered) +! +! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 +! IF (line_search_step.eq.1) THEN +! ff1 = obj_function_new +! step1 = alpha +! ELSE IF (line_search_step.eq.2) THEN +! ff2 = obj_function_new +! step2 = alpha +! ENDIF +! +! IF (unit_nr>0.AND.(line_search_step.ne.line_search_step_last)) THEN +! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3)') & +! "JOINT_SVD_lin",& +! iteration,& +! alpha,& +! obj_function,& +! obj_function_new,& +! obj_function_new-obj_function +! ENDIF +! +! IF (line_search_step.eq.1) THEN +! alpha=2.0_dp*alpha +! ENDIF +! IF (line_search_step.eq.2) THEN +! a0 = ((ff1-c0)/step1 - (ff2-c0)/step2) / (step1 - step2) +! b0 = (ff1-c0)/step1 - a0*step1 +! ! step size in to the bottom of "the parabola" +! alpha=-b0/(2.0_dp*a0) +! ! update the default step size +! almo_scf_env%truncate_v_trial_step_size=alpha +! ENDIF +! !!!IF (line_search_step.eq.1) THEN +! !!! a0 = (obj_function_new - b0 * alpha - c0) / (alpha*alpha) +! !!! ! step size in to the bottom of "the parabola" +! !!! alpha=-b0/(2.0_dp*a0) +! !!! !IF (alpha.gt.10.0_dp) alpha=10.0_dp +! !!!ENDIF +! +! ENDDO +! +! ! update Fov and U_blk_tot (use grad_blk as tmp storage) +! CALL dbcsr_copy(Fov,temp0_ov) +! CALL dbcsr_multiply("N","N",1.0_dp,U_blk_tot,U_blk,& +! 0.0_dp,grad_blk,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_copy(U_blk_tot,grad_blk) +! +! ENDIF +! +! t2 = m_walltime() +! +! IF (unit_nr>0) THEN +! WRITE(unit_nr,'(T6,A,1X,I3,1X,F10.3,E12.3,E12.3,E12.3,E12.3,F10.3)') & +! "JOINT_SVD_itr",& +! iteration,& +! alpha,& +! obj_function,& +! obj_function_new,& +! obj_function_new-obj_function,& +! grad_norm,& +! t2-t1 +! !(flop1+flop2)/(1.0E6_dp*(t2-t1)) +! CALL m_flush(unit_nr) +! ENDIF +! +! t1 = m_walltime() +! +! IF (prepare_to_exit) EXIT +! +! ENDDO ! stop iterations +! +! IF (safe_mode) THEN +! CALL dbcsr_multiply("N","N",1.0_dp,Fov_original,& +! U_blk_tot,0.0_dp,temp0_ov,& +! filter_eps=almo_scf_env%eps_filter) +!CALL dbcsr_print(temp0_ov) +! CALL dbcsr_hadamard_product(temp0_ov,matrix_filter,& +! Fov_filtered) +! obj_function_new = 0.5_dp*(dbcsr_frobenius_norm(Fov_filtered))**2 +! +! IF (unit_nr>0) THEN +! WRITE(unit_nr,'(T6,A,1X,E12.3)') & +! "SANITY CHECK:",& +! obj_function_new +! CALL m_flush(unit_nr) +! ENDIF +! +! CALL dbcsr_release(Fov_original) +! ENDIF +! +! CALL dbcsr_release(temp0_ov) +! CALL dbcsr_release(U_blk) +! CALL dbcsr_release(grad_blk) +! CALL dbcsr_release(step_blk) +! CALL dbcsr_release(matrix_filter) +! CALL dbcsr_release(Fov) +! CALL dbcsr_release(Fov_filtered) +! +! ! compute rotated virtual orbitals +! CALL dbcsr_init(v_full_tmp) +! CALL dbcsr_create(v_full_tmp,& +! template=almo_scf_env%matrix_v_full_blk(ispin),& +! matrix_type=dbcsr_type_no_symmetry) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! v_full_new,& +! matrix_sigma_vv_full_sqrt_inv,0.0_dp,v_full_tmp,& +! filter_eps=almo_scf_env%eps_filter) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! v_full_tmp,& +! U_blk_tot,0.0_dp,v_full_new,& +! filter_eps=almo_scf_env%eps_filter) +! +! CALL dbcsr_release(matrix_sigma_vv_full_sqrt_inv) +! CALL dbcsr_release(v_full_tmp) +! CALL dbcsr_release(U_blk_tot) +! +!!!!! orthogonalized virtuals are not blocked +! ! copy new virtuals into the truncated matrix +! !CALL dbcsr_work_create(almo_scf_env%matrix_v_blk(ispin),& +! CALL dbcsr_work_create(almo_scf_env%matrix_v(ispin),& +! work_mutable=.TRUE.) +! CALL dbcsr_iterator_start(iter,v_full_new) +! DO WHILE (dbcsr_iterator_blocks_left(iter)) +! +! CALL dbcsr_iterator_next_block(iter,iblock_row,iblock_col,data_p,& +! row_size=iblock_row_size,col_size=iblock_col_size) +! +! retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) +! +! CALL dbcsr_put_block(almo_scf_env%matrix_v(ispin), iblock_row,iblock_col,data_p(:,1:retained_v)) +! CPASSERT(retained_v.gt.0) +! +! ENDDO ! iterator +! CALL dbcsr_iterator_stop(iter) +! !!CALL dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin)) +! CALL dbcsr_finalize(almo_scf_env%matrix_v(ispin)) +! +! CALL dbcsr_release(v_full_new) +! +! ENDDO ! ispin +! +! CALL timestop(handle) +! +! END SUBROUTINE truncate_subspace_v_blk + ! ************************************************************************************************** !> \brief Compute the gradient wrt the main variable (e.g. Theta, X) !> \param m_grad_out ... @@ -5117,9 +6049,44 @@ CONTAINS template=m_t, & matrix_type=dbcsr_type_no_symmetry) + ! do d_E/d_T first + !IF (.NOT.PRESENT(m_FTsiginv)) THEN + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_ks,& + ! m_t,& + ! 0.0_dp,m_tmp_no_1,& + ! filter_eps=eps_filter) + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_tmp_no_1,& + ! m_siginv,& + ! 0.0_dp,m_FTsiginv,& + ! filter_eps=eps_filter) + !ENDIF + CALL dbcsr_copy(m_tmp_no_2, m_quench_t) CALL dbcsr_copy(m_tmp_no_2, m_FTsiginv, keep_sparsity=.TRUE.) + !IF (.NOT.PRESENT(m_siginvTFTsiginv)) THEN + ! CALL dbcsr_multiply("T","N",1.0_dp,& + ! m_t,& + ! m_FTsiginv,& + ! 0.0_dp,m_tmp_oo_1,& + ! filter_eps=eps_filter) + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_siginv,& + ! m_tmp_oo_1,& + ! 0.0_dp,m_siginvTFTsiginv,& + ! filter_eps=eps_filter) + !ENDIF + + !IF (.NOT.PRESENT(m_ST)) THEN + ! CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_s,& + ! m_t,& + ! 0.0_dp,m_ST,& + ! filter_eps=eps_filter) + !ENDIF + CALL dbcsr_multiply("N", "N", -1.0_dp, & m_ST, & m_siginvTFTsiginv, & @@ -5167,12 +6134,15 @@ CONTAINS SELECT CASE (2) ! allows for selection of different spread functionals CASE (1) ! functional = -W_I * log( |z_I|^2 ) CPABORT("Localization function is not implemented") + !coeff = -(weights(idim0)/z2(ielem)) CASE (2) ! functional = W_I * ( 1 - |z_I|^2 ) coeff = -weights(idim0) CASE (3) ! functional = W_I * ( 1 - |z_I| ) CPABORT("Localization function is not implemented") + !coeff = -(weights(idim0)/(2.0_dp*z2(ielem))) END SELECT CALL dbcsr_add(temp2, temp1, 1.0_dp, coeff) + !CALL dbcsr_add(grad_loc, temp1, 1.0_dp, 1.0_dp) END DO ! end loop over idim0 CALL dbcsr_add(m_tmp_no_2, temp2, my_energy_coeff, my_localiz_coeff*4.0_dp) @@ -5180,6 +6150,13 @@ CONTAINS ! add penalty on the occupied volume: det(sigma) IF (penalty_occ_vol) THEN + !RZK-warning CALL dbcsr_multiply("N","N",& + !RZK-warning penalty_occ_vol_prefactor,& + !RZK-warning m_ST,& + !RZK-warning m_siginv,& + !RZK-warning 1.0_dp,m_tmp_no_2,& + !RZK-warning retain_sparsity=.TRUE.,& + !RZK-warning ) CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", & penalty_occ_vol_prefactor, & @@ -5190,6 +6167,7 @@ CONTAINS ! this norm does not contain the normalization factors penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) energy_g_norm = dbcsr_maxabs(m_tmp_no_2) + !WRITE (*, "(A30,2F20.10)") "Energy/penalty g norms (no norm): ", energy_g_norm, penalty_occ_vol_g_norm CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, 1.0_dp) END IF @@ -5203,6 +6181,17 @@ CONTAINS ! This is because tr(T).G_Energy = 0 and ! tr(T).G_Penalty = c0*I + !! faster way to take the norm into account (tested for vol penalty olny) + !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) + !!CALL dbcsr_copy(m_tmp_no_1, m_ST, keep_sparsity=.TRUE.) + !!CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, -penalty_occ_vol_prefactor) + !!CALL dbcsr_copy(m_tmp_no_1, m_quench_t) + !!CALL dbcsr_multiply("N", "N", 1.0_dp, & + !! m_tmp_no_2, & + !! m_sig_sqrti_ii, & + !! 0.0_dp, m_tmp_no_1, & + !! retain_sparsity=.TRUE.) + ! slower way of taking the norm into account CALL dbcsr_copy(m_tmp_no_1, m_quench_t) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -5277,6 +6266,34 @@ CONTAINS CALL dbcsr_copy(m_tmp_no_1, m_grad_out) END IF + !! check whether the gradient lies entirely in R or Q + !CALL dbcsr_multiply("T","N",1.0_dp,& + ! m_t,& + ! m_tmp_no_1,& + ! 0.0_dp,m_tmp_oo_1,& + ! filter_eps=eps_filter,& + ! ) + !CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_siginv,& + ! m_tmp_oo_1,& + ! 0.0_dp,m_tmp_oo_2,& + ! filter_eps=eps_filter,& + ! ) + !CALL dbcsr_copy(m_tmp_no_2,m_tmp_no_1) + !CALL dbcsr_multiply("N","N",-1.0_dp,& + ! m_ST,& + ! m_tmp_oo_2,& + ! 1.0_dp,m_tmp_no_2,& + ! retain_sparsity=.TRUE.,& + ! ) + !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) + !WRITE(*,"(A50,2F20.10)") "Virtual-space projection of the gradient", penalty_occ_vol_g_norm + !CALL dbcsr_add(m_tmp_no_2,m_tmp_no_1,1.0_dp,-1.0_dp) + !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_2) + !WRITE(*,"(A50,2F20.10)") "Occupied-space projection of the gradient", penalty_occ_vol_g_norm + !penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1) + !WRITE(*,"(A50,2F20.10)") "Full gradient", penalty_occ_vol_g_norm + ! transform d_E/d_T to d_E/d_theta IF (optimize_theta) THEN CALL dbcsr_copy(m_tmp_no_2, m_theta) @@ -5634,6 +6651,7 @@ CONTAINS CALL dbcsr_get_diag(m_temp_oo_4, tg_diagonal) CALL dbcsr_set(m_temp_oo_4, 0.0_dp) CALL dbcsr_set_diag(m_temp_oo_4, tg_diagonal) + !CALL para_group%sum(tg_diagonal) z2(:) = z2(:) + tg_diagonal(:)*tg_diagonal(:) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -6034,6 +7052,15 @@ CONTAINS CALL dbcsr_copy(m_f_vv_out, m_prec_out) END IF +#if 0 +!penalty_only=.TRUE. + WRITE (unit_nr, *) "prefactor0:", penalty_occ_vol_prefactor + !IF (penalty_occ_vol) THEN + CALL dbcsr_desymmetrize(m_s, & + m_prec_out) + !CALL dbcsr_scale(m_prec_out,-penalty_occ_vol_prefactor) + !ENDIF +#else ! sum up the F_vv and S_vv terms CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, 1.0_dp) @@ -6045,6 +7072,7 @@ CONTAINS CALL dbcsr_add(m_prec_out, m_tmp_nn_1, & 1.0_dp, penalty_occ_vol_prefactor) END IF +#endif CALL dbcsr_copy(m_tmp_nn_1, m_prec_out) @@ -6140,6 +7168,67 @@ CONTAINS END IF ! special_case + ! invert using cholesky (works with S matrix, will not work with S-SRS matrix) + !!!CALL cp_dbcsr_cholesky_decompose(prec_vv,& + !!! para_env=almo_scf_env%para_env,& + !!! blacs_env=almo_scf_env%blacs_env) + !!!CALL cp_dbcsr_cholesky_invert(prec_vv,& + !!! para_env=almo_scf_env%para_env,& + !!! blacs_env=almo_scf_env%blacs_env,& + !!! uplo_to_full=.TRUE.) + !!!CALL dbcsr_filter(prec_vv,& + !!! almo_scf_env%eps_filter) + !!! + + ! re-create the matrix because desymmetrize is buggy - + ! it will create multiple copies of blocks + !!!DESYM!CALL dbcsr_create(prec_vv,& + !!!DESYM! template=almo_scf_env%matrix_s(1),& + !!!DESYM! matrix_type=dbcsr_type_no_symmetry) + !!!DESYM!CALL dbcsr_desymmetrize(almo_scf_env%matrix_s(1),& + !!!DESYM! prec_vv) + !CALL dbcsr_multiply("N","N",1.0_dp,& + ! almo_scf_env%matrix_s(1),& + ! matrix_t_out(ispin),& + ! 0.0_dp,m_tmp_no_1,& + ! filter_eps=almo_scf_env%eps_filter) + !CALL dbcsr_multiply("N","N",1.0_dp,& + ! m_tmp_no_1,& + ! almo_scf_env%matrix_sigma_inv(ispin),& + ! 0.0_dp,m_tmp_no_3,& + ! filter_eps=almo_scf_env%eps_filter) + !CALL dbcsr_multiply("N","T",-1.0_dp,& + ! m_tmp_no_3,& + ! m_tmp_no_1,& + ! 1.0_dp,prec_vv,& + ! filter_eps=almo_scf_env%eps_filter) + !CALL dbcsr_add_on_diag(prec_vv,& + ! prec_sf_mixing_s) + + !CALL dbcsr_create(prec_oo,& + ! template=almo_scf_env%matrix_sigma(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& + ! prec_oo) + !CALL dbcsr_filter(prec_oo,& + ! almo_scf_env%eps_filter) + + !! invert using cholesky + !CALL dbcsr_create(prec_oo_inv,& + ! template=prec_oo,& + ! matrix_type=dbcsr_type_no_symmetry) + !CALL dbcsr_desymmetrize(prec_oo,& + ! prec_oo_inv) + !CALL cp_dbcsr_cholesky_decompose(prec_oo_inv,& + ! para_env=almo_scf_env%para_env,& + ! blacs_env=almo_scf_env%blacs_env) + !CALL cp_dbcsr_cholesky_invert(prec_oo_inv,& + ! para_env=almo_scf_env%para_env,& + ! blacs_env=almo_scf_env%blacs_env,& + ! uplo_to_full=.TRUE.) + CALL dbcsr_release(m_tmp_nn_1) CALL dbcsr_release(m_tmp_no_3) @@ -6485,6 +7574,10 @@ CONTAINS filter_eps=eps_filter) ! RZK-warning +! compute preconditioner even if we do not use it +! this is for debugging because compute_preconditioner includes +! computing F_vv and S_vv necessary for +! IF ( use_preconditioner ) THEN ! domain_s_inv and domain_r_down are never used with assume_t0_q0x=FALSE CALL compute_preconditioner( & @@ -6517,6 +7610,8 @@ CONTAINS skip_inversion=.FALSE. & ) +! ENDIF ! use_preconditioner + ! initial guess CALL dbcsr_copy(m_delta(ispin), m_quench_t(ispin)) ! in order to use dbcsr_set matrix blocks must exist @@ -6552,7 +7647,10 @@ CONTAINS penalty_occ_vol_pf2=penalty_occ_vol_pf2(ispin), & m_s=m_s(1), & para_env=para_env, & - blacs_env=blacs_env) + blacs_env=blacs_env & + ) + ! correct solution by the spin factor + !CALL dbcsr_scale(m_zet(ispin),1.0_dp/(2.0_dp*spin_factor)) ELSE ! use PCG to solve H.D=-G @@ -6577,7 +7675,10 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter) + filter_eps=eps_filter & + !matrix_trimmer=,& + !use_trimmer=.FALSE.,& + ) END IF ! special_case @@ -6631,7 +7732,8 @@ CONTAINS normalize_orbitals=normalize_orbitals, & penalty_occ_vol_prefactor=penalty_occ_vol_prefactor, & eps_filter=eps_filter, & - path_num=hessian_path_reuse) + path_num=hessian_path_reuse & + ) ! alpha is computed outside the spin loop numer = 0.0_dp @@ -6676,6 +7778,10 @@ CONTAINS ! compute the new step (apply preconditioner if available) IF (use_preconditioner) THEN + !IF (unit_nr>0) THEN + ! WRITE(unit_nr,*) "....applying preconditioner...." + !ENDIF + IF (special_case == xalmo_case_block_diag .OR. & special_case == xalmo_case_fully_deloc) THEN @@ -6695,7 +7801,10 @@ CONTAINS map=domain_map(ispin), & node_of_domain=cpu_of_domain(:), & my_action=0, & - filter_eps=eps_filter) + filter_eps=eps_filter & + !matrix_trimmer=,& + !use_trimmer=.FALSE.,& + ) END IF ! special case @@ -6728,6 +7837,7 @@ CONTAINS t2 = m_walltime() IF (unit_nr > 0) THEN + !iter_type=TRIM("ALMO SCF "//iter_type) iter_type = TRIM("NR STEP") WRITE (unit_nr, '(T6,A9,I6,F14.5,F14.5,F15.10,F9.2)') & iter_type, iteration, & @@ -6750,6 +7860,26 @@ CONTAINS END DO ! outer loop +! is not necessary if penalty_occ_vol_pf2=0.0 +#if 0 + + IF (penalty_occ_vol) THEN + + DO ispin = 1, nspins + + CALL dbcsr_copy(m_zet(ispin), m_grad(ispin)) + CALL dbcsr_dot(m_delta(ispin), m_zet(ispin), alpha) + WRITE (unit_nr, *) "trace(grad.delta): ", alpha + alpha = -1.0_dp/(penalty_occ_vol_pf2(ispin)*alpha - 1.0_dp) + WRITE (unit_nr, *) "correction alpha: ", alpha + CALL dbcsr_scale(m_delta(ispin), alpha) + + END DO + + END IF + +#endif + DO ispin = 1, nspins ! check whether the step lies entirely in R or Q @@ -6956,6 +8086,44 @@ CONTAINS ! apply pre-computed F_vv and S_vv to X +#if 0 +! RZK-warning: negative sign at penalty_prefactor_local is that +! magical fix for the negative definite problem +! (since penalty_prefactor_local<0 the coeff before S_vv must +! be multiplied by -1 to take the step in the right direction) +!CALL dbcsr_multiply("N","N",-4.0_dp*penalty_prefactor_local,& +! m_s_vv(ispin),& +! m_tmp_x_in,& +! 0.0_dp,m_tmp_no_1,& +! filter_eps=eps_filter) +!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) +!CALL dbcsr_multiply("N","N",1.0_dp,& +! m_tmp_no_1,& +! m_siginv(ispin),& +! 0.0_dp,m_x_out(ispin),& +! retain_sparsity=.TRUE.) + + CALL dbcsr_multiply("N", "N", 1.0_dp, & + m_s(1), & + m_tmp_x_in, & + 0.0_dp, m_tmp_no_1, & + filter_eps=eps_filter) + CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) + CALL dbcsr_multiply("N", "N", 1.0_dp, & + m_tmp_no_1, & + m_siginv(ispin), & + 0.0_dp, m_x_out(ispin), & + retain_sparsity=.TRUE.) + +!CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) +!CALL dbcsr_multiply("N","N",1.0_dp,& +! m_s(1),& +! m_tmp_x_in,& +! 0.0_dp,m_x_out(ispin),& +! retain_sparsity=.TRUE.) + +#else + ! debugging: only vv matrices, oo matrices are kronecker CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin)) CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -6972,6 +8140,75 @@ CONTAINS retain_sparsity=.TRUE.) CALL dbcsr_add(m_x_out(ispin), m_tmp_no_2, & 1.0_dp, -4.0_dp*penalty_prefactor_local + 1.0_dp) +#endif + +! ! F_vv.X.S_oo +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_ks_vv(ispin),& +! m_tmp_x_in,& +! 0.0_dp,m_tmp_no_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_x_out(ispin),m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_tmp_no_1,& +! m_siginv(ispin),& +! 0.0_dp,m_x_out(ispin),& +! retain_sparsity=.TRUE.,& +! ) +! +! ! S_vv.X.F_oo +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_s_vv(ispin),& +! m_tmp_x_in,& +! 0.0_dp,m_tmp_no_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_tmp_no_1,& +! m_siginvTFTsiginv(ispin),& +! 0.0_dp,m_tmp_no_2,& +! retain_sparsity=.TRUE.,& +! ) +! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& +! 1.0_dp,-1.0_dp) +!! we have to add occ voll penalty here (the Svv termi (i.e. both Svv.D.Soo) +!! and STsiginv terms) +! +! ! S_vo.X^t.F_vo +! CALL dbcsr_multiply("T","N",1.0_dp,& +! m_tmp_x_in,& +! m_g_full(ispin),& +! 0.0_dp,m_tmp_oo_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_STsiginv(ispin),& +! m_tmp_oo_1,& +! 0.0_dp,m_tmp_no_2,& +! retain_sparsity=.TRUE.,& +! ) +! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& +! 1.0_dp,-1.0_dp) +! +! ! S_vo.X^t.F_vo +! CALL dbcsr_multiply("T","N",1.0_dp,& +! m_tmp_x_in,& +! m_STsiginv(ispin),& +! 0.0_dp,m_tmp_oo_1,& +! filter_eps=eps_filter,& +! ) +! CALL dbcsr_copy(m_tmp_no_2,m_quench_t(ispin)) +! CALL dbcsr_multiply("N","N",1.0_dp,& +! m_g_full(ispin),& +! m_tmp_oo_1,& +! 0.0_dp,m_tmp_no_2,& +! retain_sparsity=.TRUE.,& +! ) +! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& +! 1.0_dp,-1.0_dp) ELSE IF (path_num == hessian_path_assemble) THEN @@ -7163,6 +8400,12 @@ CONTAINS WRITE (unit_nr, *) "penalty_prefactor_local: ", penalty_prefactor_local WRITE (unit_nr, *) "penalty_prefactor_2: ", penalty_occ_vol_pf2 + !CALL dbcsr_print(matrix_grad) + !CALL dbcsr_print(matrix_F_ao_sym) + !CALL dbcsr_print(matrix_S_ao_sym) + !CALL dbcsr_print(matrix_F_mo_sym) + !CALL dbcsr_print(matrix_S_mo_sym) + ! loop over domains to find the size of the Hessian H_size = 0 DO col = 1, nblkcols_tot @@ -7262,6 +8505,23 @@ CONTAINS S_mo_block(1:mo_block_sizes(row), 1:mo_block_sizes(col)) = block_p(:, :) END IF + !WRITE(*,*) "F_AO_BLOCK", row, col, ao_domain_sizes(row), ao_domain_sizes(col) + !DO ii=1,ao_domain_sizes(row) + ! WRITE(*,'(100F13.9)') F_ao_block(ii,:) + !ENDDO + !WRITE(*,*) "S_AO_BLOCK", row, col + !DO ii=1,ao_domain_sizes(row) + ! WRITE(*,'(100F13.9)') S_ao_block(ii,:) + !ENDDO + !WRITE(*,*) "F_MO_BLOCK", row, col + !DO ii=1,mo_block_sizes(row) + ! WRITE(*,'(100F13.9)') F_mo_block(ii,:) + !ENDDO + !WRITE(*,*) "S_MO_BLOCK", row, col, mo_block_sizes(row), mo_block_sizes(col) + !DO ii=1,mo_block_sizes(row) + ! WRITE(*,'(100F13.9)') S_mo_block(ii,:) + !ENDDO + ! construct tensor products for the current row-column fragment pair lev2_vert_offset = 0 DO orb_j = 1, mo_block_sizes(row) @@ -7271,8 +8531,16 @@ CONTAINS IF (orb_i == orb_j .AND. row == col) THEN H(lev1_vert_offset + lev2_vert_offset + 1:lev1_vert_offset + lev2_vert_offset + ao_domain_sizes(row), & lev1_hori_offset + lev2_hori_offset + 1:lev1_hori_offset + lev2_hori_offset + ao_domain_sizes(col)) & + != -penalty_prefactor_local*S_ao_block(:,:) = F_ao_block(:, :) + S_ao_block(:, :) +!=S_ao_block(:,:) +!RZK-warning =F_ao_block(:,:)+( 1.0_dp + penalty_prefactor_local )*S_ao_block(:,:) +! =S_mo_block(orb_j,orb_i)*F_ao_block(:,:)& +! -F_mo_block(orb_j,orb_i)*S_ao_block(:,:)& +! +penalty_prefactor_local*S_mo_block(orb_j,orb_i)*S_ao_block(:,:) END IF + !WRITE(*,*) row, col, orb_j, orb_i, lev1_vert_offset+lev2_vert_offset+1, ao_domain_sizes(row),& + ! lev1_hori_offset+lev2_hori_offset+1, ao_domain_sizes(col), S_mo_block(orb_j,orb_i) lev2_hori_offset = lev2_hori_offset + ao_domain_sizes(col) @@ -7300,6 +8568,180 @@ CONTAINS CALL dbcsr_release(matrix_S_mo_sym) CALL dbcsr_release(matrix_F_mo_sym) +!! ! Two more terms of the Hessian: S_vo.D.F_vo and F_vo.D.S_vo +!! ! It seems that these terms break positive definite property of the Hessian +!! ALLOCATE(H1(H_size,H_size)) +!! ALLOCATE(H2(H_size,H_size)) +!! H1=0.0_dp +!! H2=0.0_dp +!! DO row = 1, nblkcols_tot +!! +!! lev1_hori_offset=0 +!! DO col = 1, nblkcols_tot +!! +!! CALL dbcsr_get_block_p(matrix_F_vo,& +!! row, col, block_p, found) +!! CALL dbcsr_get_block_p(matrix_S_vo,& +!! row, col, block_p2, found2) +!! +!! lev1_vert_offset=0 +!! DO block_col = 1, nblkcols_tot +!! +!! CALL dbcsr_get_block_p(quench_t,& +!! row, block_col, p_new_block, found_row) +!! +!! IF (found_row) THEN +!! +!! ! determine offset in this short loop +!! lev2_vert_offset=0 +!! DO block_row=1,row-1 +!! CALL dbcsr_get_block_p(quench_t,& +!! block_row, block_col, p_new_block, found_col) +!! IF (found_col) lev2_vert_offset=lev2_vert_offset+ao_block_sizes(block_row) +!! ENDDO +!! !!!!!!!! short loop +!! +!! ! over all electrons of the block +!! DO orb_i=1, mo_block_sizes(col) +!! +!! ! into all possible locations +!! DO orb_j=1, mo_block_sizes(block_col) +!! +!! ! column is copied several times +!! DO copy=1, ao_domain_sizes(col) +!! +!! IF (found) THEN +!! +!! !WRITE(*,*) row, col, block_col, orb_i, orb_j, copy,& +!! ! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1,& +!! ! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy +!! +!! H1( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& +!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& +!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& +!! =block_p(:,orb_i) +!! +!! ENDIF ! found block in the data matrix +!! +!! IF (found2) THEN +!! +!! H2( lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+1:& +!! lev1_vert_offset+(orb_j-1)*ao_domain_sizes(block_col)+lev2_vert_offset+ao_block_sizes(row),& +!! lev1_hori_offset+(orb_i-1)*ao_domain_sizes(col)+copy )& +!! =block_p2(:,orb_i) +!! +!! ENDIF ! found block in the data matrix +!! +!! ENDDO +!! +!! ENDDO +!! +!! ENDDO +!! +!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) +!! +!! ENDIF ! found block in the quench matrix +!! +!! lev1_vert_offset=lev1_vert_offset+& +!! ao_domain_sizes(block_col)*mo_block_sizes(block_col) +!! +!! ENDDO +!! +!! lev1_hori_offset=lev1_hori_offset+& +!! ao_domain_sizes(col)*mo_block_sizes(col) +!! +!! ENDDO +!! +!! !lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) +!! +!! ENDDO +!! H1(:,:)=H1(:,:)*2.0_dp*spin_factor +!! !!!WRITE(*,*) "F_vo" +!! !!!DO ii=1,H_size +!! !!! WRITE(*,'(100F13.9)') H1(ii,:) +!! !!!ENDDO +!! !!!WRITE(*,*) "S_vo" +!! !!!DO ii=1,H_size +!! !!! WRITE(*,'(100F13.9)') H2(ii,:) +!! !!!ENDDO +!! !!!!! add terms to the hessian +!! DO ii=1,H_size +!! DO jj=1,H_size +!!! add penalty_occ_vol term +!! H(ii,jj)=H(ii,jj)-H1(ii,jj)*H2(jj,ii)-H1(jj,ii)*H2(ii,jj) +!! ENDDO +!! ENDDO +!! DEALLOCATE(H1) +!! DEALLOCATE(H2) + +!! ! S_vo.S_vo diagonal component due to determiant constraint +!! ! use grad vector temporarily +!! IF (penalty_occ_vol) THEN +!! ALLOCATE(Grad_vec(H_size)) +!! Grad_vec(:)=0.0_dp +!! lev1_vert_offset=0 +!! ! loop over all electron blocks +!! DO col = 1, nblkcols_tot +!! +!! ! loop over AO-rows of the dbcsr matrix +!! lev2_vert_offset=0 +!! DO row = 1, nblkrows_tot +!! +!! CALL dbcsr_get_block_p(quench_t,& +!! row, col, block_p, found_row) +!! IF (found_row) THEN +!! +!! CALL dbcsr_get_block_p(matrix_S_vo,& +!! row, col, block_p, found) +!! IF (found) THEN +!! ! copy the data into the vector, column by column +!! DO orb_i=1, mo_block_sizes(col) +!! Grad_vec(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& +!! lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& +!! =block_p(:,orb_i) +!! ENDDO +!! +!! ENDIF +!! +!! lev2_vert_offset=lev2_vert_offset+ao_block_sizes(row) +!! +!! ENDIF +!! +!! ENDDO +!! +!! lev1_vert_offset=lev1_vert_offset+ao_domain_sizes(col)*mo_block_sizes(col) +!! +!! ENDDO ! loop over electron blocks +!! ! update H now +!! DO ii=1,H_size +!! DO jj=1,H_size +!! H(ii,jj)=H(ii,jj)+penalty_occ_vol_prefactor*& +!! penalty_occ_vol_pf2*Grad_vec(ii)*Grad_vec(jj) +!! ENDDO +!! ENDDO +!! DEALLOCATE(Grad_vec) +!! ENDIF ! penalty_occ_vol + +!S-1.G ! invert S using cholesky +!S-1.G CALL dbcsr_create(m_prec_out,& +!S-1.G template=m_s,& +!S-1.G matrix_type=dbcsr_type_no_symmetry) +!S-1.G CALL dbcsr_copy(m_prec_out,m_s) +!S-1.G CALL dbcsr_cholesky_decompose(m_prec_out,& +!S-1.G para_env=para_env,& +!S-1.G blacs_env=blacs_env) +!S-1.G CALL dbcsr_cholesky_invert(m_prec_out,& +!S-1.G para_env=para_env,& +!S-1.G blacs_env=blacs_env,& +!S-1.G uplo_to_full=.TRUE.) +!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& +!S-1.G m_prec_out,& +!S-1.G matrix_grad,& +!S-1.G 0.0_dp,matrix_step,& +!S-1.G filter_eps=1.0E-10_dp) +!S-1.G !CALL dbcsr_release(m_prec_out) +!S-1.G ALLOCATE(test3(H_size)) + ! convert gradient from the dbcsr matrix to the vector form ALLOCATE (Grad_vec(H_size)) Grad_vec(:) = 0.0_dp @@ -7323,10 +8765,22 @@ CONTAINS Grad_vec(lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + 1: & lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + ao_block_sizes(row)) & = block_p(:, orb_i) +!WRITE(*,*) "GRAD: ", row, col, orb_i, lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1, ao_block_sizes(row) END DO END IF +!S-1.G CALL dbcsr_get_block_p(matrix_step,& +!S-1.G row, col, block_p, found) +!S-1.G IF (found) THEN +!S-1.G ! copy the data into the vector, column by column +!S-1.G DO orb_i=1, mo_block_sizes(col) +!S-1.G test3(lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+1:& +!S-1.G lev1_vert_offset+ao_domain_sizes(col)*(orb_i-1)+lev2_vert_offset+ao_block_sizes(row))& +!S-1.G =block_p(:,orb_i) +!S-1.G ENDDO +!S-1.G ENDIF + lev2_vert_offset = lev2_vert_offset + ao_block_sizes(row) END IF @@ -7337,6 +8791,12 @@ CONTAINS END DO ! loop over electron blocks + !WRITE(*,*) "HESSIAN" + !DO ii=1,H_size + ! WRITE(*,*) ii + ! WRITE(*,'(20F14.10)') H(ii,:) + !ENDDO + ! invert the Hessian INFO = 0 ALLOCATE (Hinv(H_size, H_size)) @@ -7364,6 +8824,21 @@ CONTAINS ! Step_vec contains Grad_vec here Step_vec(:) = MATMUL(TRANSPOSE(Hinv), Grad_vec) + ! compute U.tr(U)-1 = error + !ALLOCATE(test(H_size,H_size)) + !test(:,:)=MATMUL(TRANSPOSE(Hinv),Hinv) + !DO ii=1,H_size + ! test(ii,ii)=test(ii,ii)-1.0_dp + !ENDDO + !test_error=0.0_dp + !DO ii=1,H_size + ! DO jj=1,H_size + ! test_error=test_error+test(jj,ii)*test(jj,ii) + ! ENDDO + !ENDDO + !WRITE(*,*) "U.tr(U)-1 error: ", SQRT(test_error) + !DEALLOCATE(test) + ! invert eigenvalues and use eigenvectors to compute the Hessian inverse ! project out zero-eigenvalue directions ALLOCATE (test(H_size, H_size)) @@ -7385,8 +8860,46 @@ CONTAINS Hinv(:, :) = test2(:, :) DEALLOCATE (test, test2) + !! shift to kill singularity + !shift=0.0_dp + !IF (eigenvalues(1).lt.0.0_dp) THEN + ! CPABORT("Negative eigenvalue(s)") + ! shift=abs(eigenvalues(1)) + ! WRITE(*,*) "Lowest eigenvalue: ", eigenvalues(1) + !ENDIF + !DO ii=1, H_size + ! IF (eigenvalues(ii).gt.eps_zero) THEN + ! shift=shift+min(1.0_dp,eigenvalues(ii))*1.0E-4_dp + ! EXIT + ! ENDIF + !ENDDO + !WRITE(*,*) "Hessian shift: ", shift + !DO ii=1, H_size + ! H(ii,ii)=H(ii,ii)+shift + !ENDDO + !! end shift + DEALLOCATE (eigenvalues) +!!!! Hinv=H +!!!! INFO=0 +!!!! CALL dpotrf('L', H_size, Hinv, H_size, INFO ) +!!!! IF( INFO/=0 ) THEN +!!!! WRITE(*,*) 'DPOTRF ERROR MESSAGE: ', INFO +!!!! CPABORT("DPOTRF failed") +!!!! END IF +!!!! CALL dpotri('L', H_size, Hinv, H_size, INFO ) +!!!! IF( INFO/=0 ) THEN +!!!! WRITE(*,*) 'DPOTRI ERROR MESSAGE: ', INFO +!!!! CPABORT("DPOTRI failed") +!!!! END IF +!!!! ! complete the matrix +!!!! DO ii=1,H_size +!!!! DO jj=ii+1,H_size +!!!! Hinv(ii,jj)=Hinv(jj,ii) +!!!! ENDDO +!!!! ENDDO + ! compute the inversion error ALLOCATE (test(H_size, H_size)) test(:, :) = MATMUL(Hinv, H) @@ -7406,6 +8919,7 @@ CONTAINS ALLOCATE (Step_vec(H_size)) ALLOCATE (tmp(H_size)) tmp(:) = MATMUL(Hinv, Grad_vec) + !tmp(:)=MATMUL(Hinv,test3) Step_vec(:) = -1.0_dp*tmp(:) ALLOCATE (tmpr(H_size)) @@ -7463,6 +8977,19 @@ CONTAINS CALL dbcsr_finalize(matrix_step) +!S-1.G CALL dbcsr_create(m_tmp_no_1,& +!S-1.G template=matrix_step,& +!S-1.G matrix_type=dbcsr_type_no_symmetry) +!S-1.G CALL dbcsr_multiply("N","N",1.0_dp,& +!S-1.G m_prec_out,& +!S-1.G matrix_step,& +!S-1.G 0.0_dp,m_tmp_no_1,& +!S-1.G filter_eps=1.0E-10_dp,& +!S-1.G ) +!S-1.G CALL dbcsr_copy(matrix_step,m_tmp_no_1) +!S-1.G CALL dbcsr_release(m_tmp_no_1) +!S-1.G CALL dbcsr_release(m_prec_out) + DEALLOCATE (mo_block_sizes, ao_block_sizes) DEALLOCATE (ao_domain_sizes) @@ -7608,6 +9135,8 @@ CONTAINS ! penalty amplitude adjusts the strength of volume conservation penalty_occ_vol = .FALSE. + !(almo_scf_env%penalty%occ_vol_method /= almo_occ_vol_penalty_none .AND. & + ! my_special_case == xalmo_case_fully_deloc) normalize_orbitals = penalty_occ_vol penalty_amplitude = 0.0_dp !almo_scf_env%penalty%occ_vol_coeff ALLOCATE (penalty_occ_vol_g_prefactor(nspins)) @@ -7877,6 +9406,8 @@ CONTAINS ! check convergence and other exit criteria DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(grad(ispin)) + !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & + ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin grad_norm_ref = MAXVAL(grad_norm_spin) @@ -7898,9 +9429,8 @@ CONTAINS scf_converged = .TRUE. border_reached = .FALSE. expected_reduction = 0.0_dp - IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) THEN + IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) & EXIT adjust_r_loop - END IF ELSE scf_converged = .FALSE. END IF @@ -8257,6 +9787,35 @@ CONTAINS END IF ! special_case + ! slower but more reliable way to get inverted hessian + !DO ispin = 1, nspins + ! CALL compute_preconditioner( & + ! domain_prec_out=domain_model_hessian_inv(:, ispin), & + ! m_prec_out=m_model_hessian_inv(ispin), & ! RZK-warning: this one is not inverted if DOMAINs + ! m_ks=almo_scf_env%matrix_ks(ispin), & + ! m_s=almo_scf_env%matrix_s(1), & + ! m_siginv=almo_scf_env%matrix_sigma_inv(ispin), & + ! m_quench_t=quench_t(ispin), & + ! m_FTsiginv=FTsiginv(ispin), & + ! m_siginvTFTsiginv=siginvTFTsiginv(ispin), & + ! m_ST=ST(ispin), & + ! para_env=almo_scf_env%para_env, & + ! blacs_env=almo_scf_env%blacs_env, & + ! nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), & + ! domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), & + ! domain_r_down=domain_r_down(:, ispin), & + ! cpu_of_domain=almo_scf_env%cpu_of_domain, & + ! domain_map=almo_scf_env%domain_map(ispin), & + ! assume_t0_q0x=.FALSE., & + ! penalty_occ_vol=penalty_occ_vol, & + ! penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), & + ! eps_filter=almo_scf_env%eps_filter, & + ! neg_thr=1.0E10_dp, & + ! spin_factor=spin_factor, & + ! skip_inversion=.FALSE., & + ! special_case=my_special_case) + !ENDDO ! ispin + CASE DEFAULT CPABORT("Unknown preconditioner") @@ -8339,9 +9898,8 @@ CONTAINS ) IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step size to border: ", step_size IF (step_size > 1.0_dp .OR. step_size < 0.0_dp) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Step size (", step_size, ") must lie inside (0,1)" - END IF CPABORT("Wrong dog leg step. We should never end up here.") END IF @@ -8408,6 +9966,8 @@ CONTAINS ! Model grad norm DO ispin = 1, nspins grad_norm_spin(ispin) = dbcsr_maxabs(m_model_r(ispin)) + !grad_norm_frob = dbcsr_frobenius_norm(grad(ispin)) / & + ! dbcsr_frobenius_norm(quench_t(ispin)) END DO ! ispin model_grad_norm = MAXVAL(grad_norm_spin) @@ -8521,6 +10081,7 @@ CONTAINS END DO ! ispin ! compute the energy + !IF (.NOT. same_position) THEN CALL main_var_to_xalmos_and_loss_func( & almo_scf_env=almo_scf_env, & qs_env=qs_env, & @@ -8543,6 +10104,7 @@ CONTAINS do_penalty=penalty_occ_vol, & special_case=my_special_case) loss_trial = energy_trial + penalty_trial + !ENDIF ! not same_position rho = (loss_trial - loss_start)/expected_reduction loss_change_to_report = loss_trial - loss_start diff --git a/src/almo_scf_qs.F b/src/almo_scf_qs.F index 82bf191e1c..99b41e1c95 100644 --- a/src/almo_scf_qs.F +++ b/src/almo_scf_qs.F @@ -288,6 +288,63 @@ CONTAINS CALL dbcsr_work_create(matrix_new, work_mutable=.TRUE.) CALL dbcsr_get_info(matrix_new, nblkrows_total=nblkrows_tot, & row_blk_size=row_blk_size, col_blk_size=col_blk_size) + ! startQQQ - this part of the code scales quadratically + ! therefore it is replaced with a less general but linear scaling algorithm below + ! the quadratic algorithm is kept to be re-written later + !QQQCALL dbcsr_get_info(matrix_new, nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot) + !QQQDO row = 1, nblkrows_tot + !QQQ DO col = 1, nblkcols_tot + !QQQ tr = .FALSE. + !QQQ iblock_row = row + !QQQ iblock_col = col + !QQQ CALL dbcsr_get_stored_coordinates(matrix_new, iblock_row, iblock_col, tr, hold) + + !QQQ IF(hold==mynode) THEN + !QQQ + !QQQ ! RZK-warning replace with a function which says if this + !QQQ ! distribution block is active or not + !QQQ ! Translate indeces of distribution blocks to domain blocks + !QQQ if (size_keys(1)==almo_mat_dim_aobasis) then + !QQQ domain_row=almo_scf_env%domain_index_of_ao_block(iblock_row) + !QQQ else if (size_keys(2)==almo_mat_dim_occ .OR. & + !QQQ size_keys(2)==almo_mat_dim_virt .OR. & + !QQQ size_keys(2)==almo_mat_dim_virt_disc .OR. & + !QQQ size_keys(2)==almo_mat_dim_virt_full) then + !QQQ domain_row=almo_scf_env%domain_index_of_mo_block(iblock_row) + !QQQ else + !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") + !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) + !QQQ endif + + !QQQ if (size_keys(2)==almo_mat_dim_aobasis) then + !QQQ domain_col=almo_scf_env%domain_index_of_ao_block(iblock_col) + !QQQ else if (size_keys(2)==almo_mat_dim_occ .OR. & + !QQQ size_keys(2)==almo_mat_dim_virt .OR. & + !QQQ size_keys(2)==almo_mat_dim_virt_disc .OR. & + !QQQ size_keys(2)==almo_mat_dim_virt_full) then + !QQQ domain_col=almo_scf_env%domain_index_of_mo_block(iblock_col) + !QQQ else + !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") + !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) + !QQQ endif + + !QQQ ! Finds if we need this block + !QQQ ! only the block-diagonal constraint is implemented here + !QQQ active=.false. + !QQQ if (domain_row==domain_col) active=.true. + + !QQQ IF (active) THEN + !QQQ ALLOCATE (new_block(row_blk_size(iblock_row), col_blk_size(iblock_col))) + !QQQ new_block(:, :) = 1.0_dp + !QQQ CALL dbcsr_put_block(matrix_new, iblock_row, iblock_col, new_block) + !QQQ DEALLOCATE (new_block) + !QQQ ENDIF + + !QQQ ENDIF ! mynode + !QQQ ENDDO + !QQQENDDO + !QQQtake care of zero-electron fragments + ! endQQQ - end of the quadratic part ! start linear-scaling replacement: ! works only for molecular blocks AND molecular distributions DO row = 1, nblkrows_tot @@ -554,7 +611,7 @@ CONTAINS n_el_f=REAL(almo_scf_env%nelectrons_total, dp), & maxocc=2.0_dp, & flexible_electron_count=dft_control%relax_multiplicity) - ELSE IF (almo_scf_env%nspins == 2) THEN + ELSEIF (almo_scf_env%nspins == 2) THEN CALL allocate_mo_set(mo_set=mos(ispin), & nao=nrow_fm, & nmo=ncol_fm, & @@ -1439,6 +1496,23 @@ CONTAINS DEALLOCATE (last_atom_of_molecule) END IF + !mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(& + ! dbcsr_distribution(almo_scf_env%quench_t(ispin)))) + !CALL dbcsr_get_info(almo_scf_env%quench_t(ispin), distribution=dist, & + ! nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot) + !DO row = 1, nblkrows_tot + ! DO col = 1, nblkcols_tot + ! tr = .FALSE. + ! iblock_row = row + ! iblock_col = col + ! CALL dbcsr_get_stored_coordinates(almo_scf_env%quench_t(ispin),& + ! iblock_row, iblock_col, tr, hold) + ! CALL dbcsr_get_block_p(almo_scf_env%quench_t(ispin),& + ! row, col, p_old_block, found) + ! write(*,*) "RST_NOTE:", mynode, row, col, hold, found + ! ENDDO + !ENDDO + CALL timestop(handle) END SUBROUTINE almo_scf_construct_quencher diff --git a/src/almo_scf_types.F b/src/almo_scf_types.F index a75d2577d9..d4c9030aa1 100644 --- a/src/almo_scf_types.F +++ b/src/almo_scf_types.F @@ -569,9 +569,8 @@ CONTAINS DO istore = 1, MIN(almo_scf_env%almo_history%istore, almo_scf_env%almo_history%nstore) CALL dbcsr_release(almo_scf_env%almo_history%matrix_p_up_down(ispin, istore)) END DO - IF (almo_scf_env%almo_history%istore > 0) THEN + IF (almo_scf_env%almo_history%istore > 0) & CALL dbcsr_release(almo_scf_env%almo_history%matrix_t(ispin)) - END IF END DO DEALLOCATE (almo_scf_env%almo_history%matrix_p_up_down) DEALLOCATE (almo_scf_env%almo_history%matrix_t) @@ -581,9 +580,8 @@ CONTAINS CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_p_up_down(ispin, istore)) !CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_x(ispin, istore)) END DO - IF (almo_scf_env%xalmo_history%istore > 0) THEN + IF (almo_scf_env%xalmo_history%istore > 0) & CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_t(ispin)) - END IF END DO DEALLOCATE (almo_scf_env%xalmo_history%matrix_p_up_down) !DEALLOCATE (almo_scf_env%xalmo_history%matrix_x) diff --git a/src/aobasis/ai_contraction.F b/src/aobasis/ai_contraction.F index 02d87a97e3..57bacd8e99 100644 --- a/src/aobasis/ai_contraction.F +++ b/src/aobasis/ai_contraction.F @@ -439,7 +439,7 @@ CONTAINS ELSE qab(ia:ja, ib:jb) = qab(ia:ja, ib:jb) + sab(1:na, 1:nb) END IF - ELSE IF (dir == "OUT" .OR. dir == "out") THEN + ELSEIF (dir == "OUT" .OR. dir == "out") THEN ! SAB <= QAB(block) ja = ia + na - 1 jb = ib + nb - 1 diff --git a/src/aobasis/ai_eri_debug.F b/src/aobasis/ai_eri_debug.F index ea40188793..4838e75ed3 100644 --- a/src/aobasis/ai_eri_debug.F +++ b/src/aobasis/ai_eri_debug.F @@ -128,16 +128,16 @@ CONTAINS IF (dn(1) > 0) THEN IABCD = os(an, bn, cn + i1, dn - i1) - (D(1) - C(1))*os(an, bn, cn, dn - i1) - ELSE IF (dn(2) > 0) THEN + ELSEIF (dn(2) > 0) THEN IABCD = os(an, bn, cn + i2, dn - i2) - (D(2) - C(2))*os(an, bn, cn, dn - i2) - ELSE IF (dn(3) > 0) THEN + ELSEIF (dn(3) > 0) THEN IABCD = os(an, bn, cn + i3, dn - i3) - (D(3) - C(3))*os(an, bn, cn, dn - i3) ELSE IF (bn(1) > 0) THEN IABCD = os(an + i1, bn - i1, cn, dn) - (B(1) - A(1))*os(an, bn - i1, cn, dn) - ELSE IF (bn(2) > 0) THEN + ELSEIF (bn(2) > 0) THEN IABCD = os(an + i2, bn - i2, cn, dn) - (B(2) - A(2))*os(an, bn - i2, cn, dn) - ELSE IF (bn(3) > 0) THEN + ELSEIF (bn(3) > 0) THEN IABCD = os(an + i3, bn - i3, cn, dn) - (B(3) - A(3))*os(an, bn - i3, cn, dn) ELSE IF (cn(1) > 0) THEN @@ -145,12 +145,12 @@ CONTAINS 0.5_dp*an(1)/eta*os(an - i1, bn, cn - i1, dn) + & 0.5_dp*(cn(1) - 1)/eta*os(an, bn, cn - i1 - i1, dn) - & xsi/eta*os(an + i1, bn, cn - i1, dn) - ELSE IF (cn(2) > 0) THEN + ELSEIF (cn(2) > 0) THEN IABCD = ((Q(2) - C(2)) + xsi/eta*(P(2) - A(2)))*os(an, bn, cn - i2, dn) + & 0.5_dp*an(2)/eta*os(an - i2, bn, cn - i2, dn) + & 0.5_dp*(cn(2) - 1)/eta*os(an, bn, cn - i2 - i2, dn) - & xsi/eta*os(an + i2, bn, cn - i2, dn) - ELSE IF (cn(3) > 0) THEN + ELSEIF (cn(3) > 0) THEN IABCD = ((Q(3) - C(3)) + xsi/eta*(P(3) - A(3)))*os(an, bn, cn - i3, dn) + & 0.5_dp*an(3)/eta*os(an - i3, bn, cn - i3, dn) + & 0.5_dp*(cn(3) - 1)/eta*os(an, bn, cn - i3 - i3, dn) - & @@ -161,12 +161,12 @@ CONTAINS (W(1) - P(1))*os(an - i1, bn, cn, dn, m + 1) + & 0.5_dp*(an(1) - 1)/xsi*os(an - i1 - i1, bn, cn, dn, m) - & 0.5_dp*(an(1) - 1)/xsi*rho/xsi*os(an - i1 - i1, bn, cn, dn, m + 1) - ELSE IF (an(2) > 0) THEN + ELSEIF (an(2) > 0) THEN IABCD = (P(2) - A(2))*os(an - i2, bn, cn, dn, m) + & (W(2) - P(2))*os(an - i2, bn, cn, dn, m + 1) + & 0.5_dp*(an(2) - 1)/xsi*os(an - i2 - i2, bn, cn, dn, m) - & 0.5_dp*(an(2) - 1)/xsi*rho/xsi*os(an - i2 - i2, bn, cn, dn, m + 1) - ELSE IF (an(3) > 0) THEN + ELSEIF (an(3) > 0) THEN IABCD = (P(3) - A(3))*os(an - i3, bn, cn, dn, m) + & (W(3) - P(3))*os(an - i3, bn, cn, dn, m + 1) + & 0.5_dp*(an(3) - 1)/xsi*os(an - i3 - i3, bn, cn, dn, m) - & diff --git a/src/aobasis/ai_os_rr.F b/src/aobasis/ai_os_rr.F index f515ef089e..f5682c7b4c 100644 --- a/src/aobasis/ai_os_rr.F +++ b/src/aobasis/ai_os_rr.F @@ -162,7 +162,7 @@ CONTAINS rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(az - 1, dp)*(rr(m, coa2z, 1) - rr(m + 1, coa2z, 1)) END DO END IF - ELSE IF (ay > 0) THEN + ELSEIF (ay > 0) THEN DO m = 0, mmax - la rr(m, coa, 1) = rap(2)*rr(m, coa1y, 1) - rcp(2)*rr(m + 1, coa1y, 1) END DO @@ -171,7 +171,7 @@ CONTAINS rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(ay - 1, dp)*(rr(m, coa2y, 1) - rr(m + 1, coa2y, 1)) END DO END IF - ELSE IF (ax > 0) THEN + ELSEIF (ax > 0) THEN DO m = 0, mmax - la rr(m, coa, 1) = rap(1)*rr(m, coa1x, 1) - rcp(1)*rr(m + 1, coa1x, 1) END DO @@ -225,7 +225,7 @@ CONTAINS rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(az, dp)*(rr(m, coa1z, cob1z) - rr(m + 1, coa1z, cob1z)) END DO END IF - ELSE IF (by > 0) THEN + ELSEIF (by > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(2)*rr(m, coa, cob1y) - rcp(2)*rr(m + 1, coa, cob1y) END DO @@ -239,7 +239,7 @@ CONTAINS rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(ay, dp)*(rr(m, coa1y, cob1y) - rr(m + 1, coa1y, cob1y)) END DO END IF - ELSE IF (bx > 0) THEN + ELSEIF (bx > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(1)*rr(m, coa, cob1x) - rcp(1)*rr(m + 1, coa, cob1x) END DO diff --git a/src/aobasis/ai_overlap.F b/src/aobasis/ai_overlap.F index a3fe82c3e1..29b7a50a38 100644 --- a/src/aobasis/ai_overlap.F +++ b/src/aobasis/ai_overlap.F @@ -2050,12 +2050,12 @@ CONTAINS DO l = 0, la IF (l == 0) THEN fun(:, l) = z_one - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN fun(:, l) = CMPLX(0.0_dp, 0.5_dp*oa*gval(:), KIND=dp) - ELSE IF (l == 2) THEN + ELSEIF (l == 2) THEN fun(:, l) = CMPLX(-(0.5_dp*oa*gval(:))**2, 0.0_dp, KIND=dp) fun(:, l) = fun(:, l) + CMPLX(0.5_dp*oa, 0.0_dp, KIND=dp) - ELSE IF (l == 3) THEN + ELSEIF (l == 3) THEN fun(:, l) = CMPLX(0.0_dp, -(0.5_dp*oa*gval(:))**3, KIND=dp) fun(:, l) = fun(:, l) + CMPLX(0.0_dp, 0.75_dp*oa*oa*gval(:), KIND=dp) ELSE @@ -2065,12 +2065,12 @@ CONTAINS DO l = 0, lb IF (l == 0) THEN gun(:, l) = z_one - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN gun(:, l) = CMPLX(0.0_dp, 0.5_dp*ob*gval(:), KIND=dp) - ELSE IF (l == 2) THEN + ELSEIF (l == 2) THEN gun(:, l) = CMPLX(-(0.5_dp*ob*gval(:))**2, 0.0_dp, KIND=dp) gun(:, l) = gun(:, l) + CMPLX(0.5_dp*ob, 0.0_dp, KIND=dp) - ELSE IF (l == 3) THEN + ELSEIF (l == 3) THEN gun(:, l) = CMPLX(0.0_dp, -(0.5_dp*ob*gval(:))**3, KIND=dp) gun(:, l) = gun(:, l) + CMPLX(0.0_dp, 0.75_dp*ob*ob*gval(:), KIND=dp) ELSE diff --git a/src/aobasis/ai_overlap3_debug.F b/src/aobasis/ai_overlap3_debug.F index 76c062b1e8..2be04a16d7 100644 --- a/src/aobasis/ai_overlap3_debug.F +++ b/src/aobasis/ai_overlap3_debug.F @@ -99,25 +99,25 @@ CONTAINS IF (bn(1) > 0) THEN IACB = os_overlap3(an, cn + i1, bn - i1) + (C(1) - B(1))*os_overlap3(an, cn, bn - i1) - ELSE IF (bn(2) > 0) THEN + ELSEIF (bn(2) > 0) THEN IACB = os_overlap3(an, cn + i2, bn - i2) + (C(2) - B(2))*os_overlap3(an, cn, bn - i2) - ELSE IF (bn(3) > 0) THEN + ELSEIF (bn(3) > 0) THEN IACB = os_overlap3(an, cn + i3, bn - i3) + (C(3) - B(3))*os_overlap3(an, cn, bn - i3) ELSE IF (cn(1) > 0) THEN IACB = os_overlap3(an + i1, cn - i1, bn) + (A(1) - C(1))*os_overlap3(an, cn - i1, bn) - ELSE IF (cn(2) > 0) THEN + ELSEIF (cn(2) > 0) THEN IACB = os_overlap3(an + i2, cn - i2, bn) + (A(2) - C(2))*os_overlap3(an, cn - i2, bn) - ELSE IF (cn(3) > 0) THEN + ELSEIF (cn(3) > 0) THEN IACB = os_overlap3(an + i3, cn - i3, bn) + (A(3) - C(3))*os_overlap3(an, cn - i3, bn) ELSE IF (an(1) > 0) THEN IACB = (G(1) - A(1))*os_overlap3(an - i1, cn, bn) + & 0.5_dp*(an(1) - 1)/(xsi + xc)*os_overlap3(an - i1 - i1, cn, bn) - ELSE IF (an(2) > 0) THEN + ELSEIF (an(2) > 0) THEN IACB = (G(2) - A(2))*os_overlap3(an - i2, cn, bn) + & 0.5_dp*(an(2) - 1)/(xsi + xc)*os_overlap3(an - i2 - i2, cn, bn) - ELSE IF (an(3) > 0) THEN + ELSEIF (an(3) > 0) THEN IACB = (G(3) - A(3))*os_overlap3(an - i3, cn, bn) + & 0.5_dp*(an(3) - 1)/(xsi + xc)*os_overlap3(an - i3 - i3, cn, bn) ELSE diff --git a/src/aobasis/ai_overlap_debug.F b/src/aobasis/ai_overlap_debug.F index 63bc5f7edc..e25ec161b7 100644 --- a/src/aobasis/ai_overlap_debug.F +++ b/src/aobasis/ai_overlap_debug.F @@ -87,18 +87,18 @@ CONTAINS IF (bn(1) > 0) THEN IAB = os_overlap2(an + i1, bn - i1) + (A(1) - B(1))*os_overlap2(an, bn - i1) - ELSE IF (bn(2) > 0) THEN + ELSEIF (bn(2) > 0) THEN IAB = os_overlap2(an + i2, bn - i2) + (A(2) - B(2))*os_overlap2(an, bn - i2) - ELSE IF (bn(3) > 0) THEN + ELSEIF (bn(3) > 0) THEN IAB = os_overlap2(an + i3, bn - i3) + (A(3) - B(3))*os_overlap2(an, bn - i3) ELSE IF (an(1) > 0) THEN IAB = (P(1) - A(1))*os_overlap2(an - i1, bn) + & 0.5_dp*(an(1) - 1)/xsi*os_overlap2(an - i1 - i1, bn) - ELSE IF (an(2) > 0) THEN + ELSEIF (an(2) > 0) THEN IAB = (P(2) - A(2))*os_overlap2(an - i2, bn) + & 0.5_dp*(an(2) - 1)/xsi*os_overlap2(an - i2 - i2, bn) - ELSE IF (an(3) > 0) THEN + ELSEIF (an(3) > 0) THEN IAB = (P(3) - A(3))*os_overlap2(an - i3, bn) + & 0.5_dp*(an(3) - 1)/xsi*os_overlap2(an - i3 - i3, bn) ELSE diff --git a/src/aobasis/basis_set_types.F b/src/aobasis/basis_set_types.F index 6f25224995..3b2b3555fa 100644 --- a/src/aobasis/basis_set_types.F +++ b/src/aobasis/basis_set_types.F @@ -1680,9 +1680,8 @@ CONTAINS l(nshell(iset) - ishell + i, iset) = lshell END DO END DO - IF (LEN_TRIM(line_att) /= 0) THEN + IF (LEN_TRIM(line_att) /= 0) & CPABORT("Error reading the Basis from input file!") - END IF DO ipgf = 1, npgf(iset) is_ok = cp_sll_val_next(list, val) IF (.NOT. is_ok) CPABORT("Error reading the Basis set from input file!") @@ -2504,9 +2503,8 @@ CONTAINS ng = gto_basis_set%npgf(1) DO iset = 1, nset - IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) THEN + IF ((ng /= gto_basis_set%npgf(iset)) .AND. do_ortho) & CPABORT("different number of primitves") - END IF END DO IF (do_ortho) THEN @@ -2684,7 +2682,7 @@ CONTAINS s00 = ai*aj*(pi*ab)**1.50_dp IF (l == 0) THEN sss = s00 - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN sss = s00*ab*0.5_dp ELSE CPABORT("aovlp lvalue") diff --git a/src/arnoldi/arnoldi_data_methods.F b/src/arnoldi/arnoldi_data_methods.F index d88400ae01..05acfa5bdb 100644 --- a/src/arnoldi/arnoldi_data_methods.F +++ b/src/arnoldi/arnoldi_data_methods.F @@ -138,15 +138,13 @@ CONTAINS CALL control%mp_group%set_handle(group_handle) CALL control%pcol_group%set_handle(pcol_handle) - IF (.NOT. subgroups_defined) THEN + IF (.NOT. subgroups_defined) & CPABORT("arnoldi only with subgroups") - END IF control%symmetric = .FALSE. ! Will need a fix for complex because there it has to be hermitian - IF (SIZE(matrix) == 1) THEN + IF (SIZE(matrix) == 1) & control%symmetric = dbcsr_get_matrix_type(matrix(1)%matrix) == dbcsr_type_symmetric - END IF ! Set the control parameters control%max_iter = max_iter @@ -160,28 +158,23 @@ CONTAINS control%nrestart = nrestarts control%generalized_ev = generalized_ev - IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) THEN + IF (control%nval_req > 1 .AND. control%nrestart > 0 .AND. .NOT. control%iram) & CALL cp_abort(__LOCATION__, 'with more than one eigenvalue requested '// & 'internal restarting with a previous EVEC is a bad idea, set IRAM or nrestsart=0') - END IF ! some checks for the generalized EV mode - IF (control%generalized_ev .AND. selection_crit == 1) THEN + IF (control%generalized_ev .AND. selection_crit == 1) & CALL cp_abort(__LOCATION__, & 'generalized ev can only highest OR lowest EV') - END IF - IF (control%generalized_ev .AND. nval_request /= 1) THEN + IF (control%generalized_ev .AND. nval_request /= 1) & CALL cp_abort(__LOCATION__, & 'generalized ev can only compute one EV at the time') - END IF - IF (control%generalized_ev .AND. control%nrestart == 0) THEN + IF (control%generalized_ev .AND. control%nrestart == 0) & CALL cp_abort(__LOCATION__, & 'outer loops are mandatory for generalized EV, set nrestart appropriatly') - END IF - IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) THEN + IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) & CALL cp_abort(__LOCATION__, & 'generalized ev needs exactly two matrices as input (2nd is the metric)') - END IF ALLOCATE (control%selected_ind(max_iter)) CALL set_control(arnoldi_env, control) @@ -393,9 +386,8 @@ CONTAINS INTEGER :: ev_ind INTEGER, DIMENSION(:), POINTER :: selected_ind - IF (ind > get_nval_out(arnoldi_env)) THEN + IF (ind > get_nval_out(arnoldi_env)) & CPABORT('outside range of indexed evals') - END IF selected_ind => get_sel_ind(arnoldi_env) ev_ind = selected_ind(ind) @@ -419,9 +411,8 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: selected_ind NULLIFY (evals) - IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) THEN + IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) & CPABORT('array for eval output too small') - END IF selected_ind => get_sel_ind(arnoldi_env) evals => get_evals(arnoldi_env) diff --git a/src/arnoldi/arnoldi_geev.F b/src/arnoldi/arnoldi_geev.F index 88390f9e2b..5c014fca00 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)/NORM2(evec_r(:, i)) + evec_r(:, i) = evec_r(:, i)/SQRT(DOT_PRODUCT(evec_r(:, i), evec_r(:, i))) revec(:, i) = CMPLX(evec_r(:, i), REAL(0.0, dp), dp) levec(:, i) = CMPLX(evec_l(:, i), REAL(0.0, dp), dp) i = i + 1 diff --git a/src/arnoldi/arnoldi_methods.F b/src/arnoldi/arnoldi_methods.F index 2790c5d1b8..3ac3ef9ef7 100644 --- a/src/arnoldi/arnoldi_methods.F +++ b/src/arnoldi/arnoldi_methods.F @@ -561,7 +561,7 @@ CONTAINS ar_data%local_history = Zmat ! broadcast the Hessenberg matrix so we don't need to care later on - DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat) + DEALLOCATE (v_vec); DEALLOCATE (w_vec); DEALLOCATE (s_vec); DEALLOCATE (h_vec); DEALLOCATE (CZmat); DEALLOCATE (Zmat); DEALLOCATE (BZmat) CALL timestop(handle) diff --git a/src/atom_electronic_structure.F b/src/atom_electronic_structure.F index d490a9d9f6..c180ff67a2 100644 --- a/src/atom_electronic_structure.F +++ b/src/atom_electronic_structure.F @@ -343,10 +343,10 @@ CONTAINS xcmat%op = 0._dp CALL calculate_atom_vxc_lda(xcmat, atom, xc_section) ! ZMP added options for the zmp calculations, building external density and vxc potential - ELSE IF (need_zmp) THEN + ELSEIF (need_zmp) THEN xcmat%op = 0._dp CALL calculate_atom_zmp(ext_density=ext_density, atom=atom, lprint=.FALSE., xcmat=xcmat) - ELSE IF (need_vxc) THEN + ELSEIF (need_vxc) THEN xcmat%op = 0._dp CALL calculate_atom_ext_vxc(vxc=ext_vxc, atom=atom, lprint=.FALSE., xcmat=xcmat) ELSE @@ -503,10 +503,10 @@ CONTAINS ne = atom%state%occupation(l, k) IF (ne == 0._dp) THEN !empty shell EXIT !assume there are no holes - ELSE IF (ne == 2._dp*nm) THEN !closed shell + ELSEIF (ne == 2._dp*nm) THEN !closed shell atom%state%occa(l, k) = nm atom%state%occb(l, k) = nm - ELSE IF (atom%state%multiplicity == -2) THEN !High spin case + ELSEIF (atom%state%multiplicity == -2) THEN !High spin case atom%state%occa(l, k) = MIN(ne, nm) atom%state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_energy.F b/src/atom_energy.F index c14bece975..7d2a7b853d 100644 --- a/src/atom_energy.F +++ b/src/atom_energy.F @@ -1103,11 +1103,11 @@ CONTAINS IF (PRESENT(counter)) THEN WRITE (str, "(I12)") counter - ELSE IF (PRESENT(rval)) THEN + ELSEIF (PRESENT(rval)) THEN WRITE (str, "(G18.8)") rval - ELSE IF (PRESENT(ival)) THEN + ELSEIF (PRESENT(ival)) THEN WRITE (str, "(I12)") ival - ELSE IF (PRESENT(cval)) THEN + ELSEIF (PRESENT(cval)) THEN WRITE (str, "(A)") TRIM(ADJUSTL(cval)) ELSE WRITE (str, "(A)") "" diff --git a/src/atom_fit.F b/src/atom_fit.F index 0f9bf3b62a..b80ba7e82d 100644 --- a/src/atom_fit.F +++ b/src/atom_fit.F @@ -657,7 +657,7 @@ CONTAINS ntarget = ntarget + 1 wtot = wtot + atom%weight*w_virt/100._dp END IF - ELSE IF (k < atom%state%maxn_occ(l)) THEN + ELSEIF (k < atom%state%maxn_occ(l)) THEN atom%orbitals%wrefene(k, l, 1) = w_semi atom%orbitals%wrefchg(k, l, 1) = w_semi/100._dp atom%orbitals%crefene(k, l, 1) = t_semi @@ -735,7 +735,7 @@ CONTAINS wtot = wtot + atom%weight*2._dp*w_virt/100._dp ntarget = ntarget + 2 END IF - ELSE IF (k < atom%state%maxn_occ(l)) THEN + ELSEIF (k < atom%state%maxn_occ(l)) THEN atom%orbitals%wrefene(k, l, 1:2) = w_semi atom%orbitals%wrefchg(k, l, 1:2) = w_semi/100._dp atom%orbitals%crefene(k, l, 1:2) = t_semi diff --git a/src/atom_grb.F b/src/atom_grb.F index e23bccc669..2575d79300 100644 --- a/src/atom_grb.F +++ b/src/atom_grb.F @@ -152,9 +152,8 @@ CONTAINS CALL allocate_grid_atom(basis%grid) CALL section_vals_val_get(grb_section, "QUADRATURE", i_val=quadtype) CALL section_vals_val_get(grb_section, "GRID_POINTS", i_val=ngp) - IF (ngp <= 0) THEN + IF (ngp <= 0) & CPABORT("# point radial grid < 0") - END IF CALL create_grid_atom(basis%grid, ngp, 1, 1, 0, quadtype) basis%grid%nr = ngp ! diff --git a/src/atom_kind_orbitals.F b/src/atom_kind_orbitals.F index 30ceb56c06..25c3265e68 100644 --- a/src/atom_kind_orbitals.F +++ b/src/atom_kind_orbitals.F @@ -273,7 +273,7 @@ CONTAINS ! total number of occupied orbitals IF (PRESENT(nocc) .AND. ghost) THEN nocc = 0 - ELSE IF (PRESENT(nocc)) THEN + ELSEIF (PRESENT(nocc)) THEN nocc = 0 DO l = 0, lmat DO k = 1, 7 diff --git a/src/atom_operators.F b/src/atom_operators.F index 6f1e65e81f..3a0e95ab1d 100644 --- a/src/atom_operators.F +++ b/src/atom_operators.F @@ -120,14 +120,14 @@ CONTAINS rc = potential%rcon sc = potential%scon cpot(1:m) = (basis%grid%rad(1:m)/rc)**sc - ELSE IF (potential%conf_type == barrier_conf) THEN + ELSEIF (potential%conf_type == barrier_conf) THEN om = potential%rcon ron = potential%scon rc = ron + om DO i = 1, m IF (basis%grid%rad(i) < ron) THEN cpot(i) = 0.0_dp - ELSE IF (basis%grid%rad(i) < rc) THEN + ELSEIF (basis%grid%rad(i) < rc) THEN x = (basis%grid%rad(i) - ron)/om x = 1._dp - x cpot(i) = -6._dp*x**5 + 15._dp*x**4 - 10._dp*x**3 + 1._dp diff --git a/src/atom_optimization.F b/src/atom_optimization.F index 8d4986d7a8..d2ffa6a3fc 100644 --- a/src/atom_optimization.F +++ b/src/atom_optimization.F @@ -221,7 +221,7 @@ CONTAINS IF (nm < 1) nm = history%max_history fmat = a*history%hmat(nnow)%fmat + (1._dp - a)*history%hmat(nm)%fmat END IF - ELSE IF (history%hlen == 1) THEN + ELSEIF (history%hlen == 1) THEN fmat = history%hmat(nnow)%fmat ELSE CPABORT("Length of matrix history hlen < 1") diff --git a/src/atom_output.F b/src/atom_output.F index 8562be639a..59d577c206 100644 --- a/src/atom_output.F +++ b/src/atom_output.F @@ -192,19 +192,16 @@ CONTAINS WRITE (iw, '(T36,A,T61,F20.12)') " Virial (-V/T) ::", -atom%energy%epot/atom%energy%ekin END IF WRITE (iw, '(T36,A,T61,F20.12)') " Core Energy ::", atom%energy%ecore - IF (atom%energy%exc /= 0._dp) THEN + IF (atom%energy%exc /= 0._dp) & WRITE (iw, '(T36,A,T61,F20.12)') " XC Energy ::", atom%energy%exc - END IF WRITE (iw, '(T36,A,T61,F20.12)') " Coulomb Energy ::", atom%energy%ecoulomb - IF (atom%energy%eexchange /= 0._dp) THEN + IF (atom%energy%eexchange /= 0._dp) & WRITE (iw, '(T34,A,T61,F20.12)') "HF Exchange Energy ::", atom%energy%eexchange - END IF IF (atom%potential%ppot_type /= NO_PSEUDO) THEN WRITE (iw, '(T20,A,T61,F20.12)') " Total Pseudopotential Energy ::", atom%energy%epseudo WRITE (iw, '(T20,A,T61,F20.12)') " Local Pseudopotential Energy ::", atom%energy%eploc - IF (atom%energy%elsd /= 0._dp) THEN + IF (atom%energy%elsd /= 0._dp) & WRITE (iw, '(T20,A,T61,F20.12)') " Local Spin-potential Energy ::", atom%energy%elsd - END IF WRITE (iw, '(T20,A,T61,F20.12)') " Nonlocal Pseudopotential Energy ::", atom%energy%epnl END IF IF (atom%potential%confinement) THEN diff --git a/src/atom_pseudo.F b/src/atom_pseudo.F index c77de88e67..7064b7a535 100644 --- a/src/atom_pseudo.F +++ b/src/atom_pseudo.F @@ -257,10 +257,10 @@ CONTAINS ne = state%occupation(l, k) IF (ne == 0._dp) THEN !empty shell EXIT !assume there are no holes - ELSE IF (ne == 2._dp*nm) THEN !closed shell + ELSEIF (ne == 2._dp*nm) THEN !closed shell state%occa(l, k) = nm state%occb(l, k) = nm - ELSE IF (state%multiplicity == -2) THEN !High spin case + ELSEIF (state%multiplicity == -2) THEN !High spin case state%occa(l, k) = MIN(ne, nm) state%occb(l, k) = MAX(0._dp, ne - nm) ELSE diff --git a/src/atom_set_basis.F b/src/atom_set_basis.F index f66006b6d4..767bc5a76e 100644 --- a/src/atom_set_basis.F +++ b/src/atom_set_basis.F @@ -204,7 +204,7 @@ CONTAINS basis%ddbf(k, i, l) = (REAL(l*(l - 1), dp)*rk**(l - 2) - & 2._dp*al*REAL(2*l + 1, dp)*rk**(l) + 4._dp*al*rk**(l + 2))*ear END DO - ELSE IF (basis%basis_type == CGTO_BASIS) THEN + ELSEIF (basis%basis_type == CGTO_BASIS) THEN DO k = 1, nr rk = basis%grid%rad(k) ear = EXP(-al*basis%grid%rad(k)**2) diff --git a/src/atom_sgp.F b/src/atom_sgp.F index 2289ec8964..178e7e93bd 100644 --- a/src/atom_sgp.F +++ b/src/atom_sgp.F @@ -122,7 +122,7 @@ CONTAINS ! generate the transformed potentials IF (is_ecp) THEN CALL ecp_sgp_constr(ecp_pot, sgp_pot, basis) - ELSE IF (is_upf) THEN + ELSEIF (is_upf) THEN CALL upf_sgp_constr(upf_pot, sgp_pot, basis) ELSE CPABORT("Either ecp_pot or upf_pot is needed for sgp_construction") @@ -137,7 +137,7 @@ CONTAINS ! IF (is_ecp) THEN CALL ecpints(hnl%op, basis, ecp_pot) - ELSE IF (is_upf) THEN + ELSEIF (is_upf) THEN CALL upfints(core%op, hnl%op, basis, upf_pot, cutpotu, sgp_pot%ac_local) ELSE CPABORT("Either ecp_pot or upf_pot is needed for sgp_construction") @@ -246,7 +246,7 @@ CONTAINS IF (do_transform) THEN IF (is_ecp) THEN CALL ecp_sgp_constr(ecp_pot, sgp_pot, atom_ref%basis) - ELSE IF (is_upf) THEN + ELSEIF (is_upf) THEN CALL upf_sgp_constr(upf_pot, sgp_pot, atom_ref%basis) ELSE CPABORT("Either ecp_pseudo or upf_pseudo is needed for atom_sgp_construction") @@ -279,7 +279,7 @@ CONTAINS ! IF (is_ecp) THEN CALL ecpints(hnl%op, atom_ref%basis, ecp_pot) - ELSE IF (is_upf) THEN + ELSEIF (is_upf) THEN CALL upfints(core%op, hnl%op, atom_ref%basis, upf_pot, cutpotu, sgp_pot%ac_local) ELSE CPABORT("Either ecp_pseudo or upf_pseudo is needed for atom_sgp_construction") diff --git a/src/atom_types.F b/src/atom_types.F index a1a2a54115..502369a13b 100644 --- a/src/atom_types.F +++ b/src/atom_types.F @@ -414,9 +414,8 @@ CONTAINS CALL allocate_grid_atom(basis%grid) CALL section_vals_val_get(basis_section, "QUADRATURE", i_val=quadtype) CALL section_vals_val_get(basis_section, "GRID_POINTS", i_val=ngp) - IF (ngp <= 0) THEN + IF (ngp <= 0) & CPABORT("The number of radial grid points must be greater than zero.") - END IF CALL create_grid_atom(basis%grid, ngp, 1, 1, 0, quadtype) basis%grid%nr = ngp basis%geometrical = .FALSE. @@ -841,9 +840,8 @@ CONTAINS CALL allocate_grid_atom(gbasis%grid) ngp = SIZE(r) quadtype = do_gapw_log - IF (ngp <= 0) THEN + IF (ngp <= 0) & CPABORT("The number of radial grid points must be greater than zero.") - END IF CALL create_grid_atom(gbasis%grid, ngp, 1, 1, 0, quadtype) gbasis%grid%nr = ngp gbasis%grid%rad(:) = r(:) diff --git a/src/atom_upf.F b/src/atom_upf.F index 8c226de646..3a19e15d04 100644 --- a/src/atom_upf.F +++ b/src/atom_upf.F @@ -218,39 +218,39 @@ CONTAINS IF (nametag(2:8) == "PP_INFO") THEN CPASSERT(nametag(9:9) == ">") CALL upf_info_section(parser, pot) - ELSE IF (nametag(2:10) == "PP_HEADER") THEN + ELSEIF (nametag(2:10) == "PP_HEADER") THEN IF (.NOT. (nametag(11:11) == ">")) THEN CALL upf_header_option(parser, pot) END IF - ELSE IF (nametag(2:8) == "PP_MESH") THEN + ELSEIF (nametag(2:8) == "PP_MESH") THEN IF (.NOT. (nametag(9:9) == ">")) THEN CALL upf_mesh_option(parser, pot) END IF CALL upf_mesh_section(parser, pot) - ELSE IF (nametag(2:8) == "PP_NLCC") THEN + ELSEIF (nametag(2:8) == "PP_NLCC") THEN IF (nametag(9:9) == ">") THEN CALL upf_nlcc_section(parser, pot, .FALSE.) ELSE CALL upf_nlcc_section(parser, pot, .TRUE.) END IF - ELSE IF (nametag(2:9) == "PP_LOCAL") THEN + ELSEIF (nametag(2:9) == "PP_LOCAL") THEN IF (nametag(10:10) == ">") THEN CALL upf_local_section(parser, pot, .FALSE.) ELSE CALL upf_local_section(parser, pot, .TRUE.) END IF - ELSE IF (nametag(2:12) == "PP_NONLOCAL") THEN + ELSEIF (nametag(2:12) == "PP_NONLOCAL") THEN CPASSERT(nametag(13:13) == ">") CALL upf_nonlocal_section(parser, pot) - ELSE IF (nametag(2:13) == "PP_SEMILOCAL") THEN + ELSEIF (nametag(2:13) == "PP_SEMILOCAL") THEN CALL upf_semilocal_section(parser, pot) - ELSE IF (nametag(2:9) == "PP_PSWFC") THEN + ELSEIF (nametag(2:9) == "PP_PSWFC") THEN ! skip section for now - ELSE IF (nametag(2:11) == "PP_RHOATOM") THEN + ELSEIF (nametag(2:11) == "PP_RHOATOM") THEN ! skip section for now - ELSE IF (nametag(2:7) == "PP_PAW") THEN + ELSEIF (nametag(2:7) == "PP_PAW") THEN ! skip section for now - ELSE IF (nametag(2:6) == "/UPF>") THEN + ELSEIF (nametag(2:6) == "/UPF>") THEN EXIT END IF END IF @@ -856,7 +856,7 @@ CONTAINS END IF IF (icount > ms) EXIT END DO - ELSE IF (string(1:15) == "") THEN + ELSEIF (string(1:15) == "") THEN EXIT ELSE ! diff --git a/src/atom_utils.F b/src/atom_utils.F index ae92b95ee4..8465ff388a 100644 --- a/src/atom_utils.F +++ b/src/atom_utils.F @@ -2549,7 +2549,7 @@ CONTAINS ja = ibptr(ia, la) jb = ibptr(ib, lb) smat(ja:ja + nna - 1, jb:jb + nnb - 1) = smat(ja:ja + nna - 1, jb:jb + nnb - 1) + sab(1:nna, 1:nnb) - ELSE IF (basis%basis_type == CGTO_BASIS) THEN + ELSEIF (basis%basis_type == CGTO_BASIS) THEN DO ka = 1, basis%nbas(la) DO kb = 1, basis%nbas(lb) ja = ibptr(ka, la) @@ -2572,7 +2572,7 @@ CONTAINS jb = ibptr(ib, lb) smat(ja:ja + nna - 1, jb:jb + nnb - 1) = smat(ja:ja + nna - 1, jb:jb + nnb - 1) & + sab(1:nna, 1:nnb) - ELSE IF (basis%basis_type == CGTO_BASIS) THEN + ELSEIF (basis%basis_type == CGTO_BASIS) THEN DO ka = 1, basis%nbas(la) DO kb = 1, basis%nbas(lb) ja = ibptr(ka, la) diff --git a/src/atoms_input.F b/src/atoms_input.F index 1156efb330..4e3b87bbf4 100644 --- a/src/atoms_input.F +++ b/src/atoms_input.F @@ -144,9 +144,8 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & CPABORT("incorrectly formatted line in coord section'"//line_att//"'") - END IF IF (wrd == 1) THEN atom_info%id_atmname(iatom) = str2id(s2s(line_att(start_c:end_c - 1))) ELSE @@ -196,26 +195,24 @@ CONTAINS EXIT END IF END DO - IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) THEN + IF (LEN_TRIM(line_att(start_c:end_c - 1)) == 0) & CALL cp_abort(__LOCATION__, & "Incorrectly formatted input line for atom "// & TRIM(ADJUSTL(cp_to_string(iatom)))// & " found in COORD section. Input line: <"// & TRIM(line_att)//"> ") - END IF SELECT CASE (wrd) CASE (1) atom_info%id_atmname(iatom) = str2id(s2s(line_att(start_c:end_c - 1))) CASE (2:4) CALL read_float_object(line_att(start_c:end_c - 1), & atom_info%r(wrd - 1, iatom), error_message) - IF (LEN_TRIM(error_message) /= 0) THEN + IF (LEN_TRIM(error_message) /= 0) & CALL cp_abort(__LOCATION__, & "Incorrectly formatted input line for atom "// & TRIM(ADJUSTL(cp_to_string(iatom)))// & " found in COORD section. "//TRIM(error_message)// & " Input line: <"//TRIM(line_att)//"> ") - END IF CASE (5) READ (line_att(start_c:end_c - 1), *) strtmp atom_info%id_molname(iatom) = str2id(strtmp) @@ -346,9 +343,8 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & CPABORT("incorrectly formatted line in coord section'"//line_att//"'") - END IF IF (wrd == 1) THEN at_name(ishell) = line_att(start_c:end_c - 1) CALL uppercase(at_name(ishell)) @@ -397,9 +393,8 @@ CONTAINS EXIT END IF END DO - IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) THEN + IF (wrd /= 5 .AND. end_c >= LEN(line_att) + 1) & CPABORT("incorrectly formatted line in coord section'"//line_att//"'") - END IF IF (wrd == 1) THEN at_name_c(ishell) = line_att(start_c:end_c - 1) CALL uppercase(at_name_c(ishell)) diff --git a/src/auto_basis.F b/src/auto_basis.F index 23546df6e7..94bccf5995 100644 --- a/src/auto_basis.F +++ b/src/auto_basis.F @@ -61,7 +61,7 @@ CONTAINS INTEGER, INTENT(IN), OPTIONAL :: basis_sort CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname, kname + CHARACTER(LEN=default_string_length) :: bsname INTEGER :: i, j, jj, l, laux, linc, lmax, lval, lx, & nsets, nx, z INTEGER, DIMENSION(0:18) :: nval @@ -84,7 +84,7 @@ CONTAINS 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 2.0_dp] ! CPASSERT(.NOT. ASSOCIATED(ri_aux_basis_set)) - NULLIFY (orb_basis_set, econf) + NULLIFY (orb_basis_set) IF (.NOT. PRESENT(basis_type)) THEN CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") ELSE @@ -106,15 +106,6 @@ CONTAINS CALL init_orbital_pointers(2*lmax) CALL get_basis_products(lmax, zmin, zmax, zeff, pmin, pmax, peff) CALL get_qs_kind(qs_kind, zeff=zval, elec_conf=econf, element_symbol=element_symbol) - IF (.NOT. ASSOCIATED(econf)) THEN - CALL get_qs_kind(qs_kind, name=kname) - CALL cp_abort(__LOCATION__, & - "AUTO_BASIS RI_AUX cannot process atom kind "// & - "<"//TRIM(ADJUSTL(kname))//"> due to missing "// & - "definition of potential or electron configuration; "// & - "consider setting keyword ELEC_CONF explicitly for "// & - "GHOST atom kind that has assigned a basis set") - END IF CALL get_ptable_info(element_symbol, ielement=z) lval = 0 DO l = 0, MAXVAL(UBOUND(econf)) @@ -245,7 +236,7 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: exact_1c_terms, tda_kernel CHARACTER(LEN=2) :: element_symbol - CHARACTER(LEN=default_string_length) :: bsname, kname + CHARACTER(LEN=default_string_length) :: bsname INTEGER :: i, j, l, laux, linc, lm, lmax, lval, n1, & n2, nsets, z INTEGER, DIMENSION(0:18) :: nval @@ -276,21 +267,12 @@ CONTAINS END IF ! CPASSERT(.NOT. ASSOCIATED(lri_aux_basis_set)) - NULLIFY (orb_basis_set, econf) + NULLIFY (orb_basis_set) CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, basis_type="ORB") IF (ASSOCIATED(orb_basis_set)) THEN CALL get_basis_keyfigures(orb_basis_set, lmax, zmin, zmax, zeff) CALL get_basis_products(lmax, zmin, zmax, zeff, pmin, pmax, peff) CALL get_qs_kind(qs_kind, zeff=zval, elec_conf=econf, element_symbol=element_symbol) - IF (.NOT. ASSOCIATED(econf)) THEN - CALL get_qs_kind(qs_kind, name=kname) - CALL cp_abort(__LOCATION__, & - "AUTO_BASIS LRI_AUX cannot process atom kind "// & - "<"//TRIM(ADJUSTL(kname))//"> due to missing "// & - "definition of potential or electron configuration; "// & - "consider setting keyword ELEC_CONF explicitly for "// & - "GHOST atom kind that has assigned a basis set") - END IF CALL get_ptable_info(element_symbol, ielement=z) lval = 0 DO l = 0, MAXVAL(UBOUND(econf)) diff --git a/src/base/base_hooks.F b/src/base/base_hooks.F index d31f199528..dd7931e047 100644 --- a/src/base/base_hooks.F +++ b/src/base/base_hooks.F @@ -145,9 +145,8 @@ CONTAINS IF (ASSOCIATED(timestop_hook)) THEN CALL timestop_hook(handle) ELSE - IF (handle /= -1) THEN + IF (handle /= -1) & CALL cp_abort(cp__l("base_hooks.F", __LINE__), "Got wrong handle") - END IF END IF END SUBROUTINE timestop diff --git a/src/base/machine.F b/src/base/machine.F index a2e21f7fa0..9cadaa31a7 100644 --- a/src/base/machine.F +++ b/src/base/machine.F @@ -741,17 +741,14 @@ CONTAINS ! on a posix system LOGNAME should be defined CALL get_environment_variable("LOGNAME", value=user, status=istat) ! nope, check alternative - IF (istat /= 0) THEN + IF (istat /= 0) & CALL get_environment_variable("USER", value=user, status=istat) - END IF ! nope, check alternative - IF (istat /= 0) THEN + IF (istat /= 0) & CALL get_environment_variable("USERNAME", value=user, status=istat) - END IF ! fall back - IF (istat /= 0) THEN + IF (istat /= 0) & user = "" - END IF END SUBROUTINE m_getlog diff --git a/src/bse_util.F b/src/bse_util.F index 3de6d00855..d6d53fbba4 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" - ELSE IF (iset == 2) THEN + ELSEIF (iset == 2) THEN WRITE (filename, '(A6,I3.3,A5,I2.2,a15)') "_NEXC_", istate, "_NTO_", i, "_Particle_State" END IF info_approx_trunc = TRIM(ADJUSTL(info_approximation)) @@ -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 - ELSE IF (iset == 2) THEN + ELSEIF (iset == 2) THEN WRITE (title, *) "Natural Transition Orbital Particle State", i END IF CALL cp_pw_to_cube(wf_r, unit_nr_cube, title, particles=particles, stride=stride, mpi_io=mpi_io) diff --git a/src/bsse.F b/src/bsse.F index 6869888a3d..3abfc8c654 100644 --- a/src/bsse.F +++ b/src/bsse.F @@ -370,10 +370,10 @@ CONTAINS iw = cp_print_key_unit_nr(logger, bsse_section, "PRINT%PROGRAM_RUN_INFO", & extension=".log") IF (iw > 0) THEN - WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf + WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf; IF (istat /= 0) conf_s = "exceeded" CALL compress(conf_s, full=.TRUE.) - WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc + WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc; IF (istat /= 0) conf_loc_s = "exceeded" CALL compress(conf_loc_s, full=.TRUE.) @@ -429,17 +429,15 @@ CONTAINS IF (explicit) THEN DO i = 1, nconf CALL section_vals_val_get(configurations, "GLB_CONF", i_rep_section=i, i_vals=glb_conf) - IF (SIZE(glb_conf) /= SIZE(conf)) THEN + IF (SIZE(glb_conf) /= SIZE(conf)) & CALL cp_abort(__LOCATION__, & "GLB_CONF requires a binary description of the configuration. Number of integer "// & "different from the number of fragments defined!") - END IF CALL section_vals_val_get(configurations, "SUB_CONF", i_rep_section=i, i_vals=sub_conf) - IF (SIZE(sub_conf) /= SIZE(conf)) THEN + IF (SIZE(sub_conf) /= SIZE(conf)) & CALL cp_abort(__LOCATION__, & "SUB_CONF requires a binary description of the configuration. Number of integer "// & "different from the number of fragments defined!") - END IF IF (ALL(conf == glb_conf) .AND. ALL(conf_loc == sub_conf)) THEN CALL section_vals_val_get(configurations, "CHARGE", i_rep_section=i, & i_val=present_charge) diff --git a/src/cell_methods.F b/src/cell_methods.F index 1cb33a48c5..fc063a2c1e 100644 --- a/src/cell_methods.F +++ b/src/cell_methods.F @@ -461,12 +461,11 @@ CONTAINS CALL section_vals_val_get(cell_section, "CELL_FILE_NAME", explicit=cell_read_file) IF (cell_read_file) THEN ! Case 1 tmp_comb_cell = (cell_read_abc .OR. (cell_read_a .OR. (cell_read_b .OR. cell_read_c))) - IF (tmp_comb_cell) THEN + IF (tmp_comb_cell) & CALL cp_warn(__LOCATION__, & "Cell Information provided through A, B, C, or ABC in conjunction "// & "with CELL_FILE_NAME. The definition in external file will override "// & "other ones.") - END IF CALL section_vals_val_get(cell_section, "CELL_FILE_NAME", c_val=cell_file_name) CALL section_vals_val_get(cell_section, "CELL_FILE_FORMAT", i_val=cell_file_format) SELECT CASE (cell_file_format) @@ -492,11 +491,10 @@ CONTAINS read_len = cell_par CALL section_vals_val_get(cell_section, "ALPHA_BETA_GAMMA", r_vals=cell_par) read_ang = cell_par - IF (cell_read_a .OR. cell_read_b .OR. cell_read_c) THEN + IF (cell_read_a .OR. cell_read_b .OR. cell_read_c) & CALL cp_warn(__LOCATION__, & "Cell information provided through vectors A, B or C in conjunction with ABC. "// & "The definition of the ABC keyword will override the one provided by A, B and C.") - END IF ELSE ! Case 3 tmp_comb_abc = ((cell_read_a .EQV. cell_read_b) .AND. (cell_read_b .EQV. cell_read_c)) IF (tmp_comb_abc) THEN @@ -506,11 +504,10 @@ CONTAINS read_mat(:, 2) = cell_par(:) CALL section_vals_val_get(cell_section, "C", r_vals=cell_par) read_mat(:, 3) = cell_par(:) - IF (cell_read_alpha_beta_gamma) THEN + IF (cell_read_alpha_beta_gamma) & CALL cp_warn(__LOCATION__, & "The keyword ALPHA_BETA_GAMMA is ignored because it was used without the "// & "keyword ABC.") - END IF ELSE CALL cp_abort(__LOCATION__, & "Neither of the keywords CELL_FILE_NAME or ABC are specified, "// & @@ -725,11 +722,10 @@ CONTAINS CPASSERT(ASSOCIATED(cell)) ! Abort, if one of the value is set to zero - IF (ANY(multiple_unit_cell <= 0)) THEN + IF (ANY(multiple_unit_cell <= 0)) & CALL cp_abort(__LOCATION__, & "CELL%MULTIPLE_UNIT_CELL accepts only integer values larger than 0! "// & "A value of 0 or negative is meaningless!") - END IF ! Scale abc according to user request cell%hmat(:, 1) = cell%hmat(:, 1)*multiple_unit_cell(1) @@ -782,9 +778,8 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_a", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field _cell_length_a or _cell.length_a was not found in CIF file! ") - END IF END IF CALL cif_get_real(parser, cell_lengths(1)) cell_lengths(1) = cp_unit_to_cp2k(cell_lengths(1), "angstrom") @@ -795,9 +790,8 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_b", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field _cell_length_b or _cell.length_b was not found in CIF file! ") - END IF END IF CALL cif_get_real(parser, cell_lengths(2)) cell_lengths(2) = cp_unit_to_cp2k(cell_lengths(2), "angstrom") @@ -808,9 +802,8 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.length_c", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field _cell_length_c or _cell.length_c was not found in CIF file! ") - END IF END IF CALL cif_get_real(parser, cell_lengths(3)) cell_lengths(3) = cp_unit_to_cp2k(cell_lengths(3), "angstrom") @@ -821,9 +814,8 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_alpha", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field _cell_angle_alpha or _cell.angle_alpha was not found in CIF file! ") - END IF END IF CALL cif_get_real(parser, cell_angles(1)) cell_angles(1) = cp_unit_to_cp2k(cell_angles(1), "deg") @@ -834,9 +826,8 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_beta", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field _cell_angle_beta or _cell.angle_beta was not found in CIF file! ") - END IF END IF CALL cif_get_real(parser, cell_angles(2)) cell_angles(2) = cp_unit_to_cp2k(cell_angles(2), "deg") @@ -847,9 +838,8 @@ CONTAINS IF (.NOT. found) THEN CALL parser_search_string(parser, "_cell.angle_gamma", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field _cell_angle_gamma or _cell.angle_gamma was not found in CIF file! ") - END IF END IF CALL cif_get_real(parser, cell_angles(3)) cell_angles(3) = cp_unit_to_cp2k(cell_angles(3), "deg") @@ -1202,9 +1192,8 @@ CONTAINS CALL parser_search_string(parser, "CRYST1", ignore_case=.FALSE., found=found, & begin_line=.TRUE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The line was not found in PDB file! ") - END IF periodic = 1 READ (parser%input_line, *, IOSTAT=ios) cryst, cell_lengths(:), cell_angles(:) diff --git a/src/colvar_methods.F b/src/colvar_methods.F index b92eebad05..0489fefb36 100644 --- a/src/colvar_methods.F +++ b/src/colvar_methods.F @@ -618,12 +618,11 @@ CONTAINS ALLOCATE (colvar%combine_cvs_param%variables(SIZE(my_par))) colvar%combine_cvs_param%variables = my_par ! Check that the number of COLVAR provided is equal to the number of variables.. - IF (SIZE(my_par) /= ncol) THEN + IF (SIZE(my_par) /= ncol) & CALL cp_abort(__LOCATION__, & "Number of defined COLVAR for COMBINE_COLVAR is different from the "// & "number of variables! It is not possible to define COLVARs in a COMBINE_COLVAR "// & "and avoid their usage in the combininig function!") - END IF ! Parameters ALLOCATE (colvar%combine_cvs_param%c_parameters(0)) CALL section_vals_val_get(combine_section, "PARAMETERS", n_rep_val=ncol) @@ -727,9 +726,8 @@ CONTAINS ! Read the specification of the two planes plane_sections => section_vals_get_subs_vals(plane_plane_angle_section, "PLANE") CALL section_vals_get(plane_sections, n_repetition=n_var) - IF (n_var /= 2) THEN + IF (n_var /= 2) & CPABORT("PLANE_PLANE_ANGLE Colvar section: Two PLANE sections must be provided!") - END IF ! Plane 1 CALL section_vals_val_get(plane_sections, "DEF_TYPE", i_rep_section=1, & i_val=colvar%plane_plane_angle_param%plane1%type_of_def) @@ -738,9 +736,8 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane1%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) THEN + IF (ASSOCIATED(cell)) & CALL cell_transform_input_cartesian(cell, colvar%plane_plane_angle_param%plane1%normal_vec) - END IF END IF ELSE CALL section_vals_val_get(plane_sections, "ATOMS", i_rep_section=1, & @@ -756,9 +753,8 @@ CONTAINS r_vals=s1) colvar%plane_plane_angle_param%plane2%normal_vec = s1 IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) THEN + IF (ASSOCIATED(cell)) & CALL cell_transform_input_cartesian(cell, colvar%plane_plane_angle_param%plane2%normal_vec) - END IF END IF ELSE CALL section_vals_val_get(plane_sections, "ATOMS", i_rep_section=2, & @@ -867,10 +863,9 @@ CONTAINS weights(ndim + 1:ndim + SIZE(wei)) = wei ndim = ndim + SIZE(wei) END DO - IF (ndim /= colvar%rmsd_param%n_atoms) THEN + IF (ndim /= colvar%rmsd_param%n_atoms) & CALL cp_abort(__LOCATION__, "CV RMSD: list of atoms and list of "// & "weights need to contain same number of entries. ") - END IF DO i = 1, ndim ii = colvar%rmsd_param%i_rmsd(i) colvar%rmsd_param%weights(ii) = weights(i) @@ -952,13 +947,11 @@ CONTAINS i_val=colvar%ring_puckering_param%iq) ! test the validity of the parameters ndim = colvar%ring_puckering_param%nring - IF (ndim <= 3) THEN + IF (ndim <= 3) & CPABORT("CV Ring Puckering: Ring size has to be 4 or larger. ") - END IF ii = colvar%ring_puckering_param%iq - IF (ABS(ii) == 1 .OR. ii < -(ndim - 1)/2 .OR. ii > ndim/2) THEN + IF (ABS(ii) == 1 .OR. ii < -(ndim - 1)/2 .OR. ii > ndim/2) & CPABORT("CV Ring Puckering: Invalid coordinate number.") - END IF ELSE IF (my_subsection(23)) THEN ! Minimum Distance wrk_section => mindist_section @@ -1333,7 +1326,7 @@ CONTAINS IF (colvar%ring_puckering_param%iq == 0) THEN WRITE (iw, '( A,T40,A)') ' COLVARS| Ring Puckering >>> coordinate', & ' Total Puckering Amplitude' - ELSE IF (colvar%ring_puckering_param%iq > 0) THEN + ELSEIF (colvar%ring_puckering_param%iq > 0) THEN WRITE (iw, '( A,T35,A,T57,I8)') ' COLVARS| Ring Puckering >>> coordinate', & ' Puckering Amplitude', & colvar%ring_puckering_param%iq @@ -2196,12 +2189,11 @@ CONTAINS CALL put_derivative(colvar, iatom, fi) END DO ELSE - IF (force_env%in_use /= use_mixed_force) THEN + IF (force_env%in_use /= use_mixed_force) & CALL cp_abort(__LOCATION__, & 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)// & ' A combination of mixed force_eval energies has been requested as '// & ' collective variable, but the MIXED env is not in use! Aborting.') - END IF CALL force_env_get(force_env, force_env_section=force_env_section) mapping_section => section_vals_get_subs_vals(force_env_section, "MIXED%MAPPING") NULLIFY (values, parameters, subsystems, particles, global_forces, map_index, glob_natoms) @@ -2691,8 +2683,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! evaluation of the angle.. - a = NORM2(xij) - b = NORM2(xkj) + a = SQRT(DOT_PRODUCT(xij, xij)) + b = SQRT(DOT_PRODUCT(xkj, xkj)) t0 = 1.0_dp/(a*b) t1 = 1.0_dp/(a**3.0_dp*b) t2 = 1.0_dp/(a*b**3.0_dp) @@ -2842,8 +2834,8 @@ CONTAINS ss = ss - NINT(ss) xkj = MATMUL(cell%hmat, ss) ! Evaluation of the angle.. - a = NORM2(xij) - b = NORM2(xkj) + a = SQRT(DOT_PRODUCT(xij, xij)) + b = SQRT(DOT_PRODUCT(xkj, xkj)) t0 = 1.0_dp/(a*b) t1 = 1.0_dp/(a**3.0_dp*b) t2 = 1.0_dp/(a*b**3.0_dp) @@ -3145,6 +3137,10 @@ CONTAINS TYPE(particle_list_type), POINTER :: particles_i TYPE(particle_type), DIMENSION(:), POINTER :: my_particles + ! settings for numerical derivatives + !REAL(KIND=dp) :: ri_step, dx_bond_j, dy_bond_j, dz_bond_j + !INTEGER :: idel + n_atoms_to = colvar%qparm_param%n_atoms_to n_atoms_from = colvar%qparm_param%n_atoms_from rcut = colvar%qparm_param%rcut @@ -3163,6 +3159,10 @@ CONTAINS CPASSERT(r1cut < rcut) denominator_tolerance = 1.0E-8_dp + !ri_step=0.1 + !DO idel=-50, 50 + !ftmp(:) = 0.0_dp + qparm = 0.0_dp inv_n_atoms_from = 1.0_dp/REAL(n_atoms_from, KIND=dp) DO ii = 1, n_atoms_from @@ -3200,10 +3200,11 @@ CONTAINS shift(:) = 0.0_dp shift(idim) = 1.0_dp xij_shift = MATMUL(cell%hmat, shift) - rij_shift = NORM2(xij_shift) + rij_shift = SQRT(DOT_PRODUCT(xij_shift, xij_shift)) ncells(idim) = FLOOR(rcut/rij_shift - 0.5) END DO !idim + !IF (mm.eq.0) WRITE(*,'(A8,3I3,A3,I10)') "Ncells:", ncells, "J:", j shift(1:3) = 0.0_dp DO aa = -ncells(1), ncells(1) DO bb = -ncells(2), ncells(2) @@ -3214,7 +3215,12 @@ CONTAINS shift(2) = REAL(bb, KIND=dp) shift(3) = REAL(cc, KIND=dp) xij = MATMUL(cell%hmat, ss0(:) + shift(:)) - rij = NORM2(xij) + rij = SQRT(DOT_PRODUCT(xij, xij)) + !IF (rij > rcut) THEN + ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " --", shift, rij + !ELSE + ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " ++", shift, rij + !ENDIF IF (rij > rcut) CYCLE ! update qlm @@ -3230,7 +3236,7 @@ CONTAINS IF (i == j) CYCLE jloop xij(:) = xpj(:) - xpi(:) - rij = NORM2(xij) + rij = SQRT(DOT_PRODUCT(xij, xij)) IF (rij > rcut) CYCLE jloop ! update qlm @@ -3245,6 +3251,11 @@ CONTAINS ! this factor is necessary if one whishes to sum over m=0,L ! instead of m=-L,+L. This is off now because it is cheap and safe fact = 1.0_dp + !IF (ABS(mm) > 0) THEN + ! fact = 2.0_dp + !ELSE + ! fact = 1.0_dp + !ENDIF IF (nbond < denominator_tolerance) THEN CPWARN("QPARM: number of neighbors is very close to zero!") @@ -3263,6 +3274,7 @@ CONTAINS END DO ! loop over m pre_fac = (4.0_dp*pi)/(2.0_dp*l + 1) + !WRITE(*,'(A8,2F10.5)') " si = ", SQRT(pre_fac*ql) qparm = qparm + SQRT(pre_fac*ql) ftmp(:) = 0.5_dp*SQRT(pre_fac/ql)*d_ql_dxi(:) ! multiply by -1 because aparently we have to save the force, not the gradient @@ -3275,6 +3287,10 @@ CONTAINS colvar%ss = qparm*inv_n_atoms_from colvar%dsdr(:, :) = colvar%dsdr(:, :)*inv_n_atoms_from + !WRITE(*,'(A15,3E20.10)') "COLVAR+DER = ", ri_step*idel, colvar%ss, -ftmp(1) + + !ENDDO ! numercal derivative + END SUBROUTINE qparm_colvar ! ************************************************************************************************** @@ -3307,6 +3323,7 @@ CONTAINS exp_fac, fi, plm, pre_fac, sqrt_c1 REAL(KIND=dp), DIMENSION(3) :: dcosTheta, dfi + !bond = 1.0_dp/(1.0_dp+EXP(alpha*(rij-rcut))) ! RZK: infinitely differentiable smooth cutoff function ! that is precisely 1.0 below r1cut and precisely 0.0 above rcut IF (rij > rcut) THEN @@ -3349,10 +3366,18 @@ CONTAINS sqrt_c1 = SQRT(((2*ll + 1)*fac(ll - ABS(mm)))/(4*pi*fac(ll + ABS(mm)))) pre_fac = bond*sqrt_c1 dylm = pre_fac*dplm + !WHY? IF (plm < 0.0_dp) THEN + !WHY? dylm = -pre_fac*dplm + !WHY? ELSE + !WHY? dylm = pre_fac*dplm + !WHY? ENDIF re_qlm = re_qlm + pre_fac*plm*COS(mm*fi) im_qlm = im_qlm + pre_fac*plm*SIN(mm*fi) + !WRITE(*,'(A8,2I4,F10.5)') " Qlm = ", mm, j, bond + !WRITE(*,'(A8,2I4,2F10.5)') " Qlm = ", mm, j, re_qlm, im_qlm + dcosTheta(:) = xij(:)*xij(3)/(rij**3) dcosTheta(3) = dcosTheta(3) - 1.0_dp/rij ! use tangent half-angle formula to compute d_fi/d_xi @@ -4570,7 +4595,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL rpath_dist_rmsd(colvar, my_particles) - ELSE IF (colvar%reaction_path_param%rmsd) THEN + ELSEIF (colvar%reaction_path_param%rmsd) THEN CALL rpath_rmsd(colvar, my_particles) ELSE CALL rpath_colvar(colvar, cell, my_particles) @@ -4923,7 +4948,7 @@ CONTAINS IF (colvar%reaction_path_param%dist_rmsd) THEN CALL dpath_dist_rmsd(colvar, my_particles) - ELSE IF (colvar%reaction_path_param%rmsd) THEN + ELSEIF (colvar%reaction_path_param%rmsd) THEN CALL dpath_rmsd(colvar, my_particles) ELSE CALL dpath_colvar(colvar, cell, my_particles) @@ -5839,12 +5864,11 @@ CONTAINS DO j = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) THEN + IF (my_end) & CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format for COORD_A (CV rmsd). Very probably the"// & " line with title is missing or is empty. Please check the XYZ file and rerun your job!") - END IF READ (parser%input_line, *) dummy_char, rptr(1:3) r_ref((j - 1)*3 + 1, i) = cp_unit_to_cp2k(rptr(1), "angstrom") r_ref((j - 1)*3 + 2, i) = cp_unit_to_cp2k(rptr(2), "angstrom") @@ -5942,7 +5966,12 @@ CONTAINS iamin = wcai(i) END IF END DO +! zero=0.0_dp +! CALL put_derivative(colvar, 1, zero) +! CALL put_derivative(colvar, 2,zero) +! CALL put_derivative(colvar, 3, zero) +! write(*,'(2(i0,1x),4(f16.8,1x))')idmin,iamin,wc(1)%WannierHamDiag(idmin),wc(1)%WannierHamDiag(iamin),dmin,amin colvar%ss = wc(1)%WannierHamDiag(idmin) - wc(1)%WannierHamDiag(iamin) DEALLOCATE (wcai) DEALLOCATE (wcdi) @@ -5959,7 +5988,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = NORM2(xv) + distance = SQRT(DOT_PRODUCT(xv, xv)) END FUNCTION distance END SUBROUTINE Wc_colvar @@ -5978,8 +6007,8 @@ CONTAINS TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & - OPTIONAL, POINTER :: particles - TYPE(qs_environment_type), OPTIONAL, POINTER :: qs_env + OPTIONAL, POINTER :: particles + TYPE(qs_environment_type), POINTER, OPTIONAL :: qs_env ! optional just because I am lazy... but I should get rid of it... INTEGER :: Od, H, Oa REAL(dp) :: rOd(3), rOa(3), rH(3), & @@ -6076,7 +6105,7 @@ CONTAINS s = MATMUL(cell%h_inv, rij) s = s - NINT(s) xv = MATMUL(cell%hmat, s) - distance = NORM2(xv) + distance = SQRT(DOT_PRODUCT(xv, xv)) END FUNCTION distance END SUBROUTINE HBP_colvar diff --git a/src/common/array_sort.fypp b/src/common/array_sort.fypp index 86ebeb1f97..2b39e3b783 100644 --- a/src/common/array_sort.fypp +++ b/src/common/array_sort.fypp @@ -97,9 +97,9 @@ ! Merge will be performed directly in arr. Need backup of first sublist. tmp_arr(1:m) = arr(1:m) tmp_idx(1:m) = indices(1:m) - i = 1 ! number of elements consumed from 1st sublist - j = 1 ! number of elements consumed from 2nd sublist - k = 1 ! number of elements already merged + i = 1; ! number of elemens consumed from 1st sublist + j = 1; ! number of elemens consumed from 2nd sublist + k = 1; ! number of elemens already merged DO WHILE (i <= m .and. j <= size(arr) - m) IF (${prefix}$_less_than(arr(m + j), tmp_arr(i))) THEN diff --git a/src/common/bibliography.F b/src/common/bibliography.F index 38ca082835..621576c26d 100644 --- a/src/common/bibliography.F +++ b/src/common/bibliography.F @@ -66,7 +66,7 @@ MODULE bibliography Kantorovich2008a, Wellendorff2012, Niklasson2014, Borstnik2014, & Rayson2009, Grimme2011, Fattebert2002, Andreussi2012, & Khaliullin2007, Khaliullin2008, Merlot2014, Lin2009, Lin2013, Lin2016ACE, & - Batzner2022, Batatia2022, DelBen2015, Souza2002, Umari2002, Stengel2009, & + Batzner2022, DelBen2015, Souza2002, Umari2002, Stengel2009, & Luber2014, Berghold2011, DelBen2015b, Campana2009, & Schiffmann2015, Bruck2014, Rappe1992, Ceriotti2012, & Ceriotti2010, Walewski2014, Monkhorst1976, MacDonald1978, Worlton1972, & @@ -164,13 +164,6 @@ CONTAINS source="Nat. Commun.", volume="13", pages="2453", & year=2022, doi="10.1038/s41467-022-29939-5") - CALL add_reference(key=Batatia2022, & - authors=s2a("I. Batatia", "D. P. Kovacs", "G. N. C. Simm", "C. Ortner", "G. Csanyi"), & - title="MACE: Higher order equivariant message passing neural networks "// & - "for fast and accurate force fields", & - source="Adv. Neural Inf. Process. Syst.", volume="35", pages="11423-11436", & - year=2022, doi="10.48550/arXiv.2206.07697") - CALL add_reference(key=VandenCic2006, & authors=s2a("E. Vanden-Eijnden", "G. Ciccotti"), & title="Second-order integrators for Langevin equations with holonomic constraints", & diff --git a/src/common/cp_array_utils.F b/src/common/cp_array_utils.F index a2bbe6c591..87fd4d9949 100644 --- a/src/common/cp_array_utils.F +++ b/src/common/cp_array_utils.F @@ -152,9 +152,8 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) THEN + IF (SIZE(array) > 0) & WRITE (unit=unit_nr, fmt=el_format, advance="no") array(SIZE(array)) - END IF ELSE DO i = 1, SIZE(array) - 1 WRITE (unit=unit_nr, fmt=defaultFormat, advance="no") array(i) @@ -164,9 +163,8 @@ CONTAINS WRITE (unit=unit_nr, fmt="(',')", advance="no") END IF END DO - IF (SIZE(array) > 0) THEN + IF (SIZE(array) > 0) & WRITE (unit=unit_nr, fmt=defaultFormat, advance="no") array(SIZE(array)) - END IF END IF WRITE (unit=unit_nr, fmt="(' )')") call m_flush(unit_nr) @@ -291,7 +289,8 @@ CONTAINS !> \note !> the array should be ordered in growing order ! ************************************************************************************************** - FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) result(res) + FUNCTION cp_1d_${nametype1}$_bsearch(array, el, l_index, u_index) & + result(res) ${type1}$, intent(in) :: array(:) ${type1}$, intent(in) :: el INTEGER, INTENT(in), OPTIONAL :: l_index, u_index diff --git a/src/common/cp_error_handling.F b/src/common/cp_error_handling.F index e54780c0d3..2d0192f8e0 100644 --- a/src/common/cp_error_handling.F +++ b/src/common/cp_error_handling.F @@ -63,9 +63,8 @@ CONTAINS CALL delay_non_master() ! cleaner output if all ranks abort simultaneously unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) THEN - unit_nr = default_output_unit - END IF ! fall back to stdout + IF (unit_nr <= 0) & + unit_nr = default_output_unit ! fall back to stdout CALL print_abort_message(message, location, unit_nr) CALL print_stack(unit_nr) @@ -126,9 +125,8 @@ CONTAINS ! we (ab)use the logger to determine the first MPI rank unit_nr = cp_logger_get_default_io_unit() - IF (unit_nr <= 0) THEN - wait_time = wait_time + 1.0_dp - END IF ! rank-0 gets a head start of one second. + IF (unit_nr <= 0) & + wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second. !$ IF (omp_get_thread_num() /= 0) & !$ wait_time = wait_time + 1.0_dp ! master threads gets another second diff --git a/src/common/cp_log_handling.F b/src/common/cp_log_handling.F index b8ea2ea26e..be0caf7b9e 100644 --- a/src/common/cp_log_handling.F +++ b/src/common/cp_log_handling.F @@ -303,9 +303,8 @@ CONTAINS logger%ref_count = 1 IF (PRESENT(template_logger)) THEN - IF (template_logger%ref_count < 1) THEN + IF (template_logger%ref_count < 1) & CPABORT(routineP//" template_logger%ref_count<1") - END IF logger%print_level = template_logger%print_level logger%default_global_unit_nr = template_logger%default_global_unit_nr logger%close_local_unit_on_dealloc = template_logger%close_local_unit_on_dealloc @@ -340,19 +339,16 @@ CONTAINS logger%suffix = "" END IF IF (PRESENT(para_env)) logger%para_env => para_env - IF (.NOT. ASSOCIATED(logger%para_env)) THEN + IF (.NOT. ASSOCIATED(logger%para_env)) & CPABORT(routineP//" para env not associated") - END IF - IF (.NOT. logger%para_env%is_valid()) THEN + IF (.NOT. logger%para_env%is_valid()) & CPABORT(routineP//" para_env%ref_count<1") - END IF CALL logger%para_env%retain() IF (PRESENT(print_level)) logger%print_level = print_level - IF (PRESENT(default_global_unit_nr)) THEN + IF (PRESENT(default_global_unit_nr)) & logger%default_global_unit_nr = default_global_unit_nr - END IF IF (PRESENT(global_filename)) THEN logger%global_filename = global_filename logger%close_global_unit_on_dealloc = .TRUE. @@ -366,9 +362,8 @@ CONTAINS END IF END IF - IF (PRESENT(default_local_unit_nr)) THEN + IF (PRESENT(default_local_unit_nr)) & logger%default_local_unit_nr = default_local_unit_nr - END IF IF (PRESENT(local_filename)) THEN logger%local_filename = local_filename logger%close_local_unit_on_dealloc = .TRUE. @@ -412,9 +407,8 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_retain', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) THEN + IF (logger%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF logger%ref_count = logger%ref_count + 1 END SUBROUTINE cp_logger_retain @@ -432,9 +426,8 @@ CONTAINS routineP = moduleN//':'//routineN IF (ASSOCIATED(logger)) THEN - IF (logger%ref_count < 1) THEN + IF (logger%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF logger%ref_count = logger%ref_count - 1 IF (logger%ref_count == 0) THEN IF (logger%close_global_unit_on_dealloc .AND. & @@ -483,9 +476,8 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) THEN + IF (lggr%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF res = level >= lggr%print_level END FUNCTION cp_logger_would_log @@ -555,9 +547,8 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'cp_logger_set_log_level', & routineP = moduleN//':'//routineN - IF (logger%ref_count < 1) THEN + IF (logger%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF logger%print_level = level END SUBROUTINE cp_logger_set_log_level @@ -593,9 +584,8 @@ CONTAINS NULLIFY (lggr) END IF IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) THEN + IF (lggr%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF IF (PRESENT(local)) loc = local IF (PRESENT(skip_not_ionode)) skip = skip_not_ionode @@ -702,9 +692,8 @@ CONTAINS lggr => logger IF (.NOT. ASSOCIATED(lggr)) lggr => cp_get_default_logger() - IF (lggr%ref_count < 1) THEN + IF (lggr%ref_count < 1) & CPABORT(routineP//" logger%ref_count<1") - END IF IF (PRESENT(local)) loc = local IF (loc) THEN res = TRIM(root)//TRIM(lggr%suffix)//'_p'// & diff --git a/src/common/cp_result_methods.F b/src/common/cp_result_methods.F index 8b943915df..c62fe15576 100644 --- a/src/common/cp_result_methods.F +++ b/src/common/cp_result_methods.F @@ -178,16 +178,14 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) THEN + IF (nrep <= 0) & CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") - END IF DO i = 1, nlist IF (TRIM(results%result_label(i)) == TRIM(description)) THEN - IF (results%result_value(i)%value%type_in_use /= result_type_real) THEN + IF (results%result_value(i)%value%type_in_use /= result_type_real) & CPABORT("Attempt to retrieve a RESULT which is not a REAL!") - END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT @@ -253,16 +251,14 @@ CONTAINS n_rep = nrep END IF - IF (nrep <= 0) THEN + IF (nrep <= 0) & CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") - END IF DO i = 1, nlist IF (TRIM(results%result_label(i)) == TRIM(description)) THEN - IF (results%result_value(i)%value%type_in_use /= result_type_real) THEN + IF (results%result_value(i)%value%type_in_use /= result_type_real) & CPABORT("Attempt to retrieve a RESULT which is not a REAL!") - END IF size_res = SIZE(results%result_value(i)%value%real_type) EXIT diff --git a/src/common/cp_units.F b/src/common/cp_units.F index d398b9f92f..9677341fd4 100644 --- a/src/common/cp_units.F +++ b/src/common/cp_units.F @@ -650,11 +650,10 @@ CONTAINS CPABORT("unknown electric field unit:"//TRIM(cp_to_string(basic_unit))) END SELECT CASE (cp_ukind_none) - IF (basic_unit /= cp_units_none) THEN + IF (basic_unit /= cp_units_none) & CALL cp_abort(__LOCATION__, & "if the kind of the unit is none also unit must be undefined,not:" & //TRIM(cp_to_string(basic_unit))) - END IF CASE default CPABORT("unknown kind of unit:"//TRIM(cp_to_string(basic_kind))) END SELECT @@ -680,11 +679,10 @@ CONTAINS my_power = 1 IF (PRESENT(power)) my_power = power IF (basic_unit == cp_units_none .AND. basic_kind /= cp_ukind_undef) THEN - IF (basic_kind /= cp_units_none) THEN + IF (basic_kind /= cp_units_none) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(cp_to_string(basic_unit))) - END IF END IF SELECT CASE (basic_kind) CASE (cp_ukind_undef) @@ -864,10 +862,9 @@ CONTAINS IF (accept_undefined) my_accept_undefined = accept_undefined IF (PRESENT(power)) my_power = power IF (basic_unit == cp_units_none) THEN - IF (.NOT. my_accept_undefined .AND. basic_kind == cp_units_none) THEN + IF (.NOT. my_accept_undefined .AND. basic_kind == cp_units_none) & CALL cp_abort(__LOCATION__, "unit not yet fully specified, unit of kind "// & TRIM(cp_to_string(basic_kind))) - END IF END IF SELECT CASE (basic_kind) CASE (cp_ukind_undef) @@ -903,11 +900,10 @@ CONTAINS res = "K_e" CASE (cp_units_none) res = "energy" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown energy unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -935,11 +931,10 @@ CONTAINS res = "au_temp" CASE (cp_units_none) res = "temperature" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown temperature unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -961,11 +956,10 @@ CONTAINS res = "au_p" CASE (cp_units_none) res = "pressure" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown pressure unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -977,11 +971,10 @@ CONTAINS res = "deg" CASE (cp_units_none) res = "angle" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown angle unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -999,11 +992,10 @@ CONTAINS res = "wavenumber_t" CASE (cp_units_none) res = "time" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown time unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1017,11 +1009,10 @@ CONTAINS res = "m_e" CASE (cp_units_none) res = "mass" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown mass unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1033,11 +1024,10 @@ CONTAINS res = "au_pot" CASE (cp_units_none) res = "potential" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown potential unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1051,11 +1041,10 @@ CONTAINS res = "au_f" CASE (cp_units_none) res = "force" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown potential unit:"//TRIM(cp_to_string(basic_unit))) END SELECT @@ -1071,11 +1060,10 @@ CONTAINS res = "au_efield" CASE (cp_units_none) res = "electric field" - IF (.NOT. my_accept_undefined) THEN + IF (.NOT. my_accept_undefined) & CALL cp_abort(__LOCATION__, & "unit not yet fully specified, unit of kind "// & TRIM(res)) - END IF CASE default CPABORT("unknown efield unit:"//TRIM(cp_to_string(basic_unit))) END SELECT diff --git a/src/common/distribution_1d_types.F b/src/common/distribution_1d_types.F index c875a3129f..8e23f4b29f 100644 --- a/src/common/distribution_1d_types.F +++ b/src/common/distribution_1d_types.F @@ -104,9 +104,8 @@ CONTAINS CALL para_env%retain() distribution_1d%listbased_distribution = .FALSE. - IF (PRESENT(listbased_distribution)) THEN + IF (PRESENT(listbased_distribution)) & distribution_1d%listbased_distribution = listbased_distribution - END IF ALLOCATE (distribution_1d%n_el(my_n_lists), distribution_1d%list(my_n_lists)) diff --git a/src/common/fparser.F b/src/common/fparser.F index 04f4f47f12..2e373db097 100644 --- a/src/common/fparser.F +++ b/src/common/fparser.F @@ -407,10 +407,10 @@ CONTAINS DO j = b, e IF (Func(j:j) == '(') THEN ParCnt = ParCnt + 1 - ELSE IF (Func(j:j) == ')') THEN + ELSEIF (Func(j:j) == ')') THEN ParCnt = ParCnt - 1 IF (ParCnt == 0) EXIT - ELSE IF (ParCnt == 1 .AND. Func(j:j) == ',') THEN + ELSEIF (ParCnt == 1 .AND. Func(j:j) == ',') THEN ArgPos = j ArgCnt = ArgCnt + 1 END IF @@ -748,7 +748,7 @@ CONTAINS DO j = b + 1, e - 1 IF (F(j:j) == '(') THEN k = k + 1 - ELSE IF (F(j:j) == ')') THEN + ELSEIF (F(j:j) == ')') THEN k = k - 1 END IF IF (k < 0) EXIT @@ -792,11 +792,11 @@ CONTAINS ! WRITE(*,*)'1. F(b:e) = "+..."' CALL CompileSubstr(i, F, b + 1, e, Var) RETURN - ELSE IF (CompletelyEnclosed(F, b, e)) THEN ! Case 2: F(b:e) = '(...)' + ELSEIF (CompletelyEnclosed(F, b, e)) THEN ! Case 2: F(b:e) = '(...)' ! WRITE(*,*)'2. F(b:e) = "(...)"' CALL CompileSubstr(i, F, b + 1, e - 1, Var) RETURN - ELSE IF (SCAN(F(b:b), calpha) > 0) THEN + ELSEIF (SCAN(F(b:b), calpha) > 0) THEN n = MathFunctionIndex(F(b:e)) IF (n > 0) THEN b2 = b + INDEX(F(b:e), '(') - 1 @@ -807,13 +807,13 @@ CONTAINS RETURN END IF END IF - ELSE IF (F(b:b) == '-') THEN + ELSEIF (F(b:b) == '-') THEN IF (CompletelyEnclosed(F, b + 1, e)) THEN ! Case 4: F(b:e) = '-(...)' ! WRITE(*,*)'4. F(b:e) = "-(...)"' CALL CompileSubstr(i, F, b + 2, e - 1, Var) CALL AddCompiledByte(i, cNeg) RETURN - ELSE IF (SCAN(F(b + 1:b + 1), calpha) > 0) THEN + ELSEIF (SCAN(F(b + 1:b + 1), calpha) > 0) THEN n = MathFunctionIndex(F(b + 1:e)) IF (n > 0) THEN b2 = b + INDEX(F(b + 1:e), '(') @@ -835,7 +835,7 @@ CONTAINS DO j = e, b, -1 IF (F(j:j) == ')') THEN k = k + 1 - ELSE IF (F(j:j) == '(') THEN + ELSEIF (F(j:j) == '(') THEN k = k - 1 END IF IF (k == 0 .AND. F(j:j) == Ops(io) .AND. IsBinaryOp(j, F)) THEN @@ -900,9 +900,9 @@ CONTAINS DO j = b, e IF (F(j:j) == '(') THEN ParCnt = ParCnt + 1 - ELSE IF (F(j:j) == ')') THEN + ELSEIF (F(j:j) == ')') THEN ParCnt = ParCnt - 1 - ELSE IF (ParCnt == 0 .AND. F(j:j) == ',') THEN + ELSEIF (ParCnt == 0 .AND. F(j:j) == ',') THEN CALL CompileSubstr(i, F, b2, j - 1, Var) b2 = j + 1 END IF @@ -938,17 +938,17 @@ CONTAINS IF (F(j:j) == '+' .OR. F(j:j) == '-') THEN ! Plus or minus sign: IF (j == 1) THEN ! - leading unary operator ? res = .FALSE. - ELSE IF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? + ELSEIF (SCAN(F(j - 1:j - 1), '+-*/^(,') > 0) THEN ! - other unary operator ? res = .FALSE. - ELSE IF (SCAN(F(j + 1:j + 1), '0123456789') > 0 .AND. & ! - in exponent of real number ? - SCAN(F(j - 1:j - 1), 'eEdD') > 0) THEN + ELSEIF (SCAN(F(j + 1:j + 1), '0123456789') > 0 .AND. & ! - in exponent of real number ? + SCAN(F(j - 1:j - 1), 'eEdD') > 0) THEN Dflag = .FALSE.; Pflag = .FALSE. k = j - 1 DO WHILE (k > 1) ! step to the left in mantissa k = k - 1 IF (SCAN(F(k:k), '0123456789') > 0) THEN Dflag = .TRUE. - ELSE IF (F(k:k) == '.') THEN + ELSEIF (F(k:k) == '.') THEN IF (Pflag) THEN EXIT ! * EXIT: 2nd appearance of '.' ELSE @@ -1011,7 +1011,7 @@ CONTAINS CASE ('+', '-') ! Permitted only IF (Bflag) THEN InMan = .TRUE.; Bflag = .FALSE. ! - at beginning of mantissa - ELSE IF (Eflag) THEN + ELSEIF (Eflag) THEN InExp = .TRUE.; Eflag = .FALSE. ! - at beginning of exponent ELSE EXIT ! - otherwise STOP @@ -1019,7 +1019,7 @@ CONTAINS CASE ('0':'9') ! Mark IF (Bflag) THEN InMan = .TRUE.; Bflag = .FALSE. ! - beginning of mantissa - ELSE IF (Eflag) THEN + ELSEIF (Eflag) THEN InExp = .TRUE.; Eflag = .FALSE. ! - beginning of exponent END IF IF (InMan) DInMan = .TRUE. ! Mantissa contains digit @@ -1028,7 +1028,7 @@ CONTAINS IF (Bflag) THEN Pflag = .TRUE. ! - mark 1st appearance of '.' InMan = .TRUE.; Bflag = .FALSE. ! mark beginning of mantissa - ELSE IF (InMan .AND. .NOT. Pflag) THEN + ELSEIF (InMan .AND. .NOT. Pflag) THEN Pflag = .TRUE. ! - mark 1st appearance of '.' ELSE EXIT ! - otherwise STOP diff --git a/src/common/gfun.F b/src/common/gfun.F index 515c79098e..55c55bf64b 100644 --- a/src/common/gfun.F +++ b/src/common/gfun.F @@ -62,7 +62,7 @@ CONTAINS IF (t <= 12.0_dp) THEN ! downward recursion - g(nmax) = gfun_taylor(nmax, t) + g(nmax) = gfun_taylor(nmax, t); DO i = nmax, 1, -1 g(i - 1) = (1.0_dp - 2.0_dp*t*g(i))/(2.0_dp*i - 1.0_dp) END DO diff --git a/src/common/hash_map.fypp b/src/common/hash_map.fypp index ff5e066b74..ee755920b3 100644 --- a/src/common/hash_map.fypp +++ b/src/common/hash_map.fypp @@ -81,13 +81,11 @@ initial_capacity_ = 11 END IF - IF (initial_capacity_ < 1) THEN + IF (initial_capacity_ < 1) & CPABORT("initial_capacity < 1") - END IF - IF (ASSOCIATED(hash_map%buckets)) THEN + IF (ASSOCIATED(hash_map%buckets)) & CPABORT("hash map is already initialized.") - END IF ALLOCATE (hash_map%buckets(initial_capacity_)) hash_map%size = 0 diff --git a/src/common/list.fypp b/src/common/list.fypp index f0adb39843..37524a2570 100644 --- a/src/common/list.fypp +++ b/src/common/list.fypp @@ -87,18 +87,15 @@ initial_capacity_ = 11 If (PRESENT(initial_capacity)) initial_capacity_ = initial_capacity - IF (initial_capacity_ < 0) THEN + IF (initial_capacity_ < 0) & CPABORT("list_${valuetype}$_create: initial_capacity < 0") - END IF - IF (ASSOCIATED(list%arr)) THEN + IF (ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_create: list is already initialized.") - END IF ALLOCATE (list%arr(initial_capacity_), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_init: allocation failed") - END IF list%size = 0 END SUBROUTINE list_${valuetype}$_init @@ -115,9 +112,8 @@ SUBROUTINE list_${valuetype}$_destroy(list) TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_destroy: list is not initialized.") - END IF do i = 1, list%size deallocate (list%arr(i)%p) @@ -141,15 +137,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_in}$, intent(in) :: value INTEGER, intent(in) :: pos - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_set: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_set: pos < 1") - END IF - IF (pos > list%size) THEN + IF (pos > list%size) & CPABORT("list_${valuetype}$_set: pos > size") - END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_set @@ -166,18 +159,15 @@ ${valuetype_in}$, intent(in) :: value INTEGER :: stat - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_push: list is not initialized.") - END IF - IF (list%size == size(list%arr)) THEN - CALL change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) - END IF + if (list%size == size(list%arr)) & + call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) list%size = list%size + 1 ALLOCATE (list%arr(list%size)%p, stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_push: allocation failed") - END IF list%arr(list%size)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_push @@ -197,19 +187,15 @@ INTEGER, intent(in) :: pos INTEGER :: i, stat - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_insert: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_insert: pos < 1") - END IF - IF (pos > list%size + 1) THEN + IF (pos > list%size + 1) & CPABORT("list_${valuetype}$_insert: pos > size+1") - END IF - if (list%size == size(list%arr)) THEN + if (list%size == size(list%arr)) & call change_capacity_${valuetype}$ (list, 2*size(list%arr) + 1) - END IF list%size = list%size + 1 do i = list%size, pos + 1, -1 @@ -217,9 +203,8 @@ end do ALLOCATE (list%arr(pos)%p, stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_insert: allocation failed.") - END IF list%arr(pos)%p%value ${value_assign}$value END SUBROUTINE list_${valuetype}$_insert @@ -236,12 +221,10 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_peek: list is not initialized.") - END IF - IF (list%size < 1) THEN + IF (list%size < 1) & CPABORT("list_${valuetype}$_peek: list is empty.") - END IF value ${value_assign}$list%arr(list%size)%p%value END FUNCTION list_${valuetype}$_peek @@ -262,12 +245,10 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list ${valuetype_out}$ :: value - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_pop: list is not initialized.") - END IF - IF (list%size < 1) THEN + IF (list%size < 1) & CPABORT("list_${valuetype}$_pop: list is empty.") - END IF value ${value_assign}$list%arr(list%size)%p%value deallocate (list%arr(list%size)%p) @@ -285,13 +266,12 @@ TYPE(list_${valuetype}$_type), intent(inout) :: list INTEGER :: i - IF (.not. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_clear: list is not initialized.") - END IF - DO i = 1, list%size + do i = 1, list%size deallocate (list%arr(i)%p) - END DO + end do list%size = 0 END SUBROUTINE list_${valuetype}$_clear @@ -310,15 +290,12 @@ INTEGER, intent(in) :: pos ${valuetype_out}$ :: value - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_get: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_get: pos < 1") - END IF - IF (pos > list%size) THEN + IF (pos > list%size) & CPABORT("list_${valuetype}$_get: pos > size") - END IF value ${value_assign}$list%arr(pos)%p%value @@ -337,20 +314,17 @@ INTEGER, intent(in) :: pos INTEGER :: i - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_del: list is not initialized.") - END IF - IF (pos < 1) THEN + IF (pos < 1) & CPABORT("list_${valuetype}$_det: pos < 1") - END IF - IF (pos > list%size) THEN + IF (pos > list%size) & CPABORT("list_${valuetype}$_det: pos > size") - END IF deallocate (list%arr(pos)%p) - DO i = pos, list%size - 1 + do i = pos, list%size - 1 list%arr(i)%p => list%arr(i + 1)%p - END DO + end do list%size = list%size - 1 @@ -368,9 +342,8 @@ TYPE(list_${valuetype}$_type), intent(in) :: list INTEGER :: size - IF (.NOT. ASSOCIATED(list%arr)) THEN + IF (.not. ASSOCIATED(list%arr)) & CPABORT("list_${valuetype}$_size: list is not initialized.") - END IF size = list%size END FUNCTION list_${valuetype}$_size @@ -390,34 +363,29 @@ TYPE(private_item_p_type_${valuetype}$), DIMENSION(:), POINTER :: old_arr new_cap = new_capacity - IF (new_cap < 0) THEN + IF (new_cap < 0) & CPABORT("list_${valuetype}$_change_capacity: new_capacity < 0") - END IF - IF (new_cap < list%size) THEN + IF (new_cap < list%size) & CPABORT("list_${valuetype}$_change_capacity: new_capacity < size") - END IF IF (new_cap > HUGE(i)) THEN - IF (size(list%arr) == HUGE(i)) THEN + IF (size(list%arr) == HUGE(i)) & CPABORT("list_${valuetype}$_change_capacity: list has reached integer limit.") - END IF new_cap = HUGE(i) ! grow as far as possible END IF old_arr => list%arr allocate (list%arr(new_cap), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_change_capacity: allocation failed") - END IF - DO i = 1, list%size + do i = 1, list%size allocate (list%arr(i)%p, stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("list_${valuetype}$_change_capacity: allocation failed") - END IF list%arr(i)%p%value ${value_assign}$old_arr(i)%p%value - DEALLOCATE (old_arr(i)%p) - END DO - DEALLOCATE (old_arr) + deallocate (old_arr(i)%p) + end do + deallocate (old_arr) END SUBROUTINE change_capacity_${valuetype}$ #:enddef diff --git a/src/common/mathlib.F b/src/common/mathlib.F index e1c5791b79..adf19a3a6e 100644 --- a/src/common/mathlib.F +++ b/src/common/mathlib.F @@ -187,8 +187,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = NORM2(a) - length_of_b = NORM2(b) + length_of_a = SQRT(DOT_PRODUCT(a, a)) + length_of_b = SQRT(DOT_PRODUCT(b, b)) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a @@ -997,9 +997,8 @@ CONTAINS ! set singular values that are too small to zero DO i = 1, n IF (sig(i) > rskip*MAXVAL(sig)) THEN - IF (PRESENT(determinant)) THEN + IF (PRESENT(determinant)) & determinant = determinant*sig(i) - END IF sig_plus(i, i) = 1._dp/sig(i) ELSE sig_plus(i, i) = 0.0_dp @@ -1976,14 +1975,12 @@ CONTAINS IF (n /= SIZE(C_out, 2)) CPABORT("Incompatible (cols) result array 3 (C).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & CPABORT("Unknown transpose character for array 1 (A).") - END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & CPABORT("Unknown transpose character for array 2 (B).") - END IF CALL timeset(routineN, handle) @@ -2021,14 +2018,12 @@ CONTAINS IF (n /= SIZE(C_out, 2)) CPABORT("Incompatible (cols) result array 3 (C).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & CPABORT("Unknown transpose character for array 1 (A).") - END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & CPABORT("Unknown transpose character for array 2 (B).") - END IF CALL timeset(routineN, handle) @@ -2073,19 +2068,16 @@ CONTAINS IF (n /= SIZE(D_out, 2)) CPABORT("Incompatible (cols) result array 4 (D).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & CPABORT("Unknown transpose character for array 1 (A).") - END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & CPABORT("Unknown transpose character for array 2 (B).") - END IF IF (.NOT. (C_trans == 'N' .OR. C_trans == 'n' .OR. & C_trans == 'T' .OR. C_trans == 't' .OR. & - C_trans == 'C' .OR. C_trans == 'c')) THEN + C_trans == 'C' .OR. C_trans == 'c')) & CPABORT("Unknown transpose character for array 3 (C).") - END IF CALL timeset(routineN, handle) @@ -2135,19 +2127,16 @@ CONTAINS IF (n /= SIZE(D_out, 2)) CPABORT("Incompatible (cols) result array 4 (D).") IF (.NOT. (A_trans == 'N' .OR. A_trans == 'n' .OR. & A_trans == 'T' .OR. A_trans == 't' .OR. & - A_trans == 'C' .OR. A_trans == 'c')) THEN + A_trans == 'C' .OR. A_trans == 'c')) & CPABORT("Unknown transpose character for array 1 (A).") - END IF IF (.NOT. (B_trans == 'N' .OR. B_trans == 'n' .OR. & B_trans == 'T' .OR. B_trans == 't' .OR. & - B_trans == 'C' .OR. B_trans == 'c')) THEN + B_trans == 'C' .OR. B_trans == 'c')) & CPABORT("Unknown transpose character for array 2 (B).") - END IF IF (.NOT. (C_trans == 'N' .OR. C_trans == 'n' .OR. & C_trans == 'T' .OR. C_trans == 't' .OR. & - C_trans == 'C' .OR. C_trans == 'c')) THEN + C_trans == 'C' .OR. C_trans == 'c')) & CPABORT("Unknown transpose character for array 3 (C).") - END IF CALL timeset(routineN, handle) diff --git a/src/common/memory_utilities_unittest.F b/src/common/memory_utilities_unittest.F index 7aeb64e973..5534658c10 100644 --- a/src/common/memory_utilities_unittest.F +++ b/src/common/memory_utilities_unittest.F @@ -32,13 +32,11 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) THEN + IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) & ERROR STOP "check_real_rank1_allocated: reallocating changed the initial values" - END IF - IF (.NOT. ALL(real_arr(11:20) == 0.)) THEN + IF (.NOT. ALL(real_arr(11:20) == 0.)) & ERROR STOP "check_real_rank1_allocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -55,9 +53,8 @@ CONTAINS CALL reallocate(real_arr, 1, 20) - IF (.NOT. ALL(real_arr(1:20) == 0.)) THEN + IF (.NOT. ALL(real_arr(1:20) == 0.)) & ERROR STOP "check_real_rank1_unallocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -76,13 +73,11 @@ CONTAINS CALL reallocate(real_arr, 1, 10, 1, 5) - IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) THEN + IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) & ERROR STOP "check_real_rank2_allocated: reallocating changed the initial values" - END IF - IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) THEN + IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) & ERROR STOP "check_real_rank2_allocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -99,9 +94,8 @@ CONTAINS CALL reallocate(real_arr, 1, 10, 1, 5) - IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) THEN + IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) & ERROR STOP "check_real_rank2_unallocated: reallocation failed to initialise new values with 0." - END IF DEALLOCATE (real_arr) @@ -120,13 +114,11 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) THEN + IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) & ERROR STOP "check_string_rank1_allocated: reallocating changed the initial values" - END IF - IF (.NOT. ALL(str_arr(11:20) == "")) THEN + IF (.NOT. ALL(str_arr(11:20) == "")) & ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." - END IF DEALLOCATE (str_arr) @@ -143,9 +135,8 @@ CONTAINS CALL reallocate(str_arr, 1, 20) - IF (.NOT. ALL(str_arr(1:20) == "")) THEN + IF (.NOT. ALL(str_arr(1:20) == "")) & ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''." - END IF DEALLOCATE (str_arr) diff --git a/src/common/parallel_rng_types.F b/src/common/parallel_rng_types.F index e969d79b88..970e64ec22 100644 --- a/src/common/parallel_rng_types.F +++ b/src/common/parallel_rng_types.F @@ -512,9 +512,8 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: antithetic, extended_precision TYPE(rng_stream_type) :: rng_stream - IF (LEN_TRIM(name) > rng_name_length) THEN + IF (LEN_TRIM(name) > rng_name_length) & CPABORT("given random number generator name is too long") - END IF rng_stream%name = TRIM(name) @@ -631,16 +630,14 @@ CONTAINS LOGICAL, INTENT(OUT), OPTIONAL :: buffer_filled IF (PRESENT(name)) name = self%name - IF (PRESENT(distribution_type)) THEN + IF (PRESENT(distribution_type)) & distribution_type = self%distribution_type - END IF IF (PRESENT(bg)) bg = self%bg IF (PRESENT(cg)) cg = self%cg IF (PRESENT(ig)) ig = self%ig IF (PRESENT(antithetic)) antithetic = self%antithetic - IF (PRESENT(extended_precision)) THEN + IF (PRESENT(extended_precision)) & extended_precision = self%extended_precision - END IF IF (PRESENT(buffer)) buffer = self%buffer IF (PRESENT(buffer_filled)) buffer_filled = self%buffer_filled END SUBROUTINE get @@ -1134,9 +1131,8 @@ CONTAINS my_write_all = .FALSE. - IF (PRESENT(write_all)) THEN + IF (PRESENT(write_all)) & my_write_all = write_all - END IF WRITE (UNIT=output_unit, FMT="(/,T2,A,/)") & "Random number stream <"//TRIM(self%name)//">:" diff --git a/src/common/parallel_rng_types_unittest.F b/src/common/parallel_rng_types_unittest.F index 142e5f2ab9..87cf2640f7 100644 --- a/src/common/parallel_rng_types_unittest.F +++ b/src/common/parallel_rng_types_unittest.F @@ -32,16 +32,14 @@ PROGRAM parallel_rng_types_TEST nsamples = 1000 nargs = command_argument_count() - IF (nargs > 1) then + IF (nargs > 1) & ERROR STOP "Usage: parallel_rng_types_TEST []" - end if IF (nargs == 1) THEN CALL get_command_argument(1, arg) READ (arg, *, iostat=stat) nsamples - IF (stat /= 0) then + IF (stat /= 0) & ERROR STOP "Usage: parallel_rng_types_TEST []" - end if END IF CALL mp_world_init(mpi_comm) @@ -62,9 +60,8 @@ PROGRAM parallel_rng_types_TEST distribution_type=UNIFORM, & extended_precision=.TRUE.) - IF (ionode) then + IF (ionode) & CALL rng_stream%write(default_output_unit) - end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -97,9 +94,8 @@ PROGRAM parallel_rng_types_TEST distribution_type=GAUSSIAN, & extended_precision=.TRUE.) - IF (ionode) then + IF (ionode) & CALL rng_stream%write(default_output_unit) - end if tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -166,9 +162,8 @@ CONTAINS CALL rng_stream%get(ig=ig, cg=cg, bg=bg, name=name) IF (ANY(ig /= ig_orig) .OR. ANY(cg /= cg_orig) .OR. ANY(bg /= bg_orig) & - .OR. (name /= name_orig)) then + .OR. (name /= name_orig)) & ERROR STOP "Stream dump and load roundtrip failed" - end if WRITE (UNIT=default_output_unit, FMT="(T4,A)") & "Roundtrip successful" @@ -190,9 +185,8 @@ CONTAINS WRITE (UNIT=default_output_unit, FMT="(T4,A10,A433)") & "GENERATED:", rng_record - IF (rng_record /= serialized_string) then + IF (rng_record /= serialized_string) & ERROR STOP "Serialized record does not match the expected output" - end if WRITE (UNIT=default_output_unit, FMT="(T4,A)") & "Serialized record matches the expected output" @@ -220,22 +214,19 @@ CONTAINS arr = orig CALL rng_stream%shuffle(arr) - IF (ALL(arr == orig)) then + IF (ALL(arr == orig)) & ERROR STOP "shuffle failed: array was left untouched" - end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." - IF (ANY(arr /= orig(arr))) then + IF (ANY(arr /= orig(arr))) & ERROR STOP "shuffle failed: the shuffled original is not the shuffled original" - end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." ! sort and compare to orig mask = .TRUE. DO idx = 1, size(orig) - IF (MINVAL(arr, mask) /= orig(idx)) then + IF (MINVAL(arr, mask) /= orig(idx)) & ERROR STOP "shuffle failed: there is at least one unknown index" - end if mask(MINLOC(arr, mask)) = .FALSE. END DO WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." @@ -244,9 +235,8 @@ CONTAINS CALL rng_stream%reset() CALL rng_stream%shuffle(arr2) - IF (ANY(arr2 /= arr)) then + IF (ANY(arr2 /= arr)) & ERROR STOP "shuffle failed: array was shuffled differently with same rng state" - end if WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "." WRITE (UNIT=default_output_unit, FMT="(T4,A)") & diff --git a/src/common/reference_manager.F b/src/common/reference_manager.F index 8ba42beaff..f900554659 100644 --- a/src/common/reference_manager.F +++ b/src/common/reference_manager.F @@ -332,18 +332,14 @@ CONTAINS WRITE (unit, '(T3,A)') ''//thebib(i)%ref%source//'' ! DOI, volume, pages, year, month. - IF (ALLOCATED(thebib(i)%ref%doi)) THEN + IF (ALLOCATED(thebib(i)%ref%doi)) & WRITE (unit, '(T3,A)') ''//TRIM(substitute_special_xml_tokens(thebib(i)%ref%doi))//'' - END IF - IF (ALLOCATED(thebib(i)%ref%volume)) THEN + IF (ALLOCATED(thebib(i)%ref%volume)) & WRITE (unit, '(T3,A)') ''//thebib(i)%ref%volume//'' - END IF - IF (ALLOCATED(thebib(i)%ref%pages)) THEN + IF (ALLOCATED(thebib(i)%ref%pages)) & WRITE (unit, '(T3,A)') ''//thebib(i)%ref%pages//'' - END IF - IF (thebib(i)%ref%year > 0) THEN + IF (thebib(i)%ref%year > 0) & WRITE (unit, '(T3,A,I4.4,A)') '', thebib(i)%ref%year, '' - END IF WRITE (unit, '(T2,A)') '' END DO diff --git a/src/common/spherical_harmonics.F b/src/common/spherical_harmonics.F index 96bd808f89..52d62548c6 100644 --- a/src/common/spherical_harmonics.F +++ b/src/common/spherical_harmonics.F @@ -1805,42 +1805,30 @@ CONTAINS REAL(KIND=dp) :: sumk, t ! Check validity of the input parameters - IF (j1 < 0.0_dp) THEN + IF (j1 < 0.0_dp) & CPABORT("The angular momentum quantum number j1 has to be nonnegative") - END IF - IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) THEN + IF (.NOT. (is_integer(j1) .OR. is_integer(2.0_dp*j1))) & CPABORT("The angular momentum quantum number j1 has to be integer or half-integer") - END IF - IF (j2 < 0.0_dp) THEN + IF (j2 < 0.0_dp) & CPABORT("The angular momentum quantum number j2 has to be nonnegative") - END IF - IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) THEN + IF (.NOT. (is_integer(j2) .OR. is_integer(2.0_dp*j2))) & CPABORT("The angular momentum quantum number j2 has to be integer or half-integer") - END IF - IF (J < 0.0_dp) THEN + IF (J < 0.0_dp) & CPABORT("The angular momentum quantum number J has to be nonnegative") - END IF - IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) THEN + IF (.NOT. (is_integer(J) .OR. is_integer(2.0_dp*J))) & CPABORT("The angular momentum quantum number J has to be integer or half-integer") - END IF - IF ((ABS(m1) - j1) > EPSILON(m1)) THEN + IF ((ABS(m1) - j1) > EPSILON(m1)) & CPABORT("The angular momentum quantum number m1 has to satisfy -j1 <= m1 <= j1") - END IF - IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) THEN + IF (.NOT. (is_integer(m1) .OR. is_integer(2.0_dp*m1))) & CPABORT("The angular momentum quantum number m1 has to be integer or half-integer") - END IF - IF ((ABS(m2) - j2) > EPSILON(m2)) THEN + IF ((ABS(m2) - j2) > EPSILON(m2)) & CPABORT("The angular momentum quantum number m2 has to satisfy -j2 <= m1 <= j2") - END IF - IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) THEN + IF (.NOT. (is_integer(m2) .OR. is_integer(2.0_dp*m2))) & CPABORT("The angular momentum quantum number m2 has to be integer or half-integer") - END IF - IF ((ABS(M) - J) > EPSILON(M)) THEN + IF ((ABS(M) - J) > EPSILON(M)) & CPABORT("The angular momentum quantum number M has to satisfy -J <= M <= J") - END IF - IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) THEN + IF (.NOT. (is_integer(M) .OR. is_integer(2.0_dp*M))) & CPABORT("The angular momentum quantum number M has to be integer or half-integer") - END IF IF (is_integer(j1 + j2 + J) .AND. & is_integer(j1 + m1) .AND. & @@ -1884,8 +1872,8 @@ CONTAINS ! ************************************************************************************************** !> \brief Compute the Wigner 3-j symbol -!> ( j1 j2 j3 ) -!> ( m1 m2 m3 ) +!> / j1 j2 j3 \ +!> \ m1 m2 m3 / !> using the Clebsch-Gordon coefficients !> \param j1 Angular momentum quantum number of the first state | j1 m1 > !> \param m1 Magnetic quantum number of the first first state | j1 m1 > diff --git a/src/common/splines.F b/src/common/splines.F index bcfc9252d5..6d808dfad9 100644 --- a/src/common/splines.F +++ b/src/common/splines.F @@ -311,21 +311,21 @@ CONTAINS i1 = 1 IF (n < 2) THEN CALL stop_error("error in iix: n < 2") - ELSE IF (n == 2) THEN + ELSEIF (n == 2) THEN i1 = 1 - ELSE IF (n == 3) THEN + ELSEIF (n == 3) THEN IF (x <= xi(2)) THEN ! first element i1 = 1 ELSE i1 = 2 END IF - ELSE IF (x <= xi(1)) THEN ! left end + ELSEIF (x <= xi(1)) THEN ! left end i1 = 1 - ELSE IF (x <= xi(2)) THEN ! first element + ELSEIF (x <= xi(2)) THEN ! first element i1 = 1 - ELSE IF (x <= xi(3)) THEN ! second element + ELSEIF (x <= xi(3)) THEN ! second element i1 = 2 - ELSE IF (x >= xi(n)) THEN ! right end + ELSEIF (x >= xi(n)) THEN ! right end i1 = n - 1 ELSE ! bisection: xi(i1) <= x < xi(i2) diff --git a/src/common/timings.F b/src/common/timings.F index d327324b23..fb81e07f11 100644 --- a/src/common/timings.F +++ b/src/common/timings.F @@ -96,9 +96,8 @@ CONTAINS IF (PRESENT(timer_env)) timer_env_ => timer_env IF (.NOT. PRESENT(timer_env)) CALL timer_env_create(timer_env_) - IF (.NOT. ASSOCIATED(timer_env_)) THEN + IF (.NOT. ASSOCIATED(timer_env_)) & CPABORT("add_timer_env: not associated") - END IF CALL timer_env_retain(timer_env_) IF (.NOT. list_isready(timers_stack)) CALL list_init(timers_stack) @@ -158,12 +157,10 @@ CONTAINS SUBROUTINE timer_env_retain(timer_env) TYPE(timer_env_type), POINTER :: timer_env - IF (.NOT. ASSOCIATED(timer_env)) THEN + IF (.NOT. ASSOCIATED(timer_env)) & CPABORT("timer_env_retain: not associated") - END IF - IF (timer_env%ref_count < 0) THEN + IF (timer_env%ref_count < 0) & CPABORT("timer_env_retain: negativ ref_count") - END IF timer_env%ref_count = timer_env%ref_count + 1 END SUBROUTINE timer_env_retain @@ -179,12 +176,10 @@ CONTAINS TYPE(callgraph_item_type), DIMENSION(:), POINTER :: ct_items TYPE(routine_stat_type), POINTER :: r_stat - IF (.NOT. ASSOCIATED(timer_env)) THEN + IF (.NOT. ASSOCIATED(timer_env)) & CPABORT("timer_env_release: not associated") - END IF - IF (timer_env%ref_count < 0) THEN + IF (timer_env%ref_count < 0) & CPABORT("timer_env_release: negativ ref_count") - END IF timer_env%ref_count = timer_env%ref_count - 1 IF (timer_env%ref_count > 0) RETURN @@ -442,12 +437,10 @@ CONTAINS TYPE(timer_env_type), POINTER :: timer_env ! catch edge cases where timer_env is not yet/anymore available - IF (.NOT. list_isready(timers_stack)) THEN + IF (.NOT. list_isready(timers_stack)) & RETURN - END IF - IF (list_size(timers_stack) == 0) THEN + IF (list_size(timers_stack) == 0) & RETURN - END IF timer_env => list_peek(timers_stack) WRITE (unit_nr, '(/,A,/)') " ===== Routine Calling Stack ===== " diff --git a/src/common/timings_report.F b/src/common/timings_report.F index 03b5a4166d..eedcf3e659 100644 --- a/src/common/timings_report.F +++ b/src/common/timings_report.F @@ -77,9 +77,8 @@ CONTAINS CALL list_init(reports) CALL collect_reports_from_ranks(reports, cost_type, para_env) - IF (list_size(reports) > 0 .AND. iw > 0) THEN + IF (list_size(reports) > 0 .AND. iw > 0) & CALL print_reports(reports, iw, r_timings, sort_by_self_time, cost_type, report_maxloc, para_env) - END IF ! deallocate reports DO WHILE (list_size(reports) > 0) @@ -112,9 +111,8 @@ CONTAINS TYPE(timer_env_type), POINTER :: timer_env NULLIFY (r_stat, r_report, timer_env) - IF (.NOT. list_isready(reports)) THEN + IF (.NOT. list_isready(reports)) & CPABORT("BUG") - END IF timer_env => get_timer_env() @@ -234,9 +232,8 @@ CONTAINS TYPE(routine_report_type), POINTER :: r_report_i, r_report_j NULLIFY (r_report_i, r_report_j) - IF (.NOT. list_isready(reports)) THEN + IF (.NOT. list_isready(reports)) & CPABORT("BUG") - END IF ! are we printing timing or energy ? SELECT CASE (cost_type) diff --git a/src/common/util.F b/src/common/util.F index 1c1988135b..f20e1ebfff 100644 --- a/src/common/util.F +++ b/src/common/util.F @@ -174,7 +174,7 @@ CONTAINS IF (j == 1) THEN DO i = 1, isize INDEX(i) = i - END DO + ENDDO END IF ! Allocate scratch arrays diff --git a/src/commutator_rpnl.F b/src/commutator_rpnl.F index 669f952309..db7084cbf9 100644 --- a/src/commutator_rpnl.F +++ b/src/commutator_rpnl.F @@ -217,7 +217,7 @@ CONTAINS nprj_ppnl => gpotential(kkind)%gth_potential%nprj_ppnl ppnl_radius = gpotential(kkind)%gth_potential%ppnl_radius vprj_ppnl => gpotential(kkind)%gth_potential%vprj_ppnl - ELSE IF (spot) THEN + ELSEIF (spot) THEN CPABORT('SGP not implemented') ELSE CPABORT('PPNL unknown') @@ -868,304 +868,282 @@ CONTAINS IF (my_rxrv) THEN ! x-component (y [z,Vnl] - z [y, Vnl]) + ! with LAPACK + ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 9), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! yzV + ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 3), na, & + ! bcint(1, 1, 4), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! -yVz + ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 9), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! -zyV + ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 4), na, & + ! bcint(1, 1, 3), nb, 1.0_dp, blocks_rxrv(1)%block, SIZE(blocks_rxrv(1)%block, 1)) ! zVy + ! with MATMUL IF (iatom <= jatom) THEN - ! yzV blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! -yVz + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) - ! -zyV + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! -yVz blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! zVy + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -zyV blocks_rxrv(1)%block(1:na, 1:nb) = blocks_rxrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 3))) + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! zVy ELSE - ! yzV blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) - ! -yVz + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) - ! -zyV + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! -yVz blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) - ! zVy + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! -zyV blocks_rxrv(1)%block(1:nb, 1:na) = blocks_rxrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 3))) + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 3))) ! zVy END IF ! y-component (z [x,Vnl] - x [z, Vnl]) + ! with LAPACK + ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 7), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! zxV + ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 4), na, & + ! bcint(1, 1, 2), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! -zVx + ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 7), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! -xzV + ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 2), na, & + ! bcint(1, 1, 4), nb, 1.0_dp, blocks_rxrv(2)%block, SIZE(blocks_rxrv(2)%block, 1)) ! xVz + ! with MATMUL IF (iatom <= jatom) THEN - ! zxV blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! -zVx + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zxV blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 2))) - ! -xzV + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! -zVx blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! xVz + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -xzV blocks_rxrv(2)%block(1:na, 1:nb) = blocks_rxrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz ELSE - ! zxV blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) - ! -zVx + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! zxV blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 2))) - ! -xzV + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 2))) ! -zVx blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) - ! xVz + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! -xzV blocks_rxrv(2)%block(1:nb, 1:na) = blocks_rxrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz END IF ! z-component (x [y,Vnl] - y [x, Vnl]) + ! with LAPACK + ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 6), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! xyV + ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 2), na, & + ! bcint(1, 1, 3), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! -xVy + ! CALL dgemm("N", "T", na, nb, np, -1.0_dp, achint(1, 1, 6), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! -yxV + ! CALL dgemm("N", "T", na, nb, np, 1.0_dp, achint(1, 1, 3), na, & + ! bcint(1, 1, 2), nb, 1.0_dp, blocks_rxrv(3)%block, SIZE(blocks_rxrv(3)%block, 1)) ! yVx + ! with MATMUL IF (iatom <= jatom) THEN - ! xyV blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! -xVy + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) - ! -yxV + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! -xVy blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! zVx + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! -yxV blocks_rxrv(3)%block(1:na, 1:nb) = blocks_rxrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 2))) + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! zVx ELSE - ! xyV blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) - ! -xVy + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) - ! -yxV + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! -xVy blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) - ! zVx + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! -yxV blocks_rxrv(3)%block(1:nb, 1:na) = blocks_rxrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 2))) + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 2))) ! zVx END IF END IF IF (my_rrv) THEN ! r_alpha * r_beta * Vnl + ! with LAPACK + ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 5), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(1)%block, SIZE(blocks_rrv(1)%block, 1)) ! xxV + ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 6), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(2)%block, SIZE(blocks_rrv(2)%block, 1)) ! xyV + ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 7), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(3)%block, SIZE(blocks_rrv(3)%block, 1)) ! xzV + ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 8), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(4)%block, SIZE(blocks_rrv(4)%block, 1)) ! yyV + ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 9), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(5)%block, SIZE(blocks_rrv(5)%block, 1)) ! yzV + ! CALL dgemm("N", "T", na, nb, np, 1._dp, achint(1, 1, 10), na, & + ! bcint(1, 1, 1), nb, 1.0_dp, blocks_rrv(6)%block, SIZE(blocks_rrv(6)%block, 1)) ! zzV + ! with MATMUL IF (iatom <= jatom) THEN - ! xxV blocks_rrv(1)%block(1:na, 1:nb) = blocks_rrv(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! xyV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV blocks_rrv(2)%block(1:na, 1:nb) = blocks_rrv(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! xzV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV blocks_rrv(3)%block(1:na, 1:nb) = blocks_rrv(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! yyV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV blocks_rrv(4)%block(1:na, 1:nb) = blocks_rrv(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! yzV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV blocks_rrv(5)%block(1:na, 1:nb) = blocks_rrv(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! zzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV blocks_rrv(6)%block(1:na, 1:nb) = blocks_rrv(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV ELSE - ! xxV blocks_rrv(1)%block(1:nb, 1:na) = blocks_rrv(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) - ! xyV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV blocks_rrv(2)%block(1:nb, 1:na) = blocks_rrv(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) - ! xzV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV blocks_rrv(3)%block(1:nb, 1:na) = blocks_rrv(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) - ! yyV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV blocks_rrv(4)%block(1:nb, 1:na) = blocks_rrv(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) - ! yzV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV blocks_rrv(5)%block(1:nb, 1:na) = blocks_rrv(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) - ! zzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV blocks_rrv(6)%block(1:nb, 1:na) = blocks_rrv(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV END IF ! - Vnl * r_alpha * r_beta + ! with LAPACK + ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & + ! bcint(1, 1, 5), nb, 1.0_dp, blocks_rrv(1)%block, SIZE(blocks_rrv(1)%block, 1)) ! Vxx + ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & + ! bcint(1, 1, 6), nb, 1.0_dp, blocks_rrv(2)%block, SIZE(blocks_rrv(2)%block, 1)) ! Vxy + ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & + ! bcint(1, 1, 7), nb, 1.0_dp, blocks_rrv(3)%block, SIZE(blocks_rrv(3)%block, 1)) ! Vxz + ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & + ! bcint(1, 1, 8), nb, 1.0_dp, blocks_rrv(4)%block, SIZE(blocks_rrv(4)%block, 1)) ! Vyy + ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & + ! bcint(1, 1, 9), nb, 1.0_dp, blocks_rrv(5)%block, SIZE(blocks_rrv(5)%block, 1)) ! Vyz + ! CALL dgemm("N", "T", na, nb, np, -1._dp, achint(1, 1, 1), na, & + ! bcint(1, 1, 10), nb, 1.0_dp, blocks_rrv(6)%block, SIZE(blocks_rrv(6)%block, 1)) ! Vzz + ! with MATMUL IF (iatom <= jatom) THEN - ! -Vxx blocks_rrv(1)%block(1:na, 1:nb) = blocks_rrv(1)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) - ! -Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! -Vxx blocks_rrv(2)%block(1:na, 1:nb) = blocks_rrv(2)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) - ! -Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! -Vxy blocks_rrv(3)%block(1:na, 1:nb) = blocks_rrv(3)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) - ! -Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! -Vxz blocks_rrv(4)%block(1:na, 1:nb) = blocks_rrv(4)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) - ! -Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! -Vyy blocks_rrv(5)%block(1:na, 1:nb) = blocks_rrv(5)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) - ! -Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! -Vyz blocks_rrv(6)%block(1:na, 1:nb) = blocks_rrv(6)%block(1:na, 1:nb) - & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! -Vzz ELSE - ! -Vxx blocks_rrv(1)%block(1:nb, 1:na) = blocks_rrv(1)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) - ! -Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! -Vxx blocks_rrv(2)%block(1:nb, 1:na) = blocks_rrv(2)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) - ! -Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! -Vxy blocks_rrv(3)%block(1:nb, 1:na) = blocks_rrv(3)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) - ! -Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! -Vxz blocks_rrv(4)%block(1:nb, 1:na) = blocks_rrv(4)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) - ! -Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! -Vyy blocks_rrv(5)%block(1:nb, 1:na) = blocks_rrv(5)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) - ! -Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! -Vyz blocks_rrv(6)%block(1:nb, 1:na) = blocks_rrv(6)%block(1:nb, 1:na) - & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! -Vzz END IF END IF IF (my_rvr) THEN ! r_alpha * Vnl * r_beta IF (iatom <= jatom) THEN - ! xVx blocks_rvr(1)%block(1:na, 1:nb) = blocks_rvr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 2))) - ! xVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 2))) ! xVx blocks_rvr(2)%block(1:na, 1:nb) = blocks_rvr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) - ! xVz + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! xVy blocks_rvr(3)%block(1:na, 1:nb) = blocks_rvr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) - ! yVy + MATMUL(achint(1:na, 1:np, 2), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! xVz blocks_rvr(4)%block(1:na, 1:nb) = blocks_rvr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 3))) - ! yVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 3))) ! yVy blocks_rvr(5)%block(1:na, 1:nb) = blocks_rvr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) - ! zVz + MATMUL(achint(1:na, 1:np, 3), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! yVz blocks_rvr(6)%block(1:na, 1:nb) = blocks_rvr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 4))) + MATMUL(achint(1:na, 1:np, 4), TRANSPOSE(bcint(1:nb, 1:np, 4))) ! zVz ELSE - ! xVx blocks_rvr(1)%block(1:nb, 1:na) = blocks_rvr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 2))) - ! xVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 2))) ! xVx blocks_rvr(2)%block(1:nb, 1:na) = blocks_rvr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) - ! xVz + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 3))) ! xVy blocks_rvr(3)%block(1:nb, 1:na) = blocks_rvr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) - ! yVy + MATMUL(bchint(1:nb, 1:np, 2), TRANSPOSE(acint(1:na, 1:np, 4))) ! xVz blocks_rvr(4)%block(1:nb, 1:na) = blocks_rvr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 3))) - ! yVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 3))) ! yVy blocks_rvr(5)%block(1:nb, 1:na) = blocks_rvr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) - ! zVz + MATMUL(bchint(1:nb, 1:np, 3), TRANSPOSE(acint(1:na, 1:np, 4))) ! yVz blocks_rvr(6)%block(1:nb, 1:na) = blocks_rvr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 4))) + MATMUL(bchint(1:nb, 1:np, 4), TRANSPOSE(acint(1:na, 1:np, 4))) ! zVz END IF END IF IF (my_rrv_vrr) THEN ! r_alpha * r_beta * Vnl IF (iatom <= jatom) THEN - ! xxV blocks_rrv_vrr(1)%block(1:na, 1:nb) = blocks_rrv_vrr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! xyV + MATMUL(achint(1:na, 1:np, 5), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xxV blocks_rrv_vrr(2)%block(1:na, 1:nb) = blocks_rrv_vrr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! xzV + MATMUL(achint(1:na, 1:np, 6), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xyV blocks_rrv_vrr(3)%block(1:na, 1:nb) = blocks_rrv_vrr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! yyV + MATMUL(achint(1:na, 1:np, 7), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! xzV blocks_rrv_vrr(4)%block(1:na, 1:nb) = blocks_rrv_vrr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! yzV + MATMUL(achint(1:na, 1:np, 8), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yyV blocks_rrv_vrr(5)%block(1:na, 1:nb) = blocks_rrv_vrr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) - ! zzV + MATMUL(achint(1:na, 1:np, 9), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! yzV blocks_rrv_vrr(6)%block(1:na, 1:nb) = blocks_rrv_vrr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) + MATMUL(achint(1:na, 1:np, 10), TRANSPOSE(bcint(1:nb, 1:np, 1))) ! zzV ELSE - ! xxV blocks_rrv_vrr(1)%block(1:nb, 1:na) = blocks_rrv_vrr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) - ! xyV + MATMUL(bchint(1:nb, 1:np, 5), TRANSPOSE(acint(1:na, 1:np, 1))) ! xxV blocks_rrv_vrr(2)%block(1:nb, 1:na) = blocks_rrv_vrr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) - ! xzV + MATMUL(bchint(1:nb, 1:np, 6), TRANSPOSE(acint(1:na, 1:np, 1))) ! xyV blocks_rrv_vrr(3)%block(1:nb, 1:na) = blocks_rrv_vrr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) - ! yyV + MATMUL(bchint(1:nb, 1:np, 7), TRANSPOSE(acint(1:na, 1:np, 1))) ! xzV blocks_rrv_vrr(4)%block(1:nb, 1:na) = blocks_rrv_vrr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) - ! yzV + MATMUL(bchint(1:nb, 1:np, 8), TRANSPOSE(acint(1:na, 1:np, 1))) ! yyV blocks_rrv_vrr(5)%block(1:nb, 1:na) = blocks_rrv_vrr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) - ! zzV + MATMUL(bchint(1:nb, 1:np, 9), TRANSPOSE(acint(1:na, 1:np, 1))) ! yzV blocks_rrv_vrr(6)%block(1:nb, 1:na) = blocks_rrv_vrr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) + MATMUL(bchint(1:nb, 1:np, 10), TRANSPOSE(acint(1:na, 1:np, 1))) ! zzV END IF ! + Vnl * r_alpha * r_beta IF (iatom <= jatom) THEN - ! +Vxx blocks_rrv_vrr(1)%block(1:na, 1:nb) = blocks_rrv_vrr(1)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) - ! +Vxy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 5))) ! +Vxx blocks_rrv_vrr(2)%block(1:na, 1:nb) = blocks_rrv_vrr(2)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) - ! +Vxz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 6))) ! +Vxy blocks_rrv_vrr(3)%block(1:na, 1:nb) = blocks_rrv_vrr(3)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) - ! +Vyy + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 7))) ! +Vxz blocks_rrv_vrr(4)%block(1:na, 1:nb) = blocks_rrv_vrr(4)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) - ! +Vyz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 8))) ! +Vyy blocks_rrv_vrr(5)%block(1:na, 1:nb) = blocks_rrv_vrr(5)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) - ! +Vzz + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 9))) ! +Vyz blocks_rrv_vrr(6)%block(1:na, 1:nb) = blocks_rrv_vrr(6)%block(1:na, 1:nb) + & - MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) + MATMUL(achint(1:na, 1:np, 1), TRANSPOSE(bcint(1:nb, 1:np, 10))) ! +Vzz ELSE - ! +Vxx blocks_rrv_vrr(1)%block(1:nb, 1:na) = blocks_rrv_vrr(1)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) - ! +Vxy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 5))) ! +Vxx blocks_rrv_vrr(2)%block(1:nb, 1:na) = blocks_rrv_vrr(2)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) - ! +Vxz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 6))) ! +Vxy blocks_rrv_vrr(3)%block(1:nb, 1:na) = blocks_rrv_vrr(3)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) - ! +Vyy + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 7))) ! +Vxz blocks_rrv_vrr(4)%block(1:nb, 1:na) = blocks_rrv_vrr(4)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) - ! +Vyz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 8))) ! +Vyy blocks_rrv_vrr(5)%block(1:nb, 1:na) = blocks_rrv_vrr(5)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) - ! +Vzz + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 9))) ! +Vyz blocks_rrv_vrr(6)%block(1:nb, 1:na) = blocks_rrv_vrr(6)%block(1:nb, 1:na) + & - MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) + MATMUL(bchint(1:nb, 1:np, 1), TRANSPOSE(acint(1:na, 1:np, 10))) ! +Vzz END IF END IF ! The indices are stored in i_1, i_x, ..., i_zzz + ! matrix_r_rxvr(alpha, beta) + ! = sum_(gamma delta) epsilon_(alpha gamma delta) + ! (r_beta * r_gamma * V_nl * r_delta - r_beta * r_gamma * r_delta * V_nl) + ! = sum_(gamma delta) epsilon_(alpha gamma delta) r_beta * r_gamma * V_nl * r_delta ! TODO: is this set to zero before? IF (my_r_rxvr) THEN diff --git a/src/constraint.F b/src/constraint.F index c8bdc9e2fa..e6d1308ea4 100644 --- a/src/constraint.F +++ b/src/constraint.F @@ -157,51 +157,43 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & CALL shake_3x3_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) - END IF ! 4x6 - IF (n4x6con /= 0) THEN + IF (n4x6con /= 0) & CALL shake_4x6_int(molecule, particle_set, pos, vel, dt, ishake_int, & int_max_sigma) - END IF ! Collective Variables - IF (ncolv%ntot /= 0) THEN + IF (ncolv%ntot /= 0) & CALL shake_colv_int(molecule, particle_set, pos, vel, dt, ishake_int, & cell, imass, int_max_sigma) - END IF END DO Shake_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL shake_int_info(log_unit, i, ishake_int, max_sigma) ! Virtual Site - IF (nvsitecon /= 0) THEN + IF (nvsitecon /= 0) & CALL shake_vsite_int(molecule, pos) - END IF END DO END DO MOL ! Intermolecular constraints IF (do_ext_constraint) THEN CALL update_temporary_set(group, pos=pos, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) THEN + IF (gci%ng3x3 /= 0) & CALL shake_3x3_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) - END IF ! 4x6 - IF (gci%ng4x6 /= 0) THEN + IF (gci%ng4x6 /= 0) & CALL shake_4x6_ext(gci, particle_set, pos, vel, dt, ishake_ext, & max_sigma) - END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) THEN + IF (gci%ncolv%ntot /= 0) & CALL shake_colv_ext(gci, particle_set, pos, vel, dt, ishake_ext, & cell, imass, max_sigma) - END IF ! Virtual Site - IF (gci%nvsite /= 0) THEN + IF (gci%nvsite /= 0) & CALL shake_vsite_ext(gci, pos) - END IF CALL restore_temporary_set(particle_set, local_particles, pos=pos, vel=vel) END IF CALL shake_ext_info(log_unit, ishake_ext, max_sigma) @@ -291,18 +283,15 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & CALL rattle_3x3_int(molecule, particle_set, vel, dt) - END IF ! 4x6 - IF (n4x6con /= 0) THEN + IF (n4x6con /= 0) & CALL rattle_4x6_int(molecule, particle_set, vel, dt) - END IF ! Collective Variables - IF (ncolv%ntot /= 0) THEN + IF (ncolv%ntot /= 0) & CALL rattle_colv_int(molecule, particle_set, vel, dt, & irattle_int, cell, imass, int_max_sigma) - END IF END DO Rattle_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL rattle_int_info(log_unit, i, irattle_int, max_sigma) @@ -312,18 +301,15 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) THEN + IF (gci%ng3x3 /= 0) & CALL rattle_3x3_ext(gci, particle_set, vel, dt) - END IF ! 4x6 - IF (gci%ng4x6 /= 0) THEN + IF (gci%ng4x6 /= 0) & CALL rattle_4x6_ext(gci, particle_set, vel, dt) - END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) THEN + IF (gci%ncolv%ntot /= 0) & CALL rattle_colv_ext(gci, particle_set, vel, dt, & irattle_ext, cell, imass, max_sigma) - END IF CALL restore_temporary_set(particle_set, local_particles, vel=vel) END IF CALL rattle_ext_info(log_unit, irattle_ext, max_sigma) @@ -431,20 +417,17 @@ CONTAINS int_max_sigma = 0.0_dp ishake_int = ishake_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & CALL shake_roll_3x3_int(molecule, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_int, int_max_sigma) - END IF ! 4x6 - IF (n4x6con /= 0) THEN + IF (n4x6con /= 0) & CALL shake_roll_4x6_int(molecule, particle_set, pos, vel, r_shake, & dt, ishake_int, int_max_sigma) - END IF ! Collective Variables - IF (ncolv%ntot /= 0) THEN + IF (ncolv%ntot /= 0) & CALL shake_roll_colv_int(molecule, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_int, cell, imass, int_max_sigma) - END IF END DO Shake_Roll_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) CALL shake_int_info(log_unit, i, ishake_int, max_sigma) @@ -458,24 +441,20 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(group, pos=pos, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) THEN + IF (gci%ng3x3 /= 0) & CALL shake_roll_3x3_ext(gci, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_ext, max_sigma) - END IF ! 4x6 - IF (gci%ng4x6 /= 0) THEN + IF (gci%ng4x6 /= 0) & CALL shake_roll_4x6_ext(gci, particle_set, pos, vel, r_shake, & dt, ishake_ext, max_sigma) - END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) THEN + IF (gci%ncolv%ntot /= 0) & CALL shake_roll_colv_ext(gci, particle_set, pos, vel, r_shake, & v_shake, dt, ishake_ext, cell, imass, max_sigma) - END IF ! Virtual Site - IF (gci%nvsite /= 0) THEN + IF (gci%nvsite /= 0) & CPABORT("Virtual Site Constraint/Restraint not implemented for SHAKE_ROLL!") - END IF CALL restore_temporary_set(particle_set, local_particles, pos=pos, vel=vel) END IF CALL shake_ext_info(log_unit, ishake_ext, max_sigma) @@ -585,20 +564,17 @@ CONTAINS int_max_sigma = 0.0_dp irattle_int = irattle_int + 1 ! 3x3 - IF (n3x3con /= 0) THEN + IF (n3x3con /= 0) & CALL rattle_roll_3x3_int(molecule, particle_set, vel, r_rattle, dt, & veps) - END IF ! 4x6 - IF (n4x6con /= 0) THEN + IF (n4x6con /= 0) & CALL rattle_roll_4x6_int(molecule, particle_set, vel, r_rattle, dt, & veps) - END IF ! Collective Variables - IF (ncolv%ntot /= 0) THEN + IF (ncolv%ntot /= 0) & CALL rattle_roll_colv_int(molecule, particle_set, vel, r_rattle, dt, & irattle_int, veps, cell, imass, int_max_sigma) - END IF END DO Rattle_Roll_Intramolecular max_sigma = MAX(max_sigma, int_max_sigma) CALL rattle_int_info(log_unit, i, irattle_int, max_sigma) @@ -608,20 +584,17 @@ CONTAINS IF (do_ext_constraint) THEN CALL update_temporary_set(para_env, vel=vel) ! 3x3 - IF (gci%ng3x3 /= 0) THEN + IF (gci%ng3x3 /= 0) & CALL rattle_roll_3x3_ext(gci, particle_set, vel, r_rattle, dt, & veps) - END IF ! 4x6 - IF (gci%ng4x6 /= 0) THEN + IF (gci%ng4x6 /= 0) & CALL rattle_roll_4x6_ext(gci, particle_set, vel, r_rattle, dt, & veps) - END IF ! Collective Variables - IF (gci%ncolv%ntot /= 0) THEN + IF (gci%ncolv%ntot /= 0) & CALL rattle_roll_colv_ext(gci, particle_set, vel, r_rattle, dt, & irattle_ext, veps, cell, imass, max_sigma) - END IF CALL restore_temporary_set(particle_set, local_particles, vel=vel) END IF CALL rattle_ext_info(log_unit, irattle_ext, max_sigma) @@ -735,7 +708,7 @@ CONTAINS IF (log_unit > 0) THEN IF (id_type == "S") THEN label = "Shake Lagrangian Multipliers:" - ELSE IF (id_type == "R") THEN + ELSEIF (id_type == "R") THEN label = "Rattle Lagrangian Multipliers:" ELSE CPABORT("Only S for Shake or R for Rattle are supported for Lagrangian Multipliers") @@ -770,12 +743,11 @@ CONTAINS "Molecule Nr.:", i, " Nr. Iterations:", ishake_int, " Max. Err.:", max_sigma END IF ! Notify a not converged SHAKE - IF (ishake_int > Max_Shake_Iter) THEN + IF (ishake_int > Max_Shake_Iter) & CALL cp_warn(__LOCATION__, & "Shake NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intramolecular constraint loop for Molecule nr. "//cp_to_string(i)// & ". CP2K continues but results could be meaningless. ") - END IF END SUBROUTINE shake_int_info ! ************************************************************************************************** @@ -797,11 +769,10 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged SHAKE - IF (ishake_ext > Max_Shake_Iter) THEN + IF (ishake_ext > Max_Shake_Iter) & CALL cp_warn(__LOCATION__, & "Shake NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intermolecular constraint. CP2K continues but results could be meaningless.") - END IF END SUBROUTINE shake_ext_info ! ************************************************************************************************** @@ -823,12 +794,11 @@ CONTAINS "Molecule Nr.:", i, " Nr. Iterations:", irattle_int, " Max. Err.:", max_sigma END IF ! Notify a not converged RATTLE - IF (irattle_int > Max_shake_Iter) THEN + IF (irattle_int > Max_shake_Iter) & CALL cp_warn(__LOCATION__, & "Rattle NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intramolecular constraint loop for Molecule nr. "//cp_to_string(i)// & ". CP2K continues but results could be meaningless.") - END IF END SUBROUTINE rattle_int_info ! ************************************************************************************************** @@ -850,11 +820,10 @@ CONTAINS " Max. Err.:", max_sigma END IF ! Notify a not converged RATTLE - IF (irattle_ext > Max_shake_Iter) THEN + IF (irattle_ext > Max_shake_Iter) & CALL cp_warn(__LOCATION__, & "Rattle NOT converged in "//cp_to_string(Max_Shake_Iter)//" iterations in the "// & "intermolecular constraint. CP2K continues but results could be meaningless.") - END IF END SUBROUTINE rattle_ext_info ! ************************************************************************************************** diff --git a/src/constraint_fxd.F b/src/constraint_fxd.F index b4f9e7b7e8..225416d12d 100644 --- a/src/constraint_fxd.F +++ b/src/constraint_fxd.F @@ -398,9 +398,8 @@ CONTAINS DO k = 1, SIZE(fixd_list) IF (fixd_list(k)%fixd == j) THEN IF (fixd_list(k)%itype /= use_perd_xyz) CYCLE - IF (.NOT. fixd_list(k)%restraint%active) THEN + IF (.NOT. fixd_list(k)%restraint%active) & colvar%dsdr(:, i) = 0.0_dp - END IF EXIT END IF END DO diff --git a/src/constraint_util.F b/src/constraint_util.F index dec377128b..0570c248f1 100644 --- a/src/constraint_util.F +++ b/src/constraint_util.F @@ -554,8 +554,8 @@ CONTAINS v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) diag = MATMUL(r_shake, v_shake) r_shake = diag - ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & - PRESENT(vector_r)) THEN + ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v) .AND. & + PRESENT(vector_r)) THEN DO i = 1, 3 r_shake(i, i) = vector_r(i)*vector_v(i) v_shake(i, i) = vector_v(i) @@ -569,7 +569,7 @@ CONTAINS diag(2, 2) = vector_v(2) diag(3, 3) = vector_v(3) v_shake = MATMUL(MATMUL(u, diag), TRANSPOSE(u)) - ELSE IF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN + ELSEIF (.NOT. PRESENT(u) .AND. PRESENT(vector_v)) THEN DO i = 1, 3 v_shake(i, i) = vector_v(i) END DO diff --git a/src/constraint_vsite.F b/src/constraint_vsite.F index ffdbb8ba52..12c4cd96c5 100644 --- a/src/constraint_vsite.F +++ b/src/constraint_vsite.F @@ -94,16 +94,14 @@ CONTAINS molecule_kind => molecule%molecule_kind CALL get_molecule_kind(molecule_kind, nconstraint=nconstraint, nvsite=nvsitecon) IF (nconstraint == 0) CYCLE - IF (nvsitecon /= 0) THEN + IF (nvsitecon /= 0) & CALL force_vsite_int(molecule, particle_set) - END IF END DO END DO MOL ! Intermolecular Virtual Site Constraints IF (do_ext_constraint) THEN - IF (gci%nvsite /= 0) THEN + IF (gci%nvsite /= 0) & CALL force_vsite_ext(gci, particle_set) - END IF END IF END SUBROUTINE vsite_force_control diff --git a/src/core_ppl.F b/src/core_ppl.F index e47510449d..c1041e16d2 100644 --- a/src/core_ppl.F +++ b/src/core_ppl.F @@ -448,7 +448,7 @@ CONTAINS IF (ecp_semi_local) THEN CALL get_potential(potential=sgp_potential, sl_lmax=slmax, & npot=npot, nrpot=nrpot, apot=apot, bpot=bpot) - ELSE IF (ecp_local) THEN + ELSEIF (ecp_local) THEN IF (SUM(ABS(aloc(1:nloc))) < 1.0e-12_dp) CYCLE END IF ELSE @@ -498,7 +498,7 @@ CONTAINS rab, dab, rac, dac, rbc, dbc, & hab(:, :, iset, jset), ppl_work, pab(:, :, iset, jset), & force_a, force_b, ppl_fwork) - ELSE IF (libgrpp_local) THEN + ELSEIF (libgrpp_local) THEN !$OMP CRITICAL(type1) CALL libgrpp_local_forces_ref(la_max(iset), la_min(iset), npgfa(iset), & rpgfa(:, iset), zeta(:, iset), & @@ -556,7 +556,7 @@ CONTAINS CALL virial_pair_force(pv_thread, f0, force_a, rac) CALL virial_pair_force(pv_thread, f0, force_b, rbc) END IF - ELSE IF (do_dR) THEN + ELSEIF (do_dR) THEN hab2_w = 0._dp CALL ppl_integral( & la_max(iset), la_min(iset), npgfa(iset), & @@ -584,7 +584,7 @@ CONTAINS nexp_ppl, alpha_ppl, nct_ppl, cval_ppl, ppl_radius, & rab, dab, rac, dac, rbc, dbc, hab(:, :, iset, jset), ppl_work) - ELSE IF (libgrpp_local) THEN + ELSEIF (libgrpp_local) THEN !If the local part of the potential is more complex, we need libgrpp !$OMP CRITICAL(type1) CALL libgrpp_local_integrals(la_max(iset), la_min(iset), npgfa(iset), & diff --git a/src/core_ppnl.F b/src/core_ppnl.F index 7fc2104d7e..906658762a 100644 --- a/src/core_ppnl.F +++ b/src/core_ppnl.F @@ -667,7 +667,7 @@ CONTAINS END IF IF (do_dR) THEN - i = 1; j = 2 + i = 1; j = 2; katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN h_block(1:na, 1:nb) = h_block(1:na, 1:nb) + & @@ -686,7 +686,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 2; j = 3 + i = 2; j = 3; katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_2block(1:na, 1:nb) = r_2block(1:na, 1:nb) + & @@ -705,7 +705,7 @@ CONTAINS MATMUL(bcint(1:nb, 1:np, j), TRANSPOSE(achint(1:na, 1:np, 1))) END IF - i = 3; j = 4 + i = 3; j = 4; katom = alist_ac%clist(kac)%catom IF (iatom <= jatom) THEN r_3block(1:na, 1:nb) = r_3block(1:na, 1:nb) + & diff --git a/src/cp2k_debug.F b/src/cp2k_debug.F index c426ba1006..3d288eeb82 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) - ELSE IF (dft_control%apply_period_efield) THEN + ELSEIF (dft_control%apply_period_efield) THEN dft_control%period_efield%strength = amplitude dft_control%period_efield%polarisation(1:3) = poldir(1:3) ELSE diff --git a/src/cp2k_info.F b/src/cp2k_info.F index cc90bc1d31..872951cffd 100644 --- a/src/cp2k_info.F +++ b/src/cp2k_info.F @@ -46,7 +46,7 @@ MODULE cp2k_info #endif !!! Keep version in sync with CMakeLists.txt !!! - CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.2 (Development Version)" + CHARACTER(LEN=*), PARAMETER :: cp2k_version = "CP2K version 2026.2" CHARACTER(LEN=*), PARAMETER :: cp2k_year = "2026" CHARACTER(LEN=*), PARAMETER :: cp2k_home = "https://www.cp2k.org/" diff --git a/src/cp_control_types.F b/src/cp_control_types.F index 4470a26447..47d3cb3bf7 100644 --- a/src/cp_control_types.F +++ b/src/cp_control_types.F @@ -891,9 +891,8 @@ CONTAINS SUBROUTINE mulliken_control_release(mulliken_restraint_control) TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken_restraint_control - IF (ASSOCIATED(mulliken_restraint_control%atoms)) THEN + IF (ASSOCIATED(mulliken_restraint_control%atoms)) & DEALLOCATE (mulliken_restraint_control%atoms) - END IF mulliken_restraint_control%strength = 0.0_dp mulliken_restraint_control%target = 0.0_dp mulliken_restraint_control%natoms = 0 @@ -928,12 +927,10 @@ CONTAINS SUBROUTINE ddapc_control_release(ddapc_restraint_control) TYPE(ddapc_restraint_type), INTENT(INOUT) :: ddapc_restraint_control - IF (ASSOCIATED(ddapc_restraint_control%atoms)) THEN + IF (ASSOCIATED(ddapc_restraint_control%atoms)) & DEALLOCATE (ddapc_restraint_control%atoms) - END IF - IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN + IF (ASSOCIATED(ddapc_restraint_control%coeff)) & DEALLOCATE (ddapc_restraint_control%coeff) - END IF ddapc_restraint_control%strength = 0.0_dp ddapc_restraint_control%target = 0.0_dp ddapc_restraint_control%natoms = 0 @@ -1210,21 +1207,18 @@ CONTAINS IF (ASSOCIATED(proj_mo_list)) THEN DO i = 1, SIZE(proj_mo_list) IF (ASSOCIATED(proj_mo_list(i)%proj_mo)) THEN - IF (ALLOCATED(proj_mo_list(i)%proj_mo%ref_mo_index)) THEN + IF (ALLOCATED(proj_mo_list(i)%proj_mo%ref_mo_index)) & DEALLOCATE (proj_mo_list(i)%proj_mo%ref_mo_index) - END IF IF (ALLOCATED(proj_mo_list(i)%proj_mo%mo_ref)) THEN DO mo_ref_nbr = 1, SIZE(proj_mo_list(i)%proj_mo%mo_ref) CALL cp_fm_release(proj_mo_list(i)%proj_mo%mo_ref(mo_ref_nbr)) END DO DEALLOCATE (proj_mo_list(i)%proj_mo%mo_ref) END IF - IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_index)) THEN + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_index)) & DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_index) - END IF - IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) THEN + IF (ALLOCATED(proj_mo_list(i)%proj_mo%td_mo_occ)) & DEALLOCATE (proj_mo_list(i)%proj_mo%td_mo_occ) - END IF DEALLOCATE (proj_mo_list(i)%proj_mo) END IF END DO @@ -1250,9 +1244,8 @@ CONTAINS IF (ASSOCIATED(efield_fields(i)%efield%envelop_i_vars)) THEN DEALLOCATE (efield_fields(i)%efield%envelop_i_vars) END IF - IF (ASSOCIATED(efield_fields(i)%efield%polarisation)) THEN + IF (ASSOCIATED(efield_fields(i)%efield%polarisation)) & DEALLOCATE (efield_fields(i)%efield%polarisation) - END IF DEALLOCATE (efield_fields(i)%efield) END IF END DO diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index abe607899e..3a2478e19e 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -164,23 +164,20 @@ CONTAINS CALL section_vals_val_get(xc_section, "gradient_cutoff", r_val=gradient_cut) CALL section_vals_val_get(xc_section, "tau_cutoff", r_val=tau_cut) ! Perform numerical stability checks and possibly correct the issues - IF (density_cut <= EPSILON(0.0_dp)*100.0_dp) THEN + IF (density_cut <= EPSILON(0.0_dp)*100.0_dp) & CALL cp_warn(__LOCATION__, & "DENSITY_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") - END IF density_cut = MAX(EPSILON(0.0_dp)*100.0_dp, density_cut) - IF (gradient_cut <= EPSILON(0.0_dp)*100.0_dp) THEN + IF (gradient_cut <= EPSILON(0.0_dp)*100.0_dp) & CALL cp_warn(__LOCATION__, & "GRADIENT_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") - END IF gradient_cut = MAX(EPSILON(0.0_dp)*100.0_dp, gradient_cut) - IF (tau_cut <= EPSILON(0.0_dp)*100.0_dp) THEN + IF (tau_cut <= EPSILON(0.0_dp)*100.0_dp) & CALL cp_warn(__LOCATION__, & "TAU_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 100*EPSILON! ") - END IF tau_cut = MAX(EPSILON(0.0_dp)*100.0_dp, tau_cut) CALL section_vals_val_set(xc_section, "density_cutoff", r_val=density_cut) CALL section_vals_val_set(xc_section, "gradient_cutoff", r_val=gradient_cut) @@ -245,18 +242,7 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - SELECT CASE (tmpstringlist(1)) - CASE ("X") - ! Do nothing - CASE DEFAULT - CALL cp_abort(__LOCATION__, & - "AUTO_BASIS: the size is invalid for the "// & - "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & - "use one of SMALL, MEDIUM, LARGE, HUGE for "// & - "the size. The syntax AUTO_BASIS X X is a "// & - "reserved case for using NO automatically "// & - "generated basis sets.") - END SELECT + isize = -1 CASE ("SMALL") isize = 0 CASE ("MEDIUM") @@ -419,9 +405,8 @@ CONTAINS IF (dft_control%admm_control%purification_method == do_admm_purify_mo_diag .OR. & dft_control%admm_control%purification_method == do_admm_purify_mo_no_diag) THEN - IF (dft_control%admm_control%method /= do_admm_basis_projection) THEN + IF (dft_control%admm_control%method /= do_admm_basis_projection) & CPABORT("ADMM: Chosen purification requires BASIS_PROJECTION") - END IF IF (.NOT. do_ot) CPABORT("ADMM: MO-based purification requires OT.") END IF @@ -444,10 +429,9 @@ CONTAINS CALL section_vals_val_get(dft_section, "MULTIPLICITY", i_val=dft_control%multiplicity) CALL section_vals_val_get(dft_section, "RELAX_MULTIPLICITY", r_val=dft_control%relax_multiplicity) IF (dft_control%relax_multiplicity > 0.0_dp) THEN - IF (.NOT. dft_control%uks) THEN + IF (.NOT. dft_control%uks) & CALL cp_abort(__LOCATION__, "The option RELAX_MULTIPLICITY is only valid for "// & "unrestricted Kohn-Sham (UKS) calculations") - END IF END IF !Read the HAIR PROBES input section if present @@ -583,9 +567,8 @@ CONTAINS CALL section_vals_val_get(tmp_section, "POLARISATION", r_vals=pol) dft_control%period_efield%polarisation(1:3) = pol(1:3) IF (PRESENT(cell)) THEN - IF (ASSOCIATED(cell)) THEN + IF (ASSOCIATED(cell)) & CALL cell_transform_input_cartesian(cell, dft_control%period_efield%polarisation(1:3)) - END IF END IF CALL section_vals_val_get(tmp_section, "D_FILTER", r_vals=pol) dft_control%period_efield%d_filter(1:3) = pol(1:3) @@ -665,12 +648,7 @@ CONTAINS END IF ! periodic fields don't work with RTP - IF (do_rtp) THEN - CALL cp_abort(__LOCATION__, & - "Periodic efield cannot be used with RTP. When restarting a "// & - "run with periodic efield, set RESTART_RTP under &EXT_RESTART "// & - "section to .FALSE. explicitly if RESTART_DEFAULT is .TRUE.") - END IF + CPASSERT(.NOT. do_rtp) IF (dft_control%period_efield%displacement_field) THEN CALL cite_reference(Stengel2009) ELSE @@ -1239,9 +1217,8 @@ CONTAINS jj = jj + SIZE(tmplist) END DO qs_control%mulliken_restraint_control%natoms = jj - IF (qs_control%mulliken_restraint_control%natoms < 1) THEN + IF (qs_control%mulliken_restraint_control%natoms < 1) & CPABORT("Need at least 1 atom to use mulliken constraints") - END IF ALLOCATE (qs_control%mulliken_restraint_control%atoms(qs_control%mulliken_restraint_control%natoms)) jj = 0 DO k = 1, n_rep @@ -1289,11 +1266,10 @@ CONTAINS CALL section_vals_val_get(se_section, "INTEGRAL_SCREENING", & i_val=qs_control%se_control%integral_screening) IF (qs_control%method_id == do_method_pnnl) THEN - IF (qs_control%se_control%integral_screening /= do_se_IS_slater) THEN + IF (qs_control%se_control%integral_screening /= do_se_IS_slater) & CALL cp_warn(__LOCATION__, & "PNNL semi-empirical parameterization supports only the Slater type "// & "integral scheme. Revert to Slater and continue the calculation.") - END IF qs_control%se_control%integral_screening = do_se_IS_slater END IF ! Global Arrays variable @@ -1358,23 +1334,21 @@ CONTAINS qs_control%se_control%do_ewald = .FALSE. qs_control%se_control%do_ewald_r3 = .FALSE. qs_control%se_control%do_ewald_gks = .TRUE. - IF (qs_control%method_id /= do_method_pnnl) THEN + IF (qs_control%method_id /= do_method_pnnl) & CALL cp_abort(__LOCATION__, & "A periodic semi-empirical calculation was requested with a long-range "// & "summation on the single integral evaluation. This scheme is supported "// & "only by the PNNL parameterization.") - END IF CASE (do_se_lr_ewald_r3) qs_control%se_control%do_ewald = .TRUE. qs_control%se_control%do_ewald_r3 = .TRUE. qs_control%se_control%do_ewald_gks = .FALSE. - IF (qs_control%se_control%integral_screening /= do_se_IS_kdso) THEN + IF (qs_control%se_control%integral_screening /= do_se_IS_kdso) & CALL cp_abort(__LOCATION__, & "A periodic semi-empirical calculation was requested with a long-range "// & "summation for the slowly convergent part 1/R^3, which is not congruent "// & "with the integral screening chosen. The only integral screening supported "// & "by this periodic type calculation is the standard Klopman-Dewar-Sabelli-Ohno.") - END IF END SELECT ! dispersion pair potentials @@ -1438,21 +1412,18 @@ CONTAINS "DFTB/TBLITE_MIXER") IF (qs_control%do_ls_scf) THEN IF (dftb_scc_mixer_explicit .AND. & - qs_control%dftb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN + qs_control%dftb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & CALL cp_warn(__LOCATION__, & "DFTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - END IF - IF (dftb_tblite_mixer_explicit) THEN + IF (dftb_tblite_mixer_explicit) & CALL cp_warn(__LOCATION__, & "DFTB/TBLITE_MIXER settings are ignored with QS/LS_SCF; LS_SCF controls "// & "the density-matrix optimization.") - END IF qs_control%dftb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF - IF (qs_control%dftb_control%tblite_mixer_damping <= 0.0_dp) THEN + IF (qs_control%dftb_control%tblite_mixer_damping <= 0.0_dp) & CPABORT("DFTB/TBLITE_MIXER/DAMPING must be positive") - END IF CALL section_vals_val_get(dftb_section, "EPS_DISP", & r_val=qs_control%dftb_control%eps_disp) CALL section_vals_val_get(dftb_section, "DO_EWALD", explicit=explicit) @@ -1512,9 +1483,8 @@ CONTAINS CALL section_vals_val_get(xtb_tblite, "_SECTION_PARAMETERS_", l_val=tblite_section_active) qs_control%xtb_control%do_tblite = (qs_control%xtb_control%gfn_type == gfn_tblite) IF (qs_control%xtb_control%do_tblite) THEN - IF (.NOT. tblite_section_active) THEN + IF (.NOT. tblite_section_active) & CPABORT("XTB/GFN_TYPE TBLITE requires an XTB/TBLITE section") - END IF ! The CP2K-internal GFN1 defaults are still used to initialize shared xTB fields. qs_control%xtb_control%gfn_type = gfn1xtb ELSE IF (tblite_section_active) THEN @@ -1535,43 +1505,37 @@ CONTAINS qs_control%xtb_control%tblite_mixer_max_weight, & qs_control%xtb_control%tblite_mixer_weight_factor, & "XTB/TBLITE_MIXER") - IF (xtb_tblite_mixer_explicit) THEN + IF (xtb_tblite_mixer_explicit) & CALL section_vals_val_get(xtb_tblite_mixer, "DAMPING", & explicit=qs_control%xtb_control%tblite_mixer_damping_explicit) - END IF IF ((.NOT. qs_control%xtb_control%do_tblite) .AND. & qs_control%xtb_control%gfn_type == 0) THEN IF (xtb_scc_mixer_explicit .AND. & qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_auto .AND. & - qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE for CP2K-internal GFN0-xTB; "// & "GFN0-xTB has no SCC variables to mix.") - END IF - IF (xtb_tblite_mixer_explicit) THEN + IF (xtb_tblite_mixer_explicit) & CALL cp_warn(__LOCATION__, & "XTB/TBLITE_MIXER settings are ignored for CP2K-internal GFN0-xTB; "// & "GFN0-xTB has no SCC variables to mix.") - END IF qs_control%xtb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF IF (qs_control%do_ls_scf) THEN IF (xtb_scc_mixer_explicit .AND. & - qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) THEN + qs_control%xtb_control%tblite_scc_mixer /= tblite_scc_mixer_none) & CALL cp_warn(__LOCATION__, & "XTB/SCC_MIXER is reset to NONE with QS/LS_SCF; LS_SCF optimizes "// & "the density matrix directly.") - END IF - IF (xtb_tblite_mixer_explicit) THEN + IF (xtb_tblite_mixer_explicit) & CALL cp_warn(__LOCATION__, & "XTB/TBLITE_MIXER settings are ignored with QS/LS_SCF; LS_SCF controls "// & "the density-matrix optimization.") - END IF qs_control%xtb_control%tblite_scc_mixer = tblite_scc_mixer_none END IF - IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) THEN + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & CPABORT("XTB/TBLITE_MIXER/DAMPING must be positive") - END IF CALL section_vals_val_get(xtb_section, "DO_EWALD", explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(xtb_section, "DO_EWALD", & @@ -1891,17 +1855,14 @@ CONTAINS c_val=qs_control%xtb_control%tblite_param_file) CALL section_vals_val_get(xtb_tblite, "ACCURACY", & r_val=qs_control%xtb_control%tblite_accuracy) - IF (qs_control%xtb_control%tblite_accuracy <= 0.0_dp) THEN + IF (qs_control%xtb_control%tblite_accuracy <= 0.0_dp) & CPABORT("XTB/TBLITE/ACCURACY must be positive") - END IF - IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) THEN + IF (qs_control%xtb_control%tblite_mixer_damping <= 0.0_dp) & CPABORT("XTB/TBLITE_MIXER/DAMPING must be positive") - END IF CALL section_vals_val_get(xtb_tblite, "REFERENCE_CLI", l_val=tblite_reference_cli) CALL section_vals_get(xtb_tblite_ref_cli, explicit=tblite_reference_cli_section) - IF (tblite_reference_cli .AND. (.NOT. tblite_reference_cli_section)) THEN + IF (tblite_reference_cli .AND. (.NOT. tblite_reference_cli_section)) & CPABORT("XTB/TBLITE/REFERENCE_CLI keyword requires an XTB/TBLITE/REFERENCE_CLI section") - END IF IF (tblite_reference_cli .OR. tblite_reference_cli_section) THEN CALL read_xtb_reference_cli_section(xtb_tblite_ref_cli, qs_control%xtb_control%reference_cli, cell) qs_control%xtb_control%reference_cli%enabled = .TRUE. @@ -1965,9 +1926,8 @@ CONTAINS IF (omega0 <= 0.0_dp) CPABORT(TRIM(section_name)//"/OMEGA0 must be positive") IF (min_weight <= 0.0_dp) CPABORT(TRIM(section_name)//"/MIN_WEIGHT must be positive") IF (max_weight <= 0.0_dp) CPABORT(TRIM(section_name)//"/MAX_WEIGHT must be positive") - IF (max_weight < min_weight) THEN + IF (max_weight < min_weight) & CPABORT(TRIM(section_name)//"/MAX_WEIGHT must not be smaller than MIN_WEIGHT") - END IF IF (weight_factor <= 0.0_dp) CPABORT(TRIM(section_name)//"/WEIGHT_FACTOR must be positive") END SUBROUTINE read_tblite_mixer_section @@ -2016,13 +1976,11 @@ CONTAINS CALL section_vals_val_get(solvation_section, "SOLVENT", c_val=ref_cli%solvation_solvent) CALL section_vals_val_get(solvation_section, "BORN_KERNEL", i_val=ref_cli%solvation_born_kernel) CALL section_vals_val_get(solvation_section, "SOLUTION_STATE", i_val=ref_cli%solvation_state) - IF (LEN_TRIM(ref_cli%solvation_solvent) == 0) THEN + IF (LEN_TRIM(ref_cli%solvation_solvent) == 0) & CPABORT("REFERENCE_CLI implicit solvation needs SOLVENT") - END IF IF (ref_cli%solvation_model == tblite_cli_solvation_cpcm .AND. & - ref_cli%solvation_born_kernel /= tblite_cli_born_kernel_auto) THEN + ref_cli%solvation_born_kernel /= tblite_cli_born_kernel_auto) & CPABORT("BORN_KERNEL is invalid with MODEL CPCM") - END IF IF (ref_cli%solvation_state /= tblite_cli_solution_state_gsolv) THEN SELECT CASE (ref_cli%solvation_model) CASE (tblite_cli_solvation_alpb, tblite_cli_solvation_gbsa) @@ -2034,21 +1992,18 @@ CONTAINS END IF CALL section_vals_val_get(ref_cli_section, "ELECTRONIC_TEMPERATURE_GUESS", & r_val=ref_cli%electronic_temperature_guess) - IF (ref_cli%electronic_temperature_guess < 0.0_dp) THEN + IF (ref_cli%electronic_temperature_guess < 0.0_dp) & CPABORT("XTB/TBLITE/REFERENCE_CLI/ELECTRONIC_TEMPERATURE_GUESS must not be negative") - END IF - IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) THEN + IF (ref_cli%electronic_temperature_guess > 0.0_dp .AND. ref_cli%guess /= tblite_guess_ceh) & CPABORT("XTB/TBLITE/REFERENCE_CLI/ELECTRONIC_TEMPERATURE_GUESS requires GUESS CEH") - END IF guess_section => section_vals_get_subs_vals(ref_cli_section, "GUESS_CLI") CALL section_vals_get(guess_section, explicit=ref_cli%guess_cli%enabled) IF (ref_cli%guess_cli%enabled) THEN CALL section_vals_val_get(guess_section, "METHOD", i_val=ref_cli%guess_cli%method) CALL section_vals_val_get(guess_section, "ELECTRONIC_TEMPERATURE_GUESS", & r_val=ref_cli%guess_cli%electronic_temperature_guess) - IF (ref_cli%guess_cli%electronic_temperature_guess < 0.0_dp) THEN + IF (ref_cli%guess_cli%electronic_temperature_guess < 0.0_dp) & CPABORT("REFERENCE_CLI/GUESS_CLI/ELECTRONIC_TEMPERATURE_GUESS must not be negative") - END IF CALL section_vals_val_get(guess_section, "SOLVER", i_val=ref_cli%guess_cli%solver) CALL section_vals_val_get(guess_section, "EFIELD", explicit=ref_cli%guess_cli%efield_active) IF (ref_cli%guess_cli%efield_active) THEN @@ -2079,12 +2034,10 @@ CONTAINS CALL section_vals_val_get(fit_section, "INPUT_FILE", c_val=ref_cli%fit_cli%input_file) CALL section_vals_val_get(fit_section, "DRY_RUN", l_val=ref_cli%fit_cli%dry_run) CALL section_vals_val_get(fit_section, "COPY", c_val=ref_cli%fit_cli%copy_file) - IF (LEN_TRIM(ref_cli%fit_cli%param_file) == 0) THEN + IF (LEN_TRIM(ref_cli%fit_cli%param_file) == 0) & CPABORT("XTB/TBLITE/REFERENCE_CLI/FIT_CLI needs PARAM_FILE") - END IF - IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) THEN + IF (LEN_TRIM(ref_cli%fit_cli%input_file) == 0) & CPABORT("XTB/TBLITE/REFERENCE_CLI/FIT_CLI needs INPUT_FILE") - END IF END IF tagdiff_section => section_vals_get_subs_vals(ref_cli_section, "TAGDIFF_CLI") CALL section_vals_get(tagdiff_section, explicit=ref_cli%tagdiff_cli%enabled) @@ -2092,12 +2045,10 @@ CONTAINS CALL section_vals_val_get(tagdiff_section, "ACTUAL", c_val=ref_cli%tagdiff_cli%actual_file) CALL section_vals_val_get(tagdiff_section, "REFERENCE", c_val=ref_cli%tagdiff_cli%reference_file) CALL section_vals_val_get(tagdiff_section, "FIT", l_val=ref_cli%tagdiff_cli%fit) - IF (LEN_TRIM(ref_cli%tagdiff_cli%actual_file) == 0) THEN + IF (LEN_TRIM(ref_cli%tagdiff_cli%actual_file) == 0) & CPABORT("XTB/TBLITE/REFERENCE_CLI/TAGDIFF_CLI needs ACTUAL") - END IF - IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) THEN + IF (LEN_TRIM(ref_cli%tagdiff_cli%reference_file) == 0) & CPABORT("XTB/TBLITE/REFERENCE_CLI/TAGDIFF_CLI needs REFERENCE") - END IF END IF CALL section_vals_val_get(ref_cli_section, "KEEP_FILES", l_val=ref_cli%keep_files) CALL section_vals_val_get(ref_cli_section, "ERROR_LIMIT", r_val=ref_cli%error_limit) @@ -2171,18 +2122,7 @@ CONTAINS CALL uppercase(tmpstringlist(2)) SELECT CASE (tmpstringlist(2)) CASE ("X") - SELECT CASE (tmpstringlist(1)) - CASE ("X") - ! Do nothing - CASE DEFAULT - CALL cp_abort(__LOCATION__, & - "AUTO_BASIS: the size is invalid for the "// & - "type <"//TRIM(ADJUSTL(tmpstringlist(1)))//">; "// & - "use one of SMALL, MEDIUM, LARGE, HUGE for "// & - "the size. The syntax AUTO_BASIS X X is a "// & - "reserved case for using NO automatically "// & - "generated basis sets.") - END SELECT + isize = -1 CASE ("SMALL") isize = 0 CASE ("MEDIUM") @@ -2208,9 +2148,8 @@ CONTAINS END IF END DO - IF (t_control%conv < 0) THEN + IF (t_control%conv < 0) & t_control%conv = ABS(t_control%conv) - END IF ! DIPOLE_MOMENTS subsection dipole_section => section_vals_get_subs_vals(t_section, "DIPOLE_MOMENTS") @@ -2252,10 +2191,9 @@ CONTAINS CALL section_vals_val_get(mgrid_section, "PROGRESSION_FACTOR", & r_val=t_control%mgrid_progression_factor, explicit=explicit) IF (explicit) THEN - IF (t_control%mgrid_progression_factor <= 1.0_dp) THEN + IF (t_control%mgrid_progression_factor <= 1.0_dp) & CALL cp_abort(__LOCATION__, & "Progression factor should be greater then 1.0 to ensure multi-grid ordering") - END IF ELSE t_control%mgrid_progression_factor = qs_control%progression_factor END IF @@ -2289,9 +2227,8 @@ CONTAINS IF (.NOT. explicit) t_control%mgrid_skip_load_balance = qs_control%skip_load_balance_distributed IF (ASSOCIATED(t_control%mgrid_e_cutoff)) THEN - IF (SIZE(t_control%mgrid_e_cutoff) /= t_control%mgrid_ngrids) THEN + IF (SIZE(t_control%mgrid_e_cutoff) /= t_control%mgrid_ngrids) & CPABORT("Inconsistent values for number of multi-grids") - END IF ! sort multi-grids in descending order according to their cutoff values t_control%mgrid_e_cutoff = -t_control%mgrid_e_cutoff @@ -2306,9 +2243,8 @@ CONTAINS xc_section => section_vals_get_subs_vals(t_section, "XC") xc_func => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL") CALL section_vals_get(xc_func, explicit=explicit) - IF (explicit) THEN + IF (explicit) & CALL xc_functionals_expand(xc_func, xc_section) - END IF ! sTDA subsection stda_section => section_vals_get_subs_vals(t_section, "STDA") @@ -2528,7 +2464,8 @@ CONTAINS dft_control%period_efield%strength END IF - IF (NORM2(dft_control%period_efield%polarisation) < EPSILON(0.0_dp)) THEN + IF (SQRT(DOT_PRODUCT(dft_control%period_efield%polarisation, & + dft_control%period_efield%polarisation)) < EPSILON(0.0_dp)) THEN CPABORT("Invalid (too small) polarisation vector specified for PERIODIC_EFIELD") END IF END IF @@ -2937,9 +2874,8 @@ CONTAINS ELSE WRITE (UNIT=output_unit, FMT="(T2,A,T71,F10.1)") & "QS| Density cutoff [a.u.]:", qs_control%cutoff - IF (qs_control%commensurate_mgrids) THEN + IF (qs_control%commensurate_mgrids) & WRITE (UNIT=output_unit, FMT="(T2,A)") "QS| Using commensurate multigrids" - END IF WRITE (UNIT=output_unit, FMT="(T2,A,T71,F10.1)") & "QS| Multi grid cutoff [a.u.]: 1) grid level", qs_control%e_cutoff(1) WRITE (UNIT=output_unit, FMT="(T2,A,I3,A,T71,F10.1)") & @@ -3069,10 +3005,9 @@ CONTAINS IF (qs_control%ddapc_restraint) THEN DO i = 1, SIZE(qs_control%ddapc_restraint_control) ddapc_restraint_control => qs_control%ddapc_restraint_control(i) - IF (SIZE(qs_control%ddapc_restraint_control) > 1) THEN + IF (SIZE(qs_control%ddapc_restraint_control) > 1) & WRITE (UNIT=output_unit, FMT="(T2,A,T3,I8)") & - "QS| parameters for DDAPC restraint number", i - END IF + "QS| parameters for DDAPC restraint number", i WRITE (UNIT=output_unit, FMT="(T2,A,T73,ES8.1)") & "QS| ddapc restraint target", ddapc_restraint_control%target WRITE (UNIT=output_unit, FMT="(T2,A,T73,ES8.1)") & @@ -3143,9 +3078,8 @@ CONTAINS IF (PRESENT(ddapc_restraint_section)) THEN IF (ASSOCIATED(qs_control%ddapc_restraint_control)) THEN - IF (SIZE(qs_control%ddapc_restraint_control) >= 2) THEN + IF (SIZE(qs_control%ddapc_restraint_control) >= 2) & CPABORT("ET_COUPLING cannot be used in combination with a normal restraint") - END IF ELSE ddapc_section => ddapc_restraint_section ALLOCATE (qs_control%ddapc_restraint_control(1)) @@ -3184,9 +3118,8 @@ CONTAINS END DO IF (jj < 1) CPABORT("Need at least 1 atom to use ddapc constraints") ddapc_restraint_control%natoms = jj - IF (ASSOCIATED(ddapc_restraint_control%atoms)) THEN + IF (ASSOCIATED(ddapc_restraint_control%atoms)) & DEALLOCATE (ddapc_restraint_control%atoms) - END IF ALLOCATE (ddapc_restraint_control%atoms(ddapc_restraint_control%natoms)) jj = 0 DO k = 1, n_rep @@ -3198,9 +3131,8 @@ CONTAINS END DO END DO - IF (ASSOCIATED(ddapc_restraint_control%coeff)) THEN + IF (ASSOCIATED(ddapc_restraint_control%coeff)) & DEALLOCATE (ddapc_restraint_control%coeff) - END IF ALLOCATE (ddapc_restraint_control%coeff(ddapc_restraint_control%natoms)) ddapc_restraint_control%coeff = 1.0_dp @@ -3212,15 +3144,13 @@ CONTAINS i_rep_val=k, r_vals=rtmplist) DO j = 1, SIZE(rtmplist) jj = jj + 1 - IF (jj > ddapc_restraint_control%natoms) THEN + IF (jj > ddapc_restraint_control%natoms) & CPABORT("Need the same number of coeff as there are atoms ") - END IF ddapc_restraint_control%coeff(jj) = rtmplist(j) END DO END DO - IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) THEN + IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) & CPABORT("Need no or the same number of coeff as there are atoms.") - END IF END DO k = 0 DO i = 1, SIZE(qs_control%ddapc_restraint_control) @@ -3409,13 +3339,12 @@ CONTAINS proj_mo_section => section_vals_get_subs_vals(rtp_section, "PRINT%PROJECTION_MO") CALL section_vals_get(proj_mo_section, explicit=is_present) IF (is_present) THEN - IF (dft_control%rtp_control%linear_scaling) THEN + IF (dft_control%rtp_control%linear_scaling) & CALL cp_abort(__LOCATION__, & "You have defined a time dependent projection of mos, but "// & "only the density matrix is propagated (DENSITY_PROPAGATION "// & ".TRUE.). Please either use MO-based real time DFT or do not "// & "define any PRINT%PROJECTION_MO section") - END IF dft_control%rtp_control%is_proj_mo = .TRUE. ELSE dft_control%rtp_control%is_proj_mo = .FALSE. @@ -3500,9 +3429,8 @@ CONTAINS DO i = 1, n_elems DO j = 1, 2 IF (dft_control%rtp_control%print_pol_elements(i, j) > 3 .OR. & - dft_control%rtp_control%print_pol_elements(i, j) < 1) THEN + dft_control%rtp_control%print_pol_elements(i, j) < 1) & CPABORT("Polarisation tensor element not 1,2 or 3 in at least one index") - END IF END DO END DO END IF @@ -3625,9 +3553,8 @@ CONTAINS END DO dft_control%probe(i)%natoms = jj - IF (dft_control%probe(i)%natoms < 1) THEN + IF (dft_control%probe(i)%natoms < 1) & CPABORT("Need at least 1 atom to use hair probes formalism") - END IF ALLOCATE (dft_control%probe(i)%atom_ids(dft_control%probe(i)%natoms)) jj = 0 diff --git a/src/cp_dbcsr_cholesky.F b/src/cp_dbcsr_cholesky.F index 8fdcc256cc..5ba00f221a 100644 --- a/src/cp_dbcsr_cholesky.F +++ b/src/cp_dbcsr_cholesky.F @@ -214,9 +214,8 @@ CONTAINS CALL copy_dbcsr_to_fm(matrixb, fm_matrixb) !CALL copy_dbcsr_to_fm(matrixout, fm_matrixout) - IF (op /= "SOLVE" .AND. op /= "MULTIPLY") THEN + IF (op /= "SOLVE" .AND. op /= "MULTIPLY") & CPABORT("wrong argument op") - END IF IF (PRESENT(pos)) THEN SELECT CASE (pos) diff --git a/src/cp_dbcsr_operations.F b/src/cp_dbcsr_operations.F index bb6ba62a78..46f66297ec 100644 --- a/src/cp_dbcsr_operations.F +++ b/src/cp_dbcsr_operations.F @@ -611,9 +611,8 @@ CONTAINS row_blk_size, col_blk_size_right_out) CALL copy_fm_to_dbcsr(fm_in, in) - IF (ncol /= k_out .OR. my_beta /= 0.0_dp) THEN + IF (ncol /= k_out .OR. my_beta /= 0.0_dp) & CALL copy_fm_to_dbcsr(fm_out, out) - END IF CALL timeset(routineN//'_core', timing_handle_mult) CALL dbcsr_multiply("N", "N", my_alpha, matrix, in, my_beta, out, & @@ -649,9 +648,8 @@ CONTAINS n1 = SIZE(sizes1) n2 = SIZE(sizes2) - IF (n1 /= n2) THEN + IF (n1 /= n2) & CPABORT("distributions must be equal!") - END IF sizes1(1:n1) = sizes2(1:n1) used = SUM(sizes1(1:n1)) ! If sizes1 does not cover everything, then we increase the @@ -725,9 +723,8 @@ CONTAINS NULLIFY (col_dist_left) IF (ncol > 0) THEN - IF (.NOT. dbcsr_valid_index(sparse_matrix)) THEN + IF (.NOT. dbcsr_valid_index(sparse_matrix)) & CPABORT("sparse_matrix must pre-exist") - END IF ! ! Setup matrix_v CALL cp_fm_get_info(matrix_v, ncol_global=k) @@ -833,6 +830,25 @@ CONTAINS WRITE (*, *) 'PRESENT (matrix_g)', PRESENT(matrix_g) WRITE (*, *) 'matrix_type=', dbcsr_get_matrix_type(sparse_matrix) WRITE (*, *) 'norm(sm+alpha*v*g^t - fm+alpha*v*g^t)/n=', norm/REAL(nao, dp) + IF (norm/REAL(nao, dp) > 1e-12_dp) THEN + !WRITE(*,*) 'fm_matrix' + !DO j=1,SIZE(fm_matrix%local_data,2) + ! DO i=1,SIZE(fm_matrix%local_data,1) + ! WRITE(*,'(A,I3,A,I3,A,E26.16,A)') 'a(',i,',',j,')=',fm_matrix%local_data(i,j),';' + ! ENDDO + !ENDDO + !WRITE(*,*) 'mat_v' + !CALL dbcsr_print(mat_v) + !WRITE(*,*) 'mat_g' + !CALL dbcsr_print(mat_g) + !WRITE(*,*) 'sparse_matrix' + !CALL dbcsr_print(sparse_matrix) + !WRITE(*,*) 'sparse_matrix2 (-sm + sparse(fm))' + !CALL dbcsr_print(sparse_matrix2) + !WRITE(*,*) 'sparse_matrix3 (copy of sm input)' + !CALL dbcsr_print(sparse_matrix3) + !stop + END IF CALL dbcsr_release(sparse_matrix2) CALL dbcsr_release(sparse_matrix3) CALL cp_fm_release(fm_matrix) @@ -1009,13 +1025,11 @@ CONTAINS estimated_blocks = max_blocks_per_bin*nbins ALLOCATE (blk_dist(estimated_blocks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_dist") - END IF ALLOCATE (blk_sizes(estimated_blocks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_sizes") - END IF element_stack = 0 nblks = 0 DO blk_layer = 1, max_blocks_per_bin @@ -1037,27 +1051,23 @@ CONTAINS block_size => blk_sizes ELSE ALLOCATE (block_distribution(nblks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_dist") - END IF block_distribution(:) = blk_dist(1:nblks) DEALLOCATE (blk_dist) ALLOCATE (block_size(nblks), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_sizes") - END IF block_size(:) = blk_sizes(1:nblks) DEALLOCATE (blk_sizes) END IF ELSE ALLOCATE (block_distribution(0), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_dist") - END IF ALLOCATE (block_size(0), stat=stat) - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("blk_sizes") - END IF END IF 1579 FORMAT(I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5) IF (debug_mod) THEN diff --git a/src/cp_ddapc_forces.F b/src/cp_ddapc_forces.F index 7c30a8d718..979571da7f 100644 --- a/src/cp_ddapc_forces.F +++ b/src/cp_ddapc_forces.F @@ -217,7 +217,7 @@ CONTAINS END IF IF (iparticle1 /= iparticle2) THEN ra = rvec - r = NORM2(ra) + r = SQRT(DOT_PRODUCT(ra, ra)) t2 = -1.0_dp/(r*r)*factor drvec = ra/r*q1t*q2t d_el(1:3, iparticle1) = d_el(1:3, iparticle1) + t2*drvec diff --git a/src/cp_ddapc_methods.F b/src/cp_ddapc_methods.F index c8630ca686..5265a249ed 100644 --- a/src/cp_ddapc_methods.F +++ b/src/cp_ddapc_methods.F @@ -204,7 +204,7 @@ CONTAINS iparticle2, istart_g, s_dim REAL(KIND=dp) :: g2, gcut2, tmp REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: my_Am, my_Amw - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: gfunc_sq(:, :, :) !NB precalculate as many things outside of the innermost loop as possible, in particular w(ig)*gfunc(ig,igauus1)*gfunc(ig,igauss2) @@ -766,7 +766,7 @@ CONTAINS ! IF (iparticle1 /= iparticle2) THEN ra = rvec - r = NORM2(ra) + r = SQRT(DOT_PRODUCT(ra, ra)) my_val = factor/r END IF EwM(idim) = my_val - factor*g_ewald diff --git a/src/cp_ddapc_util.F b/src/cp_ddapc_util.F index d9ff69876d..7fe0888cdc 100644 --- a/src/cp_ddapc_util.F +++ b/src/cp_ddapc_util.F @@ -355,8 +355,7 @@ CONTAINS bv(:) = 0.0_dp cv(:) = 1.0_dp/Vol CALL build_b_vector(bv, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut) - bv(:) = bv(:)/Vol + particle_set, radii, rho_tot_g, gcut); bv(:) = bv(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv) c1 = DOT_PRODUCT(cv, MATMUL(cp_ddapc_env%AmI, bv)) - ch_dens c1 = c1/cp_ddapc_env%c0 @@ -719,13 +718,11 @@ CONTAINS bv2(:) = 0.0_dp particle_set(iparticle)%r(i) = rvec(i) + dx CALL build_b_vector(bv1, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut) - bv1(:) = bv1(:)/Vol + particle_set, radii, rho_tot_g, gcut); bv1(:) = bv1(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv1) particle_set(iparticle)%r(i) = rvec(i) - dx CALL build_b_vector(bv2, cp_ddapc_env%gfunc, cp_ddapc_env%w, & - particle_set, radii, rho_tot_g, gcut) - bv2(:) = bv2(:)/Vol + particle_set, radii, rho_tot_g, gcut); bv2(:) = bv2(:)/Vol CALL rho_tot_g%pw_grid%para%group%sum(bv2) ddbv(:) = (bv1(:) - bv2(:))/(2.0_dp*dx) DO kk = 1, SIZE(ddbv) diff --git a/src/cp_eri_mme_interface.F b/src/cp_eri_mme_interface.F index d7e45fb6dc..b94212c6d3 100644 --- a/src/cp_eri_mme_interface.F +++ b/src/cp_eri_mme_interface.F @@ -563,9 +563,8 @@ CONTAINS WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Cutoff error:", param%par%err_c WRITE (unit_nr, '(T2, A, T72, ES9.2)') "ERI_MME| Total error (minimax + cutoff):", param%par%err_mm + param%par%err_c END IF - IF (param%par%print_calib) THEN + IF (param%par%print_calib) & WRITE (unit_nr, '(T2, A, T68, F13.10)') "ERI_MME| Minimax scaling constant in AM-GM estimate:", param%par%C_mm - END IF END IF END IF @@ -787,9 +786,8 @@ CONTAINS CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL", i_val=potential) CALL section_vals_val_get(eri_mme_test_section, "POTENTIAL_PARAM", r_val=pot_par) - IF (nzet <= 0) THEN + IF (nzet <= 0) & CPABORT("Number of exponents NZET must be greater than 0.") - END IF CALL init_orbital_pointers(l_max) diff --git a/src/cp_external_control.F b/src/cp_external_control.F index 3ae0189fef..4b32395cde 100644 --- a/src/cp_external_control.F +++ b/src/cp_external_control.F @@ -63,9 +63,8 @@ CONTAINS external_comm = comm external_master_id = in_external_master_id - IF (PRESENT(in_scf_energy_message_tag)) THEN + IF (PRESENT(in_scf_energy_message_tag)) & scf_energy_message_tag = in_scf_energy_message_tag - END IF IF (PRESENT(in_exit_tag)) THEN ! the exit tag should be different from the mpi_probe tag default CPASSERT(in_exit_tag /= -1) @@ -204,7 +203,7 @@ CONTAINS IF (PRESENT(target_time)) THEN my_target_time = target_time my_start_time = start_time - ELSE IF (PRESENT(globenv)) THEN + ELSEIF (PRESENT(globenv)) THEN my_target_time = globenv%cp2k_target_time my_start_time = globenv%cp2k_start_time ELSE diff --git a/src/cp_subsys_methods.F b/src/cp_subsys_methods.F index 73ce1a9e0a..e85b894a4c 100644 --- a/src/cp_subsys_methods.F +++ b/src/cp_subsys_methods.F @@ -128,19 +128,16 @@ CONTAINS subsys%para_env => para_env my_use_motion_section = .FALSE. - IF (PRESENT(use_motion_section)) THEN + IF (PRESENT(use_motion_section)) & my_use_motion_section = use_motion_section - END IF my_force_env_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL") - IF (PRESENT(force_env_section)) THEN + IF (PRESENT(force_env_section)) & my_force_env_section => force_env_section - END IF my_subsys_section => section_vals_get_subs_vals(my_force_env_section, "SUBSYS") - IF (PRESENT(subsys_section)) THEN + IF (PRESENT(subsys_section)) & my_subsys_section => subsys_section - END IF CALL section_vals_val_get(my_subsys_section, "SEED", i_vals=seed_vals) IF (SIZE(seed_vals) == 1) THEN @@ -291,9 +288,8 @@ CONTAINS CPASSERT(.NOT. ASSOCIATED(small_subsys)) CPASSERT(ASSOCIATED(big_subsys)) - IF (big_subsys%para_env /= small_para_env) THEN + IF (big_subsys%para_env /= small_para_env) & CPABORT("big_subsys%para_env==small_para_env") - END IF !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- diff --git a/src/cryssym.F b/src/cryssym.F index 5f8c7e52e5..4c28f5b550 100644 --- a/src/cryssym.F +++ b/src/cryssym.F @@ -1755,7 +1755,7 @@ CONTAINS csym%kplink(1, j) = i wkp(i) = wkp(i) + 1.0_dp kpop(j) = kr - ELSE IF (csym%kplink(1, j) /= i) THEN + ELSEIF (csym%kplink(1, j) /= i) THEN ! Approximate K290 operation sets need not be closed for structures whose ! coordinates lie close to several symmetry tolerances. Keep the existing ! disjoint orbit instead of aborting or double-counting this mesh point. diff --git a/src/csvr_system_types.F b/src/csvr_system_types.F index 4095fc67c4..e4e349bce2 100644 --- a/src/csvr_system_types.F +++ b/src/csvr_system_types.F @@ -148,9 +148,8 @@ CONTAINS SUBROUTINE csvr_thermo_dealloc(nvt) TYPE(csvr_thermo_type), DIMENSION(:), POINTER :: nvt - IF (ASSOCIATED(nvt)) THEN + IF (ASSOCIATED(nvt)) & DEALLOCATE (nvt) - END IF END SUBROUTINE csvr_thermo_dealloc END MODULE csvr_system_types diff --git a/src/ct_methods.F b/src/ct_methods.F index 22bc2f77a4..2aa855445a 100644 --- a/src/ct_methods.F +++ b/src/ct_methods.F @@ -39,7 +39,6 @@ MODULE ct_methods USE iterate_matrix, ONLY: matrix_sqrt_Newton_Schulz USE kinds, ONLY: dp USE machine, ONLY: m_walltime - USE mathconstants, ONLY: pi #include "./base/base_uses.f90" IMPLICIT NONE @@ -1379,12 +1378,14 @@ CONTAINS INTEGER, INTENT(OUT) :: nmins INTEGER :: i, nroots - REAL(KIND=dp) :: DD, der, p, phi, q, temp1, temp2, u, v, & - y1, y2, y2i, y2r, y3 + REAL(KIND=dp) :: DD, der, p, phi, pi, q, temp1, temp2, u, & + v, y1, y2, y2i, y2r, y3 REAL(KIND=dp), DIMENSION(3) :: x ! CALL timeset(routineN,handle) + pi = ACOS(-1.0_dp) + ! Step 0: Check coefficients and find the true order of the eq IF (a == 0.0_dp) THEN IF (b == 0.0_dp) THEN @@ -1519,9 +1520,8 @@ CONTAINS ! create a matrix for eigenvectors CALL dbcsr_work_create(c, work_mutable=.TRUE.) - IF (do_eigenvalues) THEN + IF (do_eigenvalues) & CALL dbcsr_work_create(e, work_mutable=.TRUE.) - END IF CALL dbcsr_iterator_readonly_start(iter, matrix) diff --git a/src/ct_types.F b/src/ct_types.F index 120685b60b..2d93d0acc8 100644 --- a/src/ct_types.F +++ b/src/ct_types.F @@ -66,6 +66,31 @@ MODULE ct_types REAL(KIND=dp) :: energy_correction = 0.0_dp +!SPIN!!! ! metric matrices for covariant to contravariant transformations +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_up=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: p_index_down=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_up=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: q_index_down=>NULL() +!SPIN!!! +!SPIN!!! ! kohn-sham, covariant-covariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_ks=>NULL() +!SPIN!!! ! density, contravariant-contravariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_p=>NULL() +!SPIN!!! ! occ orbitals, contravariant-covariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_t=>NULL() +!SPIN!!! ! virt orbitals, contravariant-covariant representation +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_v=>NULL() +!SPIN!!! +!SPIN!!! ! to avoid building Occ-by-N and Virt-vy-N matrices inside +!SPIN!!! ! the ct routines get them from the external code +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_qp_template=>NULL() +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER :: matrix_pq_template=>NULL() +!SPIN!!! +!SPIN!!! ! single excitation amplitudes +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_x +!SPIN!!! ! residuals +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), ALLOCATABLE :: matrix_res + ! metric matrices for covariant to contravariant transformations TYPE(dbcsr_type), POINTER :: p_index_up => NULL() TYPE(dbcsr_type), POINTER :: p_index_down => NULL() @@ -129,6 +154,7 @@ CONTAINS env%order_lanczos = 3 env%eps_lancsoz = 1.0E-4_dp env%max_iter_lanczos = 40 + !env%nspins = -1 env%converged = .FALSE. env%conjugator = cg_polak_ribiere @@ -205,6 +231,22 @@ CONTAINS qq_preconditioner_full, & pp_preconditioner_full +!INTEGER , OPTIONAL :: nspins +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_up +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: p_index_down +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_up +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: q_index_down +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_ks +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_p +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_t +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_v +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_qp_template +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_pq_template +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), POINTER, OPTIONAL :: matrix_x +!SPIN!!! +!SPIN!!! TYPE(dbcsr_type), DIMENSION(:), OPTIONAL :: copy_matrix_x +!INTEGER :: ispin + IF (PRESENT(use_occ_orbs)) use_occ_orbs = env%use_occ_orbs IF (PRESENT(use_virt_orbs)) use_virt_orbs = env%use_virt_orbs IF (PRESENT(occ_orbs_orthogonal)) occ_orbs_orthogonal = & @@ -225,6 +267,7 @@ CONTAINS IF (PRESENT(eps_convergence)) eps_convergence = env%eps_convergence IF (PRESENT(eps_filter)) eps_filter = env%eps_filter IF (PRESENT(max_iter)) max_iter = env%max_iter + !IF (PRESENT(nspins)) nspins = env%nspins IF (PRESENT(matrix_ks)) matrix_ks => env%matrix_ks IF (PRESENT(matrix_p)) matrix_p => env%matrix_p IF (PRESENT(matrix_t)) matrix_t => env%matrix_t @@ -238,8 +281,12 @@ CONTAINS IF (PRESENT(p_index_down)) p_index_down => env%p_index_down IF (PRESENT(q_index_down)) q_index_down => env%q_index_down IF (PRESENT(copy_matrix_x)) THEN + !DO ispin=1,env%nspins + !CALL dbcsr_copy(copy_matrix_x(ispin),env%matrix_x(ispin)) CALL dbcsr_copy(copy_matrix_x, env%matrix_x) + !ENDDO END IF + !IF (PRESENT(matrix_x)) matrix_x => env%matrix_x IF (PRESENT(energy_correction)) energy_correction = env%energy_correction IF (PRESENT(converged)) converged = env%converged @@ -305,6 +352,20 @@ CONTAINS LOGICAL, OPTIONAL :: qq_preconditioner_full, & pp_preconditioner_full +!INTEGER , OPTIONAL :: nspins +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_up +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: p_index_down +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_up +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: q_index_down +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_ks +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_p +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_t +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_v +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_qp_template +!SPIN!!! TYPE(dbcsr_type), TARGET, DIMENSION(:), OPTIONAL :: matrix_pq_template +! set para_env and blacs_env which are needed to operate with full matrices +! it would be nice to have everything with cp_dbcsr matrices, well maybe later + env%para_env => para_env env%blacs_env => blacs_env @@ -328,6 +389,7 @@ CONTAINS IF (PRESENT(eps_convergence)) env%eps_convergence = eps_convergence IF (PRESENT(eps_filter)) env%eps_filter = eps_filter IF (PRESENT(max_iter)) env%max_iter = max_iter + !IF (PRESENT(nspins)) env%nspins = nspins IF (PRESENT(conjugator)) env%conjugator = conjugator IF (PRESENT(matrix_ks)) env%matrix_ks => matrix_ks IF (PRESENT(matrix_p)) env%matrix_p => matrix_p @@ -353,12 +415,18 @@ CONTAINS TYPE(ct_step_env_type) :: env +!INTEGER :: ispin + NULLIFY (env%para_env) NULLIFY (env%blacs_env) !DO ispin=1,env%nspins CALL dbcsr_release(env%matrix_x) CALL dbcsr_release(env%matrix_res) + !CALL dbcsr_release(env%matrix_x(ispin)) + !CALL dbcsr_release(env%matrix_res(ispin)) + !ENDDO + !DEALLOCATE(env%matrix_x,env%matrix_res) NULLIFY (env%p_index_up) NULLIFY (env%p_index_down) diff --git a/src/dbm/dbm_api.F b/src/dbm/dbm_api.F index af1f6bc705..7cb521797f 100644 --- a/src/dbm/dbm_api.F +++ b/src/dbm/dbm_api.F @@ -182,9 +182,8 @@ CONTAINS num_blocks_diff = ABS(num_blocks - num_blocks_dbcsr) IF (num_blocks_diff /= 0) THEN WRITE (*, *) "num_blocks mismatch dbcsr:", num_blocks_dbcsr, "new:", num_blocks - IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN + IF (DBM_VALIDATE_NBLOCKS_MATCH) & CPABORT("num_blocks mismatch") - END IF END IF IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN diff --git a/src/dbm/dbm_tests.F b/src/dbm/dbm_tests.F index ee10d2ee4d..ed7e5efcd3 100644 --- a/src/dbm/dbm_tests.F +++ b/src/dbm/dbm_tests.F @@ -439,7 +439,7 @@ CONTAINS INTEGER(KIND=int_8) :: map map = ((irow - 1 + icol*INT(nrow, int_8))*(1 + MODULO(ival, 2**16)))*2 + 1 + 0*ncol ! ncol used - iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12 ! keep odd + iseed(4) = INT(MODULO(map, 2_int_8**12)); map = map/2_int_8**12; ! keep odd iseed(3) = INT(MODULO(IEOR(map, 3541_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(2) = INT(MODULO(IEOR(map, 1153_int_8), 2_int_8**12)); map = map/2_int_8**12 iseed(1) = INT(MODULO(IEOR(map, 2029_int_8), 2_int_8**12)); map = map/2_int_8**12 diff --git a/src/dbt/dbt_allocate_wrap.F b/src/dbt/dbt_allocate_wrap.F index 19e02c8664..a4e10a477b 100644 --- a/src/dbt/dbt_allocate_wrap.F +++ b/src/dbt/dbt_allocate_wrap.F @@ -56,7 +56,7 @@ CONTAINS ELSE shape_prv = shape_spec END IF - ELSE IF (PRESENT(source)) THEN + ELSEIF (PRESENT(source)) THEN IF (PRESENT(order)) THEN shape_prv(order) = SHAPE(source) ELSE diff --git a/src/dbt/dbt_array_list_methods.F b/src/dbt/dbt_array_list_methods.F index 8b24135672..e607940865 100644 --- a/src/dbt/dbt_array_list_methods.F +++ b/src/dbt/dbt_array_list_methods.F @@ -51,7 +51,7 @@ MODULE dbt_array_list_methods TYPE array_list INTEGER, DIMENSION(:), ALLOCATABLE :: col_data INTEGER, DIMENSION(:), ALLOCATABLE :: ptr - END TYPE array_list + END TYPE INTERFACE get_ith_array MODULE PROCEDURE allocate_and_get_ith_array @@ -128,7 +128,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE create_array_list + END SUBROUTINE ! ************************************************************************************************** !> \brief extract a subset of arrays @@ -151,7 +151,7 @@ CONTAINS CALL create_array_list(array_sublist, ndata, ${varlist("data", nmax=dim)}$) END IF #:endfor - END FUNCTION array_sublist + END FUNCTION ! ************************************************************************************************** !> \brief destroy array list. @@ -161,7 +161,7 @@ CONTAINS TYPE(array_list), INTENT(INOUT) :: list DEALLOCATE (list%ptr, list%col_data) - END SUBROUTINE destroy_array_list + END SUBROUTINE ! ************************************************************************************************** !> \brief Get all arrays contained in list @@ -185,7 +185,7 @@ CONTAINS o(1:ndata) = i_selected(:) ELSE ndata = number_of_arrays(list) - o(1:ndata) = [(i, i=1, ndata)] + o(1:ndata) = (/(i, i=1, ndata)/) END IF ASSOCIATE (ptr => list%ptr, col_data => list%col_data) @@ -215,7 +215,7 @@ CONTAINS END ASSOCIATE - END SUBROUTINE get_ith_array + END SUBROUTINE ! ************************************************************************************************** !> \brief get ith array @@ -231,7 +231,7 @@ CONTAINS ALLOCATE (array, source=col_data(ptr(i):ptr(i + 1) - 1)) END ASSOCIATE - END SUBROUTINE allocate_and_get_ith_array + END SUBROUTINE ! ************************************************************************************************** !> \brief sizes of arrays stored in list @@ -288,7 +288,7 @@ CONTAINS partial_sum = partial_sum + list_in%col_data(i_ptr) END DO END DO - END SUBROUTINE array_offsets + END SUBROUTINE ! ************************************************************************************************** !> \brief reorder array list. @@ -309,7 +309,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE reorder_arrays + END SUBROUTINE ! ************************************************************************************************** !> \brief check whether two array lists are equal @@ -320,7 +320,7 @@ CONTAINS LOGICAL :: check_equal check_equal = array_eq_i(list1%col_data, list2%col_data) .AND. array_eq_i(list1%ptr, list2%ptr) - END FUNCTION check_equal + END FUNCTION ! ************************************************************************************************** !> \brief check whether two arrays are equal @@ -337,6 +337,6 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION array_eq_i + END FUNCTION END MODULE dbt_array_list_methods diff --git a/src/dbt/dbt_methods.F b/src/dbt/dbt_methods.F index 13cc921049..1acfd36763 100644 --- a/src/dbt/dbt_methods.F +++ b/src/dbt/dbt_methods.F @@ -231,7 +231,7 @@ CONTAINS IF (.NOT. PRESENT(order)) THEN IF (array_eq_i(map1_in_1, map2_in_1) .AND. array_eq_i(map1_in_2, map2_in_2)) THEN dist_compatible_tas = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) - ELSE IF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN + ELSEIF (array_eq_i([map1_in_1, map1_in_2], [map2_in_1, map2_in_2])) THEN dist_compatible_tensor = check_equal(in_tmp_3%nd_dist, out_tmp_1%nd_dist) END IF END IF @@ -239,7 +239,7 @@ CONTAINS IF (dist_compatible_tas) THEN CALL dbt_tas_copy(out_tmp_1%matrix_rep, in_tmp_3%matrix_rep, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) - ELSE IF (dist_compatible_tensor) THEN + ELSEIF (dist_compatible_tensor) THEN CALL dbt_copy_nocomm(in_tmp_3, out_tmp_1, summation) IF (move_prv) CALL dbt_clear(in_tmp_3) ELSE @@ -1274,7 +1274,7 @@ CONTAINS ALLOCATE (tensor2_out) CALL dbt_remap(tensor2, ind2_linked, ind2_free, tensor2_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata2, move_data=move_data_2) - ELSE IF (compat1 == 2) THEN ! linked index is second 2d dimension + ELSEIF (compat1 == 2) THEN ! linked index is second 2d dimension ! get distribution of linked index, tensor 2 must adopt this distribution ! get grid dimensions of linked index ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) @@ -1315,7 +1315,7 @@ CONTAINS ALLOCATE (tensor1_out) CALL dbt_remap(tensor1, ind1_linked, ind1_free, tensor1_out, comm_2d=dist_in%pgrid%mp_comm_2d, & dist1=dist_list, mp_dims_1=mp_dims, nodata=nodata1, move_data=move_data_1) - ELSE IF (compat2 == 2) THEN + ELSEIF (compat2 == 2) THEN ALLOCATE (mp_dims(ndims_mapping_column(dist_in%pgrid%nd_index_grid))) CALL dbt_get_mapping_info(dist_in%pgrid%nd_index_grid, dims2_2d=mp_dims) ALLOCATE (tensor1_out) @@ -1419,7 +1419,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_in%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN + ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1442,7 +1442,7 @@ CONTAINS IF (compat1 == 1 .AND. compat2 == 2) THEN trans = .FALSE. - ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN + ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN trans = .TRUE. ELSE CPABORT("this should not happen") @@ -1453,7 +1453,7 @@ CONTAINS WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor_out%name), ":" IF (compat1 == 1 .AND. compat2 == 2) THEN WRITE (unit_nr_prv, '(A)') "Normal" - ELSE IF (compat1 == 2 .AND. compat2 == 1) THEN + ELSEIF (compat1 == 2 .AND. compat2 == 1) THEN WRITE (unit_nr_prv, '(A)') "Transposed" ELSE WRITE (unit_nr_prv, '(A)') "Not compatible" @@ -1526,7 +1526,7 @@ CONTAINS compat_map = 0 IF (array_eq_i(map1, compat_ind)) THEN compat_map = 1 - ELSE IF (array_eq_i(map2, compat_ind)) THEN + ELSEIF (array_eq_i(map2, compat_ind)) THEN compat_map = 2 END IF diff --git a/src/dbt/dbt_split.F b/src/dbt/dbt_split.F index e3ac768476..20cd9d4d81 100644 --- a/src/dbt/dbt_split.F +++ b/src/dbt/dbt_split.F @@ -272,7 +272,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE dbt_split_blocks_generic + END SUBROUTINE ! ************************************************************************************************** !> \brief Split tensor blocks into smaller blocks of maximum size PRODUCT(block_sizes). @@ -331,7 +331,7 @@ CONTAINS nodata=nodata) #:endfor - END SUBROUTINE dbt_split_blocks + END SUBROUTINE ! ************************************************************************************************** !> \brief Copy tensor with split blocks to tensor with original block sizes. @@ -480,7 +480,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE dbt_split_copyback + END SUBROUTINE ! ************************************************************************************************** !> \brief split two tensors with same total sizes but different block sizes such that they have @@ -503,8 +503,7 @@ CONTAINS INTEGER, DIMENSION(ndims_tensor(tensor1)), & INTENT(IN), OPTIONAL :: order LOGICAL, INTENT(IN), OPTIONAL :: nodata1, nodata2, move_data - INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, & - ${varlist("blk_size_split_2")}$, & + INTEGER, DIMENSION(:), ALLOCATABLE :: ${varlist("blk_size_split_1")}$, ${varlist("blk_size_split_2")}$, & blk_size_d_1, blk_size_d_2, blk_size_d_split INTEGER :: size_sum_1, size_sum_2, size_sum, bind_1, bind_2, isplit, bs, idim, i LOGICAL :: move_prv, nodata1_prv, nodata2_prv @@ -552,7 +551,7 @@ CONTAINS size_sum = size_sum + bs isplit = isplit + 1 blk_size_d_split(isplit) = bs - ELSE IF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN + ELSEIF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN bind_2 = bind_2 + 1 bs = blk_size_d_2(bind_2) blk_size_d_1(bind_1 + 1) = blk_size_d_1(bind_1 + 1) - bs @@ -609,7 +608,7 @@ CONTAINS END IF #:endfor - END SUBROUTINE dbt_make_compatible_blocks + END SUBROUTINE ! ************************************************************************************************** !> \author Patrick Seewald @@ -699,6 +698,6 @@ CONTAINS CALL dbt_copy_contraction_storage(tensor_in, tensor_out) CALL timestop(handle) - END SUBROUTINE dbt_crop + END SUBROUTINE - END MODULE dbt_split + END MODULE diff --git a/src/dbt/dbt_types.F b/src/dbt/dbt_types.F index 1a7d1b14ba..a7aa6929ad 100644 --- a/src/dbt/dbt_types.F +++ b/src/dbt/dbt_types.F @@ -211,7 +211,7 @@ CONTAINS CALL dbt_get_mapping_info(map_grid, & dims_2d=grid_dims, & dims1_2d=new_dbt_tas_dist_t%dims_grid) - ELSE IF (which_dim == 2) THEN + ELSEIF (which_dim == 2) THEN ALLOCATE (new_dbt_tas_dist_t%dims(ndims_mapping_column(map_blks))) ALLOCATE (index_map(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -335,7 +335,7 @@ CONTAINS dims_2d_i8=matrix_dims, & map1_2d=index_map, & dims1_2d=new_dbt_tas_blk_size_t%dims) - ELSE IF (which_dim == 2) THEN + ELSEIF (which_dim == 2) THEN ALLOCATE (index_map(ndims_mapping_column(map_blks))) ALLOCATE (new_dbt_tas_blk_size_t%dims(ndims_mapping_column(map_blks))) CALL dbt_get_mapping_info(map_blks, & @@ -455,7 +455,7 @@ CONTAINS IF (idim /= SIZE(tensor_dims_sorted)) THEN dims(idim + 1:) = 0 CALL mp_dims_create(pdims_rem, dims(idim + 1:)) - ELSE IF (lb_ratio_prv < 0.5_dp) THEN + ELSEIF (lb_ratio_prv < 0.5_dp) THEN ! resort to a less strict load imbalance factor dims(:) = dims_store CALL dbt_mp_dims_create(nodes, dims, tensor_dims, 0.5_dp) @@ -836,7 +836,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(dist%refcount)) THEN abort = .TRUE. - ELSE IF (dist%refcount < 1) THEN + ELSEIF (dist%refcount < 1) THEN abort = .TRUE. END IF @@ -1264,7 +1264,7 @@ CONTAINS abort = .FALSE. IF (.NOT. ASSOCIATED(tensor%refcount)) THEN abort = .TRUE. - ELSE IF (tensor%refcount < 1) THEN + ELSEIF (tensor%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_mm.F b/src/dbt/tas/dbt_tas_mm.F index 1050765b34..12d8654603 100644 --- a/src/dbt/tas/dbt_tas_mm.F +++ b/src/dbt/tas/dbt_tas_mm.F @@ -276,7 +276,7 @@ CONTAINS WRITE (unit_nr_prv, "(T4,A,T68,I13)") "Est. optimal split factor:", nsplit END IF - ELSE IF (batched_repl > 0) THEN + ELSEIF (batched_repl > 0) THEN nsplit = nsplit_batched nsplit_opt = nsplit max_mm_dim = max_mm_dim_batched @@ -342,7 +342,7 @@ CONTAINS IF (matrix_c%do_batched == 1) THEN matrix_c%mm_storage%batched_beta = beta - ELSE IF (matrix_c%do_batched > 1) THEN + ELSEIF (matrix_c%do_batched > 1) THEN matrix_c%mm_storage%batched_beta = matrix_c%mm_storage%batched_beta*beta END IF @@ -355,7 +355,7 @@ CONTAINS IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rs%matrix) IF (matrix_c%do_batched >= 1) matrix_c%mm_storage%store_batched => matrix_c_rs - ELSE IF (matrix_c%do_batched == 3) THEN + ELSEIF (matrix_c%do_batched == 3) THEN matrix_c_rs => matrix_c%mm_storage%store_batched END IF @@ -446,7 +446,7 @@ CONTAINS matrix_b%mm_storage%store_batched_repl => matrix_b_rep CALL dbt_tas_set_batched_state(matrix_b, state=3) END IF - ELSE IF (matrix_b%do_batched == 3) THEN + ELSEIF (matrix_b%do_batched == 3) THEN matrix_b_rep => matrix_b%mm_storage%store_batched_repl END IF @@ -532,14 +532,14 @@ CONTAINS matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) END IF - ELSE IF (matrix_c%do_batched == 2) THEN + ELSEIF (matrix_c%do_batched == 2) THEN ALLOCATE (matrix_c_rep) CALL dbt_tas_replicate(matrix_c_rs%matrix, dbt_tas_info(matrix_a_rs), matrix_c_rep, nodata=nodata_3) ! just leave sparsity structure for retain sparsity but no values IF (.NOT. nodata_3) CALL dbm_zero(matrix_c_rep%matrix) matrix_c%mm_storage%store_batched_repl => matrix_c_rep CALL dbt_tas_set_batched_state(matrix_c, state=3) - ELSE IF (matrix_c%do_batched == 3) THEN + ELSEIF (matrix_c%do_batched == 3) THEN matrix_c_rep => matrix_c%mm_storage%store_batched_repl END IF @@ -625,7 +625,7 @@ CONTAINS matrix_a%mm_storage%store_batched_repl => matrix_a_rep CALL dbt_tas_set_batched_state(matrix_a, state=3) END IF - ELSE IF (matrix_a%do_batched == 3) THEN + ELSEIF (matrix_a%do_batched == 3) THEN matrix_a_rep => matrix_a%mm_storage%store_batched_repl END IF @@ -740,7 +740,7 @@ CONTAINS CALL dbt_tas_destroy(matrix_c_rs) DEALLOCATE (matrix_c_rs) IF (PRESENT(filter_eps)) CALL dbt_tas_filter(matrix_c, filter_eps) - ELSE IF (matrix_c%do_batched > 0) THEN + ELSEIF (matrix_c%do_batched > 0) THEN IF (matrix_c%mm_storage%batched_out) THEN matrix_c%mm_storage%batched_trans = (transc_prv .NEQV. transc) END IF diff --git a/src/dbt/tas/dbt_tas_split.F b/src/dbt/tas/dbt_tas_split.F index c9e7d8fb28..aa7522631e 100644 --- a/src/dbt/tas/dbt_tas_split.F +++ b/src/dbt/tas/dbt_tas_split.F @@ -266,7 +266,7 @@ CONTAINS nsplit_list_square(count_square) = split count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split - ELSE IF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN + ELSEIF (accept_pgrid_dims(dims_sub, relative=.FALSE.)) THEN count_accept = count_accept + 1 nsplit_list_accept(count_accept) = split END IF @@ -277,10 +277,10 @@ CONTAINS IF (count_square > 0) THEN minpos = MINLOC(ABS(nsplit_list_square(1:count_square) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_square(minpos) - ELSE IF (count_accept > 0) THEN + ELSEIF (count_accept > 0) THEN minpos = MINLOC(ABS(nsplit_list_accept(1:count_accept) - nsplit), DIM=1) get_opt_nsplit = nsplit_list_accept(minpos) - ELSE IF (count > 0) THEN + ELSEIF (count > 0) THEN minpos = MINLOC(ABS(nsplit_list(1:count) - nsplit), DIM=1) get_opt_nsplit = nsplit_list(minpos) ELSE @@ -462,7 +462,7 @@ CONTAINS IF (.NOT. ASSOCIATED(split_info%refcount)) THEN abort = .TRUE. - ELSE IF (split_info%refcount < 1) THEN + ELSEIF (split_info%refcount < 1) THEN abort = .TRUE. END IF diff --git a/src/dbt/tas/dbt_tas_util.F b/src/dbt/tas/dbt_tas_util.F index 60f323a9d1..0f8d27acd9 100644 --- a/src/dbt/tas/dbt_tas_util.F +++ b/src/dbt/tas/dbt_tas_util.F @@ -53,7 +53,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE swap_i8 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -68,7 +68,7 @@ CONTAINS tmp = arr(1) arr(1) = arr(2) arr(2) = tmp - END SUBROUTINE swap_i + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -87,7 +87,7 @@ CONTAINS array_eq_i = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif - END FUNCTION array_eq_i + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -106,6 +106,6 @@ CONTAINS array_eq_i8 = .FALSE. IF (SIZE(arr1) == SIZE(arr2)) array_eq_i8 = ALL(arr1 == arr2) #endif - END FUNCTION array_eq_i8 + END FUNCTION END MODULE diff --git a/src/dbx/cp_dbcsr_api.F b/src/dbx/cp_dbcsr_api.F index bd02f16ab1..cdd57dca4e 100644 --- a/src/dbx/cp_dbcsr_api.F +++ b/src/dbx/cp_dbcsr_api.F @@ -235,11 +235,10 @@ CONTAINS TYPE(dbcsr_type), POINTER :: matrix CALL dbcsr_release(matrix) - IF (dbcsr_valid_index(matrix)) THEN + IF (dbcsr_valid_index(matrix)) & CALL cp_abort(__LOCATION__, & 'You should not "deallocate" a referenced matrix. '// & 'Avoid pointers to DBCSR matrices.') - END IF DEALLOCATE (matrix) END SUBROUTINE dbcsr_deallocate_matrix diff --git a/src/debug_os_integrals.F b/src/debug_os_integrals.F index 19c1160f8f..49887cda40 100644 --- a/src/debug_os_integrals.F +++ b/src/debug_os_integrals.F @@ -75,7 +75,7 @@ CONTAINS ALLOCATE (swork(lds, lds, 1)) sab = 0._dp rab(:) = B(:) - A(:) - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) xa_work(1) = xa xb_work(1) = xb rpgfa = 20._dp @@ -219,11 +219,11 @@ CONTAINS !--------------------------------------- rab(:) = B(:) - A(:) - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) rac(:) = C(:) - A(:) - dac = NORM2(rac) + dac = SQRT(DOT_PRODUCT(rac, rac)) rbc(:) = C(:) - B(:) - dbc = NORM2(rbc) + dbc = SQRT(DOT_PRODUCT(rbc, rbc)) ALLOCATE (sabc(ncoset(la_max), ncoset(lb_max), ncoset(lc_max))) xa_work(1) = xa xb_work(1) = xb @@ -422,7 +422,7 @@ CONTAINS ALLOCATE (swork(lds, lds)) saabb = 0._dp rab(:) = B(:) - A(:) - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) xa_work1(1) = xa1 xa_work2(1) = xa2 xb_work1(1) = xb1 diff --git a/src/dft_plus_u.F b/src/dft_plus_u.F index 0337c70cd1..de3bec26f0 100644 --- a/src/dft_plus_u.F +++ b/src/dft_plus_u.F @@ -189,7 +189,7 @@ CONTAINS !> \date 02.07.2008 !> \par !> \f{eqnarray*}{ -!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U} +!> E^{\rm DFT+U} & = & E^{\rm DFT} + E^{\rm U}\\\ !> & = & E^{\rm DFT} + \frac{1}{2}(U - J)\sum_\mu (q_\mu - q_\mu^2)\\[1ex] !> V_{\mu\nu}^{\rm DFT+U} & = & V_{\mu\nu}^{\rm DFT} + V_{\mu\nu}^{\rm U}\\\ !> & = & \frac{\partial E^{\rm DFT}} @@ -766,11 +766,10 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) THEN + IF (energy%dft_plus_u < 0.0_dp) & CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Lowdin charges!") - END IF ! Release (local) full matrices NULLIFY (fm_s_half) @@ -1992,11 +1991,10 @@ CONTAINS CALL para_env%sum(energy%dft_plus_u) - IF (energy%dft_plus_u < 0.0_dp) THEN + IF (energy%dft_plus_u < 0.0_dp) & CALL cp_warn(__LOCATION__, & "DFT+U energy contribution is negative possibly due "// & "to unphysical Mulliken charges!") - END IF ! Release local work storage diff --git a/src/distribution_2d_types.F b/src/distribution_2d_types.F index a02fb10510..8473cd37f5 100644 --- a/src/distribution_2d_types.F +++ b/src/distribution_2d_types.F @@ -132,9 +132,8 @@ CONTAINS END IF IF (PRESENT(n_col_distribution)) THEN IF (ASSOCIATED(distribution_2d%col_distribution)) THEN - IF (n_col_distribution > distribution_2d%n_col_distribution) THEN + IF (n_col_distribution > distribution_2d%n_col_distribution) & CPABORT("n_col_distribution<=distribution_2d%n_col_distribution") - END IF ! else alloc col_distribution? END IF distribution_2d%n_col_distribution = n_col_distribution @@ -146,17 +145,15 @@ CONTAINS END IF IF (PRESENT(n_row_distribution)) THEN IF (ASSOCIATED(distribution_2d%row_distribution)) THEN - IF (n_row_distribution > distribution_2d%n_row_distribution) THEN + IF (n_row_distribution > distribution_2d%n_row_distribution) & CPABORT("n_row_distribution<=distribution_2d%n_row_distribution") - END IF ! else alloc row_distribution? END IF distribution_2d%n_row_distribution = n_row_distribution END IF - IF (PRESENT(local_rows_ptr)) THEN + IF (PRESENT(local_rows_ptr)) & distribution_2d%local_rows => local_rows_ptr - END IF IF (.NOT. ASSOCIATED(distribution_2d%local_rows)) THEN CPASSERT(PRESENT(n_local_rows)) ALLOCATE (distribution_2d%local_rows(SIZE(n_local_rows))) @@ -167,13 +164,11 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_rows(SIZE(distribution_2d%local_rows))) IF (PRESENT(n_local_rows)) THEN - IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) THEN + IF (SIZE(distribution_2d%n_local_rows) /= SIZE(n_local_rows)) & CPABORT("SIZE(distribution_2d%n_local_rows)==SIZE(n_local_rows)") - END IF DO i = 1, SIZE(distribution_2d%n_local_rows) - IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) THEN + IF (SIZE(distribution_2d%local_rows(i)%array) < n_local_rows(i)) & CPABORT("SIZE(distribution_2d%local_rows(i)%array)>=n_local_rows(i)") - END IF distribution_2d%n_local_rows(i) = n_local_rows(i) END DO ELSE @@ -183,9 +178,8 @@ CONTAINS END DO END IF - IF (PRESENT(local_cols_ptr)) THEN + IF (PRESENT(local_cols_ptr)) & distribution_2d%local_cols => local_cols_ptr - END IF IF (.NOT. ASSOCIATED(distribution_2d%local_cols)) THEN CPASSERT(PRESENT(n_local_cols)) ALLOCATE (distribution_2d%local_cols(SIZE(n_local_cols))) @@ -196,13 +190,11 @@ CONTAINS END IF ALLOCATE (distribution_2d%n_local_cols(SIZE(distribution_2d%local_cols))) IF (PRESENT(n_local_cols)) THEN - IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) THEN + IF (SIZE(distribution_2d%n_local_cols) /= SIZE(n_local_cols)) & CPABORT("SIZE(distribution_2d%n_local_cols)==SIZE(n_local_cols)") - END IF DO i = 1, SIZE(distribution_2d%n_local_cols) - IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) THEN + IF (SIZE(distribution_2d%local_cols(i)%array) < n_local_cols(i)) & CPABORT("SIZE(distribution_2d%local_cols(i)%array)>=n_local_cols(i)") - END IF distribution_2d%n_local_cols(i) = n_local_cols(i) END DO ELSE @@ -323,9 +315,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%row_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%row_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) THEN + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -345,9 +336,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%col_distribution, 1) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%col_distribution(i, 1) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) THEN + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -365,9 +355,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_rows) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_rows(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) THEN + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE @@ -406,9 +395,8 @@ CONTAINS DO i = 1, SIZE(distribution_2d%n_local_cols) WRITE (unit=unit_nr, fmt="(i6,',')", advance="no") distribution_2d%n_local_cols(i) ! keep lines finite, so that we can open outputs in vi - IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) THEN + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) & WRITE (unit=unit_nr, fmt='()') - END IF END DO WRITE (unit=unit_nr, fmt="('),')") ELSE diff --git a/src/distribution_methods.F b/src/distribution_methods.F index 6442052837..c2a143497c 100644 --- a/src/distribution_methods.F +++ b/src/distribution_methods.F @@ -207,14 +207,12 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_count, bin, bin_price, found) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("No topmost heap element found.") - END IF ipe = bin - IF (bin_price /= workload_count(ipe)) THEN + IF (bin_price /= workload_count(ipe)) & CPABORT("inconsistent heap") - END IF workload_count(ipe) = workload_count(ipe) + nload IF (ipe == mype) THEN @@ -247,14 +245,12 @@ CONTAINS END DO ELSE CALL cp_heap_get_first(bin_heap_fill, bin, bin_price, found) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("No topmost heap element found.") - END IF ipe = bin - IF (bin_price /= workload_fill(ipe)) THEN + IF (bin_price /= workload_fill(ipe)) & CPABORT("inconsistent heap") - END IF workload_fill(ipe) = workload_fill(ipe) + nload is_local = (ipe == mype) @@ -279,9 +275,8 @@ CONTAINS END DO - IF (ANY(workload_fill /= workload_count)) THEN + IF (ANY(workload_fill /= workload_count)) & CPABORT("Inconsistent heaps encountered") - END IF CALL cp_heap_release(bin_heap_count) CALL cp_heap_release(bin_heap_fill) @@ -568,9 +563,8 @@ CONTAINS CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model) IF (.NOT. molecular_distribution) THEN DO iatom = 1, natom - IF (iatom > nclusters) THEN + IF (iatom > nclusters) & CPABORT("Bounds error") - END IF CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) cluster_list(iatom) = iatom SELECT CASE (cost_model) @@ -625,9 +619,8 @@ CONTAINS nprow, cluster_row_distribution(:, 1), npcol, cluster_col_distribution(:, 1)) ELSE IF (basic_cluster_optimization) THEN - IF (molecular_distribution) THEN + IF (molecular_distribution) & CPABORT("clustering and molecular blocking NYI") - END IF ALLOCATE (pbc_scaled_coords(3, natom), coords(3, natom)) DO iatom = 1, natom CALL real_to_scaled(pbc_scaled_coords(:, iatom), pbc(particle_set(iatom)%r(:), cell), cell) @@ -871,18 +864,15 @@ CONTAINS DO cluster_index = nclusters, 1, -1 cluster = cluster_list(cluster_index) CALL cp_heap_get_first(bin_heap, bin, bin_price, found) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("No topmost heap element found.") - END IF ! prow = INT((bin - 1)*pgrid_gcd/npcols) - IF (prow >= nprows) THEN + IF (prow >= nprows) & CPABORT("Invalid process row.") - END IF pcol = INT((bin - 1)*pgrid_gcd/nprows) - IF (pcol >= npcols) THEN + IF (pcol >= npcols) & CPABORT("Invalid process column.") - END IF row_distribution(cluster) = prow + 1 col_distribution(cluster) = pcol + 1 ! @@ -1207,7 +1197,7 @@ CONTAINS balance_new = MAXVAL(REAL(nat_cluster, KIND=dp))/MINVAL(REAL(nat_cluster, KIND=dp)) IF (balance_new < balance) THEN balance = balance_new - min_seed = seed + i*40 + min_seed = seed + i*40; END IF ELSE found = .TRUE. @@ -1324,7 +1314,7 @@ CONTAINS devi = HUGE(1.0_dp) DO j = 1, i - 1 dvec = pbc(cent_coord(:, j), cent_coord(:, i), cell) - dist = NORM2(dvec) + dist = SQRT(DOT_PRODUCT(dvec, dvec)) IF (dist < devi) devi = dist END DO rn = rng_stream%next() diff --git a/src/dm_ls_chebyshev.F b/src/dm_ls_chebyshev.F index ea57800af1..0b707213c6 100644 --- a/src/dm_ls_chebyshev.F +++ b/src/dm_ls_chebyshev.F @@ -263,33 +263,27 @@ CONTAINS DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp1) - !matrix_dummy2= - CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) - !first term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) - !second term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) + CALL dbcsr_copy(matrix_dummy2(iwindow), matrix_tmp2) !matrix_dummy2= + CALL dbcsr_scale(matrix_dummy1, kernel_g(1)*aitchev_T(1, iwindow)) !first term of chebyshev poly(matrix) + CALL dbcsr_scale(matrix_dummy2(iwindow), 2.0_dp*kernel_g(2)*aitchev_T(2, iwindow)) !second term of chebyshev poly(matrix) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) END DO DO icheb = 2, ncheb - 1 t1 = m_walltime() - !matrix multiplication(Recursion) CALL dbcsr_multiply("N", "N", 2.0_dp, matrix_F, matrix_tmp2, & - -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) + -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) !matrix multiplication(Recursion) CALL dbcsr_copy(matrix_tmp3, matrix_tmp1) CALL dbcsr_copy(matrix_tmp1, matrix_tmp2) CALL dbcsr_copy(matrix_tmp2, matrix_tmp3) - !icheb+1 th coefficient - CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) + CALL dbcsr_trace(matrix_tmp2, trace=mu(icheb + 1)) !icheb+1 th coefficient CALL kernel(kernel_g(icheb + 1), icheb + 1, ncheb) DO iwindow = 1, nwindow CALL dbcsr_copy(matrix_dummy1, matrix_tmp2) - !second term of chebyshev poly(matrix) - CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) + CALL dbcsr_scale(matrix_dummy1, 2.0_dp*kernel_g(icheb + 1)*aitchev_T(icheb + 1, iwindow)) !second term of chebyshev poly(matrix) CALL dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) CALL dbcsr_trace(matrix_dummy2(iwindow), trace=trace_dm(iwindow)) !icheb+1 th coefficient diff --git a/src/dm_ls_scf.F b/src/dm_ls_scf.F index 97b662fb2b..e5d9d07e2c 100644 --- a/src/dm_ls_scf.F +++ b/src/dm_ls_scf.F @@ -588,7 +588,7 @@ CONTAINS DO ispin = 1, nspin IF (nonscf) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) - ELSE IF (ls_scf_env%do_rho_mixing) THEN + ELSEIF (ls_scf_env%do_rho_mixing) THEN CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) ELSE IF (iscf == 1) THEN @@ -657,12 +657,10 @@ CONTAINS IF (ls_scf_env%nspins == 1) nelectron_spin_real = nelectron_spin_real/2 IF (do_transport) THEN - IF (ls_scf_env%has_s_preconditioner) THEN + IF (ls_scf_env%has_s_preconditioner) & CPABORT("NOT YET IMPLEMENTED with S preconditioner. ") - END IF - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & CPABORT("NOT YET IMPLEMENTED with molecular clustering. ") - END IF extra_scf = maxscf_reached .OR. scf_converged ! get the current Kohn-Sham matrix (ks) and return matrix_p evaluated using an external C routine @@ -693,13 +691,11 @@ CONTAINS eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos, & iounit=-1) CASE (ls_scf_pexsi) - IF (ls_scf_env%has_s_preconditioner) THEN + IF (ls_scf_env%has_s_preconditioner) & CPABORT("S preconditioning not implemented in combination with the PEXSI library. ") - END IF - IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) THEN + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & CALL cp_abort(__LOCATION__, & "Molecular clustering not implemented in combination with the PEXSI library. ") - END IF CALL density_matrix_pexsi(ls_scf_env%pexsi, ls_scf_env%matrix_p(ispin), ls_scf_env%pexsi%matrix_w(ispin), & ls_scf_env%pexsi%kTS(ispin), matrix_mixing_old(ispin), ls_scf_env%matrix_s, & nelectron_spin_real, ls_scf_env%mu_spin(ispin), iscf, ispin) @@ -838,9 +834,8 @@ CONTAINS END IF ! store the matrix for a next scf run - IF (.NOT. ls_scf_env%do_pao) THEN + IF (.NOT. ls_scf_env%do_pao) & CALL ls_scf_store_result(ls_scf_env) - END IF ! write homo and lumo energy and occupation (if not already part of the output) IF (ls_scf_env%curvy_steps) THEN @@ -913,9 +908,8 @@ CONTAINS END DO DEALLOCATE (ls_scf_env%matrix_ks) - IF (ls_scf_env%do_pexsi) THEN + IF (ls_scf_env%do_pexsi) & CALL pexsi_finalize_scf(ls_scf_env%pexsi, ls_scf_env%mu_spin) - END IF CALL timestop(handle) diff --git a/src/dm_ls_scf_create.F b/src/dm_ls_scf_create.F index 2ae4abd5c4..f094e7e7d6 100644 --- a/src/dm_ls_scf_create.F +++ b/src/dm_ls_scf_create.F @@ -155,9 +155,8 @@ CONTAINS ! initialize PEXSI IF (ls_scf_env%do_pexsi) THEN - IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) THEN + IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) & CPABORT("EPS_FILTER_MATRIX must be set to 0 for PEXSI.") - END IF CALL lib_pexsi_init(ls_scf_env%pexsi, ls_scf_env%para_env, ls_scf_env%nspins) END IF @@ -264,9 +263,8 @@ CONTAINS CALL section_vals_get(mixing_section, explicit=ls_scf_env%do_rho_mixing) CALL section_vals_val_get(mixing_section, "METHOD", i_val=ls_scf_env%density_mixing_method) - IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) THEN + IF (ls_scf_env%ls_diis .AND. ls_scf_env%do_rho_mixing) & CPABORT("LS_DIIS and RHO_MIXING are not compatible.") - END IF pexsi_section => section_vals_get_subs_vals(input, "DFT%LS_SCF%PEXSI") CALL section_vals_get(pexsi_section) @@ -315,18 +313,14 @@ CONTAINS END SELECT ! verify some requirements for the curvy steps - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) THEN + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_pexsi) & CPABORT("CURVY_STEPS cannot be used together with PEXSI.") - END IF - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) THEN + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport) & CPABORT("CURVY_STEPS cannot be used together with TRANSPORT.") - END IF - IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) THEN + IF (ls_scf_env%curvy_steps .AND. ls_scf_env%has_s_preconditioner) & CPABORT("S Preconditioning not implemented in combination with CURVY_STEPS.") - END IF - IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) THEN + IF (ls_scf_env%curvy_steps .AND. .NOT. ls_scf_env%use_s_sqrt) & CPABORT("CURVY_STEPS requires the use of the sqrt inversion.") - END IF ! verify requirements for direct submatrix sign methods IF (ls_scf_env%sign_method == ls_scf_sign_submatrix & @@ -334,9 +328,8 @@ CONTAINS ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & - ) .AND. .NOT. ls_scf_env%sign_symmetric) THEN + ) .AND. .NOT. ls_scf_env%sign_symmetric) & CPABORT("DIRECT submatrix sign methods require SIGN_SYMMETRIC being set.") - END IF IF (ls_scf_env%fixed_mu .AND. ( & ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj & .OR. ls_scf_env%submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem & diff --git a/src/dm_ls_scf_curvy.F b/src/dm_ls_scf_curvy.F index e1c9375c9b..1548418d0d 100644 --- a/src/dm_ls_scf_curvy.F +++ b/src/dm_ls_scf_curvy.F @@ -95,10 +95,9 @@ CONTAINS ! If new search direction has to be computed transform H into the orthnormal basis - IF (ls_scf_env%curvy_data%line_search_step == 1) THEN + IF (ls_scf_env%curvy_data%line_search_step == 1) & CALL transform_matrix_orth(ls_scf_env%matrix_ks, ls_scf_env%matrix_s_sqrt_inv, & ls_scf_env%eps_filter) - END IF ! Set the energies for the line search and make sure to give the correct energy back to scf_main ls_scf_env%curvy_data%energies(lsstep) = energy diff --git a/src/dm_ls_scf_methods.F b/src/dm_ls_scf_methods.F index b51f08d513..e74da48ab7 100644 --- a/src/dm_ls_scf_methods.F +++ b/src/dm_ls_scf_methods.F @@ -516,9 +516,8 @@ CONTAINS IF (sign_symmetric) THEN - IF (.NOT. PRESENT(matrix_s_sqrt_inv)) THEN + IF (.NOT. PRESENT(matrix_s_sqrt_inv)) & CPABORT("Argument matrix_s_sqrt_inv required if sign_symmetric is set") - END IF CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_create(matrix_ssqrtinv_ks_ssqrtinv2, template=matrix_s, matrix_type=dbcsr_type_no_symmetry) @@ -578,9 +577,8 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix - END IF IF (sign_symmetric) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & @@ -690,9 +688,8 @@ CONTAINS 0.0_dp, matrix_tmp, filter_eps=threshold) CALL dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) THEN + IF (unit_nr > 0 .AND. frob_matrix > 0.001_dp) & WRITE (unit_nr, '(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix - END IF CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p_ud, & 0.0_dp, matrix_tmp, filter_eps=threshold) @@ -945,9 +942,8 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(trace_gx)) THEN + IF (abnormal_value(trace_gx)) & CPABORT("trace_gx is an abnormal value (NaN/Inf).") - END IF ! a branch of 1 or 2 appears to lead to a less accurate electron number count and premature exit ! if it turns out this does not exit because we get stuck in branch 1/2 for a reason we need to refine further @@ -973,15 +969,13 @@ CONTAINS CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_x_nosym, & 0.0_dp, matrix_p, filter_eps=threshold) - ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, - ! where fk is evaluated using the stored values for gamma + ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, where fk is evaluated using the stored values for gamma ! E. Rubensson et al., Chem Phys Lett 432, 2006, 591-594 - mu_a = 0.0_dp; mu_b = 1.0_dp + mu_a = 0.0_dp; mu_b = 1.0_dp; mu_fa = evaluate_trs4_polynomial(mu_a, gamma_values, i - 1) - 0.5_dp DO j = 1, 40 mu_c = 0.5*(mu_a + mu_b) - ! i-1 because in the last iteration, only convergence is checked - mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp + mu_fc = evaluate_trs4_polynomial(mu_c, gamma_values, i - 1) - 0.5_dp ! i-1 because in the last iteration, only convergence is checked IF (ABS(mu_fc) < 1.0E-6_dp .OR. (mu_b - mu_a)/2 < 1.0E-6_dp) EXIT !TODO: define threshold values IF (mu_fc*mu_fa > 0) THEN diff --git a/src/dm_ls_scf_qs.F b/src/dm_ls_scf_qs.F index 5ae581f005..7fc0b72aca 100644 --- a/src/dm_ls_scf_qs.F +++ b/src/dm_ls_scf_qs.F @@ -322,9 +322,8 @@ CONTAINS CALL timeset(routineN, handle) my_keep_sparsity = .TRUE. - IF (PRESENT(keep_sparsity)) THEN + IF (PRESENT(keep_sparsity)) & my_keep_sparsity = keep_sparsity - END IF IF (.NOT. ls_mstruct%do_pao) THEN CALL dbcsr_create(matrix_declustered, template=matrix_qs) @@ -584,9 +583,8 @@ CONTAINS ! compute the corresponding KS matrix and new energy, mix density if requested CALL qs_rho_update_rho(rho, qs_env=qs_env) IF (ls_scf_env%do_rho_mixing) THEN - IF (ls_scf_env%density_mixing_method == direct_mixing_nr) THEN + IF (ls_scf_env%density_mixing_method == direct_mixing_nr) & CPABORT("Direct P mixing not implemented in linear scaling SCF. ") - END IF IF (ls_scf_env%density_mixing_method >= gspace_mixing_nr) THEN IF (iscf > MAX(ls_scf_env%mixing_store%nskip_mixing, 1)) THEN CALL gspace_mixing(qs_env, ls_scf_env%density_mixing_method, & @@ -841,9 +839,9 @@ CONTAINS CALL get_qs_env(qs_env, rho_atom_set=rho_atom) CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & ls_scf_env%para_env, rho_atom=rho_atom) - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(ls_scf_env%mixing_store) - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(ls_scf_env%density_mixing_method, rho, ls_scf_env%mixing_store, & diff --git a/src/dm_ls_scf_types.F b/src/dm_ls_scf_types.F index 1d26e1d570..07123e6801 100644 --- a/src/dm_ls_scf_types.F +++ b/src/dm_ls_scf_types.F @@ -208,12 +208,10 @@ CONTAINS DEALLOCATE (ls_scf_env%matrix_p) END IF - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) THEN + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) & CALL section_vals_release(ls_scf_env%chebyshev%print_key_dos) - END IF - IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) THEN + IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) & CALL section_vals_release(ls_scf_env%chebyshev%print_key_cube) - END IF IF (ASSOCIATED(ls_scf_env%chebyshev%min_energy)) THEN DEALLOCATE (ls_scf_env%chebyshev%min_energy) END IF @@ -230,9 +228,8 @@ CONTAINS CALL lib_pexsi_finalize(ls_scf_env%pexsi) END IF - IF (ls_scf_env%do_pao) THEN + IF (ls_scf_env%do_pao) & CALL pao_finalize(ls_scf_env%pao_env) - END IF DEALLOCATE (ls_scf_env) diff --git a/src/domain_submatrix_methods.F b/src/domain_submatrix_methods.F index ac020751c0..b70d9fc507 100644 --- a/src/domain_submatrix_methods.F +++ b/src/domain_submatrix_methods.F @@ -937,6 +937,33 @@ CONTAINS END DO + ! simple but quadratically scaling procedure + ! loop over local blocks + !CALL dbcsr_iterator_start(iter,matrix) + !DO WHILE (dbcsr_iterator_blocks_left(iter)) + ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& + ! row_size=row_size,col_size=col_size) + ! DO idomain = 1, ndomains + ! IF (job_type==select_row_col) THEN + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ELSE + ! domain_needs_block=(idomain==col& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ENDIF + ! IF (domain_needs_block) THEN + ! transp=.FALSE. + ! dest_node=node_of_domain(idomain) + ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& + ! ! idomain, idomain, transp, dest_node) + ! send_descriptor(1,dest_node+1)=send_descriptor(1,dest_node+1)+1 + ! send_descriptor(2,dest_node+1)=send_descriptor(2,dest_node+1)+& + ! row_size*col_size + ! ENDIF + ! ENDDO + !ENDDO + !CALL dbcsr_iterator_stop(iter) + ! communicate number of blocks and their sizes to the other nodes CALL group%alltoall(send_descriptor, recv_descriptor, ldesc) @@ -1031,6 +1058,15 @@ CONTAINS IF (block_node == myNode) THEN CALL dbcsr_get_block_p(matrix, row, col, block_p, found, row_size, col_size) IF (found) THEN + !col_offset=0 + !DO icol=1,col_size + ! start_data=send_offset_cpu(dest_node+1)+& + ! offset_block(dest_node+1)+& + ! col_offset + ! send_data(start_data+1:start_data+row_size)=& + ! data_p(1:row_size,icol) + ! col_offset=col_offset+row_size + !ENDDO col_offset = row_size*col_size start_data = send_offset_cpu(dest_node + 1) + & offset_block(dest_node + 1) @@ -1050,6 +1086,45 @@ CONTAINS END DO ! loop over rows END DO + ! more simple but quadratically scaling version + !CALL dbcsr_iterator_start(iter,matrix) + !DO WHILE (dbcsr_iterator_blocks_left(iter)) + ! CALL dbcsr_iterator_next_block(iter,row,col,data_p,& + ! row_size=row_size,col_size=col_size) + ! DO idomain = 1, ndomains + ! IF (job_type==select_row_col) THEN + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ELSE + ! domain_needs_block=(idomain==col& + ! .AND.qblk_exists(domain_map,row,idomain)) + ! ENDIF + ! IF (domain_needs_block) THEN + ! transp=.FALSE. + ! dest_node=node_of_domain(idomain) + ! !CALL dbcsr_get_stored_coordinates(distr_pattern,& + ! ! idomain, idomain, transp, dest_node) + ! ! place the data appropriately + ! col_offset=0 + ! DO icol=1,col_size + ! start_data=send_offset_cpu(dest_node+1)+& + ! offset_block(dest_node+1)+& + ! col_offset + ! send_data(start_data+1:start_data+row_size)=& + ! data_p(1:row_size,icol) + ! col_offset=col_offset+row_size + ! ENDDO + ! offset_block(dest_node+1)=offset_block(dest_node+1)+col_size*row_size + ! ! fill out row,col information + ! send_data2(send_offset2_cpu(dest_node+1)+& + ! offset2_block(dest_node+1)+1)=row + ! send_data2(send_offset2_cpu(dest_node+1)+& + ! offset2_block(dest_node+1)+2)=col + ! offset2_block(dest_node+1)=offset2_block(dest_node+1)+2 + ! ENDIF + ! ENDDO + !ENDDO + !CALL dbcsr_iterator_stop(iter) ! send-receive all blocks CALL group%alltoall(send_data, send_size_cpu, send_offset_cpu, & @@ -1067,6 +1142,9 @@ CONTAINS ! copy blocks into submatrices CALL dbcsr_get_info(matrix, col_blk_size=col_blk_size, row_blk_size=row_blk_size) +! ALLOCATE(subm_row_size(ndomains),subm_col_size(ndomains)) +! subm_row_size(:)=0 +! subm_col_size(:)=0 ndomains2 = SIZE(submatrix) IF (ndomains2 /= ndomains) THEN CPABORT("wrong submatrix size") @@ -1081,6 +1159,9 @@ CONTAINS submatrix(:)%domain = -1 DO idomain = 1, ndomains dest_node = node_of_domain(idomain) + !transp=.FALSE. + !CALL dbcsr_get_stored_coordinates(distr_pattern,& + ! idomain, idomain, transp, dest_node) IF (dest_node == mynode) THEN submatrix(idomain)%domain = idomain submatrix(idomain)%nbrows = 0 @@ -1093,9 +1174,12 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) + !DO row = 1, nblkrows_tot + ! IF (qblk_exists(domain_map,row,idomain)) THEN first_row(row) = submatrix(idomain)%nrows + 1 submatrix(idomain)%nrows = submatrix(idomain)%nrows + row_blk_size(row) submatrix(idomain)%nbrows = submatrix(idomain)%nbrows + 1 + ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_row(submatrix(idomain)%nbrows)) ALLOCATE (submatrix(idomain)%size_brow(submatrix(idomain)%nbrows)) @@ -1106,9 +1190,12 @@ CONTAINS index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) + !DO row = 1, nblkrows_tot + ! IF (first_row(row).ne.-1) THEN submatrix(idomain)%dbcsr_row(smrow) = row submatrix(idomain)%size_brow(smrow) = row_blk_size(row) smrow = smrow + 1 + ! ENDIF END DO ! loop over the necessary columns @@ -1129,9 +1216,17 @@ CONTAINS ELSE col = idomain END IF + !DO col = 1, nblkcols_tot + ! IF (job_type==select_row_col) THEN + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)) + ! ELSE + ! domain_needs_block=(col==idomain) ! RZK-warning col belongs to the domain + ! ENDIF + ! IF (domain_needs_block) THEN first_col(col) = submatrix(idomain)%ncols + 1 submatrix(idomain)%ncols = submatrix(idomain)%ncols + col_blk_size(col) submatrix(idomain)%nbcols = submatrix(idomain)%nbcols + 1 + ! ENDIF END DO ALLOCATE (submatrix(idomain)%dbcsr_col(submatrix(idomain)%nbcols)) @@ -1155,9 +1250,12 @@ CONTAINS ELSE col = idomain END IF + !DO col = 1, nblkcols_tot + ! IF (first_col(col).ne.-1) THEN submatrix(idomain)%dbcsr_col(smcol) = col submatrix(idomain)%size_bcol(smcol) = col_blk_size(col) smcol = smcol + 1 + ! ENDIF END DO ALLOCATE (submatrix(idomain)%mdata( & diff --git a/src/ec_orth_solver.F b/src/ec_orth_solver.F index 65e07cfaf7..1a8a904a72 100644 --- a/src/ec_orth_solver.F +++ b/src/ec_orth_solver.F @@ -241,9 +241,8 @@ CONTAINS ! Tr(r_0 * r_0) CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, norm_rr(ispin)) - IF (abnormal_value(norm_rr(ispin))) THEN + IF (abnormal_value(norm_rr(ispin))) & CPABORT("Preconditioner: Tr[r_j*r_j] is an abnormal value (NaN/Inf)") - END IF IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0") norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp))) @@ -273,9 +272,8 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) THEN + IF (abnormal_value(new_norm(ispin))) & CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") - END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps*0.001_dp & @@ -712,9 +710,8 @@ CONTAINS CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin)) CPABORT("tr(Ap_j*p_j) < 0") - IF (abnormal_value(norm_cA(ispin))) THEN + IF (abnormal_value(norm_cA(ispin))) & CPABORT("Preconditioner: Tr[Ap_j*p_j] is an abnormal value (NaN/Inf)") - END IF END IF @@ -793,9 +790,8 @@ CONTAINS ! Tr[r_j+1*z_j+1] CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_z0(ispin)%matrix, new_norm(ispin)) IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") - IF (abnormal_value(new_norm(ispin))) THEN + IF (abnormal_value(new_norm(ispin))) & CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") - END IF norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) IF (norm_rr(ispin) < linres_control%eps .OR. new_norm(ispin) < linres_control%eps) THEN diff --git a/src/eeq_data.F b/src/eeq_data.F index b030a0bde8..dc1bdef0d6 100644 --- a/src/eeq_data.F +++ b/src/eeq_data.F @@ -247,7 +247,7 @@ CONTAINS IF (PRESENT(eta)) eta = eeqGam(za) IF (PRESENT(kcn)) kcn = eeqkCN(za) IF (PRESENT(rad)) rad = eeqAlp(za) - ELSE IF (model == 2) THEN + ELSEIF (model == 2) THEN CPASSERT(za <= max_elem) IF (PRESENT(chi)) chi = eeq_chi(za) IF (PRESENT(eta)) eta = eeq_eta(za) diff --git a/src/eeq_method.F b/src/eeq_method.F index 7e4c0f94f4..7e86e08ea0 100644 --- a/src/eeq_method.F +++ b/src/eeq_method.F @@ -1611,7 +1611,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1693,7 +1693,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -1764,7 +1764,7 @@ CONTAINS dfilter(1:3) = dft_control%period_efield%d_filter(1:3) fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength hmat = cell%hmat(:, :)/twopi omega = cell%deth @@ -1882,7 +1882,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*dft_control%period_efield%strength use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer) diff --git a/src/efield_tb_methods.F b/src/efield_tb_methods.F index a7395d9325..11fbabcaf5 100644 --- a/src/efield_tb_methods.F +++ b/src/efield_tb_methods.F @@ -281,7 +281,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'efield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi + COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) INTEGER :: atom_a, atom_b, handle, ia, iac, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, & @@ -334,7 +334,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -452,7 +452,7 @@ CONTAINS NULLIFY (sap_int) IF (dft_control%qs_control%dftb) THEN CPABORT("DFTB stress tensor for periodic efield not implemented") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL xtb_dsint_list(qs_env, sap_int) ELSE CPABORT("TB method unknown") @@ -612,7 +612,7 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'dfield_tb_berry' COMPLEX(KIND=dp) :: zdeta - COMPLEX(KIND=dp), DIMENSION(3) :: zi + COMPLEX(KIND=dp), DIMENSION(3) :: zi(3) INTEGER :: atom_a, atom_b, handle, i, ia, iatom, & ic, icol, idir, ikind, irow, is, & ispin, jatom, jkind, natom, nimg, nspin @@ -674,7 +674,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/efield_utils.F b/src/efield_utils.F index 59efeb61bc..352369cdca 100644 --- a/src/efield_utils.F +++ b/src/efield_utils.F @@ -140,7 +140,7 @@ CONTAINS IF (DOT_PRODUCT(efield%polarisation, efield%polarisation) == 0) THEN pol(:) = 1.0_dp/3.0_dp ELSE - pol(:) = efield%polarisation(:)/NORM2(efield%polarisation) + pol(:) = efield%polarisation(:)/(SQRT(DOT_PRODUCT(efield%polarisation, efield%polarisation))) END IF SELECT CASE (efield%envelop_id) @@ -151,12 +151,10 @@ CONTAINS efield%phase_offset*pi)*pol(:) END IF CASE (ramp_env) - IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) THEN + IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) & strength = E_0*(sim_step - efield%envelop_i_vars(1))/(efield%envelop_i_vars(2) - efield%envelop_i_vars(1)) - END IF - IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) THEN + IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) & strength = E_0*(efield%envelop_i_vars(4) - sim_step)/(efield%envelop_i_vars(4) - efield%envelop_i_vars(3)) - END IF IF (sim_step > efield%envelop_i_vars(4) .AND. efield%envelop_i_vars(4) > 0) strength = 0.0_dp IF (sim_step <= efield%envelop_i_vars(1)) strength = 0.0_dp field = field + strength*COS(sim_time*nu*twopi + & diff --git a/src/eip_silicon.F b/src/eip_silicon.F index 0d611e56c8..1e5bf4d308 100644 --- a/src/eip_silicon.F +++ b/src/eip_silicon.F @@ -34,7 +34,6 @@ MODULE eip_silicon USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_para_env_type USE particle_types, ONLY: particle_type USE physcon, ONLY: angstrom,& @@ -927,17 +926,25 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & - ener, coord, ener_var, coord_var, count + REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & + ener_var, coord_var, count - INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & - laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, myspaceout, ncx, nn, nnbrx, npr - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb, num2, num3, numz - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, & - rlc3i, tcoord, tcoord2, tener, tener2 - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz, s2, s3, sz, txyz + DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: s2, s3, sz + INTEGER, ALLOCATABLE, DIMENSION(:) :: num2, num3, numz + + REAL(KIND=dp) :: coord2, cut, cut2, ener2, rlc1i, rlc2i, rlc3i, tcoord, & + tcoord2, tener, tener2 + INTEGER :: iam, iat, iat1, iat2, ii, i, il, in, indlst, indlstx, istop, & + istopg, l2, l3, laymx, ll1, ll2, ll3, lot, max_nbrs, myspace, & + l1, myspaceout, ncx, nn, nnbrx, npr ! cut=par_a cut = 3.1213820e0_dp + 1.e-14_dp @@ -1557,6 +1564,8 @@ CONTAINS END IF !$OMP END PARALLEL +! write(*,*) 'ener,norm force', & +! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2012,13 +2021,16 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) - INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rxyz + INTEGER :: icell, lstb, lay + REAL(KIND=dp) :: rel, cut2 INTEGER :: indlst - INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & + lstb(0:myspace - 1), rel(5, 0:myspace - 1) + + INTEGER :: jat, k1, k2, k3, jj + REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -2079,18 +2091,25 @@ CONTAINS coord_var, count) INTEGER :: nat - REAL(KIND=dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & - ener, coord, ener_var, coord_var, count + REAL(KIND=dp) :: alat, rxyz0, fxyz, ener, coord, & + ener_var, coord_var, count - INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, istop, istopg, l1, l2, l3, & - laymx, ll1, ll2, ll3, lot, myspace, myspaceout, ncx, nn, nnbrx, npjkx, npjx, npr, rlc1i, & - rlc2i, rlc3i - INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & - tcoord2, tener, tener2 - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik, rel, rxyz, txyz + DIMENSION rxyz0(3, nat), fxyz(3, nat), alat(3) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rxyz + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta + INTEGER, ALLOCATABLE, DIMENSION(:) :: lstb + INTEGER, ALLOCATABLE, DIMENSION(:) :: lay + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: txyz + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: f2ij, f3ij, f3ik + + REAL(KIND=dp) :: coord2, cut, cut2, ener2, tcoord, & + tcoord2, tener, tener2 + INTEGER :: i, iam, iat, iat1, iat2, ii, il, in, indlst, indlstx, & + istop, istopg, l1, l2, l3, ll1, ll2, ll3, lot, ncx, nn, & + nnbrx, npjkx, npjx, laymx, npr, rlc1i, rlc2i, rlc3i, & + myspace, myspaceout ! tmax_phi= 0.4500000e+01_dp ! cut=tmax_phi @@ -2701,6 +2720,8 @@ CONTAINS END IF !$OMP END PARALLEL +! write(*,*) 'ener,norm force', & +! ener,DNRM2(3*nat,fxyz,1) IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat @@ -2738,78 +2759,115 @@ CONTAINS ! with them and their contribution to the energy (tener). ! In addition the coordination number tcoord and the second moment of the ! local energy tener2 and coordination number tcoord2 are returned - INTEGER :: iat1, iat2, nat, lsta(2, nat) - REAL(KIND=dp) :: tener, tener2, tcoord, tcoord2 + INTEGER :: iat1, iat2, nat, lsta, lstb + REAL(KIND=dp) :: rel, tener, tener2, tcoord, tcoord2 INTEGER :: nnbrx - REAL(KIND=dp) :: rel(5, nnbrx*nat) - INTEGER :: lstb(nnbrx*nat) - REAL(KIND=dp) :: txyz(3, nat) + REAL(KIND=dp) :: txyz, f2ij INTEGER :: npjx - REAL(KIND=dp) :: f2ij(3, npjx) + REAL(KIND=dp) :: f3ij INTEGER :: npjkx - REAL(KIND=dp) :: f3ij(3, npjkx), f3ik(3, npjkx) + REAL(KIND=dp) :: f3ik INTEGER :: istop - REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: cof_rho = [0.13747000000000e+00_dp, & - -0.14831000000000e+00_dp, -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & - -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, -0.66620000000000e+00_dp, & - -0.57328000000000e+00_dp, -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & - 0.00000000000000e+00_dp] - REAL(KIND=dp), DIMENSION(0:10), PARAMETER :: dof_rho = [-0.32275496741918e+01_dp, & - -0.64119006516165e+01_dp, 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & - 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, 0.47189016693543e+00_dp, & - 0.20569572748420e+01_dp, 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & - -0.12371959895186e+02_dp] - REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: cof_ggg = [0.52541600000000e+01_dp, & - 0.23591500000000e+01_dp, 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & - 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, 0.49485900000000e+01_dp, & - 0.56179900000000e+01_dp], cof_uuu = [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & - 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, 0.12668900000000e+01_dp, & - 0.16299800000000e+01_dp, 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] - REAL(KIND=dp), DIMENSION(0:7), PARAMETER :: dof_ggg = [0.15826876132396e+02_dp, & - 0.31176239377907e+02_dp, 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & - 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, -0.18823313223755e+02_dp, & - -0.77183416481005e+01_dp], dof_uuu = [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & - -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, -0.15815242579643e-01_dp, & - 0.26112640061855e-01_dp, -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] - REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: cof_fff = [0.12503100000000e+01_dp, & - 0.86821000000000e+00_dp, 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & - 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, 0.27145000000000e+00_dp, & - 0.14814000000000e+00_dp, 0.48550000000000e-01_dp, 0.00000000000000e+00_dp], cof_phi = [ & - 0.69299400000000e+01_dp, -0.43995000000000e+00_dp, -0.17012300000000e+01_dp, & - -0.16247300000000e+01_dp, -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & - -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, -0.96100000000000e-02_dp, & - 0.00000000000000e+00_dp] - REAL(KIND=dp), DIMENSION(0:9), PARAMETER :: dof_fff = [0.27904652711432e+02_dp, & - -0.45230754228635e+01_dp, 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & - -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, -0.50891685571587e+00_dp, & - 0.66278396115427e+00_dp, 0.73976101109878e+00_dp, 0.25795319944506e+01_dp], dof_phi = [ & - 0.16533229480429e+03_dp, 0.39415410391417e+02_dp, 0.68710036300407e+01_dp, & - 0.53406950884203e+01_dp, 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & - -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, -0.40087646318907e-01_dp, & - -0.23942617684055e+00_dp] - REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp, & - h2sixth_ggg = 1.10221225156463e-002_dp, h2sixth_phi = 1.85185185185185e-002_dp, & - h2sixth_rho = 6.66666666666667e-003_dp, h2sixth_uuu = 0.318679429600340e0_dp, & - hi_fff = 4.50000000000e0_dp, hi_ggg = 3.88858644327663e0_dp, hi_phi = 3.00000000000e0_dp, & - hi_rho = 5.00000000000e0_dp, hi_uuu = 0.723181585730594e0_dp, & - hsixth_fff = 3.70370370370370e-002_dp, hsixth_ggg = 4.28604761904762e-002_dp, & - hsixth_phi = 5.55555555555556e-002_dp, hsixth_rho = 3.33333333333333e-002_dp, & - hsixth_uuu = 0.230463095238095e0_dp - REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp, tmax_ggg = 0.8001400e+00_dp, & - tmax_phi = 0.4500000e+01_dp, tmax_rho = 0.3500000e+01_dp, tmax_uuu = 0.7908520e+01_dp, & - tmin_fff = 0.1500000e+01_dp, tmin_ggg = -0.1000000e+01_dp, tmin_phi = 0.1500000e+01_dp, & - tmin_rho = 0.1500000e+01_dp, tmin_uuu = -0.1770930e+01_dp + DIMENSION lsta(2, nat), lstb(nnbrx*nat), rel(5, nnbrx*nat), txyz(3, nat) + DIMENSION f2ij(3, npjx), f3ij(3, npjkx), f3ik(3, npjkx) + REAL(KIND=dp), PARAMETER :: tmin_phi = 0.1500000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_phi = 0.4500000e+01_dp + REAL(KIND=dp), PARAMETER :: hi_phi = 3.00000000000e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_phi = 5.55555555555556e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_phi = 1.85185185185185e-002_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_phi = & + [0.69299400000000e+01_dp, -0.43995000000000e+00_dp, & + -0.17012300000000e+01_dp, -0.16247300000000e+01_dp, & + -0.99696000000000e+00_dp, -0.27391000000000e+00_dp, & + -0.24990000000000e-01_dp, -0.17840000000000e-01_dp, & + -0.96100000000000e-02_dp, 0.00000000000000e+00_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_phi = & + [0.16533229480429e+03_dp, 0.39415410391417e+02_dp, & + 0.68710036300407e+01_dp, 0.53406950884203e+01_dp, & + 0.15347960162782e+01_dp, -0.63347591535331e+01_dp, & + -0.17987794021458e+01_dp, 0.47429676211617e+00_dp, & + -0.40087646318907e-01_dp, -0.23942617684055e+00_dp] + REAL(KIND=dp), PARAMETER :: tmin_rho = 0.1500000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_rho = 0.3500000e+01_dp + REAL(KIND=dp), PARAMETER :: hi_rho = 5.00000000000e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_rho = 3.33333333333333e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_rho = 6.66666666666667e-003_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: cof_rho = & + [0.13747000000000e+00_dp, -0.14831000000000e+00_dp, & + -0.55972000000000e+00_dp, -0.73110000000000e+00_dp, & + -0.76283000000000e+00_dp, -0.72918000000000e+00_dp, & + -0.66620000000000e+00_dp, -0.57328000000000e+00_dp, & + -0.40690000000000e+00_dp, -0.16662000000000e+00_dp, & + 0.00000000000000e+00_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:10) :: dof_rho = & + [-0.32275496741918e+01_dp, -0.64119006516165e+01_dp, & + 0.10030652280658e+02_dp, 0.22937915289857e+01_dp, & + 0.17416816033995e+01_dp, 0.54648205741626e+00_dp, & + 0.47189016693543e+00_dp, 0.20569572748420e+01_dp, & + 0.23192807336964e+01_dp, -0.24908020962757e+00_dp, & + -0.12371959895186e+02_dp] + REAL(KIND=dp), PARAMETER :: tmin_fff = 0.1500000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_fff = 0.3500000e+01_dp + REAL(KIND=dp), PARAMETER :: hi_fff = 4.50000000000e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_fff = 3.70370370370370e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_fff = 8.23045267489712e-003_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: cof_fff = & + [0.12503100000000e+01_dp, 0.86821000000000e+00_dp, & + 0.60846000000000e+00_dp, 0.48756000000000e+00_dp, & + 0.44163000000000e+00_dp, 0.37610000000000e+00_dp, & + 0.27145000000000e+00_dp, 0.14814000000000e+00_dp, & + 0.48550000000000e-01_dp, 0.00000000000000e+00_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:9) :: dof_fff = & + [0.27904652711432e+02_dp, -0.45230754228635e+01_dp, & + 0.50531739800222e+01_dp, 0.11806545027747e+01_dp, & + -0.66693699112098e+00_dp, -0.89430653829079e+00_dp, & + -0.50891685571587e+00_dp, 0.66278396115427e+00_dp, & + 0.73976101109878e+00_dp, 0.25795319944506e+01_dp] + REAL(KIND=dp), PARAMETER :: tmin_uuu = -0.1770930e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_uuu = 0.7908520e+01_dp + REAL(KIND=dp), PARAMETER :: hi_uuu = 0.723181585730594e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_uuu = 0.230463095238095e0_dp + REAL(KIND=dp), PARAMETER :: h2sixth_uuu = 0.318679429600340e0_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_uuu = & + [-0.10749300000000e+01_dp, -0.20045000000000e+00_dp, & + 0.41422000000000e+00_dp, 0.87939000000000e+00_dp, & + 0.12668900000000e+01_dp, 0.16299800000000e+01_dp, & + 0.19773800000000e+01_dp, 0.23961800000000e+01_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_uuu = & + [-0.14827125747284e+00_dp, -0.14922155328475e+00_dp, & + -0.70113224223509e-01_dp, -0.39449020349230e-01_dp, & + -0.15815242579643e-01_dp, 0.26112640061855e-01_dp, & + -0.13786974745095e+00_dp, 0.74941595372657e+00_dp] + REAL(KIND=dp), PARAMETER :: tmin_ggg = -0.1000000e+01_dp + REAL(KIND=dp), PARAMETER :: tmax_ggg = 0.8001400e+00_dp + REAL(KIND=dp), PARAMETER :: hi_ggg = 3.88858644327663e0_dp + REAL(KIND=dp), PARAMETER :: hsixth_ggg = 4.28604761904762e-002_dp + REAL(KIND=dp), PARAMETER :: h2sixth_ggg = 1.10221225156463e-002_dp + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: cof_ggg = & + [0.52541600000000e+01_dp, 0.23591500000000e+01_dp, & + 0.11959500000000e+01_dp, 0.12299500000000e+01_dp, & + 0.20356500000000e+01_dp, 0.34247400000000e+01_dp, & + 0.49485900000000e+01_dp, 0.56179900000000e+01_dp] + REAL(KIND=dp), PARAMETER, DIMENSION(0:7) :: dof_ggg = & + [0.15826876132396e+02_dp, 0.31176239377907e+02_dp, & + 0.16589446539683e+02_dp, 0.11083892500520e+02_dp, & + 0.90887216383860e+01_dp, 0.54902279653967e+01_dp, & + -0.18823313223755e+02_dp, -0.77183416481005e+01_dp] - INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, & - khi_fff, khi_ggg, klo_fff, klo_ggg - REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, b_ggg, cof1_fff, & - cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, & - cof_fff_klo, cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, dens2, dens3, & - dof_fff_khi, dof_fff_klo, dof_ggg_khi, dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, & - ep_uuu, fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, gjik, gjikp, rho, rhop, & - rij, rik, sij, sik, t1, t2, t3, t4, tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, & - ypt2_fff, ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg + REAL(KIND=dp) :: a2_fff, a2_ggg, a_fff, a_ggg, b2_fff, b2_ggg, b_fff, & + b_ggg, cof1_fff, cof1_ggg, cof2_fff, cof2_ggg, cof3_fff, & + cof3_ggg, cof4_fff, cof4_ggg, cof_fff_khi, cof_fff_klo, & + cof_ggg_khi, cof_ggg_klo, coord_iat, costheta, dens, & + dens2, dens3, dof_fff_khi, dof_fff_klo, dof_ggg_khi, & + dof_ggg_klo, e_phi, e_uuu, ener_iat, ep_phi, ep_uuu, & + fij, fijp, fik, fikp, fxij, fxik, fyij, fyik, fzij, fzik, & + gjik, gjikp, rho, rhop, rij, rik, sij, sik, t1, t2, t3, t4, & + tt, tt_fff, tt_ggg, xarg, ypt1_fff, ypt1_ggg, ypt2_fff, & + ypt2_ggg, yt1_fff, yt1_ggg, yt2_fff, yt2_ggg + + INTEGER :: iat, jat, jbr, jcnt, jkcnt, kat, kbr, khi_fff, khi_ggg, & + klo_fff, klo_ggg ! initialize temporary private scalars for reduction sum on energies and ! private workarray txyz for forces forces @@ -3153,13 +3211,16 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) - INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(KIND=dp) :: rxyz + INTEGER :: icell, lstb, lay + REAL(KIND=dp) :: rel, cut2 INTEGER :: indlst - INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + DIMENSION rxyz(3, nn), lay(nn), icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), & + lstb(0:myspace - 1), rel(5, 0:myspace - 1) + + INTEGER :: jat, jj, k1, k2, k3 + REAL(KIND=dp) :: rr2, tt, xrel, yrel, zrel, tti loop_k3: DO k3 = l3 - 1, l3 + 1 loop_k2: DO k2 = l2 - 1, l2 + 1 @@ -3207,14 +3268,14 @@ CONTAINS !> \param yp ... ! ************************************************************************************************** SUBROUTINE splint(ya, y2a, tmin, tmax, hsixth, h2sixth, hi, n, x, y, yp) - REAL(KIND=dp) :: tmin, tmax, hsixth, h2sixth, hi + REAL(KIND=dp) :: ya, y2a, tmin, tmax, hsixth, h2sixth, hi INTEGER :: n - REAL(KIND=dp) :: y2a(0:n - 1), ya(0:n - 1), x, y, yp + REAL(KIND=dp) :: x, y, yp - INTEGER :: khi, klo - REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, & - tt, y2a_khi, y2a_klo, ya_khi, ya_klo, & - ypt1, ypt2, yt1, yt2 + DIMENSION y2a(0:n - 1), ya(0:n - 1) + REAL(KIND=dp) :: a, a2, b, b2, cof1, cof2, cof3, cof4, tt, & + y2a_khi, ya_klo, y2a_klo, ya_khi, ypt1, ypt2, yt1, yt2 + INTEGER :: klo, khi ! interpolate if the argument is outside the cubic spline interval [tmin,tmax] tt = (x - tmin)*hi @@ -3295,15 +3356,15 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV -! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, -! needs to be initialized to 0._dp before calling this routine for the first time +! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, real(8) : total potential energy, 2-body and 3-body, in eV +! count, real(8) : increased by 1.d0 at each call of this subroutine, +! needs to be initialized to 0.d0 before calling this routine for the first time ! ! Other variables: ! p: the 2-body potential energy @@ -3316,12 +3377,9 @@ CONTAINS !***************************************************************************************** INTEGER :: nat - REAL(dp) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & + REAL(8) :: alat(3), rxyz0(3, nat), fxyz(3, nat), & etot, count - REAL(KIND=dp), PARAMETER :: eps = 2.167239428587_dp, ra = 1.8_dp, & - sigma = 2.0951_dp - INTEGER :: i, iam, iat, ii, il, in, indlst, & indlstx, ipb, l1, l2, l3, laymx, ll1, & ll2, ll3, myspace, myspaceout, ncx, & @@ -3329,14 +3387,18 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:) :: lay, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(dp) :: cut, cut2, esigma, fx(nat), fx3(nat), & - fy(nat), fy3(nat), fz(nat), fz3(nat), & - isigma, p, p3, pv3, rlc1i, rlc2i, rlc3i - REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(8) :: cut, cut2, eps, esigma, fx(nat), & + fx3(nat), fy(nat), fy3(nat), fz(nat), & + fz3(nat), isigma, p, p3, pv3, ra, & + rlc1i, rlc2i, rlc3i, sigma + REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - count = count + 1._dp - cut = sigma*ra*2._dp - isigma = 1._dp/sigma + PARAMETER(ra=1.8d0) + PARAMETER(sigma=2.0951d0, eps=2.167239428587d0) + + count = count + 1.d0 + cut = sigma*ra*2.d0 + isigma = 1.d0/sigma esigma = eps*isigma ! linear scaling calculation of verlet list, only serial @@ -3810,15 +3872,15 @@ CONTAINS !start energy and force calculation------------------------------------------------------- !set all variables to zero - p = 0.0_dp - p3 = 0.0_dp - pv3 = 0.0_dp - fx(:) = 0.0_dp - fy(:) = 0.0_dp - fz(:) = 0.0_dp - fx3(:) = 0.0_dp - fy3(:) = 0.0_dp - fz3(:) = 0.0_dp + p = 0.0d0 + p3 = 0.0d0 + pv3 = 0.0d0 + fx(:) = 0.0d0 + fy(:) = 0.0d0 + fz(:) = 0.0d0 + fx3(:) = 0.0d0 + fy3(:) = 0.0d0 + fz3(:) = 0.0d0 !----------------------------------------------------------------------------------------- ! triple loop for the 2 and 3-body forces ! do 20 i @@ -3854,22 +3916,23 @@ CONTAINS !> \param c ... !> \return ... ! ************************************************************************************************** - REAL(KIND=dp) FUNCTION f(c) - REAL(KIND=dp) :: c + REAL(8) FUNCTION f(c) + REAL(8) :: c - REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & - bb = 0.6022245584_dp, ra = 1.8_dp + REAL(8) :: aa, bb, c4, crainv, ra - REAL(KIND=dp) :: c4, crainv + PARAMETER(aa=7.049556277d0) + PARAMETER(ra=1.8d0, bb=0.6022245584d0) - IF ((c - ra) < 0._dp) THEN - crainv = 1.0_dp/(c - ra) + IF ((c - ra) < 0.d0) THEN + crainv = 1.0d0/(c - ra) c4 = c*c*c*c - f = aa*bb*4.0_dp/(c4*c)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv + f = aa*bb*4.0d0/(c4*c)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv ELSE - f = 0._dp + f = 0.d0 END IF + RETURN END FUNCTION f ! ************************************************************************************************** @@ -3877,17 +3940,18 @@ CONTAINS !> \param d ... !> \return ... ! ************************************************************************************************** - REAL(KIND=dp) FUNCTION pe(d) - REAL(KIND=dp) :: d + REAL(8) FUNCTION pe(d) + REAL(8) :: d - REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & - bb = 0.6022245584_dp, ra = 1.8_dp + REAL(8), PARAMETER :: aa = 7.049556277d0, bb = 0.6022245584d0, & + ra = 1.8d0 - IF ((d - ra) < 0._dp) THEN - pe = aa*(bb/(d*d*d*d) - 1.0_dp)*EXP(1.0_dp/(d - ra)) + IF ((d - ra) < 0.d0) THEN + pe = aa*(bb/(d*d*d*d) - 1.0d0)*dexp(1.0d0/(d - ra)) ELSE - pe = 0._dp + pe = 0.d0 END IF + RETURN END FUNCTION pe !------------------------------------------------------------------------------------------ @@ -3917,13 +3981,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) + REAL(8) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(8) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + REAL(8) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -3940,7 +4004,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1._dp/tt + tti = 1.d0/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -3977,25 +4041,24 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE sw_subfeniat_l(i, nat, nnbrx, rel, p, p3, fx, fy, fz, fx3, fy3, fz3, lstb, lsta, isigma, sigma) INTEGER, INTENT(IN) :: i, nat, nnbrx - REAL(KIND=dp), INTENT(IN) :: rel(5, nnbrx*nat) - REAL(KIND=dp), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & + REAL(8), INTENT(IN) :: rel(5, nnbrx*nat) + REAL(8), INTENT(INOUT) :: p, p3, fx(nat), fy(nat), fz(nat), & fx3(nat), fy3(nat), fz3(nat) INTEGER, INTENT(IN) :: lstb(nnbrx*nat), lsta(2, nat) - REAL(KIND=dp), INTENT(IN) :: isigma, sigma - - REAL(KIND=dp), PARAMETER :: aa = 7.049556277_dp, & - bb = 0.6022245584_dp, gam = 1.2_dp, & - ra = 1.8_dp, ramda = 21.0_dp + REAL(8), INTENT(IN) :: isigma, sigma INTEGER :: Ipb, Ipe, j, k, l, m, nij - REAL(KIND=dp) :: c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, hi, & - hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, hiyik0, & - hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, hjxjk, & - hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, HJZIJ1, & - HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, hkyik0, & - hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, invrij, & - invrija, invrik, invrika, invrjk, invrjka, refi, refj, refk, rij, rija, rik - REAL(KIND=dp) :: rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk + REAL(8) :: aa, bb, c4, cosijk, cosijk3, cosikj, cosikj3, cosjik, cosjik3, crainv, force, & + gam, hi, hixij, hixij0, hixij1, hixik, hixik0, hixik1, hiyij, hiyij0, hiyij1, hiyik, & + hiyik0, hiyik1, HIZIJ, HIZIJ0, HIZIJ1, HIZIK, HIZIK0, HIZIK1, hj, hjxij, hjxij0, hjxij1, & + hjxjk, hjxjk0, hjxjk1, hjyij, hjyij0, hjyij1, hjyjk, hjyjk0, hjyjk1, HJZIJ, HJZIJ0, & + HJZIJ1, HJZJK, HJZJK0, HJZJK1, hk, hkxik, hkxik0, HKXIK1, hkxkj, hkxkj0, hkxkj1, hkyik, & + hkyik0, hkyik1, hkykj, hkykj0, hkykj1, HKZIK, HKZIK0, HKZIK1, HKZKJ, HKZKJ0, HKZKJ1, & + invrij, invrija, invrik, invrika, invrjk, invrjka, ra, ramda, refi, refj + REAL(8) :: refk, rij, rija, rik, rika, rjk, rjka, xij, xik, xjk, yij, yik, yjk, zij, zik, zjk + + PARAMETER(gam=1.2d0, ramda=21.0d0, aa=7.049556277d0) + PARAMETER(ra=1.8d0, bb=0.6022245584d0) Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -4010,11 +4073,11 @@ CONTAINS yij = rel(2, l)*rij zij = rel(3, l)*rij - IF (rij >= 2._dp*ra) CYCLE + IF (rij >= 2.d0*ra) CYCLE IF (rij < ra) THEN - crainv = 1.0_dp/(rij - ra) + crainv = 1.0d0/(rij - ra) c4 = rij*rij*rij*rij - force = aa*bb*4.0_dp/(c4*rij)*EXP(crainv) + aa*(bb/(c4) - 1.0_dp)*EXP(crainv)*crainv*crainv + force = aa*bb*4.0d0/(c4*rij)*dexp(crainv) + aa*(bb/(c4) - 1.0d0)*dexp(crainv)*crainv*crainv fx(i) = force*xij*invrij + fx(i) fy(i) = force*yij*invrij + fy(i) @@ -4024,7 +4087,7 @@ CONTAINS fy(j) = -force*yij*invrij + fy(j) fz(j) = -force*zij*invrij + fz(j) - p = p + aa*(bb/(rij*rij*rij*rij) - 1.0_dp)*EXP(1.0_dp/(rij - ra)) + p = p + aa*(bb/(rij*rij*rij*rij) - 1.0d0)*dexp(1.0d0/(rij - ra)) nij = 1 END IF @@ -4045,42 +4108,42 @@ CONTAINS zjk = zik - zij rjk = SQRT(xjk*xjk + yjk*yjk + zjk*zjk) - invrjk = 1._dp/rjk + invrjk = 1.d0/rjk IF ((rjk >= ra) .AND. (nij == 0)) CYCLE cosjik = (xij*xik + yij*yik + zij*zik)*(invrij*invrik) cosijk = (-xij*xjk - yij*yjk - zij*zjk)*(invrij*invrjk) cosikj = (xik*xjk + yik*yjk + zik*zjk)*(invrik*invrjk) - cosjik3 = cosjik + 1.0_dp/3.0_dp - cosijk3 = cosijk + 1.0_dp/3.0_dp - cosikj3 = cosikj + 1.0_dp/3.0_dp + cosjik3 = cosjik + 1.0d0/3.0d0 + cosijk3 = cosijk + 1.0d0/3.0d0 + cosikj3 = cosikj + 1.0d0/3.0d0 rija = rij - ra rika = rik - ra rjka = rjk - ra - invrija = 1._dp/rija - invrika = 1._dp/rika - invrjka = 1._dp/rjka + invrija = 1.d0/rija + invrika = 1.d0/rika + invrjka = 1.d0/rjka - IF (rija >= 0.0_dp) THEN - refi = 0.0_dp - refj = 0.0_dp + IF (rija >= 0.0d0) THEN + refi = 0.0d0 + refj = 0.0d0 refk = ramda*EXP(gam*invrika + gam*invrjka) - ELSE IF ((rija < 0.0_dp) .AND. (rika < 0.0_dp)) THEN - IF (rjka < 0.0_dp) THEN + ELSE IF ((rija < 0.0d0) .AND. (rika < 0.0d0)) THEN + IF (rjka < 0.0d0) THEN refi = ramda*EXP(gam*invrija + gam*invrika) refj = ramda*EXP(gam*invrija + gam*invrjka) refk = ramda*EXP(gam*invrika + gam*invrjka) ELSE refi = ramda*EXP(gam*invrija + gam*invrika) - refj = 0.0_dp - refk = 0.0_dp + refj = 0.0d0 + refk = 0.0d0 END IF - ELSE IF ((rija < 0.0_dp) .AND. (rjka < 0.0_dp)) THEN - refi = 0.0_dp + ELSE IF ((rija < 0.0d0) .AND. (rjka < 0.0d0)) THEN + refi = 0.0d0 refj = ramda*EXP(gam*invrija + gam*invrjka) - refk = 0.0_dp + refk = 0.0d0 ELSE CYCLE END IF @@ -4090,60 +4153,60 @@ CONTAINS hk = refk*cosikj3*cosikj3 p3 = p3 + hi + hj + hk - hixij0 = 2.0_dp*(xik*invrik - xij*cosjik*invrij) + hixij0 = 2.0d0*(xik*invrik - xij*cosjik*invrij) hixij1 = gam*xij*cosjik3*(invrija*invrija) hixij = refi*cosjik3*(hixij0 - hixij1)*invrij - hixik0 = 2.0_dp*(xij*invrij - xik*cosjik*invrik) + hixik0 = 2.0d0*(xij*invrij - xik*cosjik*invrik) hixik1 = gam*xik*cosjik3*(invrika*invrika) hixik = refi*cosjik3*(hixik0 - hixik1)*invrik - hjxij0 = 2.0_dp*(-xjk*invrjk - xij*cosijk*invrij) + hjxij0 = 2.0d0*(-xjk*invrjk - xij*cosijk*invrij) hjxij1 = gam*xij*cosijk3*(invrija*invrija) hjxij = refj*cosijk3*(hjxij0 - hjxij1)*invrij - hkxik0 = 2.0_dp*(xjk*invrjk - xik*cosikj*invrik) + hkxik0 = 2.0d0*(xjk*invrjk - xik*cosikj*invrik) hkxik1 = gam*xik*cosikj3*(invrika*invrika) hkxik = refk*cosikj3*(hkxik0 - hkxik1)*invrik - hjxjk0 = 2.0_dp*(-xij*invrij - xjk*cosijk*invrjk) + hjxjk0 = 2.0d0*(-xij*invrij - xjk*cosijk*invrjk) hjxjk1 = gam*xjk*cosijk3*(invrjka*invrjka) hjxjk = refj*cosijk3*(hjxjk0 - hjxjk1)*invrjk - hkxkj0 = 2.0_dp*(-xik*invrik + xjk*cosikj*invrjk) + hkxkj0 = 2.0d0*(-xik*invrik + xjk*cosikj*invrjk) hkxkj1 = gam*xjk*cosikj3*(invrjka*invrjka) hkxkj = refk*cosikj3*(hkxkj0 + hkxkj1)*invrjk - hiyij0 = 2.0_dp*(yik*invrik - yij*cosjik*invrij) + hiyij0 = 2.0d0*(yik*invrik - yij*cosjik*invrij) hiyij1 = gam*yij*cosjik3*(invrija*invrija) hiyij = refi*cosjik3*(hiyij0 - hiyij1)*invrij - hiyik0 = 2.0_dp*(yij*invrij - yik*cosjik*invrik) + hiyik0 = 2.0d0*(yij*invrij - yik*cosjik*invrik) hiyik1 = gam*yik*cosjik3*(invrika*invrika) hiyik = refi*cosjik3*(hiyik0 - hiyik1)*invrik - hjyij0 = 2.0_dp*(-yjk*invrjk - yij*cosijk*invrij) + hjyij0 = 2.0d0*(-yjk*invrjk - yij*cosijk*invrij) hjyij1 = gam*yij*cosijk3*(invrija*invrija) hjyij = refj*cosijk3*(hjyij0 - hjyij1)*invrij - hkyik0 = 2.0_dp*(yjk*invrjk - yik*cosikj*invrik) + hkyik0 = 2.0d0*(yjk*invrjk - yik*cosikj*invrik) hkyik1 = gam*yik*cosikj3*(invrika*invrika) hkyik = refk*cosikj3*(hkyik0 - hkyik1)*invrik - hjyjk0 = 2.0_dp*(-yij*invrij - yjk*cosijk*invrjk) + hjyjk0 = 2.0d0*(-yij*invrij - yjk*cosijk*invrjk) hjyjk1 = gam*yjk*cosijk3*(invrjka*invrjka) hjyjk = refj*cosijk3*(hjyjk0 - hjyjk1)*invrjk - hkykj0 = 2.0_dp*(-yik*invrik + yjk*cosikj*invrjk) + hkykj0 = 2.0d0*(-yik*invrik + yjk*cosikj*invrjk) hkykj1 = gam*yjk*cosikj3*(invrjka*invrjka) hkykj = refk*cosikj3*(hkykj0 + hkykj1)*invrjk - hizij0 = 2.0_dp*(zik*invrik - zij*cosjik*invrij) + hizij0 = 2.0d0*(zik*invrik - zij*cosjik*invrij) hizij1 = gam*zij*cosjik3*(invrija*invrija) hizij = refi*cosjik3*(hizij0 - hizij1)*invrij - hizik0 = 2.0_dp*(zij*invrij - zik*cosjik*invrik) + hizik0 = 2.0d0*(zij*invrij - zik*cosjik*invrik) hizik1 = gam*zik*cosjik3*(invrika*invrika) hizik = refi*cosjik3*(hizik0 - hizik1)*invrik - hjzij0 = 2.0_dp*(-zjk*invrjk - zij*cosijk*invrij) + hjzij0 = 2.0d0*(-zjk*invrjk - zij*cosijk*invrij) hjzij1 = gam*zij*cosijk3*(invrija*invrija) hjzij = refj*cosijk3*(hjzij0 - hjzij1)*invrij - hkzik0 = 2.0_dp*(zjk*invrjk - zik*cosikj*invrik) + hkzik0 = 2.0d0*(zjk*invrjk - zik*cosikj*invrik) hkzik1 = gam*zik*cosikj3*(invrika*invrika) hkzik = refk*cosikj3*(hkzik0 - hkzik1)*invrik - hjzjk0 = 2.0_dp*(-zij*invrij - zjk*cosijk*invrjk) + hjzjk0 = 2.0d0*(-zij*invrij - zjk*cosijk*invrjk) hjzjk1 = gam*zjk*cosijk3*(invrjka*invrjka) hjzjk = refj*cosijk3*(hjzjk0 - hjzjk1)*invrjk - hkzkj0 = 2.0_dp*(-zik*invrik + zjk*cosikj*invrjk) + hkzkj0 = 2.0d0*(-zik*invrik + zjk*cosikj*invrjk) hkzkj1 = gam*zjk*cosikj3*(invrjka*invrjka) hkzkj = refk*cosikj3*(hkzkj0 + hkzkj1)*invrjk @@ -4188,32 +4251,32 @@ CONTAINS ! ! Input: ! nat, integer: the number of atoms -! alat, REAL(KIND=dp), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied +! alat, real(8), dim(3) : the three edges of the orthoromic simulation cell, periodic boundaries are applied ! and atoms outside the cell will be brought back into the box -! rxyz, REAL(KIND=dp), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem +! rxyz, real(8), dim(3,nat) : the xyz cartesian components of the atomic positions in Angstroem ! ! Output: -! fxyz, REAL(KIND=dp), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A -! etot, REAL(KIND=dp) : total potential energy, 2-body and 3-body, in eV -! count, REAL(KIND=dp) : increased by 1._dp at each call of this subroutine, -! needs to be initialized to 0._dp before calling this routine for the first time +! fxyz, real(8), dim(3,nat): the xyz cartesian forces in on the corresponding atomic components n eV/A +! etot, real(8) : total potential energy, 2-body and 3-body, in eV +! count, real(8) : increased by 1.d0 at each call of this subroutine, +! needs to be initialized to 0.d0 before calling this routine for the first time !***************************************************************************************** INTEGER :: nat - REAL(KIND=dp) :: alat(3), rxyz(3, nat), fxyz(3, nat), & + REAL(8) :: alat(3), rxyz(3, nat), fxyz(3, nat), & etot, count INTEGER :: iat, NNmax, Npmax INTEGER, ALLOCATABLE, DIMENSION(:) :: Kinds, lstb INTEGER, ALLOCATABLE, DIMENSION(:, :) :: lsta - REAL(KIND=dp) :: Uatot, Urtot, xbox, ybox, zbox - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf - REAL(KIND=dp), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn - REAL(KIND=dp), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X + REAL(8) :: Uatot, Urtot, xbox, ybox, zbox + REAL(8), ALLOCATABLE, DIMENSION(:) :: dkEij, UadUrdf, XYZRrefdf + REAL(8), DIMENSION(1:2) :: bcsq, Co_bcd, dsq, h, Pmass, Pn + REAL(8), DIMENSION(1:2, 1:2) :: ala, alr, Ca, Cr, R1, R2, X INTEGER:: nnbrx, nnbrxt INTEGER :: i - count = count + 1._dp + count = count + 1.d0 DO iat = 1, nat rxyz(1, iat) = MODULO(MODULO(rxyz(1, iat), alat(1)), alat(1)) @@ -4233,7 +4296,7 @@ CONTAINS DO i = 1, nat kinds(i) = 2 !Since all atoms are Si, all of kind 2 END DO - fxyz = 0.0_dp + fxyz = 0.0d0 xbox = alat(1); ybox = alat(2); zbox = alat(3) CALL tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) CALL tersoff_pairlist_energy_forces(nat, Npmax, NNmax, xbox, ybox, zbox, Kinds, rxyz, R1, R2, Cr, & @@ -4261,15 +4324,14 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE tersoff_parameters(R1, R2, Cr, Ca, alr, ala, X, Pn, Co_bcd, bcsq, dsq, h, Pmass) - REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X - REAL(KIND=dp), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass + REAL(8), DIMENSION(1:2, 1:2), INTENT(out) :: R1, R2, Cr, Ca, alr, ala, X + REAL(8), DIMENSION(1:2), INTENT(out) :: Pn, Co_bcd, bcsq, dsq, h, Pmass - REAL(KIND=dp), PARAMETER :: C_ala = 2.2119_dp, C_alr = 3.4879_dp, C_b = 1.5724e-7_dp, & - C_c = 3.8049e4_dp, C_Ca = 3.4674e2_dp, C_Cr = 1.3936e3_dp, C_d = 4.3484_dp, & - C_h = -5.7058e-1_dp, C_mass = 12.0_dp, C_n = 7.2751e-1_dp, C_R1 = 1.8_dp, C_R2 = 2.1_dp, & - Si_ala = 1.7322_dp, Si_alr = 2.4799_dp, Si_b = 1.1000e-6_dp, Si_c = 1.0039e5_dp, & - Si_Ca = 4.7118e2_dp, Si_Cr = 1.8308e3_dp, Si_d = 1.6217e1_dp, Si_h = -5.9825e-1_dp, & - Si_mass = 28.0855_dp, Si_n = 7.8734e-1_dp, Si_R1 = 2.7_dp, Si_R2 = 3.3_dp + REAL(8), PARAMETER :: C_ala = 2.2119d0, C_alr = 3.4879d0, C_b = 1.5724d-7, C_c = 3.8049d4, & + C_Ca = 3.4674d2, C_Cr = 1.3936d3, C_d = 4.3484d0, C_h = -5.7058d-1, C_mass = 12.0d0, & + C_n = 7.2751d-1, C_R1 = 1.8d0, C_R2 = 2.1d0, Si_ala = 1.7322d0, Si_alr = 2.4799d0, & + Si_b = 1.1000d-6, Si_c = 1.0039d5, Si_Ca = 4.7118d2, Si_Cr = 1.8308d3, Si_d = 1.6217d1, & + Si_h = -5.9825d-1, Si_mass = 28.0855d0, Si_n = 7.8734d-1, Si_R1 = 2.7d0, Si_R2 = 3.3d0 !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version @@ -4283,48 +4345,48 @@ CONTAINS !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version !Parameter for carbon, not used in this version -!Increased Cutoff, originally 3.0_dp +!Increased Cutoff, originally 3.0d0 Cr(1, 1) = C_Cr Cr(2, 2) = Si_Cr - Cr(1, 2) = SQRT(Cr(1, 1)*Cr(2, 2)) + Cr(1, 2) = dsqrt(Cr(1, 1)*Cr(2, 2)) Cr(2, 1) = Cr(1, 2) Ca(1, 1) = C_Ca Ca(2, 2) = Si_Ca - Ca(1, 2) = SQRT(Ca(1, 1)*Ca(2, 2)) + Ca(1, 2) = dsqrt(Ca(1, 1)*Ca(2, 2)) Ca(2, 1) = Ca(1, 2) R1(1, 1) = C_R1 R1(2, 2) = Si_R1 - R1(1, 2) = SQRT(R1(1, 1)*R1(2, 2)) + R1(1, 2) = dsqrt(R1(1, 1)*R1(2, 2)) R1(2, 1) = R1(1, 2) R2(1, 1) = C_R2 R2(2, 2) = Si_R2 - R2(1, 2) = SQRT(R2(1, 1)*R2(2, 2)) + R2(1, 2) = dsqrt(R2(1, 1)*R2(2, 2)) R2(2, 1) = R2(1, 2) - X(1, 1) = 1.0_dp - X(2, 2) = 1.0_dp - X(1, 2) = 0.9776_dp - X(2, 1) = 0.9776_dp + X(1, 1) = 1.0d0 + X(2, 2) = 1.0d0 + X(1, 2) = 0.9776d0 + X(2, 1) = 0.9776d0 alr(1, 1) = C_alr alr(2, 2) = Si_alr - alr(1, 2) = 0.5_dp*(alr(1, 1) + alr(2, 2)) + alr(1, 2) = 0.5d0*(alr(1, 1) + alr(2, 2)) alr(2, 1) = alr(1, 2) ala(1, 1) = C_ala ala(2, 2) = Si_ala - ala(1, 2) = 0.5_dp*(ala(1, 1) + ala(2, 2)) + ala(1, 2) = 0.5d0*(ala(1, 1) + ala(2, 2)) ala(2, 1) = ala(1, 2) Pn(1) = C_n Pn(2) = Si_n - Co_bcd(1) = C_b*(1.0_dp + C_c*C_c/(C_d*C_d)) - Co_bcd(2) = Si_b*(1.0_dp + Si_c*Si_c/(Si_d*Si_d)) + Co_bcd(1) = C_b*(1.0d0 + C_c*C_c/(C_d*C_d)) + Co_bcd(2) = Si_b*(1.0d0 + Si_c*Si_c/(Si_d*Si_d)) bcsq(1) = C_b*C_c*C_c bcsq(2) = Si_b*Si_c*Si_c @@ -4377,32 +4439,35 @@ CONTAINS XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, & Pn, Co_bcd, bcsq, dsq, h, F, Uatot, dkEij) INTEGER, INTENT(in) :: Nmol, Npmax, NNmax - REAL(KIND=dp), INTENT(in) :: xbox, ybox, zbox + REAL(8), INTENT(in) :: xbox, ybox, zbox INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(in) :: R - REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X - REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf - REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf - REAL(KIND=dp), INTENT(out) :: Urtot + REAL(8), DIMENSION(1:3*Nmol), INTENT(in) :: R + REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: R1, R2, Cr, Ca, alr, ala, X + REAL(8), DIMENSION(1:6*Npmax), INTENT(out) :: XYZRrefdf + REAL(8), DIMENSION(1:3*Npmax), INTENT(out) :: UadUrdf + REAL(8), INTENT(out) :: Urtot INTEGER :: lsta(2, Nmol) INTEGER, INTENT(inout) :: nnbrx INTEGER :: lstb(nnbrx*Nmol) - REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(out) :: F - REAL(KIND=dp), INTENT(out) :: Uatot - REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij + REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(8), DIMENSION(1:3*Nmol), INTENT(out) :: F + REAL(8), INTENT(out) :: Uatot + REAL(8), DIMENSION(1:3*NNmax) :: dkEij INTEGER :: i, iam, iat, ii, il, in, indlst, indlstx, Ipb, istopg, jat, l1, l2, l3, laymx, & ll1, ll2, ll3, myspace, myspaceout, nat, ncx, ndat, nn, npjkx, npjx, npr, Nptot INTEGER, ALLOCATABLE, DIMENSION(:) :: lay INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: icell - REAL(KIND=dp) :: alat(3), cut, cut2, rlc1i, rlc2i, rlc3i, & - rxyz0(3, Nmol), xhalf, yhalf, zhalf - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz + REAL(8) :: alat(3), cut, cut2, pi, rlc1i, rlc2i, & + rlc3i, rxyz0(3, Nmol), xhalf, yhalf, & + zhalf + REAL(8), ALLOCATABLE, DIMENSION(:, :) :: rel, rxyz - xhalf = 0.5_dp*xbox - yhalf = 0.5_dp*ybox - zhalf = 0.5_dp*zbox + pi = dacos(-1.0d0) + + xhalf = 0.5d0*xbox + yhalf = 0.5d0*ybox + zhalf = 0.5d0*zbox nat = Nmol @@ -4885,28 +4950,29 @@ CONTAINS istopg = 0 !end of creating pairlist part------------------------------------------------------------ !Energy----------------------------------------------------------------------------------- - Urtot = 0.0_dp + Urtot = 0.0d0 Nptot = 0 - F = 0.0_dp - Uatot = 0.0_dp + F = 0.0d0 + Uatot = 0.0d0 DO_I: DO i = 1, Nmol - CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) + CALL tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel, pi) END DO DO_I - Urtot = 0.5_dp*Urtot + Urtot = 0.5d0*Urtot !Force------------------------------------------------------------------------------------ - F = 0.0_dp - Uatot = 0.0_dp + F = 0.0d0 + Uatot = 0.0d0 DO_If: DO i = 1, Nmol CALL tersoff_subfiat_l(i,Nmol,Npmax,NNmax,Kinds,Pn,Co_bcd,bcsq,dsq,h,XYZRrefdf,UadUrdf,F,Uatot,dkEij,lsta,lstb,nnbrx) END DO DO_If - F = 0.5_dp*F - Uatot = 0.5_dp*Uatot + F = 0.5d0*F + Uatot = 0.5d0*Uatot !----------------------------------------------------------------------------------------- DEALLOCATE (rxyz, icell, lay, rel) + RETURN END SUBROUTINE tersoff_pairlist_energy_forces !----------------------------------------------------------------------------------------- @@ -4936,13 +5002,13 @@ CONTAINS ! the relative position rel of iat with respect to these neighbours INTEGER :: iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, & myspace - REAL(KIND=dp) :: rxyz(3, nn) + REAL(8) :: rxyz(3, nn) INTEGER :: icell(0:ncx, -1:ll1, -1:ll2, -1:ll3), lstb(0:myspace - 1), lay(nn) - REAL(KIND=dp) :: rel(5, 0:myspace - 1), cut2 + REAL(8) :: rel(5, 0:myspace - 1), cut2 INTEGER :: indlst INTEGER :: jat, jj, k1, k2, k3 - REAL(KIND=dp) :: rr2, tt, tti, xrel, yrel, zrel + REAL(8) :: rr2, tt, tti, xrel, yrel, zrel DO k3 = l3 - 1, l3 + 1 DO k2 = l2 - 1, l2 + 1 @@ -4959,7 +5025,7 @@ CONTAINS lstb(indlst) = lay(jat) ! write(6,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) tt = SQRT(rr2) - tti = 1._dp/tt + tti = 1.d0/tt rel(1, indlst) = xrel*tti rel(2, indlst) = yrel*tti rel(3, indlst) = zrel*tti @@ -4995,20 +5061,22 @@ CONTAINS !> \param lstb ... !> \param nnbrx ... !> \param rel ... +!> \param pi ... ! ************************************************************************************************** -SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala, XYZRrefdf, UadUrdf, Urtot, lsta, lstb, nnbrx, rel) + SUBROUTINE tersoff_subeniat_l(i,Nmol,Npmax,Kinds,X,R1,R2,Cr,Ca,alr,ala,XYZRrefdf,UadUrdf,Urtot,lsta,lstb,nnbrx,rel,pi) INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(KIND=dp), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala - REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf - REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf - REAL(KIND=dp), INTENT(inout) :: Urtot + REAL(8), DIMENSION(1:2, 1:2), INTENT(in) :: X, R1, R2, Cr, Ca, alr, ala + REAL(8), DIMENSION(1:6*Npmax), INTENT(inout) :: XYZRrefdf + REAL(8), DIMENSION(1:3*Npmax), INTENT(inout) :: UadUrdf + REAL(8), INTENT(inout) :: Urtot INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) - REAL(KIND=dp), INTENT(in) :: rel(5, nnbrx*Nmol) + REAL(8), INTENT(in) :: rel(5, nnbrx*Nmol) + REAL(8) :: pi INTEGER :: j, Ki, Kj, l, Nppt3, Nppt6, Nptot - REAL(KIND=dp) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & + REAL(8) :: alaij, alrij, dfij, fij, PL1, PL2, R1ij, & R2ij, Rij, Rreij, Ua, Ur, Xij, Yij, Zij ! ####################################### @@ -5039,13 +5107,13 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala alrij = alr(Ki, Kj) alaij = ala(Ki, Kj) - Ur = Cr(Ki, Kj)*EXP(-alrij*Rij) - Ua = -Ca(Ki, Kj)*EXP(-alaij*Rij)*X(Ki, Kj) + Ur = Cr(Ki, Kj)*dexp(-alrij*Rij) + Ua = -Ca(Ki, Kj)*dexp(-alaij*Rij)*X(Ki, Kj) R1ij = R1(Ki, Kj) IF (Rij <= R1ij) THEN - XYZRrefdf(Nppt6 + 5) = 1.0_dp - XYZRrefdf(Nppt6 + 6) = 0.0_dp + XYZRrefdf(Nppt6 + 5) = 1.0d0 + XYZRrefdf(Nppt6 + 6) = 0.0d0 Urtot = Urtot + Ur UadUrdf(Nppt3 + 1) = Ua UadUrdf(Nppt3 + 2) = -alrij*Ur @@ -5053,8 +5121,8 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala ELSE PL1 = pi/(R2ij - R1ij) PL2 = PL1*(Rij - R1ij) - fij = 0.5_dp + 0.5_dp*COS(PL2) - dfij = -0.5_dp*PL1*SIN(PL2) + fij = 0.5d0 + 0.5d0*dcos(PL2) + dfij = -0.5d0*PL1*dsin(PL2) XYZRrefdf(Nppt6 + 5) = fij XYZRrefdf(Nppt6 + 6) = dfij Urtot = Urtot + fij*Ur @@ -5090,20 +5158,20 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala INTEGER :: i INTEGER, INTENT(in) :: Nmol, Npmax, NNmax INTEGER, DIMENSION(1:Nmol), INTENT(in) :: Kinds - REAL(KIND=dp), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h - REAL(KIND=dp), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf - REAL(KIND=dp), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf - REAL(KIND=dp), DIMENSION(1:3*Nmol), INTENT(inout) :: F - REAL(KIND=dp), INTENT(inout) :: Uatot - REAL(KIND=dp), DIMENSION(1:3*NNmax) :: dkEij + REAL(8), DIMENSION(1:2), INTENT(in) :: Pn, Co_bcd, bcsq, dsq, h + REAL(8), DIMENSION(1:6*Npmax), INTENT(in) :: XYZRrefdf + REAL(8), DIMENSION(1:3*Npmax), INTENT(in) :: UadUrdf + REAL(8), DIMENSION(1:3*Nmol), INTENT(inout) :: F + REAL(8), INTENT(inout) :: Uatot + REAL(8), DIMENSION(1:3*NNmax) :: dkEij INTEGER, INTENT(in) :: lsta(2, Nmol), nnbrx, lstb(nnbrx*Nmol) INTEGER :: ij, ijpt3, ijpt6, ik, ikpt6, Ipb, Ipe, & Ipt3, Jpt3, Ki, Kpt3, Nkpt3 - REAL(KIND=dp) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, & - Co_mb2, Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, & - dGi, djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, & - Rreij, Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik + REAL(8) :: bcsqi, Bij, Co1_dkEij, Co2_dkEij, Co_cdi, Co_dhcosi, Co_hcosi, Co_mb1, Co_mb2, & + Co_pa, COSijk, dfij, dfik, dFxi, dFxj, dFxk, dFyi, dFyj, dFyk, dFzi, dFzj, dFzk, dGi, & + djEij, dsqi, dXjEij2, dYjEij2, dZjEij2, Eij, fdG, fdGcos, fij, fik, Gi, hi, Pni, Rreij, & + Rreik, Ua, XRreij, XRreik, YRreij, YRreik, ZRreij, ZRreik Ipb = lsta(1, i) Ipe = lsta(2, i) @@ -5116,9 +5184,9 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala Co_cdi = Co_bcd(Ki) - dFxi = 0.0_dp - dFyi = 0.0_dp - dFzi = 0.0_dp + dFxi = 0.0d0 + dFyi = 0.0d0 + dFzi = 0.0d0 DO_J: DO ij = Ipb, Ipe, +1 @@ -5132,11 +5200,11 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala fij = XYZRrefdf(IJpt6 + 5) dfij = XYZRrefdf(IJpt6 + 6) - Eij = 0.0_dp - djEij = 0.0_dp - dXjEij2 = 0.0_dp - dYjEij2 = 0.0_dp - dZjEij2 = 0.0_dp + Eij = 0.0d0 + djEij = 0.0d0 + dXjEij2 = 0.0d0 + dYjEij2 = 0.0d0 + dZjEij2 = 0.0d0 Nkpt3 = -3 DO_K: DO ik = Ipb, Ipe, +1 @@ -5157,9 +5225,9 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala COSijk = XRreij*XRreik + YRreij*YRreik + ZRreij*ZRreik Co_hcosi = hi - COSijk - Co_dhcosi = 1.0_dp/(dsqi + Co_hcosi*Co_hcosi) + Co_dhcosi = 1.0d0/(dsqi + Co_hcosi*Co_hcosi) Gi = -bcsqi*Co_dhcosi - dGi = 2.0_dp*Co_hcosi*Co_dhcosi*Gi + dGi = 2.0d0*Co_hcosi*Co_dhcosi*Gi Gi = Gi + Co_cdi Eij = Eij + fik*Gi @@ -5181,22 +5249,22 @@ SUBROUTINE tersoff_subeniat_l(i, Nmol, Npmax, Kinds, X, R1, R2, Cr, Ca, alr, ala dkEij(Nkpt3 + 3) = Co1_dkEij*ZRreik + Co2_dkEij*ZRreij ELSE - dkEij(Nkpt3 + 1) = 0.0_dp - dkEij(Nkpt3 + 2) = 0.0_dp - dkEij(Nkpt3 + 3) = 0.0_dp + dkEij(Nkpt3 + 1) = 0.0d0 + dkEij(Nkpt3 + 2) = 0.0d0 + dkEij(Nkpt3 + 3) = 0.0d0 END IF IKIJ END DO DO_K - Bij = 1.0_dp + Eij**Pni - Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5_dp/Pni) + Bij = 1.0d0 + Eij**Pni + Ua = UadUrdf(IJpt3 + 1)*Bij**(-0.5d0/Pni) Uatot = Uatot + Ua - Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5_dp/Pni) + Co_pa = UadUrdf(IJpt3 + 2) + UadUrdf(IJpt3 + 3)*Bij**(-0.5d0/Pni) CEij: IF (Nkpt3 > 0) THEN - Co_mb1 = Ua*0.5_dp*Eij**(Pni - 1.0_dp)/Bij + Co_mb1 = Ua*0.5d0*Eij**(Pni - 1.0d0)/Bij Co_mb2 = Co_mb1*Rreij Nkpt3 = -3 diff --git a/src/emd/rt_bse_types.F b/src/emd/rt_bse_types.F index b9b647119f..7688b6c8d8 100644 --- a/src/emd/rt_bse_types.F +++ b/src/emd/rt_bse_types.F @@ -99,8 +99,7 @@ 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 @@ -146,7 +145,7 @@ MODULE rt_bse_types moments_field => NULL() INTEGER :: sim_step = 0, & sim_start = 0, & - ! Needed to continue runs by loading previous moments trace + ! Needed for continuation runs for loading of previous moments trace sim_start_orig = 0, & sim_nsteps = -1, & ! Default reference point type for output moments diff --git a/src/emd/rt_delta_pulse.F b/src/emd/rt_delta_pulse.F index f768c0abae..8bf9e04b2e 100644 --- a/src/emd/rt_delta_pulse.F +++ b/src/emd/rt_delta_pulse.F @@ -159,9 +159,8 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_old=mos_old, mos_new=mos_new) IF (rtp_control%apply_delta_pulse) THEN - IF (dft_control%qs_control%dftb) THEN + IF (dft_control%qs_control%dftb) & CALL build_dftb_overlap(qs_env, 1, matrix_s) - END IF IF (rtp_control%periodic) THEN IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T40))") & diff --git a/src/emd/rt_projection_mo_utils.F b/src/emd/rt_projection_mo_utils.F index 60ea2ff4aa..36e8080ca9 100644 --- a/src/emd/rt_projection_mo_utils.F +++ b/src/emd/rt_projection_mo_utils.F @@ -103,10 +103,9 @@ CONTAINS i_val=proj_mo%ref_nlumo) ! Relevent only in EMD - IF (.NOT. rtp_control%fixed_ions) THEN + IF (.NOT. rtp_control%fixed_ions) & CALL section_vals_val_get(proj_mo_section, "PROPAGATE_REF", i_rep_section=i_rep, & l_val=proj_mo%propagate_ref) - END IF ! If no reference .wfn is provided, using the restart SCF file: IF (proj_mo%ref_mo_file_name == "DEFAULT") THEN @@ -137,12 +136,11 @@ CONTAINS CALL section_vals_val_get(proj_mo_section, "TD_MO_SPIN", i_rep_section=i_rep, & i_val=proj_mo%td_mo_spin) - IF (proj_mo%td_mo_spin > SIZE(mos)) THEN + IF (proj_mo%td_mo_spin > SIZE(mos)) & CALL cp_abort(__LOCATION__, & "You asked to project the time dependent BETA spin while the "// & "real time DFT run has only one spin defined. "// & "Please set TD_MO_SPIN to 1 or use UKS.") - END IF CALL section_vals_val_get(proj_mo_section, "TD_MO_INDEX", i_rep_section=i_rep, & i_vals=tmp_ints) @@ -162,11 +160,10 @@ CONTAINS ALLOCATE (proj_mo%td_mo_occ(SIZE(proj_mo%td_mo_index))) proj_mo%td_mo_occ(:) = 0.0_dp DO j_td = 1, SIZE(proj_mo%td_mo_index) - IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) THEN + IF (proj_mo%td_mo_index(j_td) > nbr_mo_td_max) & CALL cp_abort(__LOCATION__, & "The MO number available in the Time Dependent run "// & "is smaller than the MO number you have required in TD_MO_INDEX.") - END IF proj_mo%td_mo_occ(j_td) = mos(proj_mo%td_mo_spin)%occupation_numbers(proj_mo%td_mo_index(j_td)) END DO END IF @@ -240,10 +237,9 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(proj_mo%ref_mo_file_name), exist=is_file) - IF (.NOT. is_file) THEN + IF (.NOT. is_file) & CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(proj_mo%ref_mo_file_name)) - END IF CALL open_file(file_name=proj_mo%ref_mo_file_name, & file_action="READ", & @@ -258,11 +254,10 @@ CONTAINS IF (para_env%is_source()) CALL close_file(unit_number=restart_unit) - IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) THEN + IF (proj_mo%ref_mo_spin > SIZE(mo_ref_temp)) & CALL cp_abort(__LOCATION__, & "Projection on spin BETA is not possible as the reference wavefunction "// & "only has one spin channel. Use a reference .wfn calculated with UKS/LSD, or set REF_MO_SPIN to 1") - END IF ! Store only the mos required nbr_mo_max = mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%ncol_global @@ -274,21 +269,19 @@ CONTAINS END DO ELSE DO i_ref = 1, SIZE(proj_mo%ref_mo_index) - IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) THEN + IF (proj_mo%ref_mo_index(i_ref) > nbr_mo_max) & CALL cp_abort(__LOCATION__, & "The number of MOs available in the reference wavefunction "// & "is smaller than the MO number you have requested in REF_MO_INDEX.") - END IF END DO END IF nbr_ref_mo = SIZE(proj_mo%ref_mo_index) - IF (nbr_ref_mo > nbr_mo_max) THEN + IF (nbr_ref_mo > nbr_mo_max) & CALL cp_abort(__LOCATION__, & "The total number of requested MOs is larger than what is available in the reference wavefunction. "// & "If you are trying to project onto virtual states, make sure they are included in the .wfn file "// & "e.g., by the ADDED_MOS keyword in the SCF section of the input when calculating your reference.") - END IF ! Store ALLOCATE (proj_mo%mo_ref(nbr_ref_mo)) @@ -297,16 +290,14 @@ CONTAINS nrow_global=mo_ref_temp(proj_mo%ref_mo_spin)%mo_coeff%matrix_struct%nrow_global, & ncol_global=1) - IF (dft_control%rtp_control%fixed_ions) THEN + IF (dft_control%rtp_control%fixed_ions) & CALL cp_fm_create(mo_coeff_temp, mo_ref_fmstruct, 'mo_ref') - END IF DO mo_index = 1, nbr_ref_mo real_mo_index = proj_mo%ref_mo_index(mo_index) - IF (real_mo_index > nbr_mo_max) THEN + IF (real_mo_index > nbr_mo_max) & CALL cp_abort(__LOCATION__, & "One of reference mo index is larger then the total number of available mo in the .wfn file.") - END IF ! fill with the reference mo values CALL cp_fm_create(proj_mo%mo_ref(mo_index), mo_ref_fmstruct, 'mo_ref') @@ -333,9 +324,8 @@ CONTAINS DEALLOCATE (mo_ref_temp) CALL cp_fm_struct_release(mo_ref_fmstruct) - IF (dft_control%rtp_control%fixed_ions) THEN + IF (dft_control%rtp_control%fixed_ions) & CALL cp_fm_release(mo_coeff_temp) - END IF END SUBROUTINE read_reference_mo_from_wfn @@ -382,9 +372,8 @@ CONTAINS ! Does not compute the projection if not the required time step IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & print_mo_section, ""), & - cp_p_file)) THEN + cp_p_file)) & RETURN - END IF IF (.NOT. dft_control%rtp_control%fixed_ions) THEN CALL get_qs_env(qs_env, & diff --git a/src/emd/rt_propagation_methods.F b/src/emd/rt_propagation_methods.F index 95cde86d30..fe656f3197 100644 --- a/src/emd/rt_propagation_methods.F +++ b/src/emd/rt_propagation_methods.F @@ -165,14 +165,12 @@ CONTAINS ! either in the lengh or velocity gauge. ! should be called after qs_energies_init and before qs_ks_update_qs_env IF (dft_control%apply_efield_field) THEN - IF (ANY(cell%perd(1:3) /= 0)) THEN + IF (ANY(cell%perd(1:3) /= 0)) & CPABORT("Length gauge (efield) and periodicity are not compatible") - END IF CALL efield_potential_lengh_gauge(qs_env) ELSE IF (rtp_control%velocity_gauge) THEN - IF (dft_control%apply_vector_potential) THEN + IF (dft_control%apply_vector_potential) & CALL update_vector_potential(qs_env, dft_control) - END IF CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) END IF @@ -410,9 +408,8 @@ CONTAINS DO i = 1, SIZE(exp_H_new) CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_new(i)%matrix, 0.0_dp, prefac) - IF (propagator == do_em) THEN + IF (propagator == do_em) & CALL dbcsr_add(propagator_matrix(i)%matrix, exp_H_old(i)%matrix, 1.0_dp, prefac) - END IF END DO CALL timestop(handle) diff --git a/src/emd/rt_propagation_output.F b/src/emd/rt_propagation_output.F index 8a78ff7660..1cee221fad 100644 --- a/src/emd/rt_propagation_output.F +++ b/src/emd/rt_propagation_output.F @@ -197,23 +197,19 @@ CONTAINS REAL(n_electrons, dp) WRITE (UNIT=output_unit, FMT="((T3,A,T59,F22.14))") & "Total energy:", rtp%energy_new - IF (run_type == ehrenfest) THEN + IF (run_type == ehrenfest) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old - END IF - IF (run_type == real_time_propagation) THEN + "Energy difference to previous iteration step:", rtp%energy_new - rtp%energy_old + IF (run_type == real_time_propagation) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,F20.14))") & - "Energy difference to initial state:", rtp%energy_new - rtp%energy_old - END IF - IF (PRESENT(delta_iter)) THEN + "Energy difference to initial state:", rtp%energy_new - rtp%energy_old + IF (PRESENT(delta_iter)) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,E20.6))") & - "Convergence:", delta_iter - END IF + "Convergence:", delta_iter IF (rtp%converged) THEN - IF (run_type == real_time_propagation) THEN + IF (run_type == real_time_propagation) & WRITE (UNIT=output_unit, FMT="((T3,A,T61,F12.2))") & - "Time needed for propagation:", used_time - END IF + "Time needed for propagation:", used_time WRITE (UNIT=output_unit, FMT="(/,(T3,A,3X,F16.14))") & "CONVERGENCE REACHED", rtp%energy_new - rtp%energy_old END IF @@ -224,25 +220,22 @@ CONTAINS CALL get_rtp(rtp=rtp, mos_new=mos_new) CALL rt_calculate_orthonormality(orthonormality, & mos_new, matrix_s(1)%matrix) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, FMT="(/,(T3,A,T60,F20.10))") & - "Max deviation from orthonormalization:", orthonormality - END IF + "Max deviation from orthonormalization:", orthonormality END IF END IF - IF (output_unit > 0) THEN + IF (output_unit > 0) & CALL m_flush(output_unit) - END IF CALL cp_print_key_finished_output(output_unit, logger, rtp_section, & "PRINT%PROGRAM_RUN_INFO") IF (rtp%converged) THEN dft_section => section_vals_get_subs_vals(input, "DFT") IF (BTEST(cp_print_key_should_output(logger%iter_info, & - dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) THEN + dft_section, "REAL_TIME_PROPAGATION%PRINT%FIELD"), cp_p_file)) & CALL print_field_applied(qs_env, dft_section) - END IF CALL make_moment(qs_env) IF (BTEST(cp_print_key_should_output(logger%iter_info, & dft_section, "REAL_TIME_PROPAGATION%PRINT%E_CONSTITUENTS"), cp_p_file)) THEN @@ -413,10 +406,9 @@ CONTAINS rtp%energy_old = rtp%energy_new - IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) THEN + IF (.NOT. rtp%converged .AND. rtp%iter >= dft_control%rtp_control%max_iter) & CALL cp_abort(__LOCATION__, "EMD did not converge, either increase MAX_ITER "// & "or use a smaller TIMESTEP") - END IF END SUBROUTINE rt_prop_output @@ -846,7 +838,7 @@ CONTAINS CHARACTER(len=14) :: ext CHARACTER(len=2) :: sdir INTEGER :: dir, handle, print_unit - INTEGER, DIMENSION(:), POINTER :: stride + INTEGER, DIMENSION(:), POINTER :: stride(:) LOGICAL :: mpi_io TYPE(cp_logger_type), POINTER :: logger TYPE(current_env_type) :: current_env @@ -894,7 +886,7 @@ CONTAINS IF (dir == 1) THEN sdir = "-x" - ELSE IF (dir == 2) THEN + ELSEIF (dir == 2) THEN sdir = "-y" ELSE sdir = "-z" diff --git a/src/emd/rt_propagation_utils.F b/src/emd/rt_propagation_utils.F index 431a2fefee..6e6997f20e 100644 --- a/src/emd/rt_propagation_utils.F +++ b/src/emd/rt_propagation_utils.F @@ -318,10 +318,9 @@ CONTAINS dft_section=dft_section) CALL set_uniform_occupation_mo_array(mo_array, nspin) - IF (dft_control%rtp_control%apply_wfn_mix_init_restart) THEN + IF (dft_control%rtp_control%apply_wfn_mix_init_restart) & CALL wfn_mix(mo_array, particle_set, dft_section, qs_kind_set, para_env, output_unit, & for_rtp=.TRUE.) - END IF DO ispin = 1, nspin CALL calculate_density_matrix(mo_array(ispin), p_rmpv(ispin)%matrix) @@ -424,9 +423,8 @@ CONTAINS DO mo = 1, mo_array(ispin)%nmo IF (mo_array(ispin)%occupation_numbers(mo) /= 0.0 .AND. & mo_array(ispin)%occupation_numbers(mo) /= 1.0 .AND. & - mo_array(ispin)%occupation_numbers(mo) /= 2.0) THEN + mo_array(ispin)%occupation_numbers(mo) /= 2.0) & is_uniform = .FALSE. - END IF END DO mo_array(ispin)%uniform_occupation = is_uniform END DO diff --git a/src/emd/rt_propagator_init.F b/src/emd/rt_propagator_init.F index 7d1cbfd570..69e42afdd0 100644 --- a/src/emd/rt_propagator_init.F +++ b/src/emd/rt_propagator_init.F @@ -161,7 +161,7 @@ CONTAINS DO imat = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(imat), mos_next(imat)) END DO - ELSE IF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN + ELSEIF (rtp_control%mat_exp == do_bch .OR. rtp_control%mat_exp == do_exact) THEN ELSE IF (rtp%linear_scaling) THEN CALL compute_exponential_sparse(exp_H_new, propagator_matrix, rtp_control, rtp) diff --git a/src/energy_corrections.F b/src/energy_corrections.F index e79c921c09..e0ea3c5191 100644 --- a/src/energy_corrections.F +++ b/src/energy_corrections.F @@ -1726,7 +1726,7 @@ CONTAINS IF (dft_control%do_admm_mo) THEN CPASSERT(.NOT. qs_env%run_rtp) CALL admm_mo_calc_rho_aux(qs_env) - ELSE IF (dft_control%do_admm_dm) THEN + ELSEIF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF diff --git a/src/environment.F b/src/environment.F index dfc1ca86d0..f981bdf787 100644 --- a/src/environment.F +++ b/src/environment.F @@ -470,9 +470,8 @@ CONTAINS iw = cp_print_key_unit_nr(logger, root_section, "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG", & extension=".Log") - IF (iw > 0) THEN + IF (iw > 0) & CALL globenv%gaussian_rng_stream%write(iw, write_all=.TRUE.) - END IF CALL cp_print_key_finished_output(iw, logger, root_section, & "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG") @@ -595,9 +594,8 @@ CONTAINS IF (trace .AND. (.NOT. trace_master .OR. para_env%mepos == 0)) THEN unit_nr = -1 - IF (logger%para_env%is_source() .OR. .NOT. trace_master) THEN + IF (logger%para_env%is_source() .OR. .NOT. trace_master) & unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) - END IF WRITE (tracing_string, "(I6.6,A1,I6.6)") para_env%mepos, ":", para_env%num_pe IF (ASSOCIATED(trace_routines)) THEN CALL timings_setup_tracing(trace_max, unit_nr, tracing_string, trace_routines) @@ -684,9 +682,8 @@ CONTAINS CPABORT("FARMING program supports only NONE as run type") END IF - IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) THEN + IF (globenv%prog_name_id == do_test .AND. globenv%run_type_id /= none_run) & CPABORT("TEST program supports only NONE as run type") - END IF CALL m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree) MemTotal_avr = MemTotal @@ -1234,9 +1231,8 @@ CONTAINS IF (ierr /= 0) CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') ELSE READ (txt(1:n), FMT="(I2,A1,I2,A1,I2)", IOSTAT=ierr) hours, c1, minutes, c2, seconds - IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") THEN + IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") & CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') - END IF walltime = 3600.0_dp*REAL(hours, dp) + 60.0_dp*REAL(minutes, dp) + REAL(seconds, dp) END IF END SUBROUTINE cp2k_get_walltime @@ -1335,18 +1331,15 @@ CONTAINS IF (cg_mode /= CALLGRAPH_NONE) THEN CALL section_vals_val_get(root_section, "GLOBAL%CALLGRAPH_FILE_NAME", c_val=cg_filename) IF (LEN_TRIM(cg_filename) == 0) cg_filename = TRIM(logger%iter_info%project_name) - IF (cg_mode == CALLGRAPH_ALL) THEN - !incorporate mpi-rank into filename + IF (cg_mode == CALLGRAPH_ALL) & !incorporate mpi-rank into filename cg_filename = TRIM(cg_filename)//"_"//TRIM(ADJUSTL(cp_to_string(para_env%mepos))) - END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,3X,A)") "Writing callgraph to: "//TRIM(cg_filename)//".callgraph" WRITE (UNIT=iw, FMT="()") WRITE (UNIT=iw, FMT="(T2,A)") "-------------------------------------------------------------------------------" END IF - IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) THEN + IF (cg_mode == CALLGRAPH_ALL .OR. para_env%is_source()) & CALL timings_report_callgraph(TRIM(cg_filename)//".callgraph") - END IF END IF CALL cp_print_key_finished_output(iw, logger, root_section, & diff --git a/src/eri_mme/eri_mme_error_control.F b/src/eri_mme/eri_mme_error_control.F index 645678d1f4..4c8a63e1c6 100644 --- a/src/eri_mme/eri_mme_error_control.F +++ b/src/eri_mme/eri_mme_error_control.F @@ -92,15 +92,13 @@ CONTAINS max_iter = 100 - IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) THEN + IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) <= tol) & CALL cp_abort(__LOCATION__, "difference of boundaries for cutoff "// & "(MAX - MIN) must be greater than cutoff precision.") - END IF - IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) THEN + IF ((delta >= 1.0_dp) .OR. (delta <= 0.0_dp)) & CALL cp_abort(__LOCATION__, & "relative delta to modify initial cutoff interval (DELTA) must be in (0, 1)") - END IF cutoff_lr(1) = cutoff_l cutoff_lr(2) = cutoff_r @@ -115,11 +113,10 @@ CONTAINS ! 1) find valid initial values for bisection DO iter1 = 1, max_iter + 1 - IF (iter1 > max_iter) THEN + IF (iter1 > max_iter) & CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine initial "// & "cutoff interval has been exceeded.") - END IF cutoff_lr(1) = MAX(cutoff_lr(1), 0.5_dp*G_min**2) ! approx.) is hit @@ -147,10 +144,9 @@ CONTAINS "ERI_MME| Step, cutoff (min, max, mid), err(minimax), err(cutoff), err diff" DO iter2 = 1, max_iter + 1 - IF (iter2 > max_iter) THEN + IF (iter2 > max_iter) & CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine cutoff has been exceeded") - END IF cutoff_mid = 0.5_dp*(cutoff_lr(1) + cutoff_lr(2)) CALL cutoff_minimax_error(cutoff_mid, hmat, h_inv, vol, G_min, zet_min, l_mm, zet_max, l_max_zet, & @@ -341,10 +337,9 @@ CONTAINS gr = 0.5_dp*(SQRT(5.0_dp) - 1.0_dp) ! golden ratio ! Find valid starting values for golden section search DO iter = 1, max_iter + 1 - IF (iter > max_iter) THEN + IF (iter > max_iter) & CALL cp_abort(__LOCATION__, "Maximum number of iterations for finding "// & "exponent maximizing cutoff error has been exceeded.") - END IF CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_max_tmp, C, err_ctff_curr, para_env) IF (err_ctff_prev >= err_ctff_curr) THEN diff --git a/src/eri_mme/eri_mme_gaussian.F b/src/eri_mme/eri_mme_gaussian.F index 1cde9784a6..fea8e96a21 100644 --- a/src/eri_mme/eri_mme_gaussian.F +++ b/src/eri_mme/eri_mme_gaussian.F @@ -133,7 +133,7 @@ CONTAINS CPASSERT(G_max > G_min) IF (potential_prv == eri_mme_coulomb .OR. potential_prv == eri_mme_longrange) THEN minimax_Rc = (G_max/G_min)**2 - ELSE IF (potential_prv == eri_mme_yukawa) THEN + ELSEIF (potential_prv == eri_mme_yukawa) THEN minimax_Rc = (G_max**2 + pot_par**2)/(G_min**2 + pot_par**2) END IF @@ -165,9 +165,9 @@ CONTAINS IF (PRESENT(err_minimax)) THEN IF (potential_prv == eri_mme_coulomb) THEN err_minimax = err_minimax/G_min**2 - ELSE IF (potential_prv == eri_mme_yukawa) THEN + ELSEIF (potential_prv == eri_mme_yukawa) THEN err_minimax = err_minimax/(G_min**2 + pot_par**2) - ELSE IF (potential_prv == eri_mme_longrange) THEN + ELSEIF (potential_prv == eri_mme_longrange) THEN err_minimax = err_minimax/G_min**2 ! approx. of Coulomb err_minimax = err_minimax*EXP(-G_min**2/pot_par**2) ! exponential factor END IF diff --git a/src/eri_mme/eri_mme_lattice_summation.F b/src/eri_mme/eri_mme_lattice_summation.F index a5f8da4731..4fd3228772 100644 --- a/src/eri_mme/eri_mme_lattice_summation.F +++ b/src/eri_mme/eri_mme_lattice_summation.F @@ -89,7 +89,7 @@ CONTAINS IF (PRESENT(G_rad)) G_rad = exp_radius(l_max, alpha_G, sum_precision, 1.0_dp, epsabs=G_res) IF (PRESENT(R_rad)) R_rad = exp_radius(l_max, alpha_R, sum_precision, 1.0_dp, epsabs=R_res) - END SUBROUTINE eri_mme_2c_get_rads + END SUBROUTINE ! ************************************************************************************************** !> \brief Get summation radii for 3c integrals @@ -149,7 +149,7 @@ CONTAINS R_rads_3(2) = exp_radius(la_max + lb_max + lc_max, alpha_R, sum_precision, 1.0_dp, R_res) END IF - END SUBROUTINE eri_mme_3c_get_rads + END SUBROUTINE ! ************************************************************************************************** !> \brief Get summation bounds for 2c integrals @@ -212,7 +212,7 @@ CONTAINS n_sum_3d(2) = nsum_2c_rspace_3d(ns_R, la_max, lb_max) END IF - END SUBROUTINE eri_mme_2c_get_bounds + END SUBROUTINE ! ************************************************************************************************** !> \brief Get summation bounds for 3c integrals @@ -326,7 +326,7 @@ CONTAINS n_sum_3d(3) = nsum_3c_rspace_3d(ns3_R1, ns3_R2, la_max, lb_max, lc_max) END IF - END SUBROUTINE eri_mme_3c_get_bounds + END SUBROUTINE ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -341,7 +341,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_1d nsum_2c_gspace_1d = NINT(ns_G*(2*exp_w + (l + m + 1)*5), KIND=int_8) - END FUNCTION nsum_2c_gspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in G space in 1 dimension @@ -380,7 +380,7 @@ CONTAINS END DO END DO - S_G(:) = REAL(S_G_c(0:l_max)*i_pow([(l, l=0, l_max)]))*inv_lgth + S_G(:) = REAL(S_G_c(0:l_max)*i_pow((/(l, l=0, l_max)/)))*inv_lgth END SUBROUTINE pgf_sum_2c_gspace_1d ! ************************************************************************************************** @@ -396,7 +396,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_gspace_3d nsum_2c_gspace_3d = NINT(ns_G*(2*exp_w + ncoset(l + m)*7), KIND=int_8) - END FUNCTION nsum_2c_gspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief As pgf_sum_2c_gspace_1d but 3d sum required for non-orthorhombic cells @@ -495,7 +495,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_1d nsum_2c_rspace_1d = NINT(ns_R*(exp_w + (l + m + 1)*3), KIND=int_8) - END FUNCTION nsum_2c_rspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Compute Ewald-like sum for 2-center ERIs in R space in 1 dimension @@ -553,7 +553,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_2c_rspace_3d nsum_2c_rspace_3d = NINT(ns_R*(exp_w + ncoset(l + m)*(4 + ncoset(l + m)*4)), KIND=int_8) - END FUNCTION nsum_2c_rspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief As pgf_sum_2c_rspace_1d but 3d sum required for non-orthorhombic cells @@ -611,8 +611,7 @@ CONTAINS END DO DO lco = 1, ncoset(l_max) CALL get_l(lco, l, lx, ly, lz) - ! cost: 4 flops - S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot + S_R_C(coset(lx, ly, lz)) = S_R_C(coset(lx, ly, lz)) + R_pow_l(1, lx)*R_pow_l(2, ly)*R_pow_l(3, lz)*exp_tot ! cost: 4 flops END DO END DO END DO @@ -795,7 +794,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_gspace_1d nsum_3c_gspace_1d = 15 - END FUNCTION nsum_3c_gspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -811,7 +810,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_product_3c_gspace_1d nsum_product_3c_gspace_1d = MIN(19, NINT(ns_G*(3 + ns_R*2))) - END FUNCTION nsum_product_3c_gspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Roughly estimated number of floating point operations @@ -827,7 +826,7 @@ CONTAINS INTEGER(KIND=int_8) :: nsum_3c_rspace_1d nsum_3c_rspace_1d = NINT(MIN((4 + ns_R1*2), ns_R1*(ns_R2 + 1)), KIND=int_8) - END FUNCTION nsum_3c_rspace_1d + END FUNCTION ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -955,7 +954,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE pgf_sum_3c_rspace_1d_generic + END SUBROUTINE ! ************************************************************************************************** !> \brief Helper routine: compute SQRT(alpha/pi) (-1)^n sum_(R, R') sum_{t=0}^{l+m} E(t,l,m) H(RC - P(R) - R', t + n, alpha) @@ -1010,7 +1009,7 @@ CONTAINS #:for l in range(0, l_tot_max) #:for k in range(0, l+2) #:if k0 - h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# + h_to_c_${k}$_${l+1}$ = #{if k 0}#+2*alpha*h_to_c_${k-1}$_${l}$#{endif}# #:else h_to_c_${k}$_${l+1}$ = 0.0_dp #:endif @@ -1088,15 +1087,15 @@ CONTAINS #:for l in range(0,l_max+1) #:for t in range(0,l+m+2) #:if l < l_max - E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l+1}$_${m}$ = zeta*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}# +c2*E_${t}$_${l}$_${m}$&#{endif}# #{if t0 and t<=l-1+m}#-${2*l}$*E_${t}$_${l-1}$_${m}$#{endif}#) #:endif #:if m < m_max - E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}#c1*E_${t-1}$_${l}$_${m}$#{endif}# & + E_${t}$_${l}$_${m+1}$ = zetb*(#{if t>0}# c1*E_${t-1}$_${l}$_${m}$#{endif}# & #{if t<=l+m}#+c3*E_${t}$_${l}$_${m}$&#{endif}# - #{if t0 and t<=m-1+l}#-${2*m}$*E_${t}$_${l}$_${m-1}$#{endif}#) #:endif #:endfor @@ -1116,7 +1115,7 @@ CONTAINS END DO S_R = S_R*pi**(-0.5_dp)*((zeta + zetb)/(zeta*zetb))**(-0.5_dp) - END SUBROUTINE pgf_sum_3c_rspace_1d_${l_max}$_${m_max}$_${n_max}$_exp_${prop_exp}$ + END SUBROUTINE #:endfor #:endfor #:endfor @@ -1266,7 +1265,7 @@ CONTAINS nsum_3c_gspace_3d = NINT(ns_G1*ns_G2*(5*exp_w + ncoset(l)*ncoset(m)*ncoset(n)*4), KIND=int_8) - END FUNCTION nsum_3c_gspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1428,7 +1427,7 @@ CONTAINS END SELECT S_G = REAL(S_G_c, KIND=dp)/vol**2 - END SUBROUTINE pgf_sum_3c_gspace_3d + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -1544,7 +1543,7 @@ CONTAINS 3*nsum_gaussian_overlap(l, m, 1) + & ncoset(l)*ncoset(m)*(ncoset(l + m)*4 + ncoset(n)*8)), & KIND=int_8) - END FUNCTION nsum_product_3c_gspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1765,7 +1764,7 @@ CONTAINS ncoset(l + m)*2 + ncoset(n)*ncoset(l + m)*4)), & KIND=int_8) - END FUNCTION nsum_3c_rspace_3d + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1963,7 +1962,7 @@ CONTAINS ELSE nsum_gaussian_overlap = nsum_gaussian_overlap + loop*32 END IF - END FUNCTION nsum_gaussian_overlap + END FUNCTION ! ************************************************************************************************** !> \brief ... @@ -1982,7 +1981,7 @@ CONTAINS IF (PRESENT(lx)) lx = indco(1, lco) IF (PRESENT(ly)) ly = indco(2, lco) IF (PRESENT(lz)) lz = indco(3, lco) - END SUBROUTINE get_l + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -1994,10 +1993,10 @@ CONTAINS COMPLEX(KIND=dp) :: i_pow COMPLEX(KIND=dp), DIMENSION(0:3), PARAMETER :: & - ip = [(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)] + ip = (/(1.0_dp, 0.0_dp), (0.0_dp, 1.0_dp), (-1.0_dp, 0.0_dp), (0.0_dp, -1.0_dp)/) i_pow = ip(MOD(i, 4)) - END FUNCTION i_pow + END FUNCTION END MODULE eri_mme_lattice_summation diff --git a/src/eri_mme/eri_mme_test.F b/src/eri_mme/eri_mme_test.F index 923b19c2c9..f67388aac6 100644 --- a/src/eri_mme/eri_mme_test.F +++ b/src/eri_mme/eri_mme_test.F @@ -158,9 +158,8 @@ CONTAINS acc_check = .TRUE. END IF - IF (.NOT. acc_check) THEN + IF (.NOT. acc_check) & CPABORT("Actual error greater than upper bound estimate.") - END IF END IF END IF diff --git a/src/eri_mme/eri_mme_types.F b/src/eri_mme/eri_mme_types.F index 25f94e1ae1..2f40d28ab0 100644 --- a/src/eri_mme/eri_mme_types.F +++ b/src/eri_mme/eri_mme_types.F @@ -127,9 +127,8 @@ CONTAINS CHARACTER(len=2) :: string WRITE (string, '(I2)') n_minimax_max - IF (n_minimax > n_minimax_max) THEN + IF (n_minimax > n_minimax_max) & CPABORT("The maximum allowed number of minimax points N_MINIMAX is "//TRIM(string)) - END IF param%n_minimax = n_minimax param%n_grids = 1 diff --git a/src/et_coupling_proj.F b/src/et_coupling_proj.F index dae0f3d119..f387e74c79 100644 --- a/src/et_coupling_proj.F +++ b/src/et_coupling_proj.F @@ -150,9 +150,8 @@ CONTAINS IF (ASSOCIATED(ec)) THEN - IF (ASSOCIATED(ec%fermi)) THEN + IF (ASSOCIATED(ec%fermi)) & DEALLOCATE (ec%fermi) - END IF IF (ASSOCIATED(ec%m_transf)) THEN CALL cp_fm_release(matrix=ec%m_transf) DEALLOCATE (ec%m_transf) @@ -167,9 +166,8 @@ CONTAINS IF (ASSOCIATED(ec%block)) THEN DO i = 1, SIZE(ec%block) - IF (ASSOCIATED(ec%block(i)%atom)) THEN + IF (ASSOCIATED(ec%block(i)%atom)) & DEALLOCATE (ec%block(i)%atom) - END IF IF (ASSOCIATED(ec%block(i)%mo)) THEN DO j = 1, SIZE(ec%block(i)%mo) CALL deallocate_mo_set(ec%block(i)%mo(j)) @@ -244,9 +242,8 @@ CONTAINS DO i = 1, n_atoms CALL get_atomic_kind(particle_set(i)%atomic_kind, kind_number=j) CALL get_qs_kind(qs_kind_set(j), basis_set=ao_basis_set) - IF (.NOT. ASSOCIATED(ao_basis_set)) THEN + IF (.NOT. ASSOCIATED(ao_basis_set)) & CPABORT('Unsupported basis set type. ') - END IF CALL get_gto_basis_set(gto_basis_set=ao_basis_set, & nset=n_set, nshell=n_shell, l=ang_mom_id) DO j = 1, n_set @@ -303,9 +300,8 @@ CONTAINS ! Count unique atoms DO j = 1, SIZE(atom_id) ! Check atom ID validity - IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) THEN + IF (atom_id(j) < 1 .OR. atom_id(j) > n_atoms) & CPABORT('invalid fragment atom ID ('//TRIM(ADJUSTL(cp_to_string(atom_id(j))))//')') - END IF ! Check if the atom is not in previously-defined blocks found = .FALSE. DO k = 1, i - 1 @@ -350,15 +346,12 @@ CONTAINS END DO ! Clean memory - IF (ASSOCIATED(atom_nf)) THEN + IF (ASSOCIATED(atom_nf)) & DEALLOCATE (atom_nf) - END IF - IF (ASSOCIATED(atom_ps)) THEN + IF (ASSOCIATED(atom_ps)) & DEALLOCATE (atom_ps) - END IF - IF (ASSOCIATED(t)) THEN + IF (ASSOCIATED(t)) & DEALLOCATE (t) - END IF END SUBROUTINE set_block_data @@ -416,9 +409,8 @@ CONTAINS ! Routine name for debug purposes ! Local variables - IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) THEN + IF (.NOT. cp_fm_struct_equivalent(mat_h%matrix_struct, mat_w%matrix_struct)) & CPABORT('cannot reorder Hamiltonian, working-matrix structure is not equivalent') - END IF ! Matrix-element reordering nr = 1 @@ -680,9 +672,8 @@ CONTAINS END DO ! Clean memory - IF (ALLOCATED(dat)) THEN + IF (ALLOCATED(dat)) & DEALLOCATE (dat) - END IF END SUBROUTINE hamiltonian_block_diag @@ -727,9 +718,8 @@ CONTAINS END IF END DO - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT('MO-fraction atom ID not defined in the block') - END IF ! sum MO coefficients from the atom DO k = 1, blk_at(j)%n_ao @@ -783,9 +773,8 @@ CONTAINS IF (n > 0) THEN - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(/,T3,A/)') 'Block state fractions:' - END IF ! Number of AO functions CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) @@ -820,9 +809,8 @@ CONTAINS IF (ASSOCIATED(list_mo)) THEN IF (j > 1) THEN - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, *) - END IF END IF DO l = 1, SIZE(list_mo) @@ -832,15 +820,13 @@ CONTAINS list_mo(l), list_at) c2 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(2), & list_mo(l), list_at) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(I5,A,I5,2F20.10)') j, ' /', list_mo(l), c1, c2 - END IF ELSE c1 = get_mo_c2_sum(ec%block(blk)%atom, mat_w(1), & list_mo(l), list_at) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(I5,A,I5,F20.10)') j, ' /', list_mo(l), c1 - END IF END IF END DO @@ -887,9 +873,8 @@ CONTAINS ! Routine name for debug purposes prnt_fm = .FALSE. - IF (PRESENT(fermi)) THEN + IF (PRESENT(fermi)) & prnt_fm = fermi - END IF IF (output_unit > 0) THEN @@ -899,13 +884,11 @@ CONTAINS IF (n_spins > 1) THEN mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) THEN + IF (PRESENT(mx_mo_a)) & mx_a = MIN(mo(1)%nmo, mx_mo_a) - END IF mx_b = mo(2)%nmo - IF (PRESENT(mx_mo_b)) THEN + IF (PRESENT(mx_mo_b)) & mx_b = MIN(mo(2)%nmo, mx_mo_b) - END IF n = MAX(mx_a, mx_b) DO i = 1, n @@ -935,9 +918,8 @@ CONTAINS ELSE mx_a = mo(1)%nmo - IF (PRESENT(mx_mo_a)) THEN + IF (PRESENT(mx_mo_a)) & mx_a = MIN(mo(1)%nmo, mx_mo_a) - END IF DO i = 1, mx_a WRITE (output_unit, '(T3,I10,2F12.4)') & @@ -1002,9 +984,8 @@ CONTAINS my_pos = "APPEND" END IF - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(/,T3,A/)') 'Printing coupling elements to output files' - END IF DO i = 1, ec%n_blocks DO j = i + 1, ec%n_blocks @@ -1123,16 +1104,15 @@ CONTAINS ALLOCATE (vec_t(n_mo)) CPASSERT(ASSOCIATED(vec_t)) CALL cp_fm_vectorssum(mat_t, vec_t) - vec_t = 1.0_dp/SQRT(vec_t) + vec_t = 1.0_dp/DSQRT(vec_t) CALL cp_fm_column_scale(mo%mo_coeff, vec_t) ! Clean memory CALL cp_fm_struct_release(fmstruct=fm_s) CALL cp_fm_release(matrix=mat_sc) CALL cp_fm_release(matrix=mat_t) - IF (ASSOCIATED(vec_t)) THEN + IF (ASSOCIATED(vec_t)) & DEALLOCATE (vec_t) - END IF END SUBROUTINE normalize_mo_vectors @@ -1242,28 +1222,24 @@ CONTAINS ! Number of states n_mo = mat_u%matrix_struct%nrow_global - IF (n_mo /= mat_u%matrix_struct%ncol_global) THEN + IF (n_mo /= mat_u%matrix_struct%ncol_global) & CPABORT('block state matrix is not square') - END IF - IF (n_mo /= SIZE(vec_e)) THEN + IF (n_mo /= SIZE(vec_e)) & CPABORT('inconsistent number of states / energies') - END IF ! Maximal occupancy CALL get_qs_env(qs_env, dft_control=dft_cntrl) mx_occ = 2.0_dp - IF (dft_cntrl%nspins > 1) THEN + IF (dft_cntrl%nspins > 1) & mx_occ = 1.0_dp - END IF ! Number of electrons n_el = ec%block(id)%n_electrons IF (dft_cntrl%nspins > 1) THEN n_el = n_el/2 IF (MOD(ec%block(id)%n_electrons, 2) == 1) THEN - IF (spin == 1) THEN + IF (spin == 1) & n_el = n_el + 1 - END IF END IF END IF @@ -1542,9 +1518,8 @@ CONTAINS ! Parallel calculation - master thread master = .FALSE. - IF (output_unit > 0) THEN + IF (output_unit > 0) & master = .TRUE. - END IF ! Header IF (master) THEN @@ -1628,23 +1603,20 @@ CONTAINS CPABORT('ET_COUPLING not implemented with kpoints') ELSE ! no K-points - IF (master) THEN + IF (master) & WRITE (output_unit, '(T3,A)') 'No K-point sampling (Gamma point only)' - END IF END IF IF (dft_cntrl%nspins == 2) THEN - IF (master) THEN + IF (master) & WRITE (output_unit, '(/,T3,A)') 'Spin-polarized calculation' - END IF !<--- Open shell / No K-points ------------------------------------------------>! ! State eneries of the whole system - IF (mo(1)%nao /= mo(2)%nao) THEN + IF (mo(1)%nao /= mo(2)%nao) & CPABORT('different number of alpha/beta AO basis functions') - END IF IF (master) THEN WRITE (output_unit, '(/,T3,A,I10)') & 'Number of AO basis functions = ', mo(1)%nao @@ -1676,9 +1648,8 @@ CONTAINS ELSE - IF (master) THEN + IF (master) & WRITE (output_unit, '(/,T3,A)') 'Spin-restricted calculation' - END IF !<--- Close shell / No K-points ----------------------------------------------->! diff --git a/src/ewald_spline_util.F b/src/ewald_spline_util.F index 74f69713b4..9ebfcab6e5 100644 --- a/src/ewald_spline_util.F +++ b/src/ewald_spline_util.F @@ -398,10 +398,10 @@ CONTAINS END DO Na = SQRT(dxTerm*dxTerm + dyTerm*dyTerm + dzTerm*dzTerm) dn = Eval_d_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) - Nn = NORM2(dn) + Nn = SQRT(DOT_PRODUCT(dn, dn)) Fterm = Eval_Interp_Spl3_pbc([xs1, xs2, xs3], TabLR) tmp1 = ABS(Term - Fterm) - tmp2 = NORM2(dn - [dxTerm, dyTerm, dzTerm]) + tmp2 = SQRT(DOT_PRODUCT(dn - [dxTerm, dyTerm, dzTerm], dn - [dxTerm, dyTerm, dzTerm])) errf = errf + tmp1 maxerrorf = MAX(maxerrorf, tmp1) errd = errd + tmp2 diff --git a/src/ewalds.F b/src/ewalds.F index b10f460437..c5df25968f 100644 --- a/src/ewalds.F +++ b/src/ewalds.F @@ -364,9 +364,9 @@ CONTAINS charges) TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set(:) TYPE(distribution_1d_type), POINTER :: local_particles - REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self + REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_self(:) REAL(KIND=dp), DIMENSION(:), POINTER :: charges INTEGER :: ewald_type, ii, iparticle_kind, & diff --git a/src/ewalds_multipole.F b/src/ewalds_multipole.F index 96abbf552e..06a4c1f867 100644 --- a/src/ewalds_multipole.F +++ b/src/ewalds_multipole.F @@ -61,17 +61,6 @@ MODULE ewalds_multipole IMPLICIT NONE PRIVATE - TYPE charge_mono_type - REAL(KIND=dp), DIMENSION(:), & - POINTER :: charge => NULL() - REAL(KIND=dp), DIMENSION(:, :), & - POINTER :: pos => NULL() - END TYPE charge_mono_type - TYPE multi_charge_type - TYPE(charge_mono_type), DIMENSION(:), & - POINTER :: charge_typ => NULL() - END TYPE multi_charge_type - LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_r_space = .FALSE. LOGICAL, PRIVATE, PARAMETER :: debug_g_space = .FALSE. @@ -1287,6 +1276,16 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, iw, debug_r_space) + TYPE charge_mono_type + REAL(KIND=dp), DIMENSION(:), & + POINTER :: charge + REAL(KIND=dp), DIMENSION(:, :), & + POINTER :: pos + END TYPE charge_mono_type + TYPE multi_charge_type + TYPE(charge_mono_type), DIMENSION(:), & + POINTER :: charge_typ + END TYPE multi_charge_type TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(fist_nonbond_env_type), POINTER :: nonbond_env @@ -1608,7 +1607,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = NORM2(rm) + r = SQRT(DOT_PRODUCT(rm, rm)) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1647,7 +1646,7 @@ CONTAINS DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge) rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1) - r = NORM2(rm) + r = SQRT(DOT_PRODUCT(rm, rm)) q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1) energy = energy + q/r*fac_ij END DO @@ -1728,7 +1727,7 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%charge(2)) ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 2)) CALL random_stream%fill(rvec) - rvec = rvec/(2.0_dp*NORM2(rvec))*dx + rvec = rvec/(2.0_dp*SQRT(DOT_PRODUCT(rvec, rvec)))*dx multipoles(i)%charge_typ(isize)%charge(1) = echarge multipoles(i)%charge_typ(isize)%pos(1:3, 1) = rvec multipoles(i)%charge_typ(isize)%charge(2) = -echarge @@ -1743,9 +1742,9 @@ CONTAINS ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 4)) CALL random_stream%fill(rvec1) CALL random_stream%fill(rvec2) - rvec1 = rvec1/NORM2(rvec1) + rvec1 = rvec1/SQRT(DOT_PRODUCT(rvec1, rvec1)) rvec2 = rvec2 - DOT_PRODUCT(rvec2, rvec1)*rvec1 - rvec2 = rvec2/NORM2(rvec2) + rvec2 = rvec2/SQRT(DOT_PRODUCT(rvec2, rvec2)) ! rvec1 = rvec1/2.0_dp*dx rvec2 = rvec2/2.0_dp*dx diff --git a/src/ewalds_multipole_sr.fypp b/src/ewalds_multipole_sr.fypp index 99d3e9d09d..4f8b2f528b 100644 --- a/src/ewalds_multipole_sr.fypp +++ b/src/ewalds_multipole_sr.fypp @@ -246,7 +246,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = EXP(-dampa_ij*r) + dampaexpi = dexp(-dampa_ij*r) dampfunci = dampsumfi*dampaexpi*dampfac_ij dampfuncdiffi = -dampa_ij*dampaexpi* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -267,7 +267,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = EXP(-dampa_ji*r) + dampaexpj = dexp(-dampa_ji*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ji dampfuncdiffj = -dampa_ji*dampaexpj* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & @@ -287,7 +287,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfj = dampsumfj + (xf/factorial) END DO - dampaexpj = EXP(-dampa_ij*r) + dampaexpj = dexp(-dampa_ij*r) dampfuncj = dampsumfj*dampaexpj*dampfac_ij dampfuncdiffj = -dampa_ij*dampaexpj* & dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ & @@ -308,7 +308,7 @@ factorial = factorial*REAL(kk, KIND=dp) dampsumfi = dampsumfi + (xf/factorial) END DO - dampaexpi = EXP(-dampa_ji*r) + dampaexpi = dexp(-dampa_ji*r) dampfunci = dampsumfi*dampaexpi*dampfac_ji dampfuncdiffi = -dampa_ji*dampaexpi* & dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ & diff --git a/src/excited_states.F b/src/excited_states.F index 13329ec4db..a5ab99bb5d 100644 --- a/src/excited_states.F +++ b/src/excited_states.F @@ -112,9 +112,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=ex_env%debug_forces) ELSE ! KS-DFT diff --git a/src/exstates_types.F b/src/exstates_types.F index d7d535d6b9..1b9c77dd55 100644 --- a/src/exstates_types.F +++ b/src/exstates_types.F @@ -106,9 +106,8 @@ CONTAINS CALL cp_fm_release(ex_env%wfn_history%evect) CALL cp_fm_release(ex_env%wfn_history%cpmos) - IF (ALLOCATED(ex_env%gw_eigen)) THEN + IF (ALLOCATED(ex_env%gw_eigen)) & DEALLOCATE (ex_env%gw_eigen) - END IF DEALLOCATE (ex_env) diff --git a/src/f77_interface.F b/src/f77_interface.F index 28be264b2a..125ff2d120 100644 --- a/src/f77_interface.F +++ b/src/f77_interface.F @@ -755,12 +755,11 @@ CONTAINS ! Check that the order of the force_eval is the correct one CALL section_vals_val_get(force_env_sections, "METHOD", i_val=method_name_id, & i_rep_section=i_force_eval(1)) - IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) THEN + IF ((method_name_id /= do_mixed) .AND. (method_name_id /= do_embed)) & CALL cp_abort(__LOCATION__, & "In case of multiple force_eval the MAIN force_eval (the first in the list of FORCE_EVAL_ORDER or "// & "the one omitted from that order list) must be a MIXED_ENV type calculation. Please check your "// & "input file and possibly correct the MULTIPLE_FORCE_EVAL%FORCE_EVAL_ORDER. ") - END IF IF (method_name_id == do_mixed) THEN check = ASSOCIATED(force_env%mixed_env%sub_para_env) @@ -808,9 +807,8 @@ CONTAINS IF (method_name_id == do_qmmm) THEN qmmmx_section => section_vals_get_subs_vals(force_env_section, "QMMM%FORCE_MIXING") CALL section_vals_get(qmmmx_section, explicit=do_qmmm_force_mixing) - IF (do_qmmm_force_mixing) THEN - method_name_id = do_qmmmx - END IF ! QMMM Force-Mixing has its own (hidden) method_id + IF (do_qmmm_force_mixing) & + method_name_id = do_qmmmx ! QMMM Force-Mixing has its own (hidden) method_id END IF SELECT CASE (method_name_id) @@ -945,9 +943,8 @@ CONTAINS ! Release force_env_section IF (nforce_eval > 1) CALL section_vals_release(force_env_section) END DO - IF (use_multiple_para_env) THEN + IF (use_multiple_para_env) & CALL cp_rm_default_logger() - END IF DEALLOCATE (group_distribution) DEALLOCATE (i_force_eval) timer_env => get_timer_env() diff --git a/src/farming_methods.F b/src/farming_methods.F index eeb540f8e2..006de02994 100644 --- a/src/farming_methods.F +++ b/src/farming_methods.F @@ -304,7 +304,7 @@ CONTAINS WRITE (output_unit, "(T2,A)") & "FARMING| ---- WARNING ---- failed to open ("//TRIM(farming_env%restart_file_name)//"), starting at 1" END IF - CLOSE (iunit) + CLOSE (iunit, IOSTAT=stat) END IF CALL cp_print_key_finished_output(output_unit, logger, farming_section, & diff --git a/src/farming_types.F b/src/farming_types.F index 45820baede..3324a31dbb 100644 --- a/src/farming_types.F +++ b/src/farming_types.F @@ -38,8 +38,7 @@ MODULE farming_types LOGICAL :: restart = .FALSE. LOGICAL :: CYCLE = .FALSE. LOGICAL :: captain_minion = .FALSE. - ! user preference for partitioning the cpus - INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() + INTEGER, DIMENSION(:), POINTER :: group_partition => NULL() ! user preference for partitioning the cpus CHARACTER(LEN=default_path_length) :: restart_file_name = "" ! restart file for farming CHARACTER(LEN=default_path_length) :: cwd = "" ! directory we started from INTEGER :: Njobs = -1 ! how many jobs to run diff --git a/src/fist_efield_methods.F b/src/fist_efield_methods.F index 86afa8d109..72be6551ad 100644 --- a/src/fist_efield_methods.F +++ b/src/fist_efield_methods.F @@ -103,7 +103,7 @@ CONTAINS END IF fieldpol = efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*efield%strength dfilter = efield%dfilter diff --git a/src/fist_environment_types.F b/src/fist_environment_types.F index ba016dd434..5a49675dc1 100644 --- a/src/fist_environment_types.F +++ b/src/fist_environment_types.F @@ -187,7 +187,7 @@ CONTAINS IF (PRESENT(subsys)) subsys => fist_env%subsys IF (PRESENT(efield)) efield => fist_env%efield - IF (ASSOCIATED(fist_env%subsys)) THEN + IF (ASSOCIATED(fist_env%subsys)) & CALL cp_subsys_get(fist_env%subsys, & atomic_kinds=atomic_kinds, & local_molecules=local_molecules, & @@ -200,7 +200,6 @@ CONTAINS multipoles=fist_multipoles, & results=results, & cell=cell) - END IF IF (PRESENT(atomic_kind_set)) atomic_kind_set => atomic_kinds%els IF (PRESENT(particle_set)) particle_set => particles%els IF (PRESENT(molecule_kind_set)) molecule_kind_set => molecule_kinds%els diff --git a/src/fist_force.F b/src/fist_force.F index f2ab3a0281..2cff3aba15 100644 --- a/src/fist_force.F +++ b/src/fist_force.F @@ -735,7 +735,7 @@ CONTAINS shell_particle_set(i)%f(3) = fshell_total(3, i) + fgshell_coulomb(3, i) END DO - ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms @@ -767,7 +767,7 @@ CONTAINS shell_particle_set(i)%f(2) = fshell_total(2, i) shell_particle_set(i)%f(3) = fshell_total(3, i) END DO - ELSE IF (shell_present .AND. .NOT. shell_model_ad) THEN + ELSEIF (shell_present .AND. .NOT. shell_model_ad) THEN CPABORT("Non adiabatic shell-model not implemented.") ELSE DO i = 1, natoms diff --git a/src/fist_intra_force.F b/src/fist_intra_force.F index 9838cd3333..882ca5fe8f 100644 --- a/src/fist_intra_force.F +++ b/src/fist_intra_force.F @@ -272,9 +272,9 @@ CONTAINS b32 = particle_set(index_c)%r - particle_set(index_b)%r b12 = pbc(b12, cell) b32 = pbc(b32, cell) - d12 = NORM2(b12) + d12 = SQRT(DOT_PRODUCT(b12, b12)) id12 = 1.0_dp/d12 - d32 = NORM2(b32) + d32 = SQRT(DOT_PRODUCT(b32, b32)) id32 = 1.0_dp/d32 dist = DOT_PRODUCT(b12, b32) theta = (dist*id12*id32) @@ -343,11 +343,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = NORM2(tm) + sm = SQRT(DOT_PRODUCT(tm, tm)) ism = 1.0_dp/sm - sn = NORM2(tn) + sn = SQRT(DOT_PRODUCT(tn, tn)) isn = 1.0_dp/sn - s32 = NORM2(t32) + s32 = SQRT(DOT_PRODUCT(t32, t32)) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -415,11 +415,11 @@ CONTAINS tn(1) = t32(2)*t34(3) - t34(2)*t32(3) tn(2) = -t32(1)*t34(3) + t34(1)*t32(3) tn(3) = t32(1)*t34(2) - t34(1)*t32(2) - sm = NORM2(tm) + sm = SQRT(DOT_PRODUCT(tm, tm)) ism = 1.0_dp/sm - sn = NORM2(tn) + sn = SQRT(DOT_PRODUCT(tn, tn)) isn = 1.0_dp/sn - s32 = NORM2(t32) + s32 = SQRT(DOT_PRODUCT(t32, t32)) is32 = 1.0_dp/s32 dist1 = DOT_PRODUCT(t12, t32) dist2 = DOT_PRODUCT(t34, t32) @@ -483,8 +483,8 @@ CONTAINS tm(1) = t32(2)*t12(3) - t12(2)*t32(3) tm(2) = -t32(1)*t12(3) + t12(1)*t32(3) tm(3) = t32(1)*t12(2) - t12(1)*t32(2) - sm = NORM2(tm) - s32 = NORM2(t32) + sm = SQRT(DOT_PRODUCT(tm, tm)) + s32 = SQRT(DOT_PRODUCT(t32, t32)) CALL force_opbends(opbend_list(iopbend)%opbend_kind%id_type, & s32, tm, t41, t42, t43, & opbend_list(iopbend)%opbend_kind%k, & diff --git a/src/fist_neighbor_list_control.F b/src/fist_neighbor_list_control.F index 0e23752054..f16cc70787 100644 --- a/src/fist_neighbor_list_control.F +++ b/src/fist_neighbor_list_control.F @@ -39,9 +39,14 @@ MODULE fist_neighbor_list_control section_vals_val_get USE kinds, ONLY: dp USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: & - ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & - pair_potential_pp_type, siepmann_type, tersoff_type + USE pair_potential_types, ONLY: ace_type,& + allegro_type,& + gal21_type,& + gal_type,& + nequip_type,& + pair_potential_pp_type,& + siepmann_type,& + tersoff_type USE particle_types, ONLY: particle_type #include "./base/base_uses.f90" @@ -231,9 +236,6 @@ CONTAINS IF (ANY(potparm%pot(ikind, jkind)%pot%type == nequip_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF - IF (ANY(potparm%pot(ikind, jkind)%pot%type == mace_type)) THEN - full_nl(ikind, jkind) = .TRUE. - END IF IF (ANY(potparm%pot(ikind, jkind)%pot%type == ace_type)) THEN full_nl(ikind, jkind) = .TRUE. END IF diff --git a/src/fist_neighbor_lists.F b/src/fist_neighbor_lists.F index 34694b9879..803244aac8 100644 --- a/src/fist_neighbor_lists.F +++ b/src/fist_neighbor_lists.F @@ -685,7 +685,7 @@ CONTAINS ra(:) = pbc(particle_set(atom_a)%r, cell) rb(:) = pbc(particle_set(atom_b)%r, cell) rab = rb(:) - ra(:) + cell_v - dab = NORM2(rab) + dab = SQRT(DOT_PRODUCT(rab, rab)) IF (ilist <= neighbor_kind_pair%nscale) THEN WRITE (UNIT=output_unit, FMT="(T3,2(I6,3(1X,F10.6)),3(1X,I3),10X,F8.4,L4,F11.5,F9.5)") & atom_a, ra(1:3)*conv, & diff --git a/src/fist_nonbond_env_types.F b/src/fist_nonbond_env_types.F index 045df06365..c90883e177 100644 --- a/src/fist_nonbond_env_types.F +++ b/src/fist_nonbond_env_types.F @@ -23,8 +23,8 @@ MODULE fist_nonbond_env_types USE kinds, ONLY: default_string_length,& dp USE pair_potential_types, ONLY: & - ace_type, allegro_type, gal21_type, gal_type, mace_type, nequip_type, & - pair_potential_pp_release, pair_potential_pp_type, siepmann_type, tersoff_type + ace_type, allegro_type, gal21_type, gal_type, nequip_type, pair_potential_pp_release, & + pair_potential_pp_type, siepmann_type, tersoff_type USE torch_api, ONLY: torch_model_release,& torch_model_type #include "./base/base_uses.f90" @@ -189,36 +189,29 @@ CONTAINS IF (PRESENT(rlist_lowsq)) rlist_lowsq => fist_nonbond_env%rlist_lowsq IF (PRESENT(ij_kind_full_fac)) ij_kind_full_fac => fist_nonbond_env%ij_kind_full_fac IF (PRESENT(nonbonded)) nonbonded => fist_nonbond_env%nonbonded - IF (PRESENT(r_last_update)) THEN + IF (PRESENT(r_last_update)) & r_last_update => fist_nonbond_env%r_last_update - END IF - IF (PRESENT(r_last_update_pbc)) THEN + IF (PRESENT(r_last_update_pbc)) & r_last_update_pbc => fist_nonbond_env%r_last_update_pbc - END IF - IF (PRESENT(rshell_last_update_pbc)) THEN + IF (PRESENT(rshell_last_update_pbc)) & rshell_last_update_pbc => fist_nonbond_env%rshell_last_update_pbc - END IF - IF (PRESENT(rcore_last_update_pbc)) THEN + IF (PRESENT(rcore_last_update_pbc)) & rcore_last_update_pbc => fist_nonbond_env%rcore_last_update_pbc - END IF - IF (PRESENT(cell_last_update)) THEN + IF (PRESENT(cell_last_update)) & cell_last_update => fist_nonbond_env%cell_last_update - END IF IF (PRESENT(lup)) lup = fist_nonbond_env%lup IF (PRESENT(aup)) aup = fist_nonbond_env%aup IF (PRESENT(ei_scale14)) ei_scale14 = fist_nonbond_env%ei_scale14 IF (PRESENT(vdw_scale14)) vdw_scale14 = fist_nonbond_env%vdw_scale14 - IF (PRESENT(shift_cutoff)) THEN + IF (PRESENT(shift_cutoff)) & shift_cutoff = fist_nonbond_env%shift_cutoff - END IF IF (PRESENT(do_electrostatics)) do_electrostatics = fist_nonbond_env%do_electrostatics IF (PRESENT(natom_types)) natom_types = fist_nonbond_env%natom_types IF (PRESENT(counter)) counter = fist_nonbond_env%counter IF (PRESENT(last_update)) last_update = fist_nonbond_env%last_update IF (PRESENT(num_update)) num_update = fist_nonbond_env%num_update - IF (PRESENT(long_range_correction)) THEN + IF (PRESENT(long_range_correction)) & long_range_correction = fist_nonbond_env%long_range_correction - END IF END SUBROUTINE fist_nonbond_env_get ! ************************************************************************************************** @@ -290,36 +283,29 @@ CONTAINS IF (PRESENT(charges)) fist_nonbond_env%charges => charges IF (PRESENT(rlist_lowsq)) fist_nonbond_env%rlist_lowsq => rlist_lowsq IF (PRESENT(nonbonded)) fist_nonbond_env%nonbonded => nonbonded - IF (PRESENT(r_last_update)) THEN + IF (PRESENT(r_last_update)) & fist_nonbond_env%r_last_update => r_last_update - END IF - IF (PRESENT(r_last_update_pbc)) THEN + IF (PRESENT(r_last_update_pbc)) & fist_nonbond_env%r_last_update_pbc => r_last_update_pbc - END IF - IF (PRESENT(rshell_last_update_pbc)) THEN + IF (PRESENT(rshell_last_update_pbc)) & fist_nonbond_env%rshell_last_update_pbc => rshell_last_update_pbc - END IF - IF (PRESENT(rcore_last_update_pbc)) THEN + IF (PRESENT(rcore_last_update_pbc)) & fist_nonbond_env%rcore_last_update_pbc => rcore_last_update_pbc - END IF - IF (PRESENT(cell_last_update)) THEN + IF (PRESENT(cell_last_update)) & fist_nonbond_env%cell_last_update => cell_last_update - END IF IF (PRESENT(lup)) fist_nonbond_env%lup = lup IF (PRESENT(aup)) fist_nonbond_env%aup = aup IF (PRESENT(ei_scale14)) fist_nonbond_env%ei_scale14 = ei_scale14 IF (PRESENT(vdw_scale14)) fist_nonbond_env%vdw_scale14 = vdw_scale14 - IF (PRESENT(shift_cutoff)) THEN + IF (PRESENT(shift_cutoff)) & fist_nonbond_env%shift_cutoff = shift_cutoff - END IF IF (PRESENT(do_electrostatics)) fist_nonbond_env%do_electrostatics = do_electrostatics IF (PRESENT(natom_types)) fist_nonbond_env%natom_types = natom_types IF (PRESENT(counter)) fist_nonbond_env%counter = counter IF (PRESENT(last_update)) fist_nonbond_env%last_update = last_update IF (PRESENT(num_update)) fist_nonbond_env%num_update = num_update - IF (PRESENT(long_range_correction)) THEN + IF (PRESENT(long_range_correction)) & fist_nonbond_env%long_range_correction = long_range_correction - END IF END SUBROUTINE fist_nonbond_env_set ! ************************************************************************************************** @@ -497,10 +483,6 @@ CONTAINS fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp END IF - IF (ANY(potparm%pot(idim, jdim)%pot%type == mace_type)) THEN - fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp - fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp - END IF IF (ANY(potparm%pot(idim, jdim)%pot%type == allegro_type)) THEN fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp fist_nonbond_env%ij_kind_full_fac(idim, jdim) = 0.5_dp diff --git a/src/fist_nonbond_force.F b/src/fist_nonbond_force.F index 0d6680b31c..6de5a4894d 100644 --- a/src/fist_nonbond_force.F +++ b/src/fist_nonbond_force.F @@ -38,9 +38,9 @@ MODULE fist_nonbond_force USE message_passing, ONLY: mp_comm_type USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, gal21_type, gal_type, mace_type, nequip_type, & - nosh_nosh, nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, & - siepmann_type, tersoff_type + ace_type, allegro_type, deepmd_type, gal21_type, gal_type, nequip_type, nosh_nosh, & + nosh_sh, pair_potential_pp_type, pair_potential_single_type, sh_sh, siepmann_type, & + tersoff_type USE particle_types, ONLY: particle_type USE shell_potential_types, ONLY: get_shell,& shell_kind_type @@ -231,7 +231,6 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & - .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = 0.5_dp*fac_ei @@ -723,7 +722,6 @@ CONTAINS full_nl = ANY(pot%type == tersoff_type) .OR. ANY(pot%type == siepmann_type) & .OR. ANY(pot%type == gal_type) .OR. ANY(pot%type == gal21_type) & .OR. ANY(pot%type == nequip_type) .OR. ANY(pot%type == allegro_type) & - .OR. ANY(pot%type == mace_type) & .OR. ANY(pot%type == ace_type) .OR. ANY(pot%type == deepmd_type) IF ((.NOT. full_nl) .AND. (atom_a == atom_b)) THEN fac_ei = fac_ei*0.5_dp diff --git a/src/floquet_utils.F b/src/floquet_utils.F index 182c1a0e93..b5e0f05f72 100644 --- a/src/floquet_utils.F +++ b/src/floquet_utils.F @@ -303,7 +303,7 @@ CONTAINS ! E_factor(α) = (i E(α) exp(i·φ(α)))/(2ω) where α = x,y,z DO i_dir = 1, 3 - efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(COS(phi(i_dir)), SIN(phi(i_dir)), KIND=dp)/(2*omega) + efactor(i_dir) = gaussi*e_vec(i_dir)*CMPLX(DCOS(phi(i_dir)), DSIN(phi(i_dir)), KIND=dp)/(2*omega) END DO DO i_dir = 1, 3 diff --git a/src/fm/cp_cfm_types.F b/src/fm/cp_cfm_types.F index 2ae9174c83..17c77dc1eb 100644 --- a/src/fm/cp_cfm_types.F +++ b/src/fm/cp_cfm_types.F @@ -439,9 +439,8 @@ CONTAINS ! * the source matrix is distributed across a number of processes, or ! * not all elements of the target matrix will be assigned, e.g. ! when the target matrix is larger then the source matrix - IF (do_zero) THEN + IF (do_zero) & CALL zcopy(SIZE(target_m), z_zero, 0, target_m(1, 1), 1) - END IF IF (tr_a) THEN DO j = start_col_local, end_col_local @@ -669,17 +668,14 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & CPABORT("internal local_data has different sizes") - END IF CALL zcopy(SIZE(source%local_data), source%local_data(1, 1), 1, destination%local_data(1, 1), 1) ELSE - IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) THEN + IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) & CPABORT("cannot copy between full matrixes of differen sizes") - END IF - IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) THEN + IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) & CPABORT("cannot copy between full matrixes of differen sizes") - END IF #if defined(__parallel) CALL pzcopy(source%matrix_struct%nrow_global* & source%matrix_struct%ncol_global, & @@ -1072,8 +1068,7 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another - ! routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends diff --git a/src/fm/cp_fm_diag_utils.F b/src/fm/cp_fm_diag_utils.F index d613da3fc9..8ac6dc147e 100644 --- a/src/fm/cp_fm_diag_utils.F +++ b/src/fm/cp_fm_diag_utils.F @@ -200,14 +200,12 @@ CONTAINS ncpu = num_pe_old - nzero ! Avoid layouts with odd number of CPUs (blacs grid layout will be square) - IF (ncpu > 2) THEN + IF (ncpu > 2) & ncpu = ncpu - MODULO(ncpu, 2) - END IF ! if there are no zero-width columns and the number of processors was even, leave it at that - IF (ncpu == num_pe_old) THEN + IF (ncpu == num_pe_old) & RETURN - END IF ! Iteratively search for the maximum number of CPUs for ELPA ! On each step, we test whether the blacs grid created with ncpu processes @@ -218,9 +216,8 @@ CONTAINS gcd_max = -1 DO ipe = 1, CEILING(SQRT(REAL(ncpu, dp))) jpe = ncpu/ipe - IF (ipe*jpe /= ncpu) THEN + IF (ipe*jpe /= ncpu) & CYCLE - END IF IF (gcd(ipe, jpe) >= gcd_max) THEN npcol = jpe gcd_max = gcd(ipe, jpe) @@ -231,20 +228,17 @@ CONTAINS ! (snippet copied from cp_fm_struct.F:cp_fm_struct_create) nzero = 0 DO ipe = 0, npcol - 1 - IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) THEN + IF (numroc(ncol_global, ncol_block, ipe, 0, npcol) == 0) & nzero = nzero + 1 - END IF END DO - IF (nzero == 0) THEN + IF (nzero == 0) & EXIT - END IF ncpu = ncpu - nzero - IF (ncpu > 2) THEN + IF (ncpu > 2) & ncpu = ncpu - MODULO(ncpu, 2) - END IF END DO END FUNCTION cp_fm_max_ncpu_non_zero_column @@ -429,9 +423,8 @@ CONTAINS eigenvectors_new = eigenvectors END IF - IF (PRESENT(redist_info)) THEN + IF (PRESENT(redist_info)) & redist_info = rdinfo - END IF #else MARK_USED(matrix) diff --git a/src/fm/cp_fm_elpa.F b/src/fm/cp_fm_elpa.F index 0fed54533c..c55f3ba75f 100644 --- a/src/fm/cp_fm_elpa.F +++ b/src/fm/cp_fm_elpa.F @@ -192,9 +192,8 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: one_stage, qr, should_print #if defined(__ELPA) - IF (elpa_init(20180525) /= ELPA_OK) THEN + IF (elpa_init(20180525) /= ELPA_OK) & CPABORT("The linked ELPA library does not support the required API version") - END IF IF (PRESENT(one_stage)) elpa_one_stage = one_stage IF (PRESENT(should_print)) elpa_print = should_print IF (PRESENT(qr)) elpa_qr = qr @@ -295,9 +294,8 @@ CONTAINS caller_is_elpa=.TRUE., redist_info=rdinfo) ! Call ELPA on CPUs that hold the new matrix - IF (ASSOCIATED(matrix_new%matrix_struct)) THEN + IF (ASSOCIATED(matrix_new%matrix_struct)) & CALL cp_fm_diag_elpa_base(matrix_new, eigenvectors_new, eigenvalues, rdinfo) - END IF ! Redistribute results and clean up CALL cp_fm_redistribute_end(matrix, eigenvectors, eigenvalues, matrix_new, eigenvectors_new) @@ -391,14 +389,12 @@ CONTAINS ! Matrix order must be even use_qr = elpa_qr .AND. (MODULO(n, 2) == 0) ! Matrix order and block size must be greater than or equal to 64 - IF (.NOT. elpa_qr_unsafe) THEN + IF (.NOT. elpa_qr_unsafe) & use_qr = use_qr .AND. (n >= 64) .AND. (nblk >= 64) - END IF ! Check if eigenvalues computed with elpa_qr_unsafe should be verified - IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) THEN + IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_print) & check_eigenvalues = .TRUE. - END IF CALL matrix%matrix_struct%para_env%bcast(check_eigenvalues) @@ -501,9 +497,8 @@ CONTAINS CALL elpa_obj%set("solver", & MERGE(ELPA_SOLVER_1STAGE, ELPA_SOLVER_2STAGE, elpa_one_stage), & success) - IF (success /= ELPA_OK) THEN + IF (success /= ELPA_OK) & CPABORT("Setting solver for ELPA failed") - END IF ! enabling the GPU must happen before setting the kernel SELECT CASE (elpa_kernel) @@ -544,9 +539,8 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (success /= ELPA_OK) THEN + IF (success /= ELPA_OK) & CPABORT("ELPA failed to diagonalize a matrix") - END IF IF (check_eigenvalues) THEN ! run again without QR @@ -554,13 +548,11 @@ CONTAINS CPASSERT(success == ELPA_OK) CALL elpa_obj%eigenvectors(matrix_noqr%local_data, eval_noqr, eigenvectors_noqr%local_data, success) - IF (success /= ELPA_OK) THEN + IF (success /= ELPA_OK) & CPABORT("ELPA failed to diagonalize a matrix even without QR decomposition") - END IF - IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) THEN + IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) & CPABORT("ELPA failed to calculate Eigenvalues with ELPA's QR decomposition") - END IF DEALLOCATE (eval_noqr) CALL cp_fm_release(matrix_noqr) diff --git a/src/fm/cp_fm_struct.F b/src/fm/cp_fm_struct.F index 3082c01518..717f915611 100644 --- a/src/fm/cp_fm_struct.F +++ b/src/fm/cp_fm_struct.F @@ -232,9 +232,8 @@ CONTAINS ALLOCATE (fmstruct%nrow_locals(0:(fmstruct%context%num_pe(1) - 1)), & fmstruct%ncol_locals(0:(fmstruct%context%num_pe(2) - 1))) - IF (.NOT. PRESENT(template_fmstruct)) THEN + IF (.NOT. PRESENT(template_fmstruct)) & fmstruct%first_p_pos = [0, 0] - END IF IF (PRESENT(first_p_pos)) fmstruct%first_p_pos = first_p_pos fmstruct%nrow_locals = 0 @@ -267,12 +266,10 @@ CONTAINS CALL m_flush(iunit) END IF - IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) THEN + IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) & CPABORT("sum of local cols not equal global cols") - END IF - IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) THEN + IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) & CPABORT("sum of local row not equal global rows") - END IF #else ! block = full matrix fmstruct%nrow_block = fmstruct%nrow_global @@ -284,11 +281,10 @@ CONTAINS fmstruct%local_leading_dimension = MAX(fmstruct%local_leading_dimension, & fmstruct%nrow_locals(fmstruct%context%mepos(1))) IF (PRESENT(local_leading_dimension)) THEN - IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) THEN + IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) & CALL cp_abort(__LOCATION__, "local_leading_dimension too small ("// & cp_to_string(local_leading_dimension)//"<"// & cp_to_string(fmstruct%local_leading_dimension)//")") - END IF fmstruct%local_leading_dimension = local_leading_dimension END IF diff --git a/src/fm/cp_fm_types.F b/src/fm/cp_fm_types.F index 756ad2f27e..75d6c4e816 100644 --- a/src/fm/cp_fm_types.F +++ b/src/fm/cp_fm_types.F @@ -482,9 +482,8 @@ CONTAINS my_ncol = matrix%matrix_struct%ncol_global IF (PRESENT(ncol)) my_ncol = ncol - IF (ncol_global < (my_start_col + my_ncol - 1)) THEN + IF (ncol_global < (my_start_col + my_ncol - 1)) & CPABORT("ncol_global>=(my_start_col+my_ncol-1)") - END IF ALLOCATE (buff(nrow_global)) @@ -1269,7 +1268,7 @@ CONTAINS IF (PRESENT(dir)) THEN IF (dir == 'c' .OR. dir == 'C') THEN docol = .TRUE. - ELSE IF (dir == 'r' .OR. dir == 'R') THEN + ELSEIF (dir == 'r' .OR. dir == 'R') THEN docol = .FALSE. ELSE CPABORT('Wrong argument DIR') @@ -1327,12 +1326,11 @@ CONTAINS cp_fm_struct_equivalent(source%matrix_struct, & destination%matrix_struct)) THEN IF (SIZE(source%local_data, 1) /= SIZE(destination%local_data, 1) .OR. & - SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) THEN + SIZE(source%local_data, 2) /= SIZE(destination%local_data, 2)) & CALL cp_abort(__LOCATION__, & "Cannot copy full matrix <"//TRIM(source%name)// & "> to full matrix <"//TRIM(destination%name)// & ">. The local_data blocks have different sizes.") - END IF CALL dcopy(SIZE(source%local_data, 1)*SIZE(source%local_data, 2), & source%local_data, 1, destination%local_data, 1) ELSE @@ -1474,21 +1472,17 @@ CONTAINS na = msource%matrix_struct%nrow_global nb = mtarget%matrix_struct%nrow_global ! nrow must be <= na and nb - IF (nrow > na) THEN + IF (nrow > na) & CPABORT("cannot copy because nrow > number of rows of source matrix") - END IF - IF (nrow > nb) THEN + IF (nrow > nb) & CPABORT("cannot copy because nrow > number of rows of target matrix") - END IF na = msource%matrix_struct%ncol_global nb = mtarget%matrix_struct%ncol_global ! ncol must be <= na_col and nb_col - IF (ncol > na) THEN + IF (ncol > na) & CPABORT("cannot copy because nrow > number of rows of source matrix") - END IF - IF (ncol > nb) THEN + IF (ncol > nb) & CPABORT("cannot copy because nrow > number of rows of target matrix") - END IF #if defined(__parallel) desca(:) = msource%matrix_struct%descriptor(:) @@ -1722,8 +1716,7 @@ CONTAINS ! pack send buffers ! call isend ! DEST_2 - ! wait for the recvs and unpack buffers (this part eventually will go into another - ! routine to allow comms to run concurrently) + ! wait for the recvs and unpack buffers (this part eventually will go into another routine to allow comms to run concurrently) ! SRC_2 ! wait for the sends @@ -2019,12 +2012,10 @@ CONTAINS ! check whether source is available on this process IF (ASSOCIATED(source%matrix_struct)) THEN desca = source%matrix_struct%descriptor - IF (nrows > source%matrix_struct%nrow_global) THEN + IF (nrows > source%matrix_struct%nrow_global) & CPABORT("nrows is greater than nrow_global of source") - END IF - IF (ncols > source%matrix_struct%ncol_global) THEN + IF (ncols > source%matrix_struct%ncol_global) & CPABORT("ncols is greater than ncol_global of source") - END IF smat => source%local_data ELSE desca = -1 @@ -2033,12 +2024,10 @@ CONTAINS ! check destination is available on this process IF (ASSOCIATED(destination%matrix_struct)) THEN descb = destination%matrix_struct%descriptor - IF (nrows > destination%matrix_struct%nrow_global) THEN + IF (nrows > destination%matrix_struct%nrow_global) & CPABORT("nrows is greater than nrow_global of destination") - END IF - IF (ncols > destination%matrix_struct%ncol_global) THEN + IF (ncols > destination%matrix_struct%ncol_global) & CPABORT("ncols is greater than ncol_global of destination") - END IF dmat => destination%local_data ELSE descb = -1 diff --git a/src/force_env_methods.F b/src/force_env_methods.F index abb560ea63..28cbe7e2ac 100644 --- a/src/force_env_methods.F +++ b/src/force_env_methods.F @@ -404,9 +404,8 @@ CONTAINS "PRINT%PROGRAM_RUN_INFO") ! terminate the run if the value of the potential is abnormal - IF (abnormal_value(e_pot)) THEN + IF (abnormal_value(e_pot)) & CPABORT("Potential energy is an abnormal value (NaN/Inf).") - END IF ! Print forces, if requested print_forces = cp_print_key_unit_nr(logger, force_env%force_env_section, "PRINT%FORCES", & @@ -626,15 +625,13 @@ CONTAINS (.NOT. use_full_grid) ! Preserve restrictions selected during initial setup. The explicit DEBUG expert option ! remains available for symmetry diagnostics on otherwise unsupported cell matrices. - IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN + IF (inversion_symmetry_only .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & use_inversion_symmetry_only = .TRUE. - END IF non_lower_triangular_cell = (ABS(cell%hmat(2, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 1)) > eps_cell) .OR. & (ABS(cell%hmat(3, 2)) > eps_cell) - IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) THEN + IF (non_lower_triangular_cell .AND. .NOT. force_full_debug_symmetry .AND. .NOT. use_full_grid) & use_inversion_symmetry_only = .TRUE. - END IF dynamic_symmetry = kpoint_symmetry .AND. .NOT. use_full_grid .AND. & .NOT. use_inversion_symmetry_only IF (run_type_id == debug_run .AND. .NOT. fd_energy .AND. .NOT. dynamic_symmetry .AND. & @@ -1285,9 +1282,8 @@ CONTAINS !Transfer results source = 0 IF (ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) THEN - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & source = force_env%para_env%mepos - END IF END IF CALL force_env%para_env%sum(source) CALL cp_results_mp_bcast(results(iforce_eval)%results, source, force_env%para_env) @@ -1398,17 +1394,14 @@ CONTAINS CALL section_vals_val_get(mixed_section, "MIXED_CDFT%LAMBDA", r_val=lambda) ! Get the states which determine the forces CALL section_vals_val_get(mixed_section, "MIXED_CDFT%FORCE_STATES", i_vals=itmplist) - IF (SIZE(itmplist) /= 2) THEN + IF (SIZE(itmplist) /= 2) & CALL cp_abort(__LOCATION__, & "Keyword FORCE_STATES takes exactly two input values.") - END IF - IF (ANY(itmplist < 0)) THEN + IF (ANY(itmplist < 0)) & CPABORT("Invalid force_eval index.") - END IF istate = itmplist - IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) THEN + IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) & CPABORT("Invalid force_eval index.") - END IF mixed_energy%pot = lambda*energies(istate(1)) + (1.0_dp - lambda)*energies(istate(2)) ! General Mapping of forces... CALL mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces, virials, results, & @@ -1522,9 +1515,8 @@ CONTAINS ! Get Mapping index array natom = SIZE(particles(iforce_eval)%list%els) ! Serial mode need to deallocate first - IF (ASSOCIATED(map_index)) THEN + IF (ASSOCIATED(map_index)) & DEALLOCATE (map_index) - END IF CALL get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, & map_index) @@ -1534,9 +1526,8 @@ CONTAINS particles(iforce_eval)%list%els(iparticle)%r = particles_mix%els(jparticle)%r END DO ! Mixed CDFT + QMMM: Need to translate now - IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN + IF (force_env%mixed_env%do_mixed_qmmm_cdft) & CALL apply_qmmm_translate(force_env%sub_force_env(iforce_eval)%force_env%qmmm_env) - END IF END DO ! For mixed CDFT calculations parallelized over CDFT states ! build weight and gradient on all processors before splitting into groups and @@ -1602,9 +1593,8 @@ CONTAINS nforce_eval = SIZE(force_env%sub_force_env) nvar = force_env%mixed_env%cdft_control%nconstraint ! Transfer cdft strengths for writing restart - IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) THEN + IF (.NOT. ASSOCIATED(force_env%mixed_env%strength)) & ALLOCATE (force_env%mixed_env%strength(nforce_eval, nvar)) - END IF force_env%mixed_env%strength = 0.0_dp DO iforce_eval = 1, nforce_eval IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE @@ -1614,16 +1604,14 @@ CONTAINS CALL force_env_get(force_env%sub_force_env(iforce_eval)%force_env, qs_env=qs_env) END IF CALL get_qs_env(qs_env, dft_control=dft_control) - IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN + IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) & force_env%mixed_env%strength(iforce_eval, :) = dft_control%qs_control%cdft_control%strength(:) - END IF END DO CALL force_env%para_env%sum(force_env%mixed_env%strength) ! Mixed CDFT: calculate ET coupling IF (force_env%mixed_env%do_mixed_et) THEN - IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) THEN + IF (MODULO(force_env%mixed_env%cdft_control%sim_step, force_env%mixed_env%et_freq) == 0) & CALL mixed_cdft_calculate_coupling(force_env) - END IF END IF END IF @@ -2145,10 +2133,9 @@ CONTAINS ! Calculate potential gradient if the step has been accepted. Otherwise, we reuse the previous one - IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) THEN + IF (opt_embed%accept_step .AND. (.NOT. opt_embed%grid_opt)) & CALL calculate_embed_pot_grad(force_env%sub_force_env(ref_subsys_number)%force_env%qs_env, & diff_rho_r, diff_rho_spin, opt_embed) - END IF ! Take the embedding step CALL opt_embed_step(diff_rho_r, diff_rho_spin, opt_embed, embed_pot, spin_embed_pot, rho_r_ref, & force_env%sub_force_env(ref_subsys_number)%force_env%qs_env) diff --git a/src/force_env_types.F b/src/force_env_types.F index f13f5bfbf1..339fcfeb75 100644 --- a/src/force_env_types.F +++ b/src/force_env_types.F @@ -230,12 +230,10 @@ CONTAINS CALL cp_add_default_logger(my_logger) END IF CALL force_env_release(force_env%sub_force_env(i)%force_env) - IF (force_env%in_use == use_mixed_force) THEN + IF (force_env%in_use == use_mixed_force) & CALL cp_rm_default_logger() - END IF - IF (force_env%in_use == use_embed) THEN + IF (force_env%in_use == use_embed) & CALL cp_rm_default_logger() - END IF END DO DEALLOCATE (force_env%sub_force_env) END IF diff --git a/src/force_env_utils.F b/src/force_env_utils.F index aba2988c97..699045290f 100644 --- a/src/force_env_utils.F +++ b/src/force_env_utils.F @@ -393,7 +393,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) DO iparticle = 1, SIZE(particles%els) force = particles%els(iparticle)%f(:) - mod_force = NORM2(force) + mod_force = SQRT(DOT_PRODUCT(force, force)) IF ((mod_force > max_value) .AND. (mod_force /= 0.0_dp)) THEN force = force/mod_force*max_value particles%els(iparticle)%f(:) = force diff --git a/src/force_fields_all.F b/src/force_fields_all.F index 798fe280b8..061e971116 100644 --- a/src/force_fields_all.F +++ b/src/force_fields_all.F @@ -64,11 +64,10 @@ MODULE force_fields_all spline_nonbond_control USE pair_potential_coulomb, ONLY: potential_coulomb USE pair_potential_types, ONLY: & - ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, mace_type, & - nequip_type, nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, & - pair_potential_pp_create, pair_potential_pp_type, pair_potential_single_add, & - pair_potential_single_clean, pair_potential_single_copy, pair_potential_single_type, & - sh_sh, siepmann_type, tersoff_type + ace_type, allegro_type, deepmd_type, ea_type, lj_charmm_type, lj_type, nequip_type, & + nn_type, nosh_nosh, nosh_sh, pair_potential_lj_create, pair_potential_pp_create, & + pair_potential_pp_type, pair_potential_single_add, pair_potential_single_clean, & + pair_potential_single_copy, pair_potential_single_type, sh_sh, siepmann_type, tersoff_type USE particle_types, ONLY: allocate_particle_set,& particle_type USE physcon, ONLY: bohr @@ -2026,12 +2025,11 @@ CONTAINS only_qm = qmmm_ff_precond_only_qm(id1=atmname, is_link=is_link_atom) CALL uppercase(atmname) - IF (charge /= -HUGE(0.0_dp)) THEN + IF (charge /= -HUGE(0.0_dp)) & CALL cp_warn(__LOCATION__, & "The charge for atom index ("//cp_to_string(iatom)//") and atom name ("// & TRIM(atmname)//") was already defined. The charge associated to this kind"// & " will be set to an uninitialized value and only the atom specific charge will be used! ") - END IF charge = -HUGE(0.0_dp) ! Check if the potential really requires the charge definition.. @@ -2173,11 +2171,10 @@ CONTAINS inp_info%shell_list(j)%shell%charge_shell charge = 0.0_dp IF (found) THEN - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "CORE-SHELL model defined for KIND ("//TRIM(atmname)//")"// & " ignoring charge definition! ") - END IF ELSE found = .TRUE. END IF @@ -2195,7 +2192,7 @@ CONTAINS atmname == inp_info%nonbonded%pot(j)%pot%at2) THEN SELECT CASE (inp_info%nonbonded%pot(j)%pot%type(1)) CASE (ea_type, tersoff_type, siepmann_type, nequip_type, & - allegro_type, deepmd_type, ace_type, mace_type) + allegro_type, deepmd_type, ace_type) ! Charge is zero for EAM, TERSOFF and SIEPMANN type potential ! Do nothing.. CASE DEFAULT @@ -2932,20 +2929,18 @@ CONTAINS ((name_atm_a) == (inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" ADDING! ") - END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declarations: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") - END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. @@ -2976,20 +2971,18 @@ CONTAINS ((name_atm_a) == (qmmm_env%inp_info%nonbonded14%pot(k)%pot%at2)))) THEN IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" Adding QM/MM forcefield specifications") - END IF potparm_nonbond14%pot(i, j)%pot => pot potparm_nonbond14%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded14%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple ONFO declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING QM/MM forcefield specifications! ") - END IF END IF IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), & " ", TRIM(name_atm_b) @@ -3234,20 +3227,18 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") - END IF END IF found = .TRUE. END IF @@ -3277,20 +3268,18 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> ADDING") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & "-"//TRIM(name_atm_b)//" -> OVERWRITING") - END IF END IF found = .TRUE. END IF @@ -3317,20 +3306,18 @@ CONTAINS END IF IF (ff_type%multiple_potential) THEN CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> ADDING") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations "//TRIM(name_atm_a)// & " - "//TRIM(name_atm_b)//" -> OVERWRITING") - END IF END IF found = .TRUE. END DO @@ -3364,20 +3351,18 @@ CONTAINS END IF IF (qmmm_env%multiple_potential) THEN CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> ADDING QM/MM forcefield specifications") - END IF potparm_nonbond%pot(i, j)%pot => pot potparm_nonbond%pot(j, i)%pot => pot ELSE CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded%pot(k)%pot, pot) - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declarations for "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" -> OVERWRITING QM/MM forcefield specifications") - END IF END IF found = .TRUE. END IF @@ -3648,10 +3633,9 @@ CONTAINS IF (PRESENT(atm3)) fmt = fmt + 1 IF (PRESENT(atm4)) fmt = fmt + 1 CALL integer_to_string(fmt - 1, sfmt) - IF (fmt > 1) THEN + IF (fmt > 1) & my_format = '(T2,"FORCEFIELD| Missing ","'//TRIM(type_name)// & '",T40,"(",A9,'//TRIM(sfmt)//'(",",A9),")")' - END IF IF (PRESENT(fatal)) fatal = .TRUE. ! Check for previous already stored equal force fields IF (ASSOCIATED(array)) nsize = SIZE(array) @@ -3676,9 +3660,8 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & found = .TRUE. - END IF CASE ("Urey-Bradley") IF (INDEX(array(i) (21:39), "Urey-Bradley") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3688,9 +3671,8 @@ CONTAINS CALL compress(my_atm2, .TRUE.) CALL compress(my_atm3, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3)) .OR. & - ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) THEN + ((atm1 == my_atm3) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm1))) & found = .TRUE. - END IF CASE ("Torsion") IF (INDEX(array(i) (21:39), "Torsion") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3702,9 +3684,8 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) THEN + ((atm1 == my_atm4) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm1))) & found = .TRUE. - END IF CASE ("Improper") IF (INDEX(array(i) (21:39), "Improper") == 0) CYCLE my_atm1 = array(i) (41:49) @@ -3720,9 +3701,8 @@ CONTAINS ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm2)) .OR. & ((atm1 == my_atm1) .AND. (atm2 == my_atm4) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm3)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) THEN + ((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm4) .AND. (atm4 == my_atm3))) & found = .TRUE. - END IF CASE ("Out of plane bend") IF (INDEX(array(i) (21:39), "Out of plane bend") == 0) CYCLE @@ -3735,9 +3715,8 @@ CONTAINS CALL compress(my_atm3, .TRUE.) CALL compress(my_atm4, .TRUE.) IF (((atm1 == my_atm1) .AND. (atm2 == my_atm2) .AND. (atm3 == my_atm3) .AND. (atm4 == my_atm4)) .OR. & - ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) THEN + ((atm1 == my_atm1) .AND. (atm2 == my_atm3) .AND. (atm3 == my_atm2) .AND. (atm4 == my_atm4))) & found = .TRUE. - END IF CASE ("Charge") IF (INDEX(array(i) (21:39), "Charge") == 0) CYCLE diff --git a/src/force_fields_input.F b/src/force_fields_input.F index 1df71ce40d..28fccce750 100644 --- a/src/force_fields_input.F +++ b/src/force_fields_input.F @@ -69,7 +69,7 @@ MODULE force_fields_input USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, deepmd_type, do_potential_single_allocation, & ea_type, eam_pot_type, ft_pot_type, ft_type, ftd_type, gal21_type, gal_type, gp_type, & - gw_type, ip_type, ipbv_pot_type, lj_charmm_type, mace_type, nequip_pot_type, nequip_type, & + gw_type, ip_type, ipbv_pot_type, lj_charmm_type, nequip_pot_type, nequip_type, & no_potential_single_allocation, pair_potential_p_type, pair_potential_reallocate, & potential_single_allocation, siepmann_type, tab_pot_type, tab_type, tersoff_type, wl_type USE shell_potential_types, ONLY: shell_p_create,& @@ -109,8 +109,8 @@ CONTAINS CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: atm_names INTEGER :: nace, nb4, nbends, nbm, nbmhft, nbmhftd, nbonds, nchg, ndeepmd, neam, ngal, & - ngal21, ngd, ngp, nimpr, nipbv, nlj, nmace, nnequip, nopbend, nshell, nsiepmann, ntab, & - ntersoff, ntors, ntot, nubs, nwl + ngal21, ngd, ngp, nimpr, nipbv, nlj, nnequip, nopbend, nshell, nsiepmann, ntab, ntersoff, & + ntors, ntot, nubs, nwl LOGICAL :: explicit, unique_spline REAL(KIND=dp) :: min_eps_spline_allowed TYPE(input_info_type), POINTER :: inp_info @@ -135,11 +135,8 @@ CONTAINS SELECT CASE (ff_type%ff_type) CASE (do_ff_charmm, do_ff_amber, do_ff_g96, do_ff_g87) CALL section_vals_val_get(ff_section, "PARM_FILE_NAME", c_val=ff_type%ff_file_name) - - IF (TRIM(ff_type%ff_file_name) == "") THEN + IF (TRIM(ff_type%ff_file_name) == "") & CPABORT("Force Field Parameter's filename is empty! Please check your input file.") - END IF - CASE (do_ff_undef) ! Do Nothing CASE DEFAULT @@ -328,19 +325,6 @@ CONTAINS CALL read_ace_section(inp_info%nonbonded, tmp_section2, ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section, "MACE") - CALL section_vals_get(tmp_section2, explicit=explicit, n_repetition=nmace) - ntot = nlj + nwl + neam + ngd + nipbv + nbmhft + nbmhftd + nb4 + nbm + ngp + ntersoff + & - ngal + ngal21 + nsiepmann + nnequip + ntab + ndeepmd + nace - IF (explicit) THEN - ! avoid repeating the mace section for each pair - CALL section_vals_val_get(tmp_section2, "ATOMS", c_vals=atm_names) - nmace = nmace - 1 + SIZE(atm_names) + (SIZE(atm_names)*SIZE(atm_names) - SIZE(atm_names))/2 - ! MACE reuses the nequip_pot_type storage (set%nequip), hence nequip=.TRUE. here - CALL pair_potential_reallocate(inp_info%nonbonded, 1, ntot + nmace, nequip=.TRUE.) - CALL read_mace_section(inp_info%nonbonded, tmp_section2, ntot) - END IF - END IF tmp_section => section_vals_get_subs_vals(ff_section, "NONBONDED14") @@ -554,9 +538,8 @@ CONTAINS ipbv%a(13) = 8756947519.029_dp ipbv%a(14) = 15793297761.67_dp ipbv%a(15) = 12917180227.21_dp - ELSE IF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & - ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN - + ELSEIF (((at1(1:1) == 'O') .AND. (at2(1:1) == 'H')) .OR. & + ((at1(1:1) == 'H') .AND. (at2(1:1) == 'O'))) THEN ipbv%rcore = 2.95_dp ! a.u. ipbv%m = -0.004025691139759147_dp ! Hartree/a.u. @@ -576,7 +559,7 @@ CONTAINS ipbv%a(13) = -4224406093.918E0_dp ipbv%a(14) = 217192386506.5E0_dp ipbv%a(15) = -157581228915.5_dp - ELSE IF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN + ELSEIF ((at1(1:1) == 'H') .AND. (at2(1:1) == 'H')) THEN ipbv%rcore = 3.165_dp ! a.u. ipbv%m = 0.002639704108787555_dp ! Hartree/a.u. ipbv%b = -0.2735482611857583_dp ! Hartree @@ -616,13 +599,12 @@ CONTAINS ft%a = cp_unit_to_cp2k(424.097_dp, "eV") ft%c = cp_unit_to_cp2k(1.05_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(0.499_dp, "eV*angstrom^8") - ELSE IF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & - ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN - + ELSEIF (((at1(1:2) == 'NA') .AND. (at2(1:2) == 'CL')) .OR. & + ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'NA'))) THEN ft%a = cp_unit_to_cp2k(1256.31_dp, "eV") ft%c = cp_unit_to_cp2k(7.00_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(8.676_dp, "eV*angstrom^8") - ELSE IF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN + ELSEIF ((at1(1:2) == 'CL') .AND. (at2(1:2) == 'CL')) THEN ft%a = cp_unit_to_cp2k(3488.998_dp, "eV") ft%c = cp_unit_to_cp2k(72.50_dp, "eV*angstrom^6") ft%d = cp_unit_to_cp2k(145.427_dp, "eV*angstrom^8") @@ -843,54 +825,6 @@ CONTAINS END SUBROUTINE read_nequip_section -! ************************************************************************************************** -!> \brief Reads the MACE section -!> \param nonbonded ... -!> \param section ... -!> \param start ... -!> \author Xinyue Sun -! ************************************************************************************************** - SUBROUTINE read_mace_section(nonbonded, section, start) - TYPE(pair_potential_p_type), POINTER :: nonbonded - TYPE(section_vals_type), POINTER :: section - INTEGER, INTENT(IN) :: start - - CHARACTER(LEN=default_string_length) :: pot_file_name - CHARACTER(LEN=default_string_length), & - DIMENSION(:), POINTER :: atm_names - INTEGER :: isec, jsec, n_items - TYPE(nequip_pot_type) :: mace - - n_items = 1 - isec = 1 - n_items = isec*n_items - CALL section_vals_val_get(section, "ATOMS", c_vals=atm_names) - CALL section_vals_val_get(section, "POT_FILE_NAME", c_val=pot_file_name) - - mace%pot_file_name = discover_file(pot_file_name) - ! MACE models use standardized units: Angstrom, eV and eV/Angstrom - mace%unit_length = "angstrom" - mace%unit_energy = "eV" - mace%unit_forces = "eV/Angstrom" - ! MACE models are exported to speak the same metadata/tensor dialect as NequIP - CALL read_nequip_data(mace) - CALL check_cp2k_atom_names_in_torch(atm_names, mace%type_names_torch) - - DO isec = 1, SIZE(atm_names) - DO jsec = isec, SIZE(atm_names) - nonbonded%pot(start + n_items)%pot%type = mace_type - nonbonded%pot(start + n_items)%pot%at1 = atm_names(isec) - nonbonded%pot(start + n_items)%pot%at2 = atm_names(jsec) - CALL uppercase(nonbonded%pot(start + n_items)%pot%at1) - CALL uppercase(nonbonded%pot(start + n_items)%pot%at2) - nonbonded%pot(start + n_items)%pot%set(1)%nequip = mace - nonbonded%pot(start + n_items)%pot%rcutsq = mace%rcutsq - n_items = n_items + 1 - END DO - END DO - - END SUBROUTINE read_mace_section - ! ************************************************************************************************** !> \brief Reads the LJ section !> \param nonbonded ... @@ -1337,13 +1271,10 @@ CONTAINS ! Calculate p_inv the inverse of the matrix p p_inv(:, :) = 0.0_dp CALL invert_matrix(p, p_inv, eval_error) - - IF (eval_error >= 1.0E-8_dp) THEN + IF (eval_error >= 1.0E-8_dp) & CALL cp_warn(__LOCATION__, & "The polynomial fit for the BUCK4RANGES potential is only accurate to "// & TRIM(cp_to_string(eval_error))) - END IF - ! Get the 6 coefficients of the 5th-order polynomial -> x(1:6) ! and the 4 coefficients of the 3rd-order polynomial -> x(7:10) x(:) = MATMUL(p_inv(:, :), v(:)) diff --git a/src/global_types.F b/src/global_types.F index 6ce57fe286..9d076d7514 100644 --- a/src/global_types.F +++ b/src/global_types.F @@ -139,9 +139,8 @@ CONTAINS CPASSERT(globenv%ref_count > 0) globenv%ref_count = globenv%ref_count - 1 IF (globenv%ref_count == 0) THEN - IF (ALLOCATED(globenv%gaussian_rng_stream)) THEN + IF (ALLOCATED(globenv%gaussian_rng_stream)) & DEALLOCATE (globenv%gaussian_rng_stream) - END IF DEALLOCATE (globenv) END IF END IF diff --git a/src/graphcon.F b/src/graphcon.F index e2ecc59f35..7a06c59b4e 100644 --- a/src/graphcon.F +++ b/src/graphcon.F @@ -547,7 +547,7 @@ CONTAINS IF (q(k) == k) THEN q(k) = n ELSE - GOTO 1 + go to 1 END IF END DO first = .TRUE. diff --git a/src/grid/grid_api.F b/src/grid/grid_api.F index 3868fa9a47..f93b6072be 100644 --- a/src/grid/grid_api.F +++ b/src/grid/grid_api.F @@ -474,18 +474,14 @@ CONTAINS hadb=hadb_cptr, & a_hdab=a_hdab_cptr) - IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) THEN + IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) & force_a = force_a + forces(:, 1) - END IF - IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) THEN + IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) & force_b = force_b + forces(:, 2) - END IF - IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) THEN + IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) & my_virial_a = my_virial_a + virials(:, :, 1) - END IF - IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) THEN + IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) & my_virial_b = my_virial_b + virials(:, :, 2) - END IF END SUBROUTINE integrate_pgf_product diff --git a/src/grpp/libgrpp.F b/src/grpp/libgrpp.F index 07b19227b7..820b585bca 100644 --- a/src/grpp/libgrpp.F +++ b/src/grpp/libgrpp.F @@ -16,10 +16,6 @@ MODULE libgrpp USE ISO_C_BINDING, ONLY: C_DOUBLE,& C_INT32_T - IMPLICIT NONE - - PRIVATE - INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_DIRAC = 0 INTEGER(4), PARAMETER :: LIBGRPP_CART_ORDER_TURBOMOLE = 1 @@ -30,12 +26,6 @@ MODULE libgrpp INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_FERMI_BUBBLE = 4 INTEGER(4), PARAMETER :: LIBGRPP_NUCLEAR_MODEL_POINT_CHARGE_NUMERICAL = 5 - PUBLIC :: libgrpp_init - PUBLIC :: libgrpp_type1_integrals - PUBLIC :: libgrpp_type1_integrals_gradient - PUBLIC :: libgrpp_type2_integrals - PUBLIC :: libgrpp_type2_integrals_gradient - INTERFACE SUBROUTINE libgrpp_init() diff --git a/src/gw_integrals.F b/src/gw_integrals.F index 9036627e7d..30582ab92c 100644 --- a/src/gw_integrals.F +++ b/src/gw_integrals.F @@ -128,7 +128,7 @@ CONTAINS IF (ctx%op_ij == do_potential_truncated .OR. ctx%op_ij == do_potential_short) THEN ctx%dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor ctx%dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (ctx%op_ij == do_potential_coulomb) THEN + ELSEIF (ctx%op_ij == do_potential_coulomb) THEN ctx%dr_ij = 1000000.0_dp ctx%dr_ik = 1000000.0_dp END IF diff --git a/src/gw_large_cell_gamma_ri_rs.F b/src/gw_large_cell_gamma_ri_rs.F index d80730fb64..5dda82c272 100644 --- a/src/gw_large_cell_gamma_ri_rs.F +++ b/src/gw_large_cell_gamma_ri_rs.F @@ -395,28 +395,9 @@ 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 @@ -971,27 +952,9 @@ 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 0cf7dfc5ef..7c0cea6568 100644 --- a/src/gw_non_periodic_ri_rs.F +++ b/src/gw_non_periodic_ri_rs.F @@ -258,16 +258,14 @@ CONTAINS DO i = 1, SIZE(zet_ao, 1) DO j = 1, SIZE(zet_ao, 2) - IF (zet_ao(i, j) > 1.0E-3_dp) THEN + IF (zet_ao(i, j) > 1.0E-3_dp) & alpha_min_ao_kind(ikind) = MIN(alpha_min_ao_kind(ikind), zet_ao(i, j)) - END IF END DO END DO DO i = 1, SIZE(zet_ri, 1) DO j = 1, SIZE(zet_ri, 2) - IF (zet_ri(i, j) > 1.0E-3_dp) THEN + IF (zet_ri(i, j) > 1.0E-3_dp) & alpha_min_ri_kind(ikind) = MIN(alpha_min_ri_kind(ikind), zet_ri(i, j)) - END IF END DO END DO END DO diff --git a/src/gw_utils.F b/src/gw_utils.F index a4206cac50..e1f635b340 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -1401,9 +1401,8 @@ CONTAINS num_pe = para_env%num_pe ! if not already set, use all processors for the group (for large-cell GW, performance ! seems to be best for a single group with all MPI processes per group) - IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) THEN + IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) & bs_env%group_size_tensor = num_pe - END IF ! group_size_tensor must divide num_pe without rest; otherwise everything will be complicated IF (MODULO(num_pe, bs_env%group_size_tensor) /= 0) THEN @@ -2053,17 +2052,15 @@ CONTAINS DO i = 1, SIZE(exp_RI, 1) DO j = 1, SIZE(exp_RI, 2) IF (exp_RI(i, j) < exp_min_RI .AND. exp_RI(i, j) > 1E-3_dp) exp_min_RI = exp_RI(i, j) - IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) THEN + IF (exp_RI(i, j) < exp_RI_kind(ikind) .AND. exp_RI(i, j) > 1E-3_dp) & exp_RI_kind(ikind) = exp_RI(i, j) - END IF END DO END DO DO i = 1, SIZE(exp_ao, 1) DO j = 1, SIZE(exp_ao, 2) IF (exp_ao(i, j) < exp_min_ao .AND. exp_ao(i, j) > 1E-3_dp) exp_min_ao = exp_ao(i, j) - IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) THEN + IF (exp_ao(i, j) < exp_ao_kind(ikind) .AND. exp_ao(i, j) > 1E-3_dp) & exp_ao_kind(ikind) = exp_ao(i, j) - END IF END DO END DO radius_ao_kind(ikind) = SQRT(-LOG(eps)/exp_ao_kind(ikind)) diff --git a/src/gx_ac_unittest.F b/src/gx_ac_unittest.F index d962c3e789..edbb4a1617 100644 --- a/src/gx_ac_unittest.F +++ b/src/gx_ac_unittest.F @@ -11,21 +11,17 @@ ! ************************************************************************************************** PROGRAM gx_ac_unittest #include "base/base_uses.f90" -#if defined(__GREENX) - USE kinds, ONLY: dp - USE gx_ac, ONLY: create_thiele_pade, & - evaluate_thiele_pade_at, & - free_params, & - params -#endif - - IMPLICIT NONE - #if !defined(__GREENX) ! Abort and inform that GreenX was not included in the compilation ! Ideally, this will be avoided in testing by the conditional tests CPABORT("CP2K not compiled with GreenX library.") #else + USE kinds, ONLY: dp + USE gx_ac, ONLY: create_thiele_pade, & + evaluate_thiele_pade_at, & + free_params, & + params + ! Create the dataset containing the fitting data ! Two Lorentzian peaks with some overlap COMPLEX(kind=dp) :: damp_one = (2, 0), & diff --git a/src/hartree_local_methods.F b/src/hartree_local_methods.F index 44e58782e8..78f4033388 100644 --- a/src/hartree_local_methods.F +++ b/src/hartree_local_methods.F @@ -329,9 +329,8 @@ CONTAINS basis_set=basis_1c, basis_type="GAPW_1C") cneo = ASSOCIATED(cneo_potential) - IF (cneo .AND. tddft) THEN + IF (cneo .AND. tddft) & CPABORT("Electronic TDDFT with CNEO quantum nuclei is not implemented.") - END IF NULLIFY (nuc_basis) max_iso_not0_nuc = 0 @@ -373,9 +372,8 @@ CONTAINS END IF nchan_0 = nsoset(lmax0) - IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) THEN + IF (nchan_0 > MAX(max_iso_not0, max_iso_not0_nuc)) & CPABORT("channels for rho0 > # max of spherical harmonics") - END IF NULLIFY (Vh1_h, Vh1_s) ALLOCATE (Vh1_h(nr, max_iso_not0)) diff --git a/src/hdf5_wrapper.F b/src/hdf5_wrapper.F index d80bd6b9cc..24a9388303 100644 --- a/src/hdf5_wrapper.F +++ b/src/hdf5_wrapper.F @@ -35,16 +35,9 @@ MODULE hdf5_wrapper IMPLICIT NONE - PRIVATE - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'hdf5_wrapper' #ifdef __HDF5 INTEGER, PARAMETER, PUBLIC :: hdf5_id = hid_t - - PUBLIC :: h5aread_double_scalar, h5awrite_boolean, h5awrite_double_scalar, h5awrite_double_simple - PUBLIC :: h5awrite_fixlen_string, h5awrite_integer_scalar, h5awrite_integer_simple - PUBLIC :: h5awrite_string_simple, h5close, h5dread_double_simple, h5dwrite_double_simple, h5fclose - PUBLIC :: h5fcreate, h5fopen, h5gclose, h5gcreate, h5gopen, h5open #endif CONTAINS diff --git a/src/hfx_ace_methods.F b/src/hfx_ace_methods.F index e095b59ca0..501997a8ef 100644 --- a/src/hfx_ace_methods.F +++ b/src/hfx_ace_methods.F @@ -182,17 +182,15 @@ CONTAINS nspins = dft_control%nspins IF (n_rep_hf /= 1) CPABORT("ACE: only one &HF section is supported.") - IF (dft_control%nimages /= 1) THEN + IF (dft_control%nimages /= 1) & CPABORT("ACE: k-points / multiple images are not implemented.") - END IF ! ACE requires explicit MO coefficients (C_occ) which are only available ! with diagonalization-based SCF. OT never constructs mo_coeff during ! the SCF, so the ACE projector build loop would silently get garbage. CALL get_qs_env(qs_env, scf_control=scf_control) - IF (scf_control%use_ot) THEN + IF (scf_control%use_ot) & CPABORT("ACE: OT doesn't work, use diagonalization-based SCF.") - END IF rebuild_freq = MAX(1, ace_rebuild_frequency) @@ -200,9 +198,8 @@ CONTAINS ! Bypass A: energy-only call ! ------------------------------------------------------------------ IF (just_energy) THEN - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T2,A)') 'ACE | just_energy=T: full HFX (no matrix update)' - END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -214,9 +211,8 @@ CONTAINS ! Bypass B: ionic forces requested ! ------------------------------------------------------------------ IF (calculate_forces) THEN - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T2,A)') 'ACE | calculate_forces=T: full HFX for exact forces' - END IF CALL hfx_call(qs_env, ks_matrix, rho, energy, & calculate_forces, just_energy, & v_rspace_new, v_tau_rspace, ext_xc_section) @@ -275,15 +271,13 @@ CONTAINS IF (ace_built_now) THEN ace_is_built = .TRUE. ace_step_counter = 1 - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T4,A)') 'ACE | W built. Projector live from next step.' - END IF ELSE ace_is_built = .FALSE. ace_step_counter = 0 - IF (DBG_ROUTING .AND. iw > 0) THEN + IF (DBG_ROUTING .AND. iw > 0) & WRITE (iw, '(T4,A)') 'ACE | Build deferred (C_occ=0). Full HFX in ks_matrix.' - END IF END IF ELSE @@ -415,9 +409,8 @@ CONTAINS v_rspace_new, v_tau_rspace, ext_xc_section) ehfx_full = energy%ex - IF (DBG_BUILD .AND. iw > 0) THEN + IF (DBG_BUILD .AND. iw > 0) & WRITE (iw, '(/,T2,A,F20.10)') 'ACE BUILD | E_x(full HFX) = ', ehfx_full - END IF ! Allocate / resize module storage IF (ALLOCATED(ace_W)) THEN @@ -433,10 +426,9 @@ CONTAINS ! ---------------------------------------------------------------- DO ispin = 1, nspins - IF (mos_for_ace(ispin)%use_mo_coeff_b) THEN + IF (mos_for_ace(ispin)%use_mo_coeff_b) & CALL copy_dbcsr_to_fm(mos_for_ace(ispin)%mo_coeff_b, & mos_for_ace(ispin)%mo_coeff) - END IF CALL get_mo_set(mos_for_ace(ispin), mo_coeff=mo_coeff, & nao=nao, nmo=nmo, homo=nocc, & @@ -458,9 +450,8 @@ CONTAINS END IF IF (frob < 1.0e-20_dp) THEN - IF (DBG_BUILD .AND. iw > 0) THEN + IF (DBG_BUILD .AND. iw > 0) & WRITE (iw, '(T4,A)') 'mo_coeff=0: build deferred to next step.' - END IF CALL timestop(handle) RETURN END IF @@ -539,14 +530,12 @@ CONTAINS CPABORT("ACE: Cholesky of -M failed (not positive definite).") END IF - IF (DBG_BUILD .AND. iw > 0) THEN + IF (DBG_BUILD .AND. iw > 0) & WRITE (iw, '(T4,A)') 'Cholesky OK (info=0).' - END IF ! Step 7: W = xi * U^{-1} - IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) THEN + IF (ASSOCIATED(ace_W(1, ispin)%matrix_struct)) & CALL cp_fm_release(ace_W(1, ispin)) - END IF CALL cp_fm_create(ace_W(1, ispin), xi_fm%matrix_struct, name="W_ACE") CALL cp_fm_to_fm(xi_fm, ace_W(1, ispin)) @@ -746,10 +735,9 @@ CONTAINS CALL cp_fm_release(P_fm) CALL cp_fm_release(PW_fm) - IF (DBG_ENERGY .AND. iw > 0) THEN + IF (DBG_ENERGY .AND. iw > 0) & WRITE (iw, '(T4,A,I4,A,F20.10)') & - 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val - END IF + 'ispin=', ispin, ' E_x(ACE) += ', -0.5_dp*trace_val END DO energy%ex = ehfx_ace @@ -788,17 +776,15 @@ CONTAINS IF (do_admm) THEN CALL get_admm_env(admm_env, mos_aux_fit=mos_aux_diag) - IF (mos_aux_diag(ispin)%use_mo_coeff_b) THEN + IF (mos_aux_diag(ispin)%use_mo_coeff_b) & CALL copy_dbcsr_to_fm(mos_aux_diag(ispin)%mo_coeff_b, & mos_aux_diag(ispin)%mo_coeff) - END IF CALL get_mo_set(mos_aux_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) ELSE - IF (mos_diag(ispin)%use_mo_coeff_b) THEN + IF (mos_diag(ispin)%use_mo_coeff_b) & CALL copy_dbcsr_to_fm(mos_diag(ispin)%mo_coeff_b, & mos_diag(ispin)%mo_coeff) - END IF CALL get_mo_set(mos_diag(ispin), mo_coeff=mo_coeff_diag, & nao=nao_d, nmo=nmo_d, homo=nocc_d) END IF diff --git a/src/hfx_admm_utils.F b/src/hfx_admm_utils.F index 502353ae25..95aa6eb99c 100644 --- a/src/hfx_admm_utils.F +++ b/src/hfx_admm_utils.F @@ -213,9 +213,8 @@ CONTAINS IF (PRESENT(ext_xc_section)) hfx_sections => section_vals_get_subs_vals(ext_xc_section, "HF") CALL section_vals_get(hfx_sections, n_repetition=n_rep_hf) - IF (n_rep_hf > 1) THEN + IF (n_rep_hf > 1) & CPABORT("ADMM can handle only one HF section.") - END IF IF (.NOT. ASSOCIATED(admm_env)) THEN ! setup admm environment @@ -229,9 +228,8 @@ CONTAINS admm_env=admm_env) ! Initialize the GAPW data types - IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN + IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) & CALL init_admm_gapw(qs_env) - END IF ! ADMM neighbor lists and overlap matrices CALL admm_init_hamiltonians(admm_env, qs_env, "AUX_FIT") @@ -306,13 +304,11 @@ CONTAINS CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) !Test combinations of input values. So far, only ADMM2 is availavle - IF (.NOT. admm_env%purification_method == do_admm_purify_none) THEN + IF (.NOT. admm_env%purification_method == do_admm_purify_none) & CPABORT("Only ADMM_PURIFICATION_METHOD NONE implemeted for ADMM K-points") - END IF IF (.NOT. (dft_control%admm_control%method == do_admm_basis_projection & - .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) THEN + .OR. dft_control%admm_control%method == do_admm_charge_constrained_projection)) & CPABORT("Only BASIS_PROJECTION and CHARGE_CONSTRAINED_PROJECTION implemented for KP") - END IF IF (admm_env%do_admms .OR. admm_env%do_admmp .OR. admm_env%do_admmq) THEN IF (use_real_wfn) CPABORT("Only KP-HFX ADMM2 is implemented with REAL wavefunctions") END IF @@ -641,7 +637,7 @@ CONTAINS mic = molecule_only IF (kpoints%nkp > 0) THEN mic = .FALSE. - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN mic = .TRUE. END IF @@ -1243,9 +1239,8 @@ CONTAINS ! Remember: Vhfx is added, energy is calclulated from total Vhfx, ! so energy of last iteration is correct - IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) THEN + IF (do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core) & CPABORT("HFX_TREAT_LSD_IN_CORE not implemented for adiabatically rescaled hybrids") - END IF ! everything is calculated with adiabatic rescaling but the potential is not added in a first step distribute_fock_matrix = .NOT. do_adiabatic_rescaling diff --git a/src/hfx_compression_methods.F b/src/hfx_compression_methods.F index 6b9e07e456..d6d0df4ae7 100644 --- a/src/hfx_compression_methods.F +++ b/src/hfx_compression_methods.F @@ -225,9 +225,7 @@ CONTAINS !! This happens in case a container has fully been filled in the compression step !! but no other was needed for the current bit size !! Therefore we can safely igonore an eof error - ! We still need to ask for it to read the data correctly, so we mark it as used READ (container%unit, IOSTAT=stat) container%current%data - MARK_USED(stat) memory_usage = memory_usage + 1 container%file_counter = container%file_counter + 1 ELSE diff --git a/src/hfx_energy_potential.F b/src/hfx_energy_potential.F index eec9821017..679a821530 100644 --- a/src/hfx_energy_potential.F +++ b/src/hfx_energy_potential.F @@ -3123,13 +3123,12 @@ CONTAINS DO mb = 1, mb_max DO ma = 1, ma_max iint = iint + 1 - IF (ABS(prim(iint)) > 0.0000000000001) THEN + IF (ABS(prim(iint)) > 0.0000000000001) & WRITE (99, *) atom_offsets(i, 1) + ma + set_offsets(iset, 1, i, 1) - 1, & - atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & - atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & - atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & - prim(iint) - END IF + atom_offsets(j, 1) + ma + set_offsets(jset, 1, j, 1) - 1, & + atom_offsets(k, 1) + ma + set_offsets(kset, 1, k, 1) - 1, & + atom_offsets(l, 1) + ma + set_offsets(lset, 1, l, 1) - 1, & + prim(iint) END DO END DO END DO diff --git a/src/hfx_exx.F b/src/hfx_exx.F index c083d86131..4116db4143 100644 --- a/src/hfx_exx.F +++ b/src/hfx_exx.F @@ -567,7 +567,7 @@ CONTAINS xc_section_aux => qs_env%mp2_env%ri_rpa%xc_section_aux xc_section_primary => qs_env%mp2_env%ri_rpa%xc_section_primary END IF - ELSE IF (qs_env%energy_correction) THEN + ELSEIF (qs_env%energy_correction) THEN IF (ASSOCIATED(qs_env%ec_env%xc_section_aux) .AND. & ASSOCIATED(qs_env%ec_env%xc_section_primary)) THEN xc_section_aux => qs_env%ec_env%xc_section_aux diff --git a/src/hfx_load_balance_methods.F b/src/hfx_load_balance_methods.F index 38f34ce1e0..5b13c6a164 100644 --- a/src/hfx_load_balance_methods.F +++ b/src/hfx_load_balance_methods.F @@ -1860,10 +1860,9 @@ CONTAINS ! it also avoids degenerate cases where thousands of zero sized tasks ! are assigned to the same (least loaded) cpu ! - IF (do_randomize) THEN + IF (do_randomize) & rng_stream = rng_stream_type(name="uniform_rng", & distribution_type=UNIFORM) - END IF DO i = total_number_of_bins, 1, -nstep tmp_cpu_cost = my_cost_cpu diff --git a/src/hfx_pw_methods.F b/src/hfx_pw_methods.F index f4a1e7ca5b..8551fc0b85 100644 --- a/src/hfx_pw_methods.F +++ b/src/hfx_pw_methods.F @@ -147,7 +147,7 @@ CONTAINS END IF IF (potential_type == do_potential_coulomb) THEN CALL pw_copy(poisson_env%green_fft%influence_fn, greenfn) - ELSE IF (potential_type == do_potential_truncated) THEN + ELSEIF (potential_type == do_potential_truncated) THEN CALL section_vals_val_get(ip_section, "CUTOFF_RADIUS", r_val=rcut) grid => poisson_env%green_fft%influence_fn%pw_grid DO ig = grid%first_gne0, grid%ngpts_cut_local @@ -156,10 +156,9 @@ CONTAINS g3d = fourpi/g2 greenfn%array(ig) = g3d*(1.0_dp - COS(rcut*gg)) END DO - IF (grid%have_g0) THEN + IF (grid%have_g0) & greenfn%array(1) = 0.5_dp*fourpi*rcut*rcut - END IF - ELSE IF (potential_type == do_potential_short) THEN + ELSEIF (potential_type == do_potential_short) THEN CALL section_vals_val_get(ip_section, "OMEGA", r_val=omega) IF (omega > 0.0_dp) omega = 0.25_dp/(omega*omega) grid => poisson_env%green_fft%influence_fn%pw_grid diff --git a/src/hfx_ri.F b/src/hfx_ri.F index 087348e6b3..23675f8016 100644 --- a/src/hfx_ri.F +++ b/src/hfx_ri.F @@ -3708,10 +3708,9 @@ CONTAINS CALL get_RI_density_coeffs(density_coeffs, rho_ao, 1, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) - IF (nspins == 2) THEN + IF (nspins == 2) & CALL get_RI_density_coeffs(density_coeffs_2, rho_ao, 2, basis_set_AO, basis_set_RI, & mult_by_s, skip_ri_metric, ri_data, qs_env) - END IF unit_nr = cp_print_key_unit_nr(logger, input, "DFT%XC%HF%RI%PRINT%RI_DENSITY_COEFFS", & extension=".dat", file_status="REPLACE", & diff --git a/src/hfx_ri_kp.F b/src/hfx_ri_kp.F index 2093e39aad..238d2f9b50 100644 --- a/src/hfx_ri_kp.F +++ b/src/hfx_ri_kp.F @@ -250,9 +250,8 @@ CONTAINS !We do all the checks on what we allow in this initial implementation IF (ri_data%flavor /= ri_pmat) CPABORT("K-points RI-HFX only with RHO flavor") IF (ri_data%same_op) ri_data%same_op = .FALSE. !force the full calculation with RI metric - IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) THEN + IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) & CPABORT("RI%EPS_PGF_ORB and QS%EPS_PGF_ORB must be identical for RI-HFX k-points") - END IF CALL get_kp_and_ri_images(ri_data, qs_env) nimg = ri_data%nimg @@ -3638,9 +3637,8 @@ CONTAINS DO i_img = 1, nimg DO i_spin = 1, nspins - IF (.NOT. (i_img == 1 .AND. i_spin == 1)) THEN + IF (.NOT. (i_img == 1 .AND. i_spin == 1)) & CALL dbt_create(rho_ao_t_sub(1, 1), rho_ao_t_sub(i_spin, i_img)) - END IF CALL copy_2c_to_subgroup(rho_ao_t_sub(i_spin, i_img), rho_ao_t(i_spin, i_img), & group_size, ngroups, para_env) CALL dbt_destroy(rho_ao_t(i_spin, i_img)) @@ -4400,9 +4398,8 @@ CONTAINS CALL neighbor_list_iterator_release(nl_iterator) CALL release_neighbor_list_sets(nl_2c) CALL para_env%max(ri_data%nimg) - IF (ri_data%nimg > nimg) THEN + IF (ri_data%nimg > nimg) & CPABORT("Make sure the smallest exponent of the RI-HFX basis is larger than that of the ORB basis.") - END IF !Keep track of which images will not contribute, so that can be ignored before calculation CALL para_env%sum(present_img) diff --git a/src/hfx_types.F b/src/hfx_types.F index d81fd2de0e..1c11cc9d77 100644 --- a/src/hfx_types.F +++ b/src/hfx_types.F @@ -778,9 +778,8 @@ CONTAINS actual_x_data%load_balance_parameter%do_randomize = logic_val actual_x_data%load_balance_parameter%rtp_redistribute = .FALSE. - IF (ASSOCIATED(dft_control%rtp_control)) THEN + IF (ASSOCIATED(dft_control%rtp_control)) & actual_x_data%load_balance_parameter%rtp_redistribute = dft_control%rtp_control%hfx_redistribute - END IF CALL section_vals_val_get(hf_sub_section, "BLOCK_SIZE", i_val=int_val) ! negative values ask for a computed default @@ -1045,13 +1044,11 @@ CONTAINS ! Sanity checks IF (actual_x_data%use_ace) THEN ! ACE requires HFX to be meaningful - IF (actual_x_data%general_parameter%fraction <= 0.0_dp) THEN + IF (actual_x_data%general_parameter%fraction <= 0.0_dp) & CPABORT("ACE requires FRACTION > 0.") - END IF ! If frequency is 1, it is full HFX - IF (actual_x_data%ace_rebuild_freq < 1) THEN + IF (actual_x_data%ace_rebuild_freq < 1) & CPABORT("ACE: REBUILD_FREQUENCY must be >= 1") - END IF END IF END IF END DO @@ -1219,9 +1216,8 @@ CONTAINS ri_metric%scale_longrange = hfx_pot%scale_longrange END IF - IF (ri_metric%potential_type == do_potential_short) THEN + IF (ri_metric%potential_type == do_potential_short) & CALL erfc_cutoff(ri_data%eps_schwarz, ri_metric%omega, ri_metric%cutoff_radius) - END IF IF (ri_metric%potential_type == do_potential_id) ri_metric%cutoff_radius = 0.0_dp END ASSOCIATE @@ -1436,7 +1432,7 @@ CONTAINS DEALLOCATE (dist1, dist2) CALL dbt_create(ri_data%ks_t(1, 1), ri_data%ks_t(2, 1)) - ELSE IF (ri_data%flavor == ri_mo) THEN + ELSEIF (ri_data%flavor == ri_mo) THEN ALLOCATE (ri_data%t_2c_int(2, 1)) CALL create_2c_tensor(ri_data%t_2c_int(1, 1), dist1, dist2, ri_data%pgrid_2d, & @@ -1626,7 +1622,7 @@ CONTAINS DEALLOCATE (ri_data%blk_indices) DEALLOCATE (ri_data%store_3c) - ELSE IF (ri_data%flavor == ri_mo) THEN + ELSEIF (ri_data%flavor == ri_mo) THEN CALL dbt_destroy(ri_data%t_3c_int_ctr_1(1, 1)) CALL dbt_destroy(ri_data%t_3c_int_ctr_2(1, 1)) DEALLOCATE (ri_data%t_3c_int_ctr_1) diff --git a/src/hfxbase/hfx_compression_core_methods.F b/src/hfxbase/hfx_compression_core_methods.F index bdb6ca7c6a..302e5b90b6 100644 --- a/src/hfxbase/hfx_compression_core_methods.F +++ b/src/hfxbase/hfx_compression_core_methods.F @@ -21,38 +21,38 @@ MODULE hfx_compression_core_methods ! masks the corresponding number of bits from the right INTEGER(kind=int_8), PARAMETER :: mask_right(0:63) = & - [0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & + (/0_int_8, 1_int_8, 3_int_8, 7_int_8, 15_int_8, 31_int_8, 63_int_8, 127_int_8, 255_int_8, 511_int_8, & 1023_int_8, 2047_int_8, 4095_int_8, 8191_int_8, 16383_int_8, 32767_int_8, 65535_int_8, 131071_int_8, & 262143_int_8, 524287_int_8, 1048575_int_8, 2097151_int_8, 4194303_int_8, 8388607_int_8, 16777215_int_8, & 33554431_int_8, 67108863_int_8, 134217727_int_8, 268435455_int_8, 536870911_int_8, 1073741823_int_8, & - 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & + 2147483647_int_8, 4294967295_int_8, 8589934591_int_8, 17179869183_int_8, 34359738367_int_8, & 68719476735_int_8, 137438953471_int_8, 274877906943_int_8, 549755813887_int_8, 1099511627775_int_8, & - 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & - 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & + 2199023255551_int_8, 4398046511103_int_8, 8796093022207_int_8, 17592186044415_int_8, & + 35184372088831_int_8, 70368744177663_int_8, 140737488355327_int_8, 281474976710655_int_8, & 562949953421311_int_8, 1125899906842623_int_8, 2251799813685247_int_8, 4503599627370495_int_8, & 9007199254740991_int_8, 18014398509481983_int_8, 36028797018963967_int_8, 72057594037927935_int_8, & - 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & - 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & - 9223372036854775807_int_8] + 144115188075855871_int_8, 288230376151711743_int_8, 576460752303423487_int_8, & + 1152921504606846975_int_8, 2305843009213693951_int_8, 4611686018427387903_int_8, & + 9223372036854775807_int_8/) ! masks the corresponding number of bits from the left ! use ishft to avoid explicitly writing -HUGE-1, and keep it out of the array a work-around for a bug in pgi 6.1-1 INTEGER(kind=int_8), PARAMETER :: ugly_duck = ISHFT(1_int_8, 63) INTEGER(kind=int_8), PARAMETER :: mask_left(0:63) = & - [0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & - -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & - -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & + (/0_int_8, ugly_duck, -4611686018427387904_int_8, -2305843009213693952_int_8, & + -1152921504606846976_int_8, -576460752303423488_int_8, -288230376151711744_int_8, & + -144115188075855872_int_8, -72057594037927936_int_8, -36028797018963968_int_8, & -18014398509481984_int_8, -9007199254740992_int_8, -4503599627370496_int_8, -2251799813685248_int_8, & -1125899906842624_int_8, -562949953421312_int_8, -281474976710656_int_8, -140737488355328_int_8, & - -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & - -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & + -70368744177664_int_8, -35184372088832_int_8, -17592186044416_int_8, -8796093022208_int_8, & + -4398046511104_int_8, -2199023255552_int_8, -1099511627776_int_8, -549755813888_int_8, & -274877906944_int_8, -137438953472_int_8, -68719476736_int_8, -34359738368_int_8, -17179869184_int_8, & -8589934592_int_8, -4294967296_int_8, -2147483648_int_8, -1073741824_int_8, -536870912_int_8, & - -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & + -268435456_int_8, -134217728_int_8, -67108864_int_8, -33554432_int_8, -16777216_int_8, & -8388608_int_8, -4194304_int_8, -2097152_int_8, -1048576_int_8, -524288_int_8, -262144_int_8, & -131072_int_8, -65536_int_8, -32768_int_8, -16384_int_8, -8192_int_8, -4096_int_8, -2048_int_8, & -1024_int_8, -512_int_8, -256_int_8, -128_int_8, -64_int_8, -32_int_8, -16_int_8, -8_int_8, -4_int_8, & - -2_int_8] + -2_int_8/) PUBLIC :: bits2ints_specific, ints2bits_specific @@ -70,7 +70,7 @@ CONTAINS INTEGER(KIND=int_8), INTENT(OUT) :: full_data(*) full_data(1:Ndata) = packed_data(1:Ndata) - END SUBROUTINE ints2ints + END SUBROUTINE ! Nbits : number of relevant bits per int in the bit stream (this includes all bits) ! Ndata : number of ints that need to be extracted from the bit stream @@ -160,30 +160,22 @@ CONTAINS idata = idata + 1 IF (ibits_remaining >= Nbits) THEN data_tmp = full_data(idata) - ! put bits on the left - data_tmp = ISHFT(data_tmp, 64 - Nbits) - ! add to the packed data - pack_tmp = IOR(pack_tmp, data_tmp) + data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left + pack_tmp = IOR(pack_tmp, data_tmp) ! add to the packed data ibits_remaining = ibits_remaining - Nbits - ! and shift to the right to make place for the next - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! and shift to the right to make place for the next ELSE i_odd_bits = ibits_remaining data_tmp = full_data(idata) - ! put bits on the left - data_tmp = ISHFT(data_tmp, 64 - Nbits) - ! restrict to those bits for which we still have space - data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) + data_tmp = ISHFT(data_tmp, 64 - Nbits) ! put bits on the left + data_tmp = IAND(data_tmp, mask_left(i_odd_bits)) ! restrict to those bits for which we still have space pack_tmp = IOR(pack_tmp, data_tmp) ! add them to the packed bits ipack = ipack + 1 - ! store the full packed data away and start with a new one - packed_data(ipack) = pack_tmp + packed_data(ipack) = pack_tmp ! store the full packed data away and start with a new one data_tmp = full_data(idata) - ! put the missing bits on the left if pack_tmp - pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) + pack_tmp = ISHFT(data_tmp, 64 - Nbits + i_odd_bits) ! put the missing bits on the left if pack_tmp ibits_remaining = 64 - Nbits + i_odd_bits - ! shift to make place, but not more than the number of available bits - pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) + pack_tmp = ISHFT(pack_tmp, -MIN(Nbits, ibits_remaining)) ! shift to make place, but not more than the number of available bits END IF END DO diff --git a/src/hirshfeld_methods.F b/src/hirshfeld_methods.F index f4dbc0691a..d045ff0a39 100644 --- a/src/hirshfeld_methods.F +++ b/src/hirshfeld_methods.F @@ -220,18 +220,16 @@ CONTAINS IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) THEN + IF (hirshfeld_env%use_bohr) & rco = cp_unit_to_cp2k(rco, "angstrom") - END IF END IF CASE (radius_covalent) CALL get_ptable_info(symbol=esym, covalent_radius=rco, found=found) IF (.NOT. found) THEN rco = MAX(rco, 1.0_dp) ELSE - IF (hirshfeld_env%use_bohr) THEN + IF (hirshfeld_env%use_bohr) & rco = cp_unit_to_cp2k(rco, "angstrom") - END IF END IF CASE (radius_single) CPASSERT(PRESENT(radius)) diff --git a/src/iao_analysis.F b/src/iao_analysis.F index 080d92ca5c..0e658efcd6 100644 --- a/src/iao_analysis.F +++ b/src/iao_analysis.F @@ -1179,7 +1179,7 @@ CONTAINS WRITE (filename, '(A18,I1.1)') "IBO_CENTERS_SPREAD" iw = cp_print_key_unit_nr(logger, print_section, "", extension=".csp", & middle_name=TRIM(filename), file_position="REWIND", log_filename=.FALSE.) - ELSE IF (PRESENT(iounit)) THEN + ELSEIF (PRESENT(iounit)) THEN iw = iounit ELSE iw = -1 @@ -1702,7 +1702,7 @@ CONTAINS IF (order == 2) THEN aij = aij + 4._dp*mij**2 - (mii - mjj)**2 bij = bij + 4._dp*mij*(mii - mjj) - ELSE IF (order == 4) THEN + ELSEIF (order == 4) THEN aij = aij - mii**4 - mjj**4 + 6._dp*(mii**2 + mjj**2)*mij**2 + & mii**3*mjj + mii*mjj**3 bij = bij + 4._dp*mij*(mii**3 - mjj**3) diff --git a/src/iao_types.F b/src/iao_types.F index 27fa24a883..ce837e271c 100644 --- a/src/iao_types.F +++ b/src/iao_types.F @@ -239,9 +239,8 @@ CONTAINS nfrags = 0 DO ii = 1, SIZE(particle_set) - IF (nfrags < particle_set(ii)%fragment_index) THEN + IF (nfrags < particle_set(ii)%fragment_index) & nfrags = particle_set(ii)%fragment_index - END IF END DO logger => cp_get_default_logger() @@ -270,13 +269,13 @@ CONTAINS IF (particle_set(iatom)%fragment_index == jj) THEN totalcol = totalcol + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcoljj = .FALSE. - ELSE IF (lfirstcoljj) THEN + ELSEIF (lfirstcoljj) THEN colskip = colskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF IF (particle_set(iatom)%fragment_index == ii) THEN totalrow = totalrow + orb_basis_set_list(ikind)%gto_basis_set%nsgf lfirstcol = .FALSE. - ELSE IF (lfirstcol) THEN + ELSEIF (lfirstcol) THEN rowskip = rowskip + orb_basis_set_list(ikind)%gto_basis_set%nsgf END IF rowfrag = rowfrag + orb_basis_set_list(ikind)%gto_basis_set%nsgf diff --git a/src/input/cp_output_handling.F b/src/input/cp_output_handling.F index ca7c1fb19e..8abac352bf 100644 --- a/src/input/cp_output_handling.F +++ b/src/input/cp_output_handling.F @@ -981,38 +981,33 @@ CONTAINS filename_bak_2 = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(i - 1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Moving file "//TRIM(filename_bak_2)// & - " into file "//TRIM(filename_bak_1)//"." - END IF + " into file "//TRIM(filename_bak_1)//"." END IF INQUIRE (FILE=filename_bak_2, EXIST=found) IF (.NOT. found) THEN IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "File "//TRIM(filename_bak_2)//" not existing.." - END IF END IF ELSE ! Shared file: rotate on the source rank only; per-task ! (my_local) files are per-rank, rotated by their owner. - IF (my_local .OR. logger%para_env%is_source()) THEN + IF (my_local .OR. logger%para_env%is_source()) & CALL m_mov(TRIM(filename_bak_2), TRIM(filename_bak_1)) - END IF END IF END DO ! The last backup is always the one with index 1 filename_bak = TRIM(filename)//".bak-"//ADJUSTL(cp_to_string(1)) IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Moving file "//TRIM(filename)//" into file "//TRIM(filename_bak)//"." - END IF END IF - IF (my_local .OR. logger%para_env%is_source()) THEN + IF (my_local .OR. logger%para_env%is_source()) & CALL m_mov(TRIM(filename), TRIM(filename_bak)) - END IF ELSE ! Zero the backup history for this new iteration level.. print_key%ibackup(my_backup_level) = 0 @@ -1033,11 +1028,10 @@ CONTAINS END IF IF (do_log) THEN unit_nr = cp_logger_get_unit_nr(logger, local=my_local) - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & WRITE (unit_nr, *) "Writing "//TRIM(print_key%section%name)//" "// & - TRIM(cp_iter_string(logger%iter_info))//" to "// & - TRIM(filename) - END IF + TRIM(cp_iter_string(logger%iter_info))//" to "// & + TRIM(filename) END IF END IF ELSE diff --git a/src/input/cp_parser_ilist_methods.F b/src/input/cp_parser_ilist_methods.F index 6b178f7ab2..bb8b41979c 100644 --- a/src/input/cp_parser_ilist_methods.F +++ b/src/input/cp_parser_ilist_methods.F @@ -44,12 +44,11 @@ CONTAINS ind = INDEX(token, "..") READ (UNIT=token(:ind - 1), FMT=*) ilist%istart READ (UNIT=token(ind + 2:), FMT=*) ilist%iend - IF (ilist%istart > ilist%iend) THEN + IF (ilist%istart > ilist%iend) & CALL cp_abort(__LOCATION__, & "Invalid list range specified: "// & TRIM(ADJUSTL(cp_to_string(ilist%istart)))//".."// & TRIM(ADJUSTL(cp_to_string(ilist%iend)))) - END IF ilist%nel_list = ilist%iend - ilist%istart + 1 ilist%ipresent = ilist%istart ilist%in_use = .TRUE. diff --git a/src/input/cp_parser_inpp_methods.F b/src/input/cp_parser_inpp_methods.F index 1ba2e7f5dc..dd2d552f06 100644 --- a/src/input/cp_parser_inpp_methods.F +++ b/src/input/cp_parser_inpp_methods.F @@ -53,18 +53,15 @@ CONTAINS is_valid_varname = .FALSE. - IF (LEN(str) == 0) then + IF (LEN(str) == 0) & RETURN - end if - IF (INDEX(alpha, str(1:1)) == 0) then + IF (INDEX(alpha, str(1:1)) == 0) & RETURN - end if DO idx = 2, LEN(str) - IF (INDEX(alphanum, str(idx:idx)) == 0) then + IF (INDEX(alphanum, str(idx:idx)) == 0) & RETURN - end if END DO is_valid_varname = .TRUE. @@ -595,9 +592,8 @@ CONTAINS CPABORT(TRIM(message)) END IF - IF (idx > 0) then + IF (idx > 0) & var_value = TRIM(inpp%variable_value(idx)) - end if newline = input_line(1:pos1 - 3)//var_value//input_line(pos2 + 2:) input_line = newline @@ -609,9 +605,8 @@ CONTAINS pos1 = pos1 + 1 ! move to the start of the variable name pos2 = INDEX(input_line(pos1:), ' ') - IF (pos2 == 0) then + IF (pos2 == 0) & pos2 = LEN_TRIM(input_line(pos1:)) + 1 - end if pos2 = pos1 + pos2 - 2 ! end of the variable name, minus the separating whitespace var_name = input_line(pos1:pos2) diff --git a/src/input/cp_parser_methods.F b/src/input/cp_parser_methods.F index 8b9b1bbbc7..a57066f206 100644 --- a/src/input/cp_parser_methods.F +++ b/src/input/cp_parser_methods.F @@ -548,9 +548,8 @@ CONTAINS ! Read input string of fixed length (single line) ! Check for EOF - IF (parser%icol == -1) THEN + IF (parser%icol == -1) & CPABORT("Unexpectetly reached EOF"//TRIM(parser_location(parser))) - END IF length = MIN(len_trim_inputline - parser%icol1 + 1, length) parser%icol1 = parser%icol + 1 diff --git a/src/input/cp_parser_types.F b/src/input/cp_parser_types.F index f8a4340268..d4fec0975d 100644 --- a/src/input/cp_parser_types.F +++ b/src/input/cp_parser_types.F @@ -196,9 +196,8 @@ CONTAINS parser%input_unit = unit_nr IF (PRESENT(file_name)) parser%input_file_name = TRIM(ADJUSTL(file_name)) ELSE - IF (.NOT. PRESENT(file_name)) THEN + IF (.NOT. PRESENT(file_name)) & CPABORT("at least one of filename and unit_nr must be present") - END IF CALL open_file(file_name=TRIM(ADJUSTL(file_name)), & unit_number=parser%input_unit) parser%input_file_name = TRIM(ADJUSTL(file_name)) diff --git a/src/input/input_enumeration_types.F b/src/input/input_enumeration_types.F index ca21d04940..112b8b49ae 100644 --- a/src/input/input_enumeration_types.F +++ b/src/input/input_enumeration_types.F @@ -175,9 +175,8 @@ CONTAINS END DO PRINT *, enum%i_vals END IF - IF (enum%strict) THEN + IF (enum%strict) & CPABORT("invalid value for enumeration:"//cp_to_string(i)) - END IF res = ADJUSTL(cp_to_string(i)) END IF END FUNCTION enum_i2c @@ -212,13 +211,11 @@ CONTAINS END DO IF (.NOT. found) THEN - IF (enum%strict) THEN + IF (enum%strict) & CPABORT("invalid value for enumeration:"//TRIM(c)) - END IF READ (c, "(i10)", iostat=iostat) res - IF (iostat /= 0) THEN + IF (iostat /= 0) & CPABORT("invalid value for enumeration2:"//TRIM(c)) - END IF END IF END FUNCTION enum_c2i diff --git a/src/input/input_keyword_types.F b/src/input/input_keyword_types.F index 8f33f0b1bd..1665d10024 100644 --- a/src/input/input_keyword_types.F +++ b/src/input/input_keyword_types.F @@ -274,9 +274,8 @@ CONTAINS IF (PRESENT(default_l_val) .OR. PRESENT(default_l_vals) .OR. & PRESENT(default_i_val) .OR. PRESENT(default_i_vals) .OR. & PRESENT(default_r_val) .OR. PRESENT(default_r_vals) .OR. & - PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) THEN + PRESENT(default_c_val) .OR. PRESENT(default_c_vals)) & CPABORT("you should pass either default_val or a default value, not both") - END IF keyword%default_value => default_val IF (ASSOCIATED(default_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN @@ -311,11 +310,10 @@ CONTAINS " assumed undefined type by default") END IF ELSE IF (PRESENT(type_of_var)) THEN - IF (keyword%type_of_var /= type_of_var) THEN + IF (keyword%type_of_var /= type_of_var) & CALL cp_abort(__LOCATION__, & "keyword "//TRIM(keyword%names(1))// & " has a type different from the type of the default_value") - END IF keyword%type_of_var = type_of_var END IF @@ -327,17 +325,15 @@ CONTAINS IF (PRESENT(lone_keyword_l_val) .OR. PRESENT(lone_keyword_l_vals) .OR. & PRESENT(lone_keyword_i_val) .OR. PRESENT(lone_keyword_i_vals) .OR. & PRESENT(lone_keyword_r_val) .OR. PRESENT(lone_keyword_r_vals) .OR. & - PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) THEN + PRESENT(lone_keyword_c_val) .OR. PRESENT(lone_keyword_c_vals)) & CALL cp_abort(__LOCATION__, & "you should pass either lone_keyword_val or a lone_keyword value, not both") - END IF keyword%lone_keyword_value => lone_keyword_val CALL val_retain(lone_keyword_val) IF (ASSOCIATED(lone_keyword_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN - IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) THEN + IF (.NOT. ASSOCIATED(keyword%enum, lone_keyword_val%enum)) & CPABORT("keyword%enum/=lone_keyword_val%enum") - END IF ELSE IF (ASSOCIATED(keyword%lone_keyword_value)) THEN CPABORT(".NOT. ASSOCIATED(keyword%lone_keyword_value)") @@ -359,9 +355,8 @@ CONTAINS IF (keyword%lone_keyword_value%type_of_var == no_t) THEN CALL val_release(keyword%lone_keyword_value) ELSE - IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) THEN + IF (keyword%lone_keyword_value%type_of_var /= keyword%type_of_var) & CPABORT("lone_keyword_value type incompatible with keyword type") - END IF ! lc_val cannot have lone_keyword_value! IF (keyword%type_of_var == enum_t) THEN IF (keyword%enum%strict) THEN @@ -369,9 +364,8 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) THEN + IF (.NOT. check) & CPABORT("default value not in enumeration : "//keyword%names(1)) - END IF END IF END IF END IF @@ -390,9 +384,8 @@ CONTAINS DO i = 1, SIZE(keyword%enum%i_vals) check = check .OR. (keyword%default_value%i_val(1) == keyword%enum%i_vals(i)) END DO - IF (.NOT. check) THEN + IF (.NOT. check) & CPABORT("default value not in enumeration : "//keyword%names(1)) - END IF END IF keyword%n_var = SIZE(keyword%default_value%i_val) CASE (real_t) @@ -408,9 +401,8 @@ CONTAINS END SELECT END IF IF (PRESENT(n_var)) keyword%n_var = n_var - IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) THEN + IF (keyword%type_of_var == lchar_t .AND. keyword%n_var /= 1) & CPABORT("arrays of lchar_t not supported : "//keyword%names(1)) - END IF IF (PRESENT(unit_str)) THEN ALLOCATE (keyword%unit) @@ -768,11 +760,10 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(keyword%description))) & //"" - IF (ALLOCATED(keyword%deprecation_notice)) THEN + IF (ALLOCATED(keyword%deprecation_notice)) & WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & - //"" - END IF + TRIM(substitute_special_xml_tokens(keyword%deprecation_notice)) & + //"" IF (ASSOCIATED(keyword%default_value) .AND. & (keyword%type_of_var /= no_t)) THEN diff --git a/src/input/input_parsing.F b/src/input/input_parsing.F index 332e6791ef..dab4ca7b6b 100644 --- a/src/input/input_parsing.F +++ b/src/input/input_parsing.F @@ -93,25 +93,22 @@ CONTAINS output_unit = cp_logger_get_default_io_unit() CPASSERT(section_vals%ref_count > 0) - IF (root_sect .AND. parser%icol1 > parser%icol2) THEN + IF (root_sect .AND. parser%icol1 > parser%icol2) & CALL cp_abort(__LOCATION__, & "Error 1: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) - END IF section => section_vals%section IF (root_sect) THEN token = TRIM(ADJUSTL(parser%input_line(parser%icol1:parser%icol2))) ! Ignore leading or trailing blanks CALL uppercase(token) - IF (token /= parser%section_character//section%name) THEN + IF (token /= parser%section_character//section%name) & CALL cp_abort(__LOCATION__, & "Error 2: this routine must be called just after having parsed the start of the section " & //TRIM(parser_location(parser))) - END IF END IF - IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) THEN + IF (.NOT. section%repeats .AND. SIZE(section_vals%values, 2) /= 0) & CALL cp_abort(__LOCATION__, "Section "//TRIM(section%name)// & " should not repeat "//TRIM(parser_location(parser))) - END IF CALL section_vals_add_values(section_vals) irs = SIZE(section_vals%values, 2) @@ -141,11 +138,10 @@ CONTAINS lower_to_upper=.TRUE., at_end=at_end) token = TRIM(ADJUSTL(token)) ! Ignore leading or trailing blanks IF (at_end) THEN - IF (root_sect) THEN + IF (root_sect) & CALL cp_abort(__LOCATION__, & "unexpected end of file while parsing section "// & TRIM(section%name)//" "//TRIM(parser_location(parser))) - END IF EXIT END IF IF (token(1:1) == parser%section_character) THEN @@ -273,17 +269,15 @@ CONTAINS END IF END IF - IF (ALLOCATED(keyword%deprecation_notice)) THEN + IF (ALLOCATED(keyword%deprecation_notice)) & CALL cp_warn(__LOCATION__, & "The specified keyword '"//TRIM(token)// & "' is deprecated and may be removed in a future version: "// & keyword%deprecation_notice) - END IF NULLIFY (el) - IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) THEN + IF (ik /= 0 .AND. keyword%type_of_var == lchar_t) & CALL parser_skip_space(parser) - END IF CALL val_create_parsing(el, type_of_var=keyword%type_of_var, & n_var=keyword%n_var, default_value=keyword%lone_keyword_value, & enum=keyword%enum, unit=keyword%unit, & @@ -295,11 +289,10 @@ CONTAINS IF (.NOT. ASSOCIATED(last_val)) THEN section_vals%values(ik, irs)%list => new_val ELSE - IF (.NOT. keyword%repeats) THEN + IF (.NOT. keyword%repeats) & CALL cp_abort(__LOCATION__, & "Keyword "//TRIM(token)// & " in section "//TRIM(section%name)//" should not repeat.") - END IF IF (ASSOCIATED(last_val, previous_list)) THEN last_val => previous_last ELSE @@ -531,18 +524,16 @@ CONTAINS END IF END IF CASE (lchar_t) - IF (ASSOCIATED(default_value)) THEN + IF (ASSOCIATED(default_value)) & CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot have a lone keyword attribute,"// & " no value is interpreted as empty string"// & TRIM(parser_location(parser))) - END IF - IF (n_var /= 1) THEN + IF (n_var /= 1) & CALL cp_abort(__LOCATION__, & "input variables of type lchar_t cannot be repeated,"// & " one always represent a whole line, till the end"// & TRIM(parser_location(parser))) - END IF IF (parser_test_next_token(parser) == "EOL") THEN ALLOCATE (c_val_p(1)) c_val_p(1) = ' ' @@ -686,12 +677,11 @@ CONTAINS my_unit => unit END IF END IF - IF (.NOT. cp_unit_compatible(unit, my_unit)) THEN + IF (.NOT. cp_unit_compatible(unit, my_unit)) & CALL cp_abort(__LOCATION__, & "Incompatible units. Defined as ("// & TRIM(cp_unit_desc(unit))//") specified in input as ("// & TRIM(cp_unit_desc(my_unit))//"). These units are incompatible!") - END IF END IF CALL parser_get_object(parser, r_val) IF (ASSOCIATED(unit)) THEN diff --git a/src/input/input_section_types.F b/src/input/input_section_types.F index 44662e9ed1..917c8edeb1 100644 --- a/src/input/input_section_types.F +++ b/src/input/input_section_types.F @@ -326,9 +326,8 @@ CONTAINS IF (ASSOCIATED(section)) THEN CPASSERT(section%ref_count > 0) - IF (.NOT. my_hide_root) THEN + IF (.NOT. my_hide_root) & WRITE (UNIT=unit_nr, FMT="('*** section &',A,' ***')") TRIM(ADJUSTL(section%name)) - END IF IF (level > 1) THEN message = get_section_info(section) CALL print_message(TRIM(a2s(section%description))//TRIM(message), unit_nr, 0, 0, 0) @@ -348,9 +347,8 @@ CONTAINS END DO END IF IF (section%n_subsections > 0 .AND. my_recurse >= 0) THEN - IF (.NOT. my_hide_root) THEN + IF (.NOT. my_hide_root) & WRITE (UNIT=unit_nr, FMT="('** subsections **')") - END IF DO isub = 1, section%n_subsections IF (my_recurse > 0) THEN CALL section_describe(section%subsections(isub)%section, unit_nr, & @@ -360,9 +358,8 @@ CONTAINS END IF END DO END IF - IF (.NOT. my_hide_root) THEN + IF (.NOT. my_hide_root) & WRITE (UNIT=unit_nr, FMT="('*** &end section ',A,' ***')") TRIM(ADJUSTL(section%name)) - END IF ELSE WRITE (unit_nr, "(a)") '
' END IF @@ -589,12 +586,11 @@ CONTAINS section%subsections => new_subsections END IF DO i = 1, section%n_subsections - IF (subsection%name == section%subsections(i)%section%name) THEN + IF (subsection%name == section%subsections(i)%section%name) & CALL cp_abort(__LOCATION__, & "trying to add a subsection with a name ("// & TRIM(subsection%name)//") that was already used in section " & //TRIM(section%name)) - END IF END DO CALL section_retain(subsection) section%n_subsections = section%n_subsections + 1 @@ -765,11 +761,10 @@ CONTAINS isection = section_get_subsection_index(section_vals%section, subsection_name(1:my_index)) IF (isection > 0) res => section_vals%subs_vals(isection, irep)%section_vals - IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) THEN + IF (.NOT. (ASSOCIATED(res) .OR. my_can_return_null)) & CALL cp_abort(__LOCATION__, & "could not find subsection "//TRIM(subsection_name(1:my_index))//" in section "// & TRIM(section_vals%section%name)//" at ") - END IF IF (is_path .AND. ASSOCIATED(res)) THEN res => section_vals_get_subs_vals(res, subsection_name(my_index + 2:LEN_TRIM(subsection_name)), & i_rep_section, can_return_null) @@ -1101,18 +1096,16 @@ CONTAINS PRESENT(c_val) .OR. PRESENT(l_vals) .OR. PRESENT(i_vals) .OR. & PRESENT(r_vals) .OR. PRESENT(c_vals) ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF keyword => section%keywords(ik)%keyword - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF NULLIFY (my_val) IF (PRESENT(n_rep_val)) n_rep_val = 0 IF (irs <= SIZE(s_vals%values, 2)) THEN ! the section was parsed @@ -1135,12 +1128,11 @@ CONTAINS END IF IF (PRESENT(val)) val => my_val IF (valRequested) THEN - IF (.NOT. ASSOCIATED(my_val)) THEN + IF (.NOT. ASSOCIATED(my_val)) & CALL cp_abort(__LOCATION__, & "Value requested, but no value set getting value from "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF CALL val_get(my_val, l_val=l_val, i_val=i_val, r_val=r_val, & c_val=c_val, l_vals=l_vals, i_vals=i_vals, r_vals=r_vals, & c_vals=c_vals) @@ -1191,17 +1183,15 @@ CONTAINS IF (PRESENT(i_rep_section)) irs = i_rep_section section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF list => s_vals%values(ik, irs)%list END SUBROUTINE section_vals_list_get @@ -1276,22 +1266,20 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF ! Add values.. DO IF (irs <= SIZE(s_vals%values, 2)) EXIT CALL section_vals_add_values(s_vals) END DO - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF keyword => s_vals%section%keywords(ik)%keyword NULLIFY (my_val) IF (PRESENT(val)) my_val => val @@ -1300,20 +1288,18 @@ CONTAINS PRESENT(r_vals_ptr) .OR. PRESENT(c_vals_ptr) IF (ASSOCIATED(my_val)) THEN ! check better? - IF (valSet) THEN + IF (valSet) & CALL cp_abort(__LOCATION__, & " both val and values present, in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF ELSE ! ignore ? - IF (.NOT. valSet) THEN + IF (.NOT. valSet) & CALL cp_abort(__LOCATION__, & " empty value in setting "// & "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF CPASSERT(valSet) IF (keyword%type_of_var == lchar_t) THEN CALL val_create(my_val, lc_val=c_val, lc_vals_ptr=c_vals_ptr) @@ -1330,12 +1316,11 @@ CONTAINS IF (irk == -1) THEN CALL cp_sll_val_insert_el_at(vals, my_val, index=-1) ELSE IF (irk <= cp_sll_val_get_length(vals)) THEN - IF (irk <= 0) THEN + IF (irk <= 0) & CALL cp_abort(__LOCATION__, & "invalid irk "//TRIM(ADJUSTL(cp_to_string(irk)))// & " in keyword "//TRIM(keyword_name(my_index:len_key))//" of section "// & TRIM(section%name)) - END IF old_val => cp_sll_val_get_el_at(vals, index=irk) CALL val_release(old_val) CALL cp_sll_val_set_el_at(vals, value=my_val, index=irk) @@ -1401,19 +1386,17 @@ CONTAINS IF (PRESENT(i_rep_val)) irk = i_rep_val section => s_vals%section ik = section_get_keyword_index(s_vals%section, keyword_name(my_index:len_key)) - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & TRIM(keyword_name(my_index:len_key))) - END IF ! ignore unset of non set values IF (irs <= SIZE(s_vals%values, 2)) THEN - IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) THEN + IF (.NOT. (irs > 0 .AND. irs <= SIZE(s_vals%subs_vals, 2))) & CALL cp_abort(__LOCATION__, & "section repetition requested ("//cp_to_string(irs)// & ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals, 2)) & //")") - END IF IF (irk == -1) THEN pos => cp_sll_val_get_rest(s_vals%values(ik, irs)%list, iter=-1) ELSE @@ -1606,11 +1589,10 @@ CONTAINS TRIM(substitute_special_xml_tokens(a2s(section%description))) & //"" - IF (ALLOCATED(section%deprecation_notice)) THEN + IF (ALLOCATED(section%deprecation_notice)) & WRITE (UNIT=unit_number, FMT="(A)") REPEAT(" ", l1)//""// & - TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & - //"" - END IF + TRIM(substitute_special_xml_tokens(section%deprecation_notice)) & + //"" IF (ASSOCIATED(section%citations)) THEN DO i = 1, SIZE(section%citations, 1) @@ -1753,11 +1735,10 @@ CONTAINS CPASSERT(irep <= SIZE(s_vals%subs_vals, 2)) isection = section_get_subsection_index(s_vals%section, subsection_name(my_index:LEN_TRIM(subsection_name))) - IF (isection <= 0) THEN + IF (isection <= 0) & CALL cp_abort(__LOCATION__, & "could not find subsection "//subsection_name(my_index:LEN_TRIM(subsection_name))//" in section "// & TRIM(section_vals%section%name)//" at ") - END IF CALL section_vals_retain(new_section_vals) CALL section_vals_release(s_vals%subs_vals(isection, irep)%section_vals) s_vals%subs_vals(isection, irep)%section_vals => new_section_vals @@ -1832,12 +1813,10 @@ CONTAINS END DO END DO IF (.NOT. PRESENT(i_rep_low) .AND. (.NOT. PRESENT(i_rep_high))) THEN - IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) THEN + IF (.NOT. (SIZE(section_vals_in%values, 2) == SIZE(section_vals_out%values, 2))) & CPABORT("Incompatible sizes of values between input and output") - END IF - IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) THEN + IF (.NOT. (SIZE(section_vals_in%subs_vals, 2) == SIZE(section_vals_out%subs_vals, 2))) & CPABORT("Incompatible sizes of subsections between input and output") - END IF END IF iend = SIZE(section_vals_in%subs_vals, 2) IF (PRESENT(i_rep_high)) iend = i_rep_high diff --git a/src/input/input_val_types.F b/src/input/input_val_types.F index 83580f89e0..9ac7220f12 100644 --- a/src/input/input_val_types.F +++ b/src/input/input_val_types.F @@ -399,26 +399,23 @@ CONTAINS IF (val%type_of_var == lchar_t) THEN l_in = default_string_length*(SIZE(val%c_val) - 1) + & LEN_TRIM(val%c_val(SIZE(val%c_val))) - IF (l_out < l_in) THEN + IF (l_out < l_in) & CALL cp_warn(__LOCATION__, & "val_get will truncate value, value beginning with '"// & TRIM(val%c_val(1))//"' is too long for variable") - END IF DO i = 1, SIZE(val%c_val) c_val((i - 1)*default_string_length + 1:MIN(l_out, i*default_string_length)) = & val%c_val(i) (1:MIN(80, l_out - (i - 1)*default_string_length)) IF (l_out <= i*default_string_length) EXIT END DO - IF (l_out > SIZE(val%c_val)*default_string_length) THEN + IF (l_out > SIZE(val%c_val)*default_string_length) & c_val(SIZE(val%c_val)*default_string_length + 1:l_out) = "" - END IF ELSE l_in = LEN_TRIM(val%c_val(1)) - IF (l_out < l_in) THEN + IF (l_out < l_in) & CALL cp_warn(__LOCATION__, & "val_get will truncate value, value '"// & TRIM(val%c_val(1))//"' is too long for variable") - END IF c_val = val%c_val(1) END IF ELSE diff --git a/src/input_cp2k_check.F b/src/input_cp2k_check.F index 87a01c5aaf..273e17ad76 100644 --- a/src/input_cp2k_check.F +++ b/src/input_cp2k_check.F @@ -80,9 +80,8 @@ CONTAINS CPASSERT(ASSOCIATED(input_file)) CPASSERT(input_file%ref_count > 0) ! ext_restart - IF (PRESENT(output_unit)) THEN + IF (PRESENT(output_unit)) & CALL handle_ext_restart(input_declaration, input_file, para_env, output_unit) - END IF ! checks on force_eval section sections => section_vals_get_subs_vals(input_file, "FORCE_EVAL") @@ -147,15 +146,13 @@ CONTAINS ! do not allow the use of external potential section => section_vals_get_subs_vals(sections, "DFT%EXTERNAL_POTENTIAL") CALL section_vals_get(section, explicit=apply_ext_potential) - IF (apply_ext_potential) THEN + IF (apply_ext_potential) & CPABORT("The EXTERNAL_POTENTIAL section is not allowed for the MiMiC runtype.") - END IF ! force eval methods supported with MiMiC CALL section_vals_val_get(sections, "METHOD", i_val=force_eval_method) - IF (force_eval_method /= do_qs) THEN + IF (force_eval_method /= do_qs) & CPABORT("At the moment, only Quickstep method is supported with MiMiC.") - END IF END IF CALL timestop(handle) @@ -434,33 +431,29 @@ CONTAINS IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_COORD") CALL section_vals_set_subs_vals(section2, "SHELL_COORD", section) - IF (check_restart(section1, section2, "SHELL_COORD")) THEN + IF (check_restart(section1, section2, "SHELL_COORD")) & CALL set_restart_info("SHELL COORDINATES", restarted_infos) - END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_POS", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_COORD") CALL section_vals_set_subs_vals(section2, "CORE_COORD", section) - IF (check_restart(section1, section2, "CORE_COORD")) THEN + IF (check_restart(section1, section2, "CORE_COORD")) & CALL set_restart_info("CORE COORDINATES", restarted_infos) - END IF END IF CALL section_vals_val_get(r_section, "RESTART_SHELL_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "SHELL_VELOCITY") CALL section_vals_set_subs_vals(section2, "SHELL_VELOCITY", section) - IF (check_restart(section1, section2, "SHELL_VELOCITY")) THEN + IF (check_restart(section1, section2, "SHELL_VELOCITY")) & CALL set_restart_info("SHELL VELOCITIES", restarted_infos) - END IF END IF CALL section_vals_val_get(r_section, "RESTART_CORE_VELOCITY", l_val=flag) IF (flag) THEN section => section_vals_get_subs_vals(section1, "CORE_VELOCITY") CALL section_vals_set_subs_vals(section2, "CORE_VELOCITY", section) - IF (check_restart(section1, section2, "CORE_VELOCITY")) THEN + IF (check_restart(section1, section2, "CORE_VELOCITY")) & CALL set_restart_info("CORE VELOCITIES", restarted_infos) - END IF END IF END IF ELSE @@ -984,20 +977,18 @@ CONTAINS CALL section_vals_set_subs_vals(input_file, TRIM(path)//"%AD_LANGEVIN%MASS", section) END SELECT ELSE - IF (input_type /= restart_type) THEN + IF (input_type /= restart_type) & CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of thermostat! Restarting is not possible! "// & "Thermostat will not be restarted! ") - END IF - IF (input_region /= restart_region) THEN + IF (input_region /= restart_region) & CALL cp_warn(__LOCATION__, & "Requested to restart thermostat: "//TRIM(path)//". The thermostat "// & "specified in the input file and the information present in the restart "// & "file do not match the same type of REGION! Restarting is not possible! "// & "Thermostat will not be restarted! ") - END IF END IF END IF END SUBROUTINE restart_thermostat diff --git a/src/input_cp2k_dft.F b/src/input_cp2k_dft.F index 74c65fff9f..082cc27f4b 100644 --- a/src/input_cp2k_dft.F +++ b/src/input_cp2k_dft.F @@ -250,14 +250,8 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify type and size of automatically generated auxiliary "// & - "(RI) basis sets. Exactly two arguments are required for this option. "// & - "The first argument of basis type should be one of the following: "// & - "`RI_AUX`, `AUX_FIT`, `LRI_AUX`, `P_LRI_AUX`, `RI_HXC`, `RI_XAS`, or "// & - "`RI_HFX`. The second argument of basis size should be one of the "// & - "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & - "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & - "as written here).", & + description="Specify size of automatically generated auxiliary (RI) basis sets: "// & + "Options={small,medium,large,huge}", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) diff --git a/src/input_cp2k_mm.F b/src/input_cp2k_mm.F index 4938f9cfea..aeb0be36a1 100644 --- a/src/input_cp2k_mm.F +++ b/src/input_cp2k_mm.F @@ -15,9 +15,9 @@ ! ************************************************************************************************** MODULE input_cp2k_mm USE bibliography, ONLY: & - Batatia2022, Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, & - Drautz2019, Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, & - Tan2025, Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 + Batzner2022, Bochkarev2024, Clabaut2020, Clabaut2021, Devynck2012, Dick1958, Drautz2019, & + Foiles1986, Lysogorskiy2021, Mitchell1993, Musaelian2023, Siepmann1995, Tan2025, & + Tersoff1988, Tosi1964a, Tosi1964b, Wang2018, Yamada2000, Zeng2023 USE cp_output_handling, ONLY: cp_print_key_section_create,& debug_print_level,& high_print_level,& @@ -1185,10 +1185,6 @@ CONTAINS CALL section_add_subsection(section, subsection) CALL section_release(subsection) - CALL create_MACE_section(subsection) - CALL section_add_subsection(section, subsection) - CALL section_release(subsection) - CALL create_DEEPMD_section(subsection) CALL section_add_subsection(section, subsection) CALL section_release(subsection) @@ -1487,48 +1483,6 @@ CONTAINS END SUBROUTINE create_NEQUIP_section -! ************************************************************************************************** -!> \brief This section specifies the input parameters for MACE potential type -!> \param section the section to create -!> \author Xinyue Sun -! ************************************************************************************************** - SUBROUTINE create_MACE_section(section) - TYPE(section_type), POINTER :: section - - TYPE(keyword_type), POINTER :: keyword - - CPASSERT(.NOT. ASSOCIATED(section)) - CALL section_create(section, __LOCATION__, name="MACE", & - description="This section specifies the input parameters for MACE potential type, "// & - "a higher-order equivariant message-passing neural network. "// & - "The MACE model must be exported to a TorchScript file that takes a single "// & - "dictionary argument (see the create_cp2k_model.py helper). "// & - "Requires linking with libtorch library from .", & - citations=[Batatia2022], n_keywords=1, n_subsections=0, repeats=.FALSE.) - - NULLIFY (keyword) - - CALL keyword_create(keyword, __LOCATION__, name="ATOMS", & - description="Defines the atomic kinds involved in the MACE potential. "// & - "Provide a list of each element, making sure that the mapping from the ATOMS list "// & - "to MACE atom types is correct. This mapping should also be consistent for the "// & - "atomic coordinates as specified in the sections COORDS or TOPOLOGY.", & - usage="ATOMS {KIND 1} {KIND 2} .. {KIND N}", type_of_var=char_t, & - n_var=-1) - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - CALL keyword_create(keyword, __LOCATION__, name="POT_FILE_NAME", & - variants=["MODEL_FILE_NAME"], & - description="Specifies the filename that contains the exported MACE model. "// & - "MACE models use standardized units (Angstrom for length, eV for energy, "// & - "eV/Angstrom for forces), so no unit keywords are required.", & - usage="POT_FILE_NAME {FILENAME}", default_lc_val=" ") - CALL section_add_keyword(section, keyword) - CALL keyword_release(keyword) - - END SUBROUTINE create_MACE_section - ! ************************************************************************************************** !> \brief This section specifies the input parameters for ACE potential type !> \param section the section to create diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index 68a5a348e7..e120efee04 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -1803,13 +1803,8 @@ CONTAINS CALL keyword_release(keyword) CALL keyword_create(keyword, __LOCATION__, name="AUTO_BASIS", & - description="Specify type and size of automatically generated auxiliary "// & - "(RI) basis sets. Exactly two arguments are required for this option. "// & - "The first argument of basis type should be one of the following: "// & - "`P_LRI_AUX`. The second argument of basis size should be one of the "// & - "following: `SMALL`, `MEDIUM`, `LARGE`, or `HUGE`. The default is not "// & - "using any of these basis sets, requested by `AUTO_BASIS X X` (exactly "// & - "as written here).", & + description="Specify size of automatically generated auxiliary basis sets: "// & + "Options={small,medium,large,huge}", & usage="AUTO_BASIS {basis_type} {basis_size}", & type_of_var=char_t, repeats=.TRUE., n_var=-1, default_c_vals=["X", "X"]) CALL section_add_keyword(section, keyword) diff --git a/src/input_cp2k_restarts_util.F b/src/input_cp2k_restarts_util.F index c281e5f8b7..2411d815ec 100644 --- a/src/input_cp2k_restarts_util.F +++ b/src/input_cp2k_restarts_util.F @@ -62,11 +62,10 @@ CONTAINS CPASSERT(velocity_section%ref_count > 0) section => velocity_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF ! At least one of the two arguments must be present.. check = PRESENT(particles) .NEQV. PRESENT(velocity) diff --git a/src/input_restart_force_eval.F b/src/input_restart_force_eval.F index e333517e4b..77181ca694 100644 --- a/src/input_restart_force_eval.F +++ b/src/input_restart_force_eval.F @@ -555,11 +555,10 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT @@ -690,11 +689,10 @@ CONTAINS CPASSERT(dipoles_section%ref_count > 0) section => dipoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF ! At least one of the two arguments must be present.. nloop = SIZE(dipoles, 2) @@ -768,11 +766,10 @@ CONTAINS CPASSERT(quadrupoles_section%ref_count > 0) section => quadrupoles_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF ! At least one of the two arguments must be present.. nloop = SIZE(quadrupoles, 2) diff --git a/src/input_restart_rng.F b/src/input_restart_rng.F index ea236ff010..51913f61cf 100644 --- a/src/input_restart_rng.F +++ b/src/input_restart_rng.F @@ -61,11 +61,10 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, & "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(rng_section%values, 2) == 1) EXIT diff --git a/src/ipi_driver.F b/src/ipi_driver.F index 19404bd82f..ea8b57b9a3 100644 --- a/src/ipi_driver.F +++ b/src/ipi_driver.F @@ -212,9 +212,8 @@ CONTAINS CALL para_env%bcast(combuf) CALL force_env_get(force_env, subsys=subsys) - IF (nat /= subsys%particles%n_els) THEN + IF (nat /= subsys%particles%n_els) & CPABORT("@DRIVER MODE: Uh-oh! Particle number mismatch between i-PI and cp2k input!") - END IF ii = 0 DO ip = 1, subsys%particles%n_els DO idir = 1, 3 diff --git a/src/ipi_server.F b/src/ipi_server.F index 488e5a19b4..8cb6ac0d66 100644 --- a/src/ipi_server.F +++ b/src/ipi_server.F @@ -179,18 +179,16 @@ CONTAINS ! Step 1: See if the client is ready CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "READY") THEN + IF (TRIM(msgbuffer) /= "READY") & CPABORT("i–PI: Expected READY header but recieved "//TRIM(msgbuffer)) - END IF ! Step 2: Send cell and position data to client CALL send_posdata(comm_socket, subsys=ipi_env%subsys) ! Step 3: Ask for status, should be done now CALL ask_status(comm_socket, msgbuffer) - IF (TRIM(msgbuffer) /= "HAVEDATA") THEN + IF (TRIM(msgbuffer) /= "HAVEDATA") & CPABORT("i–PI: Expected HAVEDATA header but recieved "//TRIM(msgbuffer)) - END IF ! Step 4: Ask for data ALLOCATE (forces(3, nAtom)) @@ -269,9 +267,8 @@ CONTAINS ! Exchange headers CALL writebuffer(sockfd, msg, msglength) CALL get_header(sockfd, msgbuffer) - IF (TRIM(msgbuffer) /= "FORCEREADY") THEN + IF (TRIM(msgbuffer) /= "FORCEREADY") & CPABORT("i–PI: Expected FORCEREADY header but recieved "//TRIM(msgbuffer)) - END IF ! Recieve data CALL readbuffer(sockfd, energy) diff --git a/src/iterate_matrix.F b/src/iterate_matrix.F index 4a6b4b3a88..d78f5a3191 100644 --- a/src/iterate_matrix.F +++ b/src/iterate_matrix.F @@ -1177,9 +1177,8 @@ CONTAINS END IF END DO - IF (.NOT. converged) THEN + IF (.NOT. converged) & CPABORT("dense_matrix_sign_Newton_Schulz did not converge within 100 iterations") - END IF DEALLOCATE (tmp1) DEALLOCATE (tmp2) @@ -1808,9 +1807,8 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) THEN + IF (abnormal_value(conv)) & CPABORT("conv is an abnormal value (NaN/Inf).") - END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN @@ -2030,9 +2028,8 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (abnormal_value(conv)) THEN + IF (abnormal_value(conv)) & CPABORT("conv is an abnormal value (NaN/Inf).") - END IF ! conv < SQRT(threshold) IF ((conv*conv) < threshold) THEN diff --git a/src/kg_correction.F b/src/kg_correction.F index 3377337cde..ab870ac90a 100644 --- a/src/kg_correction.F +++ b/src/kg_correction.F @@ -309,9 +309,8 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) THEN + IF (ASSOCIATED(vxc_tau)) & ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) - END IF END DO END IF END IF @@ -410,9 +409,8 @@ CONTAINS ekin_imol = 0.0_dp DO ispin = 1, nspins ekin_imol = ekin_imol + pw_integral_ab(rho1_r(ispin), vxc_rho(ispin)) - IF (ASSOCIATED(vxc_tau)) THEN + IF (ASSOCIATED(vxc_tau)) & ekin_imol = ekin_imol + pw_integral_ab(tau1_r(ispin), vxc_tau(ispin)) - END IF END DO END IF END IF diff --git a/src/kg_vertex_coloring_methods.F b/src/kg_vertex_coloring_methods.F index d95ccc533a..bf437d443f 100644 --- a/src/kg_vertex_coloring_methods.F +++ b/src/kg_vertex_coloring_methods.F @@ -667,9 +667,8 @@ CONTAINS valid = .FALSE. CALL check_coloring(graph, valid) - IF (.NOT. valid) THEN + IF (.NOT. valid) & CPABORT("Coloring not valid.") - END IF nnodes = SIZE(kg_env%molecule_set) diff --git a/src/kpoint_io.F b/src/kpoint_io.F index a7e2ee483c..e7e544a0a0 100644 --- a/src/kpoint_io.F +++ b/src/kpoint_io.F @@ -231,7 +231,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -266,7 +266,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 diff --git a/src/kpoint_methods.F b/src/kpoint_methods.F index 6abad3f2a7..1c579b7dac 100644 --- a/src/kpoint_methods.F +++ b/src/kpoint_methods.F @@ -2299,14 +2299,14 @@ CONTAINS CALL dbcsr_iterator_next_block(iter, irow, icol, rblock) IF (.NOT. ALLOCATED(rwork)) THEN ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSE IF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN + ELSEIF (SIZE(rwork, 1) /= SIZE(rblock, 1) .OR. SIZE(rwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (rwork) ALLOCATE (rwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF IF (.NOT. real_only) THEN IF (.NOT. ALLOCATED(cwork)) THEN ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) - ELSE IF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN + ELSEIF (SIZE(cwork, 1) /= SIZE(rblock, 1) .OR. SIZE(cwork, 2) /= SIZE(rblock, 2)) THEN DEALLOCATE (cwork) ALLOCATE (cwork(SIZE(rblock, 1), SIZE(rblock, 2))) END IF diff --git a/src/kpoint_mo_symmetry_methods.F b/src/kpoint_mo_symmetry_methods.F deleted file mode 100644 index 3483dc7889..0000000000 --- a/src/kpoint_mo_symmetry_methods.F +++ /dev/null @@ -1,238 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright 2000-2026 CP2K developers group ! -! ! -! SPDX-License-Identifier: GPL-2.0-or-later ! -!--------------------------------------------------------------------------------------------------! - -! ************************************************************************************************** -!> \brief Utilities for transforming k-point MO coefficients under symmetry operations -! ************************************************************************************************** -MODULE kpoint_mo_symmetry_methods - USE cp_fm_types, ONLY: cp_fm_copy_general,& - cp_fm_get_info,& - cp_fm_get_submatrix,& - cp_fm_set_submatrix,& - cp_fm_type - USE kinds, ONLY: dp - USE kpoint_types, ONLY: kind_rotmat_type,& - kpoint_sym_type,& - kpoint_type - USE mathconstants, ONLY: twopi - USE message_passing, ONLY: mp_para_env_type -#include "./base/base_uses.f90" - - IMPLICIT NONE - PRIVATE - - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'kpoint_mo_symmetry_methods' - - PUBLIC :: kpoint_same_periodic, & - kpoint_transform_scf_mo - -CONTAINS - -! ************************************************************************************************** -!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. -!> \param xkp_a first k-point -!> \param xkp_b second k-point -!> \return true if the k-points are equivalent -! ************************************************************************************************** - LOGICAL FUNCTION kpoint_same_periodic(xkp_a, xkp_b) RESULT(same) - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b - - REAL(KIND=dp), DIMENSION(3) :: diff - - diff(1:3) = xkp_a(1:3) - xkp_b(1:3) - diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) - same = SUM(ABS(diff(1:3))) < 1.0e-8_dp - - END FUNCTION kpoint_same_periodic - -! ************************************************************************************************** -!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. -!> \param src_real real part of source MO coefficients -!> \param src_imag imaginary part of source MO coefficients -!> \param dst_real real part of transformed MO coefficients -!> \param dst_imag imaginary part of transformed MO coefficients -!> \param qs_kpoint SCF k-point object containing symmetry operations -!> \param ikred representative k-point index -!> \param isym symmetry operation index; 0 direct copy, -1 time reversal -!> \param para_env global parallel environment -!> \param success true if the transformation was performed -!> \param reason diagnostic message -! ************************************************************************************************** - SUBROUTINE kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & - isym, para_env, success, reason) - TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: ikred, isym - TYPE(mp_para_env_type), POINTER :: para_env - LOGICAL, INTENT(OUT) :: success - CHARACTER(LEN=*), INTENT(OUT) :: reason - - INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & - nmo, rot_slot, source_atom, source_dim, target_atom, target_dim - INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start - LOGICAL :: reverse_phase, time_reversal - REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & - phase_imag, phase_real, sinkl - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r - REAL(KIND=dp), DIMENSION(3) :: xkp_phase - REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat - TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot - TYPE(kpoint_sym_type), POINTER :: kpsym - - success = .FALSE. - reason = "" - IF (isym == 0) THEN - CALL cp_fm_copy_general(src_real, dst_real, para_env) - CALL cp_fm_copy_general(src_imag, dst_imag, para_env) - success = .TRUE. - RETURN - END IF - - CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) - ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) - CALL cp_fm_get_submatrix(src_real, src_r) - CALL cp_fm_get_submatrix(src_imag, src_i) - dst_r(:, :) = 0.0_dp - dst_i(:, :) = 0.0_dp - - IF (isym == -1) THEN - dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) - dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i) - success = .TRUE. - RETURN - END IF - - IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN - reason = "SCF symmetry operation data are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym - IF (.NOT. ASSOCIATED(kpsym)) THEN - reason = "SCF k-point symmetry operation is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (isym > kpsym%nwred) THEN - reason = "SCF k-point symmetry operation index is out of range" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN - reason = "SCF atom mappings or basis rotation matrices are not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - - rot_slot = find_kpoint_rotation_slot(qs_kpoint, kpsym%rotp(isym)) - IF (rot_slot == 0) THEN - reason = "could not match the SCF symmetry operation to a basis rotation" - DEALLOCATE (src_r, src_i, dst_r, dst_i) - RETURN - END IF - kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) - natom = SIZE(qs_kpoint%atype) - ALLOCATE (ao_start(natom), ao_size(natom)) - irow = 1 - DO iatom = 1, natom - ikind = qs_kpoint%atype(iatom) - IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN - reason = "a required basis rotation matrix is not available" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - ao_start(iatom) = irow - ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) - irow = irow + ao_size(iatom) - END DO - IF (irow - 1 /= nao) THEN - reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - - time_reversal = kpsym%rotp(isym) < 0 - reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) - IF (ASSOCIATED(kpsym%phase_mode)) THEN - IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 - END IF - xkp_phase(1:3) = kpsym%xkp(1:3, isym) - DO iatom = 1, natom - source_atom = iatom - target_atom = kpsym%f0(iatom, isym) - ikind = qs_kpoint%atype(source_atom) - rotmat => kind_rot(ikind)%rmat - source_dim = ao_size(source_atom) - target_dim = ao_size(target_atom) - IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN - reason = "basis rotation dimensions do not match the atom/AO symmetry transform" - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - RETURN - END IF - arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & - REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & - REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) - IF (ASSOCIATED(kpsym%kgphase)) THEN - arg = arg + kpsym%kgphase(source_atom, isym) - END IF - IF (reverse_phase) arg = -arg - coskl = COS(twopi*arg) - sinkl = SIN(twopi*arg) - DO imo = 1, nmo - DO irow_work = 1, source_dim - irow_source = ao_start(source_atom) + irow_work - 1 - coeff_real = src_r(irow_source, imo) - coeff_imag = src_i(irow_source, imo) - IF (time_reversal) coeff_imag = -coeff_imag - phase_real = coskl*coeff_real - sinkl*coeff_imag - phase_imag = sinkl*coeff_real + coskl*coeff_imag - DO iao = 1, target_dim - irow_target = ao_start(target_atom) + iao - 1 - dst_r(irow_target, imo) = dst_r(irow_target, imo) + & - rotmat(iao, irow_work)*phase_real - dst_i(irow_target, imo) = dst_i(irow_target, imo) + & - rotmat(iao, irow_work)*phase_imag - END DO - END DO - END DO - END DO - - CALL cp_fm_set_submatrix(dst_real, dst_r) - CALL cp_fm_set_submatrix(dst_imag, dst_i) - DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) - success = .TRUE. - - END SUBROUTINE kpoint_transform_scf_mo - -! ************************************************************************************************** -!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. -!> \param qs_kpoint SCF k-point object -!> \param rotp signed operation identifier -!> \return rotation slot, or zero when no slot matches -! ************************************************************************************************** - INTEGER FUNCTION find_kpoint_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) - TYPE(kpoint_type), POINTER :: qs_kpoint - INTEGER, INTENT(IN) :: rotp - - INTEGER :: irot, rot_abs - - rot_slot = 0 - rot_abs = ABS(rotp) - IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN - DO irot = 1, SIZE(qs_kpoint%ibrot) - IF (rot_abs == qs_kpoint%ibrot(irot)) THEN - rot_slot = irot - RETURN - END IF - END DO - - END FUNCTION find_kpoint_rotation_slot - -END MODULE kpoint_mo_symmetry_methods diff --git a/src/kpoint_transitional.F b/src/kpoint_transitional.F index 3a0ca3aa07..fba771ac76 100644 --- a/src/kpoint_transitional.F +++ b/src/kpoint_transitional.F @@ -47,9 +47,8 @@ CONTAINS TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: res IF (ASSOCIATED(this%ptr_1d)) THEN - IF (SIZE(this%ptr_2d, 2) /= 1) THEN + IF (SIZE(this%ptr_2d, 2) /= 1) & CPABORT("Method not implemented for k-points") - END IF END IF res => this%ptr_1d diff --git a/src/kpoint_types.F b/src/kpoint_types.F index 10a0dd0c05..2f949201c3 100644 --- a/src/kpoint_types.F +++ b/src/kpoint_types.F @@ -566,9 +566,8 @@ CONTAINS IF (PRESENT(full_grid)) full_grid = kpoint%full_grid IF (PRESENT(inversion_symmetry_only)) inversion_symmetry_only = kpoint%inversion_symmetry_only IF (PRESENT(symmetry_backend)) symmetry_backend = kpoint%symmetry_backend - IF (PRESENT(symmetry_reduction_method)) THEN + IF (PRESENT(symmetry_reduction_method)) & symmetry_reduction_method = kpoint%symmetry_reduction_method - END IF IF (PRESENT(use_real_wfn)) use_real_wfn = kpoint%use_real_wfn IF (PRESENT(eps_geo)) eps_geo = kpoint%eps_geo IF (PRESENT(parallel_group_size)) parallel_group_size = kpoint%parallel_group_size @@ -682,9 +681,8 @@ CONTAINS IF (PRESENT(full_grid)) kpoint%full_grid = full_grid IF (PRESENT(inversion_symmetry_only)) kpoint%inversion_symmetry_only = inversion_symmetry_only IF (PRESENT(symmetry_backend)) kpoint%symmetry_backend = symmetry_backend - IF (PRESENT(symmetry_reduction_method)) THEN + IF (PRESENT(symmetry_reduction_method)) & kpoint%symmetry_reduction_method = symmetry_reduction_method - END IF IF (PRESENT(use_real_wfn)) kpoint%use_real_wfn = use_real_wfn IF (PRESENT(eps_geo)) kpoint%eps_geo = eps_geo IF (PRESENT(parallel_group_size)) kpoint%parallel_group_size = parallel_group_size diff --git a/src/kpsym.F b/src/kpsym.F index 4342c92f8b..170c44e613 100644 --- a/src/kpsym.F +++ b/src/kpsym.F @@ -188,12 +188,10 @@ CONTAINS a02(i) = a2(i)/alat a03(i) = a3(i)/alat END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| NUMBER OF ATOMS (STRUCT):",I6)') nat - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",10X,"K TYPE",14X,"X(K)")') - END IF itype = 0 DO i = 1, nat ! Assign an atomic type (for internal purposes) @@ -208,22 +206,19 @@ CONTAINS END IF itype = itype + 1 IF (itype > nsp) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I4,")")') & - ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & - nsp - END IF - IF (iout > 0) THEN + ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & + nsp + IF (iout > 0) & WRITE (iout, '(" KPSYM| THE ARRAY TY IS:",/,9(1X,10I7,/))') & - (ty(j), j=1, nat) - END IF + (ty(j), j=1, nat) CALL stopgm('K290', 'FATAL ERROR') END IF 178 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",6X,I5,I6,3F10.5)') & - i, ty(i), (xkapa(j, i), j=1, 3) - END IF + i, ty(i), (xkapa(j, i), j=1, 3) END DO ! ==--------------------------------------------------------------== ! IS THE STRAIN SIGNIFICANT ? @@ -269,12 +264,11 @@ CONTAINS ! ==--------------------------------------------------------------== invadd = 0 IF (li == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,A,/,A)') & - ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & - ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & - ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' - END IF + ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & + ' KPSYM| CONTAIN INVERSION, THE SPECIAL POINT GENERATION ALGORITHM', & + ' KPSYM| WILL CONSIDER IT AS A SYMMETRY OPERATION' invadd = 1 END IF ! ==--------------------------------------------------------------== @@ -289,125 +283,101 @@ CONTAINS ! ==--------------------------------------------------------------== ! == GROUP-THEORETICAL INFORMATION == ! ==--------------------------------------------------------------== - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM| GROUP-THEORETICAL INFORMATION:")') - END IF ! IHG .... Point group of the primitive lattice, holohedral - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(" KPSYM| POINT GROUP OF THE PRIMITIVE LATTICE: ",A," SYSTEM")') & - icst(ihg) - END IF + icst(ihg) ! IHC .... Code distinguishing between hexagonal and cubic groups ! ISY .... Code indicating whether the space group is symmorphic IF (isy == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP")') - END IF - ELSE IF (isy == 1) THEN - IF (iout > 0) THEN + ELSEIF (isy == 1) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP")') - END IF - ELSE IF (isy == -1) THEN - IF (iout > 0) THEN + ELSEIF (isy == -1) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP WITH NON-STANDARD ORIGIN")') - END IF - ELSE IF (isy == -2) THEN - IF (iout > 0) THEN + ELSEIF (isy == -2) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP???")') - END IF END IF ! LI ..... Inversions symmetry IF (li == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NO INVERSION SYMMETRY")') - END IF - ELSE IF (li > 0) THEN - IF (iout > 0) THEN + ELSEIF (li > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"INVERSION SYMMETRY")') - END IF END IF ! NC ..... Total number of elements in the point group - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(" KPSYM|",4X,"TOTAL NUMBER OF ELEMENTS IN THE POINT GROUP:",I3)') nc - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"TO SUM UP: (",I1,5I3,")")') & - ihg, ihc, isy, li, nc, indpg - END IF + ihg, ihc, isy, li, nc, indpg ! IB ..... List of the rotations constituting the point group - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE ROTATIONS:")') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(7X,12I4)') (ib(i), i=1, nc) - END IF ! V ...... Nonprimitive translations (for nonsymmorphic groups) IF (isy <= 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"NONPRIMITIVE TRANSLATIONS:")') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A)') & - ' ROT V IN THE BASIS A1, A2, A3 ', & - 'V IN CARTESIAN COORDINATES' - END IF + ' ROT V IN THE BASIS A1, A2, A3 ', & + 'V IN CARTESIAN COORDINATES' ! Cartesian components of nonprimitive translation. DO i = 1, nc DO j = 1, 3 vv0(j) = v(1, i)*a1(j) + v(2, i)*a2(j) + v(3, i)*a3(j) END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(1X,I3,3F10.5,3X,3F10.5)') & - ib(i), (v(j, i), j=1, 3), vv0 - END IF + ib(i), (v(j, i), j=1, 3), vv0 END DO END IF ! F0 ..... The function defined in Maradudin, Ipatova by ! eq. (3.2.12): atom transformation table. - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(/," KPSYM|",4X,"ATOM TRANSFORMATION TABLE (MARADUDIN,VOSKO):")') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(5(4X,"R AT->AT"))') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(I5," [Identity]")') 1 - END IF DO k = 2, nc DO j = 1, nat - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(I5,2I4)', advance="no") ib(k), j, f0(k, j) - END IF - IF ((MOD(j, 5) == 0) .AND. iout > 0) THEN + IF ((MOD(j, 5) == 0) .AND. iout > 0) & WRITE (iout, *) - END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & WRITE (iout, *) - END IF END DO ! R ...... List of the 3 x 3 rotation matrices - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE 3 X 3 ROTATION MATRICES:")') - END IF IF (ihc == 0) THEN DO k = 1, nc - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(4X,I3," (",I2,": ",A11,")",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) - END IF + k, ib(k), rname_hexai(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) END DO ELSE DO k = 1, nc - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, & '(4X,I3," (",I2,": ",A10,") ",2(3F14.6,/,25X),3F14.6)') & - k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) - END IF + k, ib(k), rname_cubic(ib(k)), ((r(i, j, ib(k)), j=1, 3), i=1, 3) END DO END IF ! ==--------------------------------------------------------------== @@ -421,42 +391,34 @@ CONTAINS ! (cubic/hexagonal) will apply to the crystal as well as the Bravais ! lattice. ! ==--------------------------------------------------------------== - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/,1X,19("*"),A,25("*"))') & - ' GENERATION OF SPECIAL POINTS ' - END IF + ' GENERATION OF SPECIAL POINTS ' ! Parameter Q of Monkhorst and Pack, generalized for 3 axes B1,2,3 - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,1X,3I5)') & - ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & - iq1, iq2, iq3 - END IF + ' KPSYM| MONKHORST-PACK PARAMETERS (GENERALIZED) IQ1,IQ2,IQ3:', & + iq1, iq2, iq3 ! WVK0 is the shift of the whole mesh (see Macdonald) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,1X,3F10.5)') & - ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 - END IF - IF (ABS(iq1) + ABS(iq2) + ABS(iq3) == 0) GOTO 710 + ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 + IF (iabs(iq1) + iabs(iq2) + iabs(iq3) == 0) GOTO 710 IF (ABS(istriz) /= 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz - END IF CALL stopgm('K290', 'ISTRIZ WRONG ARGUMENT') END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" KPSYM| SYMMETRIZATION SWITCH: ",I3)', advance="no") istriz - END IF IF (istriz == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" (SYMMETRIZATION OF MONKHORST-PACK MESH)")') - END IF ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" (NO SYMMETRIZATION OF MONKHORST-PACK MESH)")') - END IF END IF ! Set to 0. DO i = 1, nkpoint @@ -471,15 +433,12 @@ CONTAINS ! rotations than Bravais lattice. ! We use only the rotations for Bravais lattices IF (ntvec == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR BRAVAIS LATTICE', nc0 - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR CRYSTAL LATTICE', nc - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) ' KPSYM| NO DUPLICATION FOUND' - END IF CALL stopgm('ERROR', & 'SOMETHING IS WRONG IN GROUP DETERMINATION') END IF @@ -487,24 +446,19 @@ CONTAINS DO i = 1, nc0 ib(i) = ib0(i) END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/,1X,20("! "),"WARNING",20("!"))') - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' - END IF - IF (iout > 0) THEN + ' KPSYM| THE CRYSTAL HAS MORE SYMMETRY THAN THE BRAVAIS LATTICE' + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' - END IF - IF (iout > 0) THEN + ' KPSYM| BECAUSE THIS IS NOT A PRIMITIVE CELL' + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' - END IF - IF (iout > 0) THEN + ' KPSYM| USE ONLY SYMMETRY FROM BRAVAIS LATTICE' + IF (iout > 0) & WRITE (iout, '(1X,20("! "),"WARNING",20("!"),/)') - END IF END IF CALL sppt2(iout, iq1, iq2, iq3, wvk0, nkpoint, & a01, a02, a03, b01, b02, b03, & @@ -513,18 +467,16 @@ CONTAINS ! ==--------------------------------------------------------------== ! == Check on error signals == ! ==--------------------------------------------------------------== - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/," KPSYM|",1X,I5," SPECIAL POINTS GENERATED")') ntot - END IF IF (ntot == 0) THEN GOTO 710 ELSE IF (ntot < 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I5,/,A,/,A)') ' KPSYM| DIMENSION NKPOINT =', nkpoint, & - ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & - ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' - END IF - ntot = ABS(ntot) + ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & + ' KPSYM| WHAT FOLLOWS IS AN INCOMPLETE LIST' + ntot = iabs(ntot) END IF ! Before using the list WVKL as wave vectors, they have to be ! multiplied by 2*Pi @@ -533,10 +485,9 @@ CONTAINS DO i = 1, ntot iswght = iswght + lwght(i) END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(8X,A,T33,A,4X,A)') & - 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' - END IF + 'WAVEVECTOR K', 'WEIGHT', 'UNFOLDING ROTATIONS' ! Set near-zeroes equal to zero: DO l = 1, ntot DO i = 1, 3 @@ -557,20 +508,17 @@ CONTAINS END DO END IF lmax = lwght(l) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, fmt='(1X,I5,3F8.4,I8,T42,12I3)') & - l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) - END IF + l, (wvkl(i, l), i=1, 3), lwght(l), (lrot(i, l), i=1, MIN(lmax, 12)) DO j = 13, lmax, 12 - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, fmt='(T42,12I3)') & - (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) - END IF + (lrot(i, l), i=j, MIN(lmax, j - 1 + 12)) END DO END DO - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(24X,"TOTAL:",I8)') iswght - END IF ! ==--------------------------------------------------------------== 710 CONTINUE ! ==--------------------------------------------------------------== @@ -775,14 +723,12 @@ CONTAINS IF (iout > 0) THEN IF (li > 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(1X,A)') & - 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' - END IF + 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) - END IF END IF END SUBROUTINE group1s @@ -1354,139 +1300,138 @@ CONTAINS ! (Thierry Deutsch - 1998 [Maybe not complete!!]) IF (ihg < 6) THEN IF (nc == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC - END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSE IF (nc == 1) THEN + ELSEIF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSE IF (nc == 2 .AND. ib(2) == 25) THEN + ELSEIF (nc == 2 .AND. ib(2) == 25) THEN ! IB=125 indpg = 2 ! <1>(ci) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 4 .OR. & ! 2[001] - ib(2) == 2 .OR. & ! 2[100] - ib(2) == 3)) THEN ! 2[010] + ELSEIF (nc == 2 .AND. ( & + ib(2) == 4 .OR. & ! 2[001] + ib(2) == 2 .OR. & ! 2[100] + ib(2) == 3)) THEN ! 2[010] ! Monoclinic system ! IB=14 (z-axis) OR ! IB=12 (x-axis) OR ! IB=13 (y-axis) indpg = 3 ! 2 (c2) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 28 .OR. & - ib(2) == 26 .OR. & - ib(2) == 27)) THEN + ELSEIF (nc == 2 .AND. ( & + ib(2) == 28 .OR. & + ib(2) == 26 .OR. & + ib(2) == 27)) THEN ! IB=128 (z-axis) OR ! IB=126 (x-axis) OR ! IB=127 (y-axis) indpg = 4 ! m (c1h) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 28 .OR. & ! 2[001] - ib(4) == 27 .OR. & ! 2[010] - ib(4) == 26 .OR. & ! 2[100] - ib(4) == 37 .OR. & ! -2[-110] - ib(4) == 40)) THEN ! 2[110] + ELSEIF (nc == 4 .AND. ( & + ib(4) == 28 .OR. & ! 2[001] + ib(4) == 27 .OR. & ! 2[010] + ib(4) == 26 .OR. & ! 2[100] + ib(4) == 37 .OR. & ! -2[-110] + ib(4) == 40)) THEN ! 2[110] ! IB=1 425 28 (z-axis) OR ! IB=1 225 26 (x-axis) OR ! IB=1 325 27 (y-axis) OR ! IB=113 2537 (-xy-axis)OR ! IB=116 2540 (xy-axis) indpg = 5 ! 2/m(c2h) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 15 .OR. & - ib(4) == 20 .OR. & - ib(4) == 24)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 15 .OR. & + ib(4) == 20 .OR. & + ib(4) == 24)) THEN ! Tetragonal system ! IB=14 1415 (z-axis) OR ! IB=12 1920 (x-axis) OR ! IB=13 2224 (y-axis) indpg = 11 ! 4 (c4) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 39 .OR. & - ib(4) == 44 .OR. & - ib(4) == 48)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 39 .OR. & + ib(4) == 44 .OR. & + ib(4) == 48)) THEN ! IB=14 3839 (z-axis) OR ! IB=12 4344 (x-axis) OR ! IB=13 4648 (y-axis) indpg = 12 ! <4>(s4) - ELSE IF (nc == 8 .AND. ( & - (ib(3) == 14 .AND. ib(8) == 39) .OR. & - (ib(3) == 19 .AND. ib(8) == 44) .OR. & - (ib(3) == 22 .AND. ib(8) == 48))) THEN + ELSEIF (nc == 8 .AND. ( & + (ib(3) == 14 .AND. ib(8) == 39) .OR. & + (ib(3) == 19 .AND. ib(8) == 44) .OR. & + (ib(3) == 22 .AND. ib(8) == 48))) THEN ! IB=14 1415 2825 3839 (z-axis) OR ! IB=12 1920 2625 4344 (x-axis) OR ! IB=13 2224 2725 4648 (y-axis) indpg = 13 ! 422(d4) - ELSE IF (nc == 8 .AND. ib(4) == 4 .AND. ( & - ib(8) == 16 .OR. & - ib(8) == 20 .OR. & - ib(8) == 24)) THEN + ELSEIF (nc == 8 .AND. ib(4) == 4 .AND. ( & + ib(8) == 16 .OR. & + ib(8) == 20 .OR. & + ib(8) == 24)) THEN ! IB=12 3 413 1415 16 (z-axis) OR ! IB=12 3 417 1920 18 (x-axis) OR ! IB=12 3 421 2224 23 (y-axis) indpg = 14 ! 4/m(c4h) - ELSE IF (nc == 8 .AND. ( & - ib(8) == 40 .OR. & - ib(8) == 42 .OR. & - ib(8) == 47)) THEN + ELSEIF (nc == 8 .AND. ( & + ib(8) == 40 .OR. & + ib(8) == 42 .OR. & + ib(8) == 47)) THEN ! IB=14 1415 2627 3740 (z-axis) OR ! IB=12 1920 2827 4142 (x-axis) OR ! IB=13 2224 2628 4547 (y-axis) indpg = 15 ! 4mm(c4v) - ELSE IF (nc == 8 .AND. ( & - (ib(3) == 13 .AND. ib(8) == 39) .OR. & - (ib(3) == 17 .AND. ib(8) == 44) .OR. & - (ib(3) == 21 .AND. ib(8) == 48))) THEN + ELSEIF (nc == 8 .AND. ( & + (ib(3) == 13 .AND. ib(8) == 39) .OR. & + (ib(3) == 17 .AND. ib(8) == 44) .OR. & + (ib(3) == 21 .AND. ib(8) == 48))) THEN ! IB=14 1316 2627 3839 (z-axis) OR ! IB=12 1718 2827 4344 (x-axis) OR ! IB=13 2123 2628 4648 (y-axis) indpg = 16 ! <4>2m(d2d) - ELSE IF (nc == 16 .AND. ( & - ib(16) == 40 .OR. & - ib(16) == 44 .OR. & - ib(16) == 48)) THEN + ELSEIF (nc == 16 .AND. ( & + ib(16) == 40 .OR. & + ib(16) == 44 .OR. & + ib(16) == 48)) THEN ! IB=12 3 413 1415 1625 2627 2837 3839 40 (z-axis) OR ! IB=12 3 417 1920 1825 2627 2841 4344 42 (x-axis) OR ! IB=12 3 421 2224 2325 2627 2845 4648 47 (y-axis) indpg = 17 ! 4/mmm(d4h) - ELSE IF (nc == 4 .AND. (ib(4) == 4)) THEN + ELSEIF (nc == 4 .AND. (ib(4) == 4)) THEN ! Orthorhombic system ! IB=12 3 4 indpg = 25 ! 222(d2) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 27 .OR. & - ib(4) == 28)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 27 .OR. & + ib(4) == 28)) THEN ! IB=13 2627 (z-axis) OR ! IB=12 2728 (x-axis) OR ! IB=14 2628 (y-axis) OR indpg = 26 ! mm2(c2v) - ELSE IF (nc == 8) THEN + ELSEIF (nc == 8) THEN ! IB=12 3 425 2627 28 indpg = 27 ! mmm(d2h) - ELSE IF (nc == 12 .AND. ( & - ib(12) == 12 .OR. & - ib(12) == 47 .OR. & - ib(12) == 45)) THEN + ELSEIF (nc == 12 .AND. ( & + ib(12) == 12 .OR. & + ib(12) == 47 .OR. & + ib(12) == 45)) THEN ! Cubic system ! IB=12 3 4 5 6 7 8 910 1112 OR ! IB=15 1113 1823 2530 3537 4247 OR ! IB=18 1016 1821 2532 3440 4245 indpg = 28 ! 23 (t) - ELSE IF (nc == 24 .AND. ib(24) == 36) THEN + ELSEIF (nc == 24 .AND. ib(24) == 36) THEN ! IB= 1 2 3 4 5 6 7 8 910 1112 ! 2526 2728 2930 3132 3334 3536 indpg = 29 ! m3 (th) - ELSE IF (nc == 24 .AND. ib(24) == 24) THEN + ELSEIF (nc == 24 .AND. ib(24) == 24) THEN ! IB=12 3 45 6 78 9 1011 12 ! 1314 1516 1718 1920 2122 2324 indpg = 30 ! 432 (o) - ELSE IF (nc == 24 .AND. ib(24) == 48) THEN + ELSEIF (nc == 24 .AND. ib(24) == 48) THEN ! IB=12 3 45 6 78 9 1011 12 ! 3738 3940 4142 4345 4647 48 indpg = 31 ! <4>3m(td) - ELSE IF (nc == 48) THEN + ELSEIF (nc == 48) THEN ! IB=1..48 indpg = 32 ! m3m(oh) ELSE @@ -1496,70 +1441,69 @@ CONTAINS ! Probably a sub-group of 32 indpg = -32 END IF - ELSE IF (ihg >= 6) THEN + ELSEIF (ihg >= 6) THEN IF (nc == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC - END IF CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSE IF (nc == 1) THEN + ELSEIF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSE IF (nc == 2 .AND. ib(2) == 13) THEN + ELSEIF (nc == 2 .AND. ib(2) == 13) THEN ! IB=113 indpg = 2 ! <1>(ci) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 4)) THEN ! 2[001] + ELSEIF (nc == 2 .AND. ( & + ib(2) == 4)) THEN ! 2[001] ! Monoclinic system ! IB=1 4 indpg = 3 ! 2 (c2) - ELSE IF (nc == 2 .AND. ( & - ib(2) == 16)) THEN + ELSEIF (nc == 2 .AND. ( & + ib(2) == 16)) THEN ! IB=116 indpg = 4 ! m (c1h) - ELSE IF (nc == 4 .AND. ( & - ib(4) == 24 .OR. & - ib(4) == 20)) THEN + ELSEIF (nc == 4 .AND. ( & + ib(4) == 24 .OR. & + ib(4) == 20)) THEN ! IB=112 1324 OR ! IB=1 813 20 indpg = 5 ! 2/m(c2h) - ELSE IF (nc == 3 .AND. ib(3) == 5) THEN + ELSEIF (nc == 3 .AND. ib(3) == 5) THEN ! Trigonal system ! IB=13 5 indpg = 6 ! 3 (c3) - ELSE IF (nc == 6 .AND. ib(6) == 17) THEN + ELSEIF (nc == 6 .AND. ib(6) == 17) THEN ! IB=113 1517 35 indpg = 7 ! <3>(c3i) - ELSE IF (nc == 6 .AND. ib(6) == 11) THEN + ELSEIF (nc == 6 .AND. ib(6) == 11) THEN ! IB=17 9 1135 indpg = 8 ! 32 (d3) - ELSE IF (nc == 6 .AND. ib(6) == 23) THEN + ELSEIF (nc == 6 .AND. ib(6) == 23) THEN ! IB=13 5 1921 23 indpg = 9 ! 3m (c3v) - ELSE IF (nc == 12 .AND. ib(12) == 23) THEN + ELSEIF (nc == 12 .AND. ib(12) == 23) THEN ! IB=13 5 79 1113 1517 1921 23 indpg = 10 ! <3>m(d3d) - ELSE IF (nc == 6 .AND. ib(6) == 6) THEN + ELSEIF (nc == 6 .AND. ib(6) == 6) THEN ! Hexagonal system ! IB=12 3 45 6 indpg = 18 ! 6 (c6) - ELSE IF (nc == 6 .AND. ib(6) == 18) THEN + ELSEIF (nc == 6 .AND. ib(6) == 18) THEN ! IB=13 5 1416 18 indpg = 19 ! <6>(c3h) - ELSE IF (nc == 12 .AND. ib(12) == 18) THEN + ELSEIF (nc == 12 .AND. ib(12) == 18) THEN ! IB=12 3 45 6 1314 1516 1718 indpg = 20 ! 6/m(c6h) - ELSE IF (nc == 12 .AND. ib(12) == 12) THEN + ELSEIF (nc == 12 .AND. ib(12) == 12) THEN ! IB=12 3 45 6 78 9 1011 12 indpg = 21 ! 622(d6) - ELSE IF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN + ELSEIF (nc == 12 .AND. ib(2) == 2 .AND. ib(12) == 24) THEN ! IB=12 3 45 6 1920 2122 2324 indpg = 22 ! 6mm(c6v) - ELSE IF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN + ELSEIF (nc == 12 .AND. ib(2) == 3 .AND. ib(12) == 24) THEN ! IB=13 5 79 1114 1618 2022 24 indpg = 23 ! <6>m2(d3h) - ELSE IF (nc == 24) THEN + ELSEIF (nc == 24) THEN ! IB=1..24 indpg = 24 ! 6/mmm(d6h) ELSE @@ -1596,7 +1540,7 @@ CONTAINS xb(i) = a(i, 1)*origin(1) + a(i, 2)*origin(2) + a(i, 3)*origin(3) END DO isy = -1 - ELSE IF (info == 0) THEN + ELSEIF (info == 0) THEN isy = 0 ELSE isy = -2 @@ -1610,98 +1554,83 @@ CONTAINS ! == Output == ! ==--------------------------------------------------------------== IF (iout > 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) - END IF CALL xstring(icst(ihg), i, j) IF ((ihg == 7 .AND. nc == 24) .OR. & (ihg == 5 .AND. nc == 48)) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A,A)') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & - icst(ihg) (i:j), & - ' GROUP' - END IF + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & + icst(ihg) (i:j), & + ' GROUP' ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A,A,I2,A)') & - ' KPSYM| THE CRYSTAL SYSTEM IS ', & - icst(ihg) (i:j), & - ' WITH ', nc, ' OPERATIONS:' - END IF + ' KPSYM| THE CRYSTAL SYSTEM IS ', & + icst(ihg) (i:j), & + ' WITH ', nc, ' OPERATIONS:' IF (ihc == 0) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '( 5(5(A13),/))') (rname_hexai(ib(i)), i=1, nc) - END IF ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(10(5(A13),/))') (rname_cubic(ib(i)), i=1, nc) - END IF END IF END IF ! ==------------------------------------------------------------== IF (isy == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - END IF - ELSE IF (isy == -1) THEN - IF (iout > 0) THEN + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + ELSEIF (isy == -1) THEN + IF (iout > 0) & WRITE (iout, '(A)') & - ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - END IF - IF (iout > 0) THEN + ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' + IF (iout > 0) & WRITE (iout, '(A,A,/,T3,3F10.6,3X,3F10.6)') & - ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & - '[CARTESIAN] [CRYSTAL]', xb, origin - END IF - ELSE IF (isy == 0) THEN - IF (iout > 0) THEN + ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & + '[CARTESIAN] [CRYSTAL]', xb, origin + ELSEIF (isy == 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' (SUM OF TRANSLATION VECTORS=', vs, ')' - END IF - ELSE IF (isy == -2) THEN - IF (iout > 0) THEN + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' (SUM OF TRANSLATION VECTORS=', vs, ')' + ELSEIF (isy == -2) THEN + IF (iout > 0) & WRITE (iout, '(A,A)') & - ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & - ' SYMMORPHIC OR NOT' - END IF - IF (iout > 0) THEN + ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & + ' SYMMORPHIC OR NOT' + IF (iout > 0) & WRITE (iout, '(A,/,A,/,3X,A,F15.6,A)') & - ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & - ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & - ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' - END IF + ' KPSYM| THE SPACE GROUP IS NON-SYMMORPHIC,', & + ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & + ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' END IF IF (indpg > 0) THEN CALL xstring(pgrp(indpg), i, j) CALL xstring(pgrd(indpg), k, l) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & - pgrd(indpg) (k:l), indpg - END IF + ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS ', pgrp(indpg) (i:j), & + pgrd(indpg) (k:l), indpg ELSE CALL xstring(pgrp(-indpg), i, j) CALL xstring(pgrd(-indpg), k, l) - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I2,A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & - ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & - ' SUBGROUP OF ', pgrp(-indpg) (i:j), & - pgrd(-indpg) (k:l), -indpg - END IF + ' KPSYM| POINT GROUP: GROUP ORDER=', nc, & + ' SUBGROUP OF ', pgrp(-indpg) (i:j), & + pgrd(-indpg) (k:l), -indpg END IF IF (ntvec == 1) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec - END IF + ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec ELSE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,T60,I6)') & - ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec - END IF + ' KPSYM| NUMBER OF PRIMITIVE CELLS:', ntvec END IF END IF @@ -2474,12 +2403,11 @@ CONTAINS 280 CONTINUE END DO END DO - IF (iremov > 0 .AND. iout > 0) THEN + IF (iremov > 0 .AND. iout > 0) & WRITE (iout, '(A,A,/,A,1X,I6,A,/)') & - ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & - 'TRANSLATION VECTORS', & - ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' - END IF + ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & + 'TRANSLATION VECTORS', & + ' KPSYM|', iremov, ' OF THE MESH POINTS REMOVED.' END IF ! ==--------------------------------------------------------------== ! == IN THE MESH OF WAVEVECTORS, NOW SEARCH FOR EQUIVALENT POINTS:== @@ -2572,72 +2500,59 @@ CONTAINS ! == THE LIST OF WEIGHTS LWGHT IS NOT NORMALIZED == ! ==--------------------------------------------------------------== IF (ntot > nkpoint) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) 'IN SPPT2 NUMBER OF SPECIAL POINTS = ', ntot - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) 'BUT NKPOINT = ', nkpoint - END IF ntot = -1 END IF IF (iout > 0) THEN ! Write the index table relating k points in the mesh ! with special k points - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(/,A,4X,A)') & - ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' - END IF - IF (iout > 0) THEN + ' KPSYM|', 'CROSS TABLE RELATING MESH POINTS WITH SPECIAL POINTS:' + IF (iout > 0) & WRITE (iout, '(5(4X,"IK -> SK"))') - END IF DO i = 1, imesh iplace = includ(i)/2 - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(1X,I5,1X,I5)', advance="no") i, iplace - END IF - IF ((MOD(i, 5) == 0) .AND. iout > 0) THEN + IF ((MOD(i, 5) == 0) .AND. iout > 0) & WRITE (iout, *) - END IF END DO - IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) THEN + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & WRITE (iout, *) - END IF END IF RETURN ! ==--------------------------------------------------------------== ! == ERROR MESSAGES == ! ==--------------------------------------------------------------== 450 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' - END IF + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' CALL stopgm('SPPT2', 'VECTOR OUTSIDE THE 1BZ') ! ==--------------------------------------------------------------== 470 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, *) 'MESH SIZE EXCEEDS NKPOINT=', nkpoint - END IF CALL stopgm('SPPT2', 'MESH SIZE EXCEEDED') ! ==--------------------------------------------------------------== 490 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') & - ' THE VECTOR ', wva, & - ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & - ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' - END IF + ' THE VECTOR ', wva, & + ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' CALL stopgm('SPPT2', 'VECTOR NOT IN THE LIST') ! ==--------------------------------------------------------------== RETURN @@ -2700,7 +2615,7 @@ CONTAINS igarbg = 0 RETURN ! ==--------------------------------------------------------------== - ELSE IF ((iplace > -2) .AND. (iplace <= 0)) THEN + ELSEIF ((iplace > -2) .AND. (iplace <= 0)) THEN ! The particular HASH function used in this case: rhash = 0.7890_dp*wvk(1) & + 0.6810_dp*wvk(2) & @@ -2724,11 +2639,10 @@ CONTAINS ipoint = list(ihash) END DO ! List too long - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(2A,/,A)') & - ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & - ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' - END IF + ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & + ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' CALL stopgm('MESH', 'WARNING') ! WVK was not found 130 CONTINUE @@ -2740,14 +2654,12 @@ CONTAINS ! IPLACE=0: add WVK to the list list(ihash) = istore IF (istore > nmesh) THEN - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A)') 'SUBROUTINE MESH *** FATAL ERROR ***' - END IF - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,I10,A,/,A,3F10.5)') & - ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & - ' WVK = ', wvk - END IF + ' ISTORE=', istore, ' EXCEEDS DIMENSIONS', & + ' WVK = ', wvk CALL stopgm('MESH', 'WARNING') END IF list(istore) = nil @@ -2779,12 +2691,11 @@ CONTAINS ! == Error - beyond list == ! ==--------------------------------------------------------------== 190 CONTINUE - IF (iout > 0) THEN + IF (iout > 0) & WRITE (iout, '(A,/,A,I5,A,/)') & - ' SUBROUTINE MESH *** WARNING ***', & - ' IPLACE = ', iplace, & - ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' - END IF + ' SUBROUTINE MESH *** WARNING ***', & + ' IPLACE = ', iplace, & + ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' DO i = 1, 3 wvk(i) = 1.0e38_dp END DO diff --git a/src/libint_2c_3c.F b/src/libint_2c_3c.F index 1fa20a7fd6..e7698ae20d 100644 --- a/src/libint_2c_3c.F +++ b/src/libint_2c_3c.F @@ -147,7 +147,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op == do_potential_coulomb) THEN + ELSEIF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -515,7 +515,7 @@ CONTAINS .OR. op == do_potential_mix_cl_trunc) THEN dr_bc = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ac = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op == do_potential_coulomb) THEN + ELSEIF (op == do_potential_coulomb) THEN dr_bc = 1000000.0_dp dr_ac = 1000000.0_dp END IF @@ -885,7 +885,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF @@ -1135,7 +1135,7 @@ CONTAINS potential_parameter%potential_type == do_potential_short .OR. & potential_parameter%potential_type == do_potential_mix_cl_trunc) THEN dr_ab = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (potential_parameter%potential_type == do_potential_coulomb) THEN + ELSEIF (potential_parameter%potential_type == do_potential_coulomb) THEN dr_ab = 1000000.0_dp END IF diff --git a/src/libint_wrapper.F b/src/libint_wrapper.F index 93e9f7b84c..edebee3a87 100644 --- a/src/libint_wrapper.F +++ b/src/libint_wrapper.F @@ -120,10 +120,9 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) THEN + IF (${m_max}$ <= m_max) & libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & - = F(${m_max}$+1) - END IF + = F(${m_max}$+1) #endif #:endfor @@ -216,10 +215,9 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) THEN + IF (${m_max}$ <= m_max) & libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) - END IF + = F(${m_max}$+1) #endif #:endfor @@ -289,10 +287,9 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ <= m_max) THEN + IF (${m_max}$ <= m_max) & libint%prv(1)%f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_${m_max}$ (1) & ! ERROR: __LIBINT_MAX_AM is too large - = F(${m_max}$+1) - END IF + = F(${m_max}$+1) #endif #:endfor diff --git a/src/library_tests.F b/src/library_tests.F index 0c64f82e17..b1f2cbd5b5 100644 --- a/src/library_tests.F +++ b/src/library_tests.F @@ -287,7 +287,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env INTEGER :: iw - INTEGER :: i, j, len, ntim, siz + INTEGER :: i, ierr, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: ca, cb @@ -298,8 +298,10 @@ CONTAINS DO i = 6, 24 len = 2**i IF (8.0_dp*REAL(len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ca(len)) - ALLOCATE (cb(len)) + ALLOCATE (ca(len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (cb(len), STAT=ierr) + IF (ierr /= 0) EXIT CALL RANDOM_NUMBER(ca) ntim = NINT(1.e7_dp/REAL(len, KIND=dp)) @@ -346,7 +348,7 @@ CONTAINS LOGICAL :: test_matmul, test_dgemm INTEGER :: iw - INTEGER :: i, j, len, ntim, siz + INTEGER :: i, ierr, j, len, ntim, siz REAL(KIND=dp) :: perf, t, tend, tstart, xdum REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: ma, mb, mc @@ -358,9 +360,12 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len)) - ALLOCATE (mb(len, len)) - ALLOCATE (mc(len, len)) + ALLOCATE (ma(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mb(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mc(len, len), STAT=ierr) + IF (ierr /= 0) EXIT mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -449,9 +454,12 @@ CONTAINS DO i = 5, siz, 2 len = 2**i + 1 IF (8.0_dp*REAL(len*len, KIND=dp) > max_memory*0.3_dp) EXIT - ALLOCATE (ma(len, len)) - ALLOCATE (mb(len, len)) - ALLOCATE (mc(len, len)) + ALLOCATE (ma(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mb(len, len), STAT=ierr) + IF (ierr /= 0) EXIT + ALLOCATE (mc(len, len), STAT=ierr) + IF (ierr /= 0) EXIT mc = 0.0_dp CALL RANDOM_NUMBER(xdum) @@ -558,8 +566,8 @@ CONTAINS INTEGER, PARAMETER :: ndate(3) = [12, 48, 96] - INTEGER :: iall, it, j, len, n(3), ntim, radix_in, & - radix_out, siz, stat + INTEGER :: iall, ierr, it, j, len, n(3), ntim, & + radix_in, radix_out, siz, stat COMPLEX(KIND=dp), DIMENSION(4, 4, 4) :: zz COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: ca, cb, cc CHARACTER(LEN=7) :: method @@ -597,8 +605,8 @@ CONTAINS len = radix_out n = len IF (16.0_dp*REAL(len*len*len, KIND=dp) > max_memory*0.5_dp) EXIT - ALLOCATE (ra(len, len, len)) - ALLOCATE (ca(len, len, len)) + ALLOCATE (ra(len, len, len), STAT=ierr) + ALLOCATE (ca(len, len, len), STAT=ierr) CALL RANDOM_NUMBER(ra) ca(:, :, :) = ra CALL RANDOM_NUMBER(ra) @@ -644,29 +652,25 @@ CONTAINS CALL fft3d(FWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is changed in out-of-place FFT !" - END IF + " Input array is changed in out-of-place FFT !" ELSE - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " FWFFT ", & - " Input array is not changed in out-of-place FFT !" - END IF + " Input array is not changed in out-of-place FFT !" END IF ca(:, :, :) = cc CALL fft3d(BWFFT, n, ca, cb) tdiff = MAXVAL(ABS(ca - cc)) IF (tdiff > 1.0E-12_dp) THEN - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is changed in out-of-place FFT !" - END IF + " Input array is changed in out-of-place FFT !" ELSE - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & WRITE (iw, '(T2,A,A,A)') ADJUSTR(method), " BWFFT ", & - " Input array is not changed in out-of-place FFT !" - END IF + " Input array is not changed in out-of-place FFT !" END IF IF (para_env%is_source()) WRITE (iw, *) diff --git a/src/linesearch.F b/src/linesearch.F index 8948e11682..3d9977d78f 100644 --- a/src/linesearch.F +++ b/src/linesearch.F @@ -610,9 +610,8 @@ CONTAINS is_done = .FALSE. - IF (this%gave_up) THEN + IF (this%gave_up) & CPABORT("had to give up, should not be called again") - END IF IF (.NOT. this%have_left) THEN this%left_x = 0.0_dp @@ -686,9 +685,8 @@ CONTAINS IF (this%have_left .AND. this%have_middle .AND. this%have_right) THEN a = this%middle_x - this%left_x b = this%right_x - this%middle_x - IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) THEN + IF (ABS(MIN(a, b)*phi - MAX(a, b)) > 1.0E-10) & CPABORT("golden-ratio gone") - END IF IF (a < b) THEN step_size = this%middle_x + a/phi diff --git a/src/local_gemm_api.F b/src/local_gemm_api.F index e45895578f..7812c45cc1 100644 --- a/src/local_gemm_api.F +++ b/src/local_gemm_api.F @@ -8,7 +8,6 @@ MODULE local_gemm_api USE ISO_C_BINDING, ONLY: C_NULL_PTR, & C_PTR - USE kinds, ONLY: dp #if defined(__SPLA) && defined(__OFFLOAD_GEMM) USE input_constants, ONLY: do_dgemm_spla USE ISO_C_BINDING, ONLY: C_ASSOCIATED, & @@ -84,25 +83,25 @@ CONTAINS INTEGER, INTENT(in) :: m INTEGER, INTENT(in) :: n INTEGER, INTENT(in) :: k - REAL(KIND=dp), INTENT(in) :: alpha + REAL(8), INTENT(in) :: alpha #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: A + REAL(8), DIMENSION(*), INTENT(in), TARGET :: A #else - REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: A + REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: A #endif INTEGER, INTENT(in) :: lda #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(KIND=dp), DIMENSION(*), INTENT(in), TARGET :: B + REAL(8), DIMENSION(*), INTENT(in), TARGET :: B #else - REAL(KIND=dp), DIMENSION(:, :), INTENT(in), TARGET :: B + REAL(8), DIMENSION(:, :), INTENT(in), TARGET :: B #endif INTEGER, INTENT(in) :: ldb - REAL(KIND=dp), INTENT(in) :: beta + REAL(8), INTENT(in) :: beta #if defined(__SPLA) && defined(__OFFLOAD_GEMM) - REAL(KIND=dp), DIMENSION(*), INTENT(inout), TARGET ::C + REAL(8), DIMENSION(*), INTENT(inout), TARGET ::C #else - REAL(KIND=dp), DIMENSION(:, :), INTENT(inout), TARGET :: C + REAL(8), DIMENSION(:, :), INTENT(inout), TARGET :: C #endif INTEGER, INTENT(in) :: ldc CLASS(local_gemm_ctxt_type), INTENT(inout) :: ctx diff --git a/src/localization_tb.F b/src/localization_tb.F index 866e1d491f..417e0fa0f7 100644 --- a/src/localization_tb.F +++ b/src/localization_tb.F @@ -147,7 +147,7 @@ CONTAINS IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSE IF (dft_control%restricted) THEN + ELSEIF (dft_control%restricted) THEN IF (iounit > 0) WRITE (iounit, *) & " Unclear how we define MOs / localization in the restricted case ... skipping" ELSE diff --git a/src/localized_moments.F b/src/localized_moments.F index 6a82b95e68..7f6782fb0e 100644 --- a/src/localized_moments.F +++ b/src/localized_moments.F @@ -737,10 +737,9 @@ CONTAINS DO idir = 1, 3 CALL dbcsr_get_readonly_block_p(moments_der(i, idir)%matrix, & iatom, jatom, oblock, found) - IF (found) THEN + IF (found) & qupole_der((i - 1)*3 + idir) = & - qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) - END IF + qupole_der((i - 1)*3 + idir) - factor*SUM(pblock*oblock) END DO END DO END IF diff --git a/src/lri_optimize_ri_basis_types.F b/src/lri_optimize_ri_basis_types.F index 4a79d3914a..41bf462a06 100644 --- a/src/lri_optimize_ri_basis_types.F +++ b/src/lri_optimize_ri_basis_types.F @@ -227,7 +227,8 @@ CONTAINS END DO DO ishell = 1, gto_basis_set%nshell(iset) - gcc(:, ishell, iset) = gcc(:, ishell, iset)/NORM2(gcc(:, ishell, iset)) + gcc(:, ishell, iset) = gcc(:, ishell, iset)/ & + SQRT(DOT_PRODUCT(gcc(:, ishell, iset), gcc(:, ishell, iset))) END DO END DO diff --git a/src/manybody_eam.F b/src/manybody_eam.F index 38cc5ba35b..0819359be8 100644 --- a/src/manybody_eam.F +++ b/src/manybody_eam.F @@ -186,7 +186,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) @@ -196,7 +196,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -233,7 +233,7 @@ CONTAINS index = INT(rab/eam_a%drar) + 1 IF (index > eam_a%npoints) THEN index = eam_a%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_a%rval(index) @@ -247,7 +247,7 @@ CONTAINS index = INT(rab/eam_b%drar) + 1 IF (index > eam_b%npoints) THEN index = eam_b%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = rab - eam_b%rval(index) diff --git a/src/manybody_gal.F b/src/manybody_gal.F index cb57bcddd6..8c72d24322 100644 --- a/src/manybody_gal.F +++ b/src/manybody_gal.F @@ -81,8 +81,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair - !Vector in pbc from j to i - rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) + rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) !Vector in pbc from j to i IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only ALLOCATE (gal%n_vectors(3, SIZE(particle_set))) @@ -99,8 +98,7 @@ CONTAINS Vang = 0.0_dp IF (gcn_weight2 /= 0.0) THEN - ! Calculation of the normal vector centered on the Me atom of the pair, only the first time - ! that an interaction with the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -108,14 +106,13 @@ CONTAINS particle_set, cell) END IF - !Else, retrive it, should not have moved sinc metal is supposed to be frozen - nvec(:) = gal%n_vectors(:, jparticle) + nvec(:) = gal%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-NORM2(rji)/gal%r1) + weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = angular(gal, r_last_update_pbc, iparticle, cell, particle_set, nvec, & @@ -226,13 +223,12 @@ CONTAINS IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) drjk2 = DOT_PRODUCT(rjk, rjk) - !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair - IF (drjk2 > gal%rcutsq) CYCLE + IF (drjk2 > gal%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair normale(:) = normale(:) - rjk(:) !Build the normal, vector by vector END DO ! Normalisation of the vector - normale(:) = normale(:)/NORM2(normale) + normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) END FUNCTION normale @@ -268,11 +264,9 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal%rcutsq) CYCLE - !Build the sum of the exponential weights - IF (element_symbol_k == gal%met1) somme = somme + EXP(-NORM2(rki)/gal%r1) - IF (element_symbol_k == gal%met2) somme = somme + EXP(-NORM2(rki)/gal%r2) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (element_symbol_k == gal%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r1) !Build the sum of the exponential weights + IF (element_symbol_k == gal%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal%r2) !Build the sum of the exponential weights END DO END FUNCTION somme @@ -323,11 +317,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -341,7 +335,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -396,7 +390,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal%n_vectors)) THEN !First calling of the forcefield only @@ -413,8 +407,7 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% IF (gcn_weight2 /= 0.0) THEN - ! Calculation of the normal vector centered on the Me atom of the pair, only the first time - ! that an interaction with the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & gal%n_vectors(2, jparticle) == 0.0_dp .AND. & gal%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -531,7 +524,7 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-NORM2(rji)/gal%r1) + weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system @@ -539,13 +532,11 @@ CONTAINS element_symbol=element_symbol_k) IF (element_symbol_k /= gal%met1 .AND. element_symbol_k /= gal%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal%rcutsq) CYCLE - drki = NORM2(rki) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + drki = SQRT(DOT_PRODUCT(rki, rki)) rki_hat(:) = rki(:)/drki - !Build the sum of derivativs - IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) + IF (element_symbol_k == gal%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r1)*EXP(-drki/gal%r1)*rki_hat(:) !Build the sum of derivativs IF (element_symbol_k == gal%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal%r2)*EXP(-drki/gal%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -596,11 +587,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -612,15 +603,14 @@ CONTAINS END IF rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector - ! Theta is the angle between the normal to the surface and the dipole - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) + rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -628,7 +618,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*gal%a1*SIN(theta) - gal%a2*2.0_dp*SIN(2.0_dp*theta) - & gal%a3*3.0_dp*SIN(3.0_dp*theta) - gal%a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term diff --git a/src/manybody_gal21.F b/src/manybody_gal21.F index 7604fe379c..c31ac17f5c 100644 --- a/src/manybody_gal21.F +++ b/src/manybody_gal21.F @@ -105,8 +105,7 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Vang = 0.0_dp - ! Calculation of the normal vector centered on the Me atom of the pair, - ! only the first time that an interaction with the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -114,14 +113,13 @@ CONTAINS particle_set, cell) END IF - ! Else, retrive it, should not have moved sinc metal is supposed to be frozen - nvec(:) = gal21%n_vectors(:, jparticle) + nvec(:) = gal21%n_vectors(:, jparticle) !Else, retrive it, should not have moved sinc metal is supposed to be frozen !Calculation of the sum of the expontial weights of each Me surrounding the principal one sum_weight = somme(gal21, r_last_update_pbc, iparticle, particle_set, cell) !Exponential damping weight for angular dependance - weight = EXP(-NORM2(rji)/gal21%r1) + weight = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) !Calculation of the truncated fourier series of the water-dipole/surface-normal angle anglepart = 0.0_dp @@ -231,18 +229,15 @@ CONTAINS IF (kparticle == jparticle) CYCLE !Avoid the principal Me atom (j) in the counting CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - !Keep only metals - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals rjk(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(kparticle)%r(:), cell) - drjk = NORM2(rjk) - !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair - IF (drjk > gal21%rcutsq) CYCLE - !Build the normal, vector by vector - normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) + drjk = SQRT(DOT_PRODUCT(rjk, rjk)) + IF (drjk > gal21%rcutsq) CYCLE !Keep only those within square root of the force-field cutoff distance of the metallic atom of the evaluated pair + normale(:) = normale(:) - rjk(:)/(drjk*drjk*drjk*drjk*drjk) !Build the normal, vector by vector END DO ! Normalisation of the vector - normale(:) = normale(:)/NORM2(normale) + normale(:) = normale(:)/SQRT(DOT_PRODUCT(normale, normale)) END FUNCTION normale @@ -274,14 +269,11 @@ CONTAINS DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - !Keep only metals - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal21%rcutsq) CYCLE - !Build the sum of the exponential weights - IF (element_symbol_k == gal21%met1) somme = somme + EXP(-NORM2(rki)/gal21%r1) - IF (element_symbol_k == gal21%met2) somme = somme + EXP(-NORM2(rki)/gal21%r2) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + IF (element_symbol_k == gal21%met1) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r1) !Build the sum of the exponential weights + IF (element_symbol_k == gal21%met2) somme = somme + EXP(-SQRT(DOT_PRODUCT(rki, rki))/gal21%r2) !Build the sum of the exponential weights END DO END FUNCTION somme @@ -333,11 +325,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -356,7 +348,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -367,7 +359,8 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) - VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*NORM2(rjh1)) + EXP(-BH*NORM2(rjh2))) + VH = (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)*(EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & + EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) ! For fit purpose IF (gal21%express .AND. energy) THEN @@ -377,8 +370,9 @@ CONTAINS IF (index_outfile > 0) WRITE (index_outfile, *) "Fourier", costheta, COS(2.0_dp*theta), COS(3.0_dp*theta), & COS(4.0_dp*theta) !, theta - IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*NORM2(rjh1)) + & - EXP(-BH*NORM2(rjh2)) + IF (index_outfile > 0) WRITE (index_outfile, *) "H_rep", EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1))) + & + EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2))) + !IF (index_outfile > 0) WRITE (index_outfile, *) "H_r6", -1/DOT_PRODUCT(rjh1,rjh1)**3 -1/DOT_PRODUCT(rjh2,rjh2)**3 CALL cp_print_key_finished_output(index_outfile, logger, mm_section, & "PRINT%PROGRAM_RUN_INFO") @@ -421,7 +415,7 @@ CONTAINS IF (element_symbol == "O") THEN !To avoid counting two times each pair rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji ! hat = pure directional component of a given vector IF (.NOT. ALLOCATED(gal21%n_vectors)) THEN !First calling of the forcefield only @@ -436,8 +430,7 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with - ! the metal atom of the pair is evaluated + !Calculation of the normal vector centered on the Me atom of the pair, only the first time that an interaction with the metal atom of the pair is evaluated IF (gal21%n_vectors(1, jparticle) == 0.0_dp .AND. & gal21%n_vectors(2, jparticle) == 0.0_dp .AND. & gal21%n_vectors(3, jparticle) == 0.0_dp) THEN @@ -573,22 +566,19 @@ CONTAINS rki_hat(3), weight_rji rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - weight_rji = EXP(-NORM2(rji)/gal21%r1) + weight_rji = EXP(-SQRT(DOT_PRODUCT(rji, rji))/gal21%r1) natom = SIZE(particle_set) DO kparticle = 1, natom !Loop on every atom of the system CALL get_atomic_kind(atomic_kind=particle_set(kparticle)%atomic_kind, & element_symbol=element_symbol_k) - !Keep only metals - IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE + IF (element_symbol_k /= gal21%met1 .AND. element_symbol_k /= gal21%met2) CYCLE !Keep only metals rki(:) = pbc(r_last_update_pbc(kparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) - IF (NORM2(rki) > gal21%rcutsq) CYCLE - drki = NORM2(rki) + IF (SQRT(DOT_PRODUCT(rki, rki)) > gal21%rcutsq) CYCLE !Keep only those within cutoff distance of the oxygen atom of the evaluated pair (the omega ensemble) + drki = SQRT(DOT_PRODUCT(rki, rki)) rki_hat(:) = rki(:)/drki - !Build the sum of derivativs - IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) + IF (element_symbol_k == gal21%met1) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r1)*EXP(-drki/gal21%r1)*rki_hat(:) !Build the sum of derivativs IF (element_symbol_k == gal21%met2) dwdr(:) = (-1.0_dp)*(1.0_dp/gal21%r2)*EXP(-drki/gal21%r2)*rki_hat(:) f_nonbond(1:3, iparticle) = f_nonbond(1:3, iparticle) + dwdr(1:3)*weight_rji & @@ -651,11 +641,11 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE !Kepp only hydrogen rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - IF (NORM2(rih) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O + IF (SQRT(DOT_PRODUCT(rih, rih)) >= h_max_dist) CYCLE !Keep only hydrogen that are bounded to the considered O count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -672,14 +662,14 @@ CONTAINS a4 = gal21%a41 + gal21%a42*gal21%gcn(jparticle) + gal21%a43*gal21%gcn(jparticle)*gal21%gcn(jparticle) rji(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(iparticle)%r(:), cell) - rji_hat(:) = rji(:)/NORM2(rji) ! hat = pure directional component of a given vector + rji_hat(:) = rji(:)/SQRT(DOT_PRODUCT(rji, rji)) ! hat = pure directional component of a given vector !dipole vector rix of the H2O molecule rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) ! build the dipole vector rix of the H2O molecule - rix_hat(:) = rix(:)/NORM2(rix) ! hat = pure directional component of a given vector - costheta = DOT_PRODUCT(rix, nvec)/NORM2(rix) ! Theta is the angle between the normal to the surface and the dipole + rix_hat(:) = rix(:)/SQRT(DOT_PRODUCT(rix, rix)) ! hat = pure directional component of a given vector + costheta = DOT_PRODUCT(rix, nvec)/SQRT(DOT_PRODUCT(rix, rix)) ! Theta is the angle between the normal to the surface and the dipole IF (costheta < -1.0_dp) costheta = -1.0_dp IF (costheta > +1.0_dp) costheta = +1.0_dp theta = ACOS(costheta) ! Theta is the angle between the normal to the surface and the dipole @@ -687,7 +677,7 @@ CONTAINS ! Calculation of partial derivativ of the angular components dsumdtheta = -1.0_dp*a1*SIN(theta) - a2*2.0_dp*SIN(2.0_dp*theta) - & a3*3.0_dp*SIN(3.0_dp*theta) - a4*4.0_dp*SIN(4.0_dp*theta) - dcostheta(:) = (1.0_dp/NORM2(rix))*(nvec(:) - costheta*rix_hat(:)) + dcostheta(:) = (1.0_dp/SQRT(DOT_PRODUCT(rix, rix)))*(nvec(:) - costheta*rix_hat(:)) dangular(:) = prefactor*dsumdtheta*(-1.0_dp/SIN(theta))*dcostheta(:) !Force due to the third component of the derivativ of the angular term @@ -705,35 +695,35 @@ CONTAINS rjh1(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) f_nonbond(1:3, index_h1) = f_nonbond(1:3, index_h1) + (gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))*rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))*rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh1(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))) & - *rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & + *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh1(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))) & - *rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & + *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh1(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh1))) & - *rjh1(:)/NORM2(rjh1) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh1, rjh1)))) & + *rjh1(:)/SQRT(DOT_PRODUCT(rjh1, rjh1)) END IF rjh2(:) = pbc(r_last_update_pbc(jparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) f_nonbond(1:3, index_h2) = f_nonbond(1:3, index_h2) + ((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) IF (use_virial) THEN pv_nonbond(1, 1:3) = pv_nonbond(1, 1:3) + rjh2(1)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) pv_nonbond(2, 1:3) = pv_nonbond(2, 1:3) + rjh2(2)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) pv_nonbond(3, 1:3) = pv_nonbond(3, 1:3) + rjh2(3)*((gal21%AH2*gal21%gcn(jparticle) + gal21%AH1)* & - BH*EXP(-BH*NORM2(rjh2))) & - *rjh2(:)/NORM2(rjh2) + BH*EXP(-BH*SQRT(DOT_PRODUCT(rjh2, rjh2)))) & + *rjh2(:)/SQRT(DOT_PRODUCT(rjh2, rjh2)) END IF END SUBROUTINE angular_d diff --git a/src/manybody_e3nn.F b/src/manybody_nequip.F similarity index 94% rename from src/manybody_e3nn.F rename to src/manybody_nequip.F index 58e5dc64c6..adff300a10 100644 --- a/src/manybody_e3nn.F +++ b/src/manybody_nequip.F @@ -6,16 +6,13 @@ !--------------------------------------------------------------------------------------------------! ! ************************************************************************************************** -!> \brief Shared TorchScript evaluation path for e3nn-based equivariant message-passing -!> potentials (NequIP, Allegro and MACE). !> \par History !> Implementation of NequIP and Allegro potentials - [gtocci] 2022 !> Index mapping of atoms from .xyz to Allegro config.yaml file - [mbilichenko] 2024 !> Refactoring and update to NequIP version >= v0.7.0 - [gtocci] 2026 -!> Renamed manybody_nequip -> manybody_e3nn as it now also serves MACE - [xysun] 2026 !> \author Gabriele Tocci ! ************************************************************************************************** -MODULE manybody_e3nn +MODULE manybody_nequip USE atomic_kind_types, ONLY: atomic_kind_type USE cell_types, ONLY: cell_type @@ -31,8 +28,7 @@ MODULE manybody_e3nn dp,& int_8 USE message_passing, ONLY: mp_para_env_type - USE pair_potential_types, ONLY: mace_type,& - nequip_pot_type,& + USE pair_potential_types, ONLY: nequip_pot_type,& nequip_type,& pair_potential_pp_type,& pair_potential_single_type @@ -47,10 +43,10 @@ MODULE manybody_e3nn IMPLICIT NONE PRIVATE - PUBLIC :: e3nn_energy_store_force_virial, & - e3nn_add_force_virial + PUBLIC :: nequip_energy_store_force_virial, & + nequip_add_force_virial - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_e3nn' + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'manybody_nequip' TYPE, PRIVATE :: nequip_work_type INTEGER :: target_pot_type @@ -93,10 +89,10 @@ CONTAINS !> Refactoring and unifying NequIP and Allegro - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_total, fist_nonbond_env, para_env, use_virial, & - target_pot_type) + SUBROUTINE nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_total, fist_nonbond_env, para_env, use_virial, & + target_pot_type) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(particle_type), POINTER :: particle_set(:) @@ -111,7 +107,7 @@ CONTAINS LOGICAL, INTENT(IN) :: use_virial INTEGER, INTENT(IN) :: target_pot_type - CHARACTER(LEN=*), PARAMETER :: routineN = 'e3nn_energy_store_force_virial' + CHARACTER(LEN=*), PARAMETER :: routineN = 'nequip_energy_store_force_virial' INTEGER :: handle TYPE(nequip_data_type), POINTER :: neq_data @@ -136,8 +132,7 @@ CONTAINS CALL setup_neq_data(fist_nonbond_env, neq_data, neq_pot, nequip_work) - IF (nequip_work%target_pot_type == nequip_type .OR. & - nequip_work%target_pot_type == mace_type) THEN + IF (nequip_work%target_pot_type == nequip_type) THEN CALL prepare_edges_shifts_nequip(nequip_work) ELSE CALL prepare_edges_shifts_allegro(nequip_work) @@ -151,7 +146,7 @@ CONTAINS CALL release_nequip_work(nequip_work) CALL timestop(handle) - END SUBROUTINE e3nn_energy_store_force_virial + END SUBROUTINE nequip_energy_store_force_virial ! ************************************************************************************************** !> \brief ... @@ -473,9 +468,8 @@ CONTAINS END IF IF (ASSOCIATED(neq_data%force)) THEN - IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) THEN + IF (SIZE(neq_data%force, 2) /= nequip_work%n_atoms_use) & DEALLOCATE (neq_data%force, neq_data%use_indices) - END IF END IF IF (.NOT. ASSOCIATED(neq_data%force)) THEN @@ -569,8 +563,7 @@ CONTAINS n_atoms = SIZE(nequip_work%particle_set) ! for allegro ensure ghost atoms are included in the evaluation - IF (nequip_work%target_pot_type /= nequip_type .AND. & - nequip_work%target_pot_type /= mace_type) THEN + IF (nequip_work%target_pot_type /= nequip_type) THEN ! label atoms in the local edges DO i = 1, SIZE(nequip_work%local_edges, 2) atom_a = INT(nequip_work%local_edges(1, i)) @@ -714,8 +707,7 @@ CONTAINS DO iat_use = 1, SIZE(neq_data%use_indices) iat = neq_data%use_indices(iat_use) ! Only apply the local mask for Allegro models - IF (nequip_work%target_pot_type /= nequip_type .AND. & - nequip_work%target_pot_type /= mace_type) THEN + IF (nequip_work%target_pot_type /= nequip_type) THEN IF (.NOT. nequip_work%sum_energy(iat)) CYCLE END IF @@ -724,8 +716,7 @@ CONTAINS CALL torch_tensor_release(t_energy) pot_total = pot_total*pot%unit_energy_val - IF (nequip_work%target_pot_type == nequip_type .OR. & - nequip_work%target_pot_type == mace_type) THEN + IF (nequip_work%target_pot_type == nequip_type) THEN neq_data%force = neq_data%force/REAL(nequip_work%para_env%num_pe, dp) pot_total = pot_total/REAL(nequip_work%para_env%num_pe, dp) END IF @@ -736,8 +727,7 @@ CONTAINS neq_data%virial(:, :) = RESHAPE(v_ptr, [3, 3])*pot%unit_energy_val CALL torch_tensor_release(t_virial) - IF (nequip_work%target_pot_type == nequip_type .OR. & - nequip_work%target_pot_type == mace_type) THEN + IF (nequip_work%target_pot_type == nequip_type) THEN neq_data%virial = neq_data%virial/REAL(nequip_work%para_env%num_pe, dp) END IF END IF @@ -754,7 +744,7 @@ CONTAINS !> Sum forces, virial to nonbond - [gtocci] 2026 !> \author Gabriele Tocci - University of Zurich ! ************************************************************************************************** - SUBROUTINE e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + SUBROUTINE nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: f_nonbond, pv_nonbond LOGICAL, INTENT(IN) :: use_virial @@ -773,6 +763,6 @@ CONTAINS f_nonbond(1:3, iat) = f_nonbond(1:3, iat) + neq_data%force(1:3, iat_use) END DO - END SUBROUTINE e3nn_add_force_virial + END SUBROUTINE nequip_add_force_virial -END MODULE manybody_e3nn +END MODULE manybody_nequip diff --git a/src/manybody_potential.F b/src/manybody_potential.F index a3a706a7f1..16b5faec93 100644 --- a/src/manybody_potential.F +++ b/src/manybody_potential.F @@ -30,8 +30,6 @@ MODULE manybody_potential ace_energy_store_force_virial USE manybody_deepmd, ONLY: deepmd_add_force_virial,& deepmd_energy_store_force_virial - USE manybody_e3nn, ONLY: e3nn_add_force_virial,& - e3nn_energy_store_force_virial USE manybody_eam, ONLY: get_force_eam USE manybody_gal, ONLY: destroy_gal_arrays,& gal_energy,& @@ -41,6 +39,8 @@ MODULE manybody_potential gal21_energy,& gal21_forces,& setup_gal21_arrays + USE manybody_nequip, ONLY: nequip_add_force_virial,& + nequip_energy_store_force_virial USE manybody_siepmann, ONLY: destroy_siepmann_arrays,& print_nr_ions_siepmann,& setup_siepmann_arrays,& @@ -54,9 +54,8 @@ MODULE manybody_potential USE message_passing, ONLY: mp_para_env_type USE pair_potential_types, ONLY: & ace_type, allegro_type, deepmd_type, ea_type, eam_pot_type, gal21_pot_type, gal21_type, & - gal_pot_type, gal_type, mace_type, nequip_type, pair_potential_pp_type, & - pair_potential_single_type, siepmann_pot_type, siepmann_type, tersoff_pot_type, & - tersoff_type + gal_pot_type, gal_type, nequip_type, pair_potential_pp_type, pair_potential_single_type, & + siepmann_pot_type, siepmann_type, tersoff_pot_type, tersoff_type USE particle_types, ONLY: particle_type USE util, ONLY: sort #include "./base/base_uses.f90" @@ -106,11 +105,11 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_mace, & - any_nequip, any_siepmann, any_tersoff + any_gal, any_gal21, any_nequip, & + any_siepmann, any_tersoff REAL(KIND=dp) :: drij, embed, pot_ace, pot_allegro, & - pot_deepmd, pot_loc, pot_mace, & - pot_nequip, qr, rab2_max, rij(3) + pot_deepmd, pot_loc, pot_nequip, qr, & + rab2_max, rij(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v REAL(KIND=dp), POINTER :: fembed(:) @@ -133,7 +132,6 @@ CONTAINS any_gal21 = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. - any_mace = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. CALL timeset(routineN, handle) @@ -179,7 +177,6 @@ CONTAINS pot => potparm%pot(ikind, jkind)%pot any_tersoff = any_tersoff .OR. ANY(pot%type == tersoff_type) any_nequip = any_nequip .OR. ANY(pot%type == nequip_type) - any_mace = any_mace .OR. ANY(pot%type == mace_type) any_ace = any_ace .OR. ANY(pot%type == ace_type) any_allegro = any_allegro .OR. ANY(pot%type == allegro_type) any_deepmd = any_deepmd .OR. ANY(pot%type == deepmd_type) @@ -192,30 +189,21 @@ CONTAINS ! NEQUIP IF (any_nequip) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_nequip, fist_nonbond_env, & - para_env, use_virial, nequip_type) + CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_nequip, fist_nonbond_env, & + para_env, use_virial, nequip_type) pot_manybody = pot_manybody + pot_nequip END IF ! ALLEGRO IF (any_allegro) THEN NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_allegro, fist_nonbond_env, & - para_env, use_virial, allegro_type) + CALL nequip_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & + atomic_kind_set, potparm, r_last_update_pbc, & + pot_allegro, fist_nonbond_env, & + para_env, use_virial, allegro_type) pot_manybody = pot_manybody + pot_allegro END IF - ! MACE (reuses the NequIP message-passing evaluation path) - IF (any_mace) THEN - NULLIFY (glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL e3nn_energy_store_force_virial(nonbonded, particle_set, local_particles, cell, & - atomic_kind_set, potparm, r_last_update_pbc, & - pot_mace, fist_nonbond_env, & - para_env, use_virial, mace_type) - pot_manybody = pot_manybody + pot_mace - END IF ! ACE IF (any_ace) THEN CALL ace_energy_store_force_virial(particle_set, cell, atomic_kind_set, potparm, & @@ -590,8 +578,8 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a, work_list INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list, list, sort_list LOGICAL :: any_ace, any_allegro, any_deepmd, & - any_gal, any_gal21, any_mace, & - any_nequip, any_siepmann, any_tersoff + any_gal, any_gal21, any_nequip, & + any_siepmann, any_tersoff REAL(KIND=dp) :: f_eam, fac, fr(3), ptens11, ptens12, ptens13, ptens21, ptens22, ptens23, & ptens31, ptens32, ptens33, rab(3), rab2, rab2_max, rtmp(3) REAL(KIND=dp), DIMENSION(3) :: cell_v, cvi @@ -611,7 +599,6 @@ CONTAINS any_tersoff = .FALSE. any_allegro = .FALSE. any_nequip = .FALSE. - any_mace = .FALSE. any_siepmann = .FALSE. any_ace = .FALSE. any_deepmd = .FALSE. @@ -652,9 +639,8 @@ CONTAINS END DO END DO ! ACE - IF (any_ace) THEN + IF (any_ace) & CALL ace_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) - END IF DO ikind = 1, nkinds DO jkind = ikind, nkinds @@ -662,9 +648,8 @@ CONTAINS END DO END DO ! DEEPMD - IF (any_deepmd) THEN + IF (any_deepmd) & CALL deepmd_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) - END IF ! NEQUIP DO ikind = 1, nkinds @@ -673,7 +658,7 @@ CONTAINS END DO END DO IF (any_nequip) THEN - CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! ALLEGRO @@ -683,17 +668,7 @@ CONTAINS END DO END DO IF (any_allegro) THEN - CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) - END IF - - ! MACE (reuses the NequIP force/virial accumulation) - DO ikind = 1, nkinds - DO jkind = ikind, nkinds - any_mace = any_mace .OR. ANY(potparm%pot(ikind, jkind)%pot%type == mace_type) - END DO - END DO - IF (any_mace) THEN - CALL e3nn_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) + CALL nequip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, use_virial) END IF ! starting the force loop diff --git a/src/manybody_siepmann.F b/src/manybody_siepmann.F index 09e29c1ef7..42c619b843 100644 --- a/src/manybody_siepmann.F +++ b/src/manybody_siepmann.F @@ -185,7 +185,7 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) IF (kparticle == jparticle) CYCLE @@ -243,7 +243,7 @@ CONTAINS F = siepmann%F rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji nparticle = SIZE(r_last_update_pbc) @@ -339,19 +339,19 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) DO iatom = 1, natom CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = NORM2(rih) + drih = SQRT(DOT_PRODUCT(rih, rih)) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO @@ -363,21 +363,21 @@ CONTAINS ELSE CPABORT("No H atoms for O found") END IF - ELSE IF (count_h == 1) THEN + ELSEIF (count_h == 1) THEN IF (siepmann%allow_oh_formation) THEN IF (PRESENT(nr_oh)) nr_oh = nr_oh + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Only one H atom of O atom found") END IF - ELSE IF (count_h == 3) THEN + ELSEIF (count_h == 3) THEN IF (siepmann%allow_h3o_formation) THEN IF (PRESENT(nr_h3o)) nr_h3o = nr_h3o + 1 siep_Phi_ij = 0.0_dp ELSE CPABORT("Three H atoms for O atom found") END IF - ELSE IF (count_h > 3) THEN + ELSEIF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -386,7 +386,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = NORM2(rix) + drix = SQRT(DOT_PRODUCT(rix, rix)) cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp IF (cosphi > +1.0_dp) cosphi = +1.0_dp @@ -441,7 +441,7 @@ CONTAINS cell_v, cell, rcutsq, & particle_set) rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji DO iatom = 1, natom @@ -449,23 +449,23 @@ CONTAINS element_symbol=element_symbol) IF (element_symbol /= "H") CYCLE rih(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(iatom)%r(:), cell) - drih = NORM2(rih) + drih = SQRT(DOT_PRODUCT(rih, rih)) IF (drih >= h_max_dist) CYCLE count_h = count_h + 1 IF (count_h == 1) THEN index_h1 = iatom - ELSE IF (count_h == 2) THEN + ELSEIF (count_h == 2) THEN index_h2 = iatom END IF END DO IF (count_h == 0 .AND. .NOT. siepmann%allow_o_formation) THEN CPABORT("No H atoms for O found") - ELSE IF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN + ELSEIF (count_h == 1 .AND. .NOT. siepmann%allow_oh_formation) THEN CPABORT("Only one H atom for O atom found") - ELSE IF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN + ELSEIF (count_h == 3 .AND. .NOT. siepmann%allow_h3o_formation) THEN CPABORT("Three H atoms for O atom found") - ELSE IF (count_h > 3) THEN + ELSEIF (count_h > 3) THEN CPABORT("Error in Siepmann-Sprik part: too many H atoms for O") END IF @@ -474,7 +474,7 @@ CONTAINS rih1(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h1)%r(:), cell) rih2(:) = pbc(r_last_update_pbc(iparticle)%r(:), r_last_update_pbc(index_h2)%r(:), cell) rix(:) = rih1(:) + rih2(:) - drix = NORM2(rix) + drix = SQRT(DOT_PRODUCT(rix, rix)) rix_hat(:) = rix(:)/drix cosphi = DOT_PRODUCT(rji, rix)/(drji*drix) IF (cosphi < -1.0_dp) cosphi = -1.0_dp @@ -561,7 +561,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) rji_hat(:) = rji(:)/drji fac = -1.0_dp !gradient to force @@ -646,7 +646,7 @@ CONTAINS IF (element_symbol /= "O") RETURN rji(:) = -1.0_dp*(r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v) - drji = NORM2(rji) + drji = SQRT(DOT_PRODUCT(rji, rji)) fac = -1.0_dp Phi_ij = siep_Phi_ij(siepmann, r_last_update_pbc, iparticle, jparticle, & diff --git a/src/manybody_tersoff.F b/src/manybody_tersoff.F index 719e662a37..9f86baecab 100644 --- a/src/manybody_tersoff.F +++ b/src/manybody_tersoff.F @@ -346,7 +346,7 @@ CONTAINS lambda3 = tersoff%lambda3 rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = NORM2(rij) + drij = SQRT(DOT_PRODUCT(rij, rij)) ter_zeta_ij = 0.0_dp DO ilist = 1, n_loc_size kparticle = full_loc_list(2, ilist) @@ -413,7 +413,7 @@ CONTAINS rab2_max = rcutsq rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = NORM2(rij) + drij = SQRT(DOT_PRODUCT(rij, rij)) rij_hat(:) = rij(:)/drij nparticle = SIZE(r_last_update_pbc) @@ -576,7 +576,7 @@ CONTAINS CALL timeset(routineN, handle) rij(:) = r_last_update_pbc(jparticle)%r(:) - r_last_update_pbc(iparticle)%r(:) + cell_v - drij = NORM2(rij) + drij = SQRT(DOT_PRODUCT(rij, rij)) rij_hat(:) = rij(:)/drij fac = -0.5_dp diff --git a/src/mao_basis.F b/src/mao_basis.F index 6234629519..ed28ab101b 100644 --- a/src/mao_basis.F +++ b/src/mao_basis.F @@ -261,9 +261,8 @@ CONTAINS ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) THEN + IF (col_blk_sizes(iab) < 0) & CPABORT("Minimum number of MAOs has to be specified in KIND section for all elements") - END IF END DO DO ispin = 1, nspin ! coefficients diff --git a/src/mao_io.F b/src/mao_io.F index 1b300ea47e..53728ce974 100644 --- a/src/mao_io.F +++ b/src/mao_io.F @@ -122,10 +122,8 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) THEN - ! catch corner-case + IF (SIZE(local_block) > 0) & ! catch corner-case mpi_buffer(:, :) = local_block(:, :) - END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/mao_wfn_analysis.F b/src/mao_wfn_analysis.F index d0d7132444..ba7f41bdc2 100644 --- a/src/mao_wfn_analysis.F +++ b/src/mao_wfn_analysis.F @@ -243,9 +243,8 @@ CONTAINS CALL get_particle_set(particle_set, qs_kind_set, nmao=col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) THEN + IF (col_blk_sizes(iab) < 0) & CPABORT("Number of MAOs has to be specified in KIND section for all elements") - END IF END DO DO ispin = 1, nspin ! coeficients diff --git a/src/metadyn_tools/graph.F b/src/metadyn_tools/graph.F index 62eb7713ea..92444bd6da 100644 --- a/src/metadyn_tools/graph.F +++ b/src/metadyn_tools/graph.F @@ -200,9 +200,8 @@ PROGRAM graph END IF END DO - IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) THEN + IF (COUNT([l_orac, l_cp2k, l_cpmd]) /= 1) & CPABORT("Error! You've to specify either ORAC, CP2K or CPMD!") - END IF ! For CPMD move filename to colvar_mtd IF (l_cpmd) THEN @@ -359,10 +358,9 @@ PROGRAM graph END IF END DO - IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) THEN + IF (ANY(mep_input_data%minima == HUGE(0.0_dp))) & CALL cp_abort(__LOCATION__, & "-find-path requires the specification of -point-a and -point-b !") - END IF ELSE ALLOCATE (mep_input_data%minima(0, 0)) END IF @@ -649,7 +647,7 @@ PROGRAM graph IF (.NOT. lstride .AND. MOD(it, nwr) == 0) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" - ELSE IF (.NOT. lstride .AND. it == nt) THEN + ELSEIF (.NOT. lstride .AND. it == nt) THEN WRITE (iw, '("FES|",T7,a,i4,a2)') "Mapping Gaussians ::", INT(10*ANINT(10.*it/nt)), " %" END IF END DO Hills @@ -665,7 +663,7 @@ PROGRAM graph IF (ncount < 10) THEN WRITE (out3_stride, '(A,i1)') TRIM(out3), ncount - ELSE IF (ncount < 100) THEN + ELSEIF (ncount < 100) THEN WRITE (out3_stride, '(A,i2)') TRIM(out3), ncount ELSE WRITE (out3_stride, '(A,i3)') TRIM(out3), ncount diff --git a/src/metadyn_tools/graph_methods.F b/src/metadyn_tools/graph_methods.F index 8ec364e70e..739fd093e7 100644 --- a/src/metadyn_tools/graph_methods.F +++ b/src/metadyn_tools/graph_methods.F @@ -323,7 +323,7 @@ CONTAINS fes_old = fes_now !WRITE(10+j,'(10f20.10)')(xx(id),id=ndim,1,-1),-fes(pnt) - norm_dx = NORM2(dx) + norm_dx = SQRT(DOT_PRODUCT(dx, dx)) IF (norm_dx == 0.0_dp) EXIT ! It is in a really flat region xx = xx - MIN(0.1_dp, norm_dx)*dx/norm_dx ! Re-evaluating pos @@ -448,7 +448,7 @@ CONTAINS ! compute average length (distance 1) DO irep = 2, nreplica xx = pos(:, irep) - pos(:, irep - 1) - avg1 = avg1 + NORM2(xx) + avg1 = avg1 + SQRT(DOT_PRODUCT(xx, xx)) END DO avg1 = avg1/REAL(nreplica - 1, KIND=dp) @@ -456,7 +456,7 @@ CONTAINS ! compute average length (distance 2) DO irep = 3, nreplica xx = pos(:, irep) - pos(:, irep - 2) - avg2 = avg2 + NORM2(xx) + avg2 = avg2 + SQRT(DOT_PRODUCT(xx, xx)) END DO avg2 = avg2/REAL(nreplica - 2, KIND=dp) @@ -478,7 +478,7 @@ CONTAINS davg2 = 0.0_dp IF (irep < nf - 1) THEN xx = pos(:, irep) - pos(:, irep + 2) - xx0 = NORM2(xx) + xx0 = SQRT(DOT_PRODUCT(xx, xx)) dxx = 1.0_dp/xx0*xx ene = ene + 0.25_dp*mep_input_data%kb*(xx0 - avg2)**2 davg2 = davg2 + dxx @@ -486,7 +486,7 @@ CONTAINS IF (irep > ns + 1) THEN xx = pos(:, irep) - pos(:, irep - 2) - yy0 = NORM2(xx) + yy0 = SQRT(DOT_PRODUCT(xx, xx)) dyy = 1.0_dp/yy0*xx davg2 = davg2 + dyy END IF @@ -503,11 +503,11 @@ CONTAINS ! Evaluation of the elastic term ! ------------------------------------------------------------- xx = pos(:, irep) - pos(:, irep + 1) - yy0 = NORM2(xx) + yy0 = SQRT(DOT_PRODUCT(xx, xx)) dyy = 1.0_dp/yy0*xx xx = pos(:, irep) - pos(:, irep - 1) - xx0 = NORM2(xx) + xx0 = SQRT(DOT_PRODUCT(xx, xx)) dxx = 1.0_dp/xx0*xx davg1 = (dxx + dyy)/REAL(nreplica - 1, KIND=dp) @@ -517,11 +517,11 @@ CONTAINS ! Evaluate the tangent xx = pos(:, irep + 1) - pos(:, irep) - xx = xx/NORM2(xx) + xx = xx/SQRT(DOT_PRODUCT(xx, xx)) yy = pos(:, irep) - pos(:, irep - 1) - yy = yy/NORM2(yy) + yy = yy/SQRT(DOT_PRODUCT(yy, yy)) tang = xx + yy - tang = tang/NORM2(tang) + tang = tang/SQRT(DOT_PRODUCT(tang, tang)) xx = derivative(fes, ipos, iperd, ndim, ngrid, dp_grid) dx(:, irep) = DOT_PRODUCT(dx(:, irep), tang)*tang + & @@ -536,7 +536,7 @@ CONTAINS ene = ene + fes_rep(irep) IF ((irep == 1) .OR. (irep == nreplica)) CYCLE - norm_dx = NORM2(dx(:, irep)) + norm_dx = SQRT(DOT_PRODUCT(dx(:, irep), dx(:, irep))) IF (norm_dx /= 0.0_dp) THEN pos(:, irep) = pos(:, irep) - MIN(0.1_dp, norm_dx)*dx(:, irep)/norm_dx END IF diff --git a/src/metadynamics_types.F b/src/metadynamics_types.F index 985188607a..a299e450b9 100644 --- a/src/metadynamics_types.F +++ b/src/metadynamics_types.F @@ -272,9 +272,8 @@ CONTAINS END IF ! Langevin on COLVARS - IF (meta_env%langevin) THEN + IF (meta_env%langevin) & DEALLOCATE (meta_env%rng) - END IF NULLIFY (meta_env%time) NULLIFY (meta_env%metadyn_section) diff --git a/src/metadynamics_utils.F b/src/metadynamics_utils.F index 72834021df..91b33ff467 100644 --- a/src/metadynamics_utils.F +++ b/src/metadynamics_utils.F @@ -157,10 +157,9 @@ CONTAINS "Overriding input specification!") END IF check = meta_env%hills_env%nt_hills >= meta_env%hills_env%min_nt_hills - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "MIN_NT_HILLS must have a value smaller or equal to NT_HILLS! "// & "Cross check with the input reference!") - END IF !RG Adaptive hills CALL section_vals_val_get(metadyn_section, "MIN_DISP", r_val=meta_env%hills_env%min_disp) CALL section_vals_val_get(metadyn_section, "OLD_HILL_NUMBER", i_val=meta_env%hills_env%old_hill_number) @@ -190,18 +189,15 @@ CONTAINS IF (meta_env%well_tempered) THEN meta_env%hills_env%wtcontrol = meta_env%hills_env%wtcontrol .OR. check check = meta_env%hills_env%wtcontrol - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "When using Well-Tempered metadynamics, "// & "DELTA_T (or WTGAMMA) should be explicitly specified.") - END IF - IF (meta_env%extended_lagrange) THEN + IF (meta_env%extended_lagrange) & CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with extended-lagrangian formulation.") - END IF - IF (meta_env%hills_env%min_disp > 0.0_dp) THEN + IF (meta_env%hills_env%min_disp > 0.0_dp) & CALL cp_abort(__LOCATION__, & "Well-Tempered metadynamics not possible with Adaptive hills.") - END IF END IF CALL section_vals_val_get(metadyn_section, "COLVAR_AVG_TEMPERATURE_RESTART", & @@ -211,13 +207,12 @@ CONTAINS CALL metavar_read(meta_env%metavar(i), meta_env%extended_lagrange, & meta_env%langevin, i, metavar_section) check = (meta_env%metavar(i)%icolvar <= number_allocated_colvars) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "An error occurred in the specification of COLVAR for METAVAR. "// & "Specified COLVAR #("//TRIM(ADJUSTL(cp_to_string(meta_env%metavar(i)%icolvar)))//") "// & "is larger than the maximum number of COLVARS defined in the SUBSYS ("// & TRIM(ADJUSTL(cp_to_string(number_allocated_colvars)))//") !") - END IF END DO ! Parsing the Multiple Walkers Info @@ -240,13 +235,12 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(walkers_section, "WALKERS_STATUS", i_vals=walkers_status) check = (SIZE(walkers_status) == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "size of the WALKERS_STATUS. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") - END IF meta_env%multiple_walkers%walkers_status = walkers_status ELSE meta_env%multiple_walkers%walkers_status = 0 @@ -257,13 +251,12 @@ CONTAINS CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & n_rep_val=n_rep) check = (n_rep == meta_env%multiple_walkers%walkers_tot_nr) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Number of Walkers specified in the input does not match with the "// & "number of Walkers File names provided. Please check your input and in case "// & "this is a restart run consider the possibility to switch off the "// & "RESTART_WALKERS in the EXT_RESTART section! ") - END IF DO i = 1, n_rep CALL section_vals_val_get(walkers_section, "WALKERS_FILE_NAME%_DEFAULT_KEYWORD_", & i_rep_val=i, c_val=walkers_file_name) diff --git a/src/minbas_methods.F b/src/minbas_methods.F index 96f1c421df..57411747cf 100644 --- a/src/minbas_methods.F +++ b/src/minbas_methods.F @@ -138,9 +138,8 @@ CONTAINS nmao = SUM(col_blk_sizes) ! check if MAOs have been specified DO iab = 1, natom - IF (col_blk_sizes(iab) < 0) THEN + IF (col_blk_sizes(iab) < 0) & CPABORT("Number of MAOs has to be specified in KIND section for all elements") - END IF END DO CALL get_mo_set(mo_set=mos(1), nao=nao, nmo=nmo) @@ -168,7 +167,7 @@ CONTAINS WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' END IF do_minbas = .FALSE. - ELSE IF (nmo /= nmx) THEN + ELSEIF (nmo /= nmx) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T2,A)') 'Different Number of Alpha and Beta MOs' WRITE (unit_nr, '(T2,A)') 'Localized Minimal Basis Analysis not possible' diff --git a/src/minbas_wfn_analysis.F b/src/minbas_wfn_analysis.F index 3c501d3076..bd4c617ca7 100644 --- a/src/minbas_wfn_analysis.F +++ b/src/minbas_wfn_analysis.F @@ -424,9 +424,9 @@ CONTAINS wij = ABS(SUM(qblock*sblock))/REAL(n, KIND=dp) IF (wij > 0.1_dp) THEN ecount(jatom, 1) = ecount(jatom, 1) + 1 - ELSE IF (wij > 0.01_dp) THEN + ELSEIF (wij > 0.01_dp) THEN ecount(jatom, 2) = ecount(jatom, 2) + 1 - ELSE IF (wij > 0.001_dp) THEN + ELSEIF (wij > 0.001_dp) THEN ecount(jatom, 3) = ecount(jatom, 3) + 1 END IF END IF diff --git a/src/minimax/minimax_exp.F b/src/minimax/minimax_exp.F index 2d9554e462..af4d922b38 100644 --- a/src/minimax/minimax_exp.F +++ b/src/minimax/minimax_exp.F @@ -142,7 +142,7 @@ CONTAINS CALL get_minimax_coeff_k15(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k15 END IF - ELSE IF (k <= 53) THEN + ELSEIF (k <= 53) THEN CALL get_minimax_coeff_k53(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k53 ELSE diff --git a/src/minimax/minimax_rpa.F b/src/minimax/minimax_rpa.F index 9d89e943ed..869a85a9e8 100644 --- a/src/minimax/minimax_rpa.F +++ b/src/minimax/minimax_rpa.F @@ -155,7 +155,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 2) :: fit_coef - REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = [8.4569134345088148E-01_dp, & + REAL(KIND=dp), DIMENSION(52), PARAMETER :: c01 = (/8.4569134345088148E-01_dp, & -2.3864746901255809E-01_dp, -1.1361819501552294E-01_dp, 6.7690505100738471E-02_dp, & 5.3985186361341728E-03_dp, -1.9612317325166117E-02_dp, 7.3513074383591715E-03_dp, & 1.9996243815975012E-03_dp, -3.1205386442664557E-03_dp, 6.2573451848435199E-04_dp, & @@ -172,8 +172,8 @@ CONTAINS -3.6844989012010113E-06_dp, -7.8361514387479545E+00_dp, -3.6112788486477720E+00_dp, & 9.5851351388967405E+00_dp, 7.2698001012821694E+00_dp, -1.1403856909523945E+01_dp, & -1.7651082087203267E+01_dp, 3.2669706643838275E+01_dp, -5.4176678145626020E+00_dp, & - -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp] - REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE([c01], [13, 2, 2]) + -1.4771604007512861E+01_dp, 1.1600808336065933E+00_dp, 6.4627594951385223E+00_dp/) + REAL(KIND=dp), DIMENSION(13, 2, 2), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 2, 2/)) INTEGER :: irange @@ -205,7 +205,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 4) :: fit_coef - REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = [4.9649110596357299E-01_dp, & + REAL(KIND=dp), DIMENSION(156), PARAMETER :: c01 = (/4.9649110596357299E-01_dp, & -1.8397680763708085E-01_dp, -2.6764777836094898E-02_dp, 1.4685597048762128E-02_dp, & 3.8551475599549168E-03_dp, -6.6371384965829621E-04_dp, -8.2857349546675376E-04_dp, & 3.7111617653054724E-05_dp, 1.2814660801267966E-04_dp, 6.1538340479780230E-06_dp, & @@ -257,8 +257,8 @@ CONTAINS -4.9301857791232557E+01_dp, 3.1465928358831281E+00_dp, 7.7404606802819202E+01_dp, & -3.3013072565887242E+01_dp, -1.2019494685884978E+02_dp, 1.5486223363142261E+02_dp, & 3.2337501402758228E+01_dp, -1.8488455295931200E+02_dp, 5.0234562973130487E+01_dp, & - 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp] - REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 4, 3]) + 1.4928893567718609E+02_dp, -1.0852276420140453E+02_dp/) + REAL(KIND=dp), DIMENSION(13, 4, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 4, 3/)) INTEGER :: irange @@ -295,7 +295,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 6) :: fit_coef - REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = [4.7223379816403283E-01_dp, & + REAL(KIND=dp), DIMENSION(234), PARAMETER :: c01 = (/4.7223379816403283E-01_dp, & -2.2042504935487547E-01_dp, -1.0700855642800766E-01_dp, 2.9282041797865813E-02_dp, & 3.3026836310057026E-02_dp, 1.1386996102844459E-02_dp, -1.2818345627763791E-02_dp, & -4.0229827105483680E-03_dp, 5.2714678853526230E-03_dp, -5.7896018199156346E-03_dp, & @@ -373,8 +373,8 @@ CONTAINS -1.7804086701584447E+02_dp, 5.3879411878296139E+01_dp, 2.5019726837316304E+02_dp, & -2.4632876610675547E+02_dp, -2.3728096521661567E+02_dp, 7.2832435058031899E+02_dp, & -6.3406381009820018E+02_dp, 7.2166814993792187E+01_dp, 2.2865645970566064E+02_dp, & - -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp] - REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 6, 3]) + -5.9497992164644941E+01_dp, -5.9908598748248629E+01_dp/) + REAL(KIND=dp), DIMENSION(13, 6, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 6, 3/)) INTEGER :: irange @@ -411,7 +411,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 8) :: fit_coef - REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = [4.0437679455062153E-01_dp, & + REAL(KIND=dp), DIMENSION(312), PARAMETER :: c01 = (/4.0437679455062153E-01_dp, & -1.9968645981826424E-01_dp, -9.6669556285432015E-02_dp, 2.6839132012201752E-02_dp, & 3.6190132805626725E-02_dp, 4.1166010414531336E-03_dp, -1.0769456290470580E-02_dp, & -8.7529874160434775E-05_dp, 5.7309585756926467E-03_dp, -1.0860752534826048E-02_dp, & @@ -515,8 +515,8 @@ CONTAINS -6.8223088256704716E+02_dp, 3.4708903230411840E+02_dp, 1.0990846081358511E+03_dp, & -1.7164437218305100E+03_dp, -5.1026413431245879E+02_dp, 4.8843366036040652E+03_dp, & -7.6063698448775094E+03_dp, 5.5268501397810141E+03_dp, -6.4043799549226162E+02_dp, & - -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp] - REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE([c01], [13, 8, 3]) + -1.8963185698837842E+03_dp, 1.0098848671258462E+03_dp/) + REAL(KIND=dp), DIMENSION(13, 8, 3), PARAMETER :: coefdata = RESHAPE((/c01/), (/13, 8, 3/)) INTEGER :: irange @@ -553,7 +553,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 10) :: fit_coef - REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = [-4.8858613834160547E-01_dp, & + REAL(KIND=dp), DIMENSION(120), PARAMETER :: c02 = (/-4.8858613834160547E-01_dp, & 3.4033685149450971E-01_dp, -1.0142642654121627E-01_dp, 1.8656576613307461E+00_dp, & -2.2611249862234847E-07_dp, -4.2139600757794465E-01_dp, 2.7923611356976985E-01_dp, & 4.7524652113269663E-03_dp, -5.0664309914469052E-01_dp, 9.4151166751519222E-01_dp, & @@ -593,8 +593,8 @@ CONTAINS -2.0215919999407249E+03_dp, 1.3397278899112848E+03_dp, 3.2785602402023524E+03_dp, & -6.7015638377241066E+03_dp, 8.2607523725594240E+02_dp, 1.7011468237133256E+04_dp, & -3.7898634628790373E+04_dp, 4.6113041763967398E+04_dp, -3.4882603781213867E+04_dp, & - 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6550926316288959E-01_dp, & + 1.5359465882590917E+04_dp, -2.9911038365687018E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6550926316288959E-01_dp, & -1.4194808279243129E-01_dp, -1.8340243943233556E-02_dp, 1.5594859644926301E-02_dp, & 6.5213609288545414E-03_dp, -7.2580394496045918E-04_dp, -1.4367869259991610E-03_dp, & -5.1441935266499043E-04_dp, 1.1018516863846910E-04_dp, 1.3857094404802231E-04_dp, & @@ -727,8 +727,9 @@ CONTAINS -9.5025460048391619E+02_dp, 1.8084927413816368E+02_dp, 4.5372254459206868E-01_dp, & -3.2706671239427972E-08_dp, -6.0956447616697843E-02_dp, 4.0392497654627497E-02_dp, & -5.9611390145588245E-03_dp, -6.4482812112108656E-02_dp, 1.3285507045769324E-01_dp, & - -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp] - REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 10, 4]) + -1.0786011793963135E-01_dp, -8.2044143611323866E-02_dp, 3.5942368229798438E-01_dp/) + REAL(KIND=dp), DIMENSION(13, 10, 4), PARAMETER :: & + coefdata = RESHAPE((/c01, c02/), (/13, 10, 4/)) INTEGER :: irange @@ -770,7 +771,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 12) :: fit_coef - REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = [-2.1886099081761100E-02_dp, & + REAL(KIND=dp), DIMENSION(224), PARAMETER :: c02 = (/-2.1886099081761100E-02_dp, & 1.6493591518278907E-03_dp, 1.1789604920345118E-03_dp, 6.4862232853117350E+00_dp, & -1.7754848782963699E+00_dp, -1.3982954414549702E+00_dp, 8.0870739791892121E-01_dp, & -3.2912209721480506E-01_dp, 6.6541689936850468E-01_dp, -7.1706760669376735E-01_dp, & @@ -845,8 +846,8 @@ CONTAINS 4.8176388108956071E+03_dp, 1.0175276953355078E+04_dp, -2.6714845272387549E+04_dp, & 1.3141868511851815E+04_dp, 5.7600064337445598E+04_dp, -1.7044732018512717E+05_dp, & 2.5361567867653081E+05_dp, -2.3362423558935185E+05_dp, 1.2691185251979054E+05_dp, & - -3.1278542676771558E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.3880318322659616E-01_dp, & + -3.1278542676771558E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.3880318322659616E-01_dp, & -1.3504254699048457E-01_dp, -1.8598173825632135E-02_dp, 1.5951626606880761E-02_dp, & 7.2684956676590529E-03_dp, -5.7141087071240480E-04_dp, -1.5395949213734461E-03_dp, & -7.1572363929054415E-04_dp, 3.6877254806601694E-05_dp, 5.4320682223059976E-06_dp, & @@ -979,8 +980,9 @@ CONTAINS -1.0634490523999061E+02_dp, 2.1350371455168180E+01_dp, 3.4511581153937105E+00_dp, & -4.6074986504725718E-01_dp, -4.1793306232973060E-01_dp, 1.1447565909224683E-01_dp, & -9.1392964448968397E-02_dp, 1.8219557370192899E-01_dp, -1.6634354182093192E-01_dp, & - 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp] - REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 12, 4]) + 1.0757299759560938E-01_dp, -7.7683124155527070E-02_dp, 5.4245972534987336E-02_dp/) + REAL(KIND=dp), DIMENSION(13, 12, 4), PARAMETER :: & + coefdata = RESHAPE((/c01, c02/), (/13, 12, 4/)) INTEGER :: irange @@ -1022,7 +1024,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 14) :: fit_coef - REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = [-4.1754731782680632E-02_dp, & + REAL(KIND=dp), DIMENSION(328), PARAMETER :: c02 = (/-4.1754731782680632E-02_dp, & 6.9637423606893978E-03_dp, 9.8317123038661812E-04_dp, 9.3141247748056060E+00_dp, & -3.3034187378384154E+00_dp, -2.3099777024265484E+00_dp, 1.9795050912537626E+00_dp, & -8.5251482053787397E-01_dp, 1.2153039011546896E+00_dp, -1.4541564892554977E+00_dp, & @@ -1131,8 +1133,8 @@ CONTAINS -6.0796509451681840E-03_dp, -1.2729055327721569E+04_dp, 1.1355442435730931E+04_dp, & 1.9420434975201191E+04_dp, -5.7157101053784776E+04_dp, 4.1961441009360387E+04_dp, & 8.2301170473632315E+04_dp, -2.9848869860082364E+05_dp, 4.7636758440468600E+05_dp, & - -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.6444089699692058E-01_dp, & + -4.6114819297381287E+05_dp, 2.6149542649940349E+05_dp, -6.7032773576863750E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.6444089699692058E-01_dp, & -1.5470504999202458E-01_dp, -4.6856578935403119E-02_dp, 2.5042624726789489E-02_dp, & 1.9131665599864848E-02_dp, -2.9696778036559586E-03_dp, -3.7556543742271655E-03_dp, & 1.6266657874186815E-04_dp, 4.6360340975112090E-03_dp, -7.8332396642386976E-03_dp, & @@ -1265,8 +1267,9 @@ CONTAINS 1.3457500127744759E-03_dp, 3.1573603989801897E-04_dp, 3.6037055399201039E+00_dp, & -8.0542869559173069E-01_dp, -6.3866068626924610E-01_dp, 3.6581611775536099E-01_dp, & -1.8032325305523136E-01_dp, 3.1726528871551424E-01_dp, -3.4024223010999666E-01_dp, & - 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp] - REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: coefdata = RESHAPE([c01, c02], [13, 14, 4]) + 2.2409139887689597E-01_dp, -1.3723892898385098E-01_dp, 9.0749009387187926E-02_dp/) + REAL(KIND=dp), DIMENSION(13, 14, 4), PARAMETER :: & + coefdata = RESHAPE((/c01, c02/), (/13, 14, 4/)) INTEGER :: irange @@ -1308,7 +1311,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 16) :: fit_coef - REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = [-8.9013840273255062E+02_dp, & + REAL(KIND=dp), DIMENSION(32), PARAMETER :: c03 = (/-8.9013840273255062E+02_dp, & 4.4450456221108550E+02_dp, 5.3174323393059228E+02_dp, -1.2592882857295644E+03_dp, & 1.0557554278716216E+03_dp, -3.5046238641220043E+02_dp, 1.2930757301899466E+03_dp, & 1.1516939780618657E-03_dp, -1.6608759395740256E+03_dp, 1.4462154462223984E+03_dp, & @@ -1319,8 +1322,8 @@ CONTAINS 1.9619149559132464E+04_dp, 2.5759373028729122E+04_dp, -7.7020575840804217E+04_dp, & 6.3201727988014049E+04_dp, 6.8163632238120859E+04_dp, -2.9053341169350612E+05_dp, & 4.7359098571404989E+05_dp, -4.6694609866564447E+05_dp, 2.7229709401159501E+05_dp, & - -7.2557173401722219E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7310961221813451E-01_dp, & + -7.2557173401722219E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7310961221813451E-01_dp, & -9.5711109831144323E-02_dp, -2.5960297888544426E-02_dp, 7.7258590328211849E-03_dp, & 5.1368496261163018E-03_dp, -1.1234374052788891E-03_dp, -1.0608869644587510E-03_dp, & 4.0213920388401469E-04_dp, 3.0775150301006290E-04_dp, -5.8915574825377335E-05_dp, & @@ -1453,8 +1456,8 @@ CONTAINS -1.6811781491598083E+01_dp, 4.2614301447710945E+00_dp, 4.2182283329260298E+02_dp, & -9.0232374730691106E+02_dp, 7.1913307941971050E+02_dp, 6.5788926678577425E+01_dp, & -5.6847305624230580E+02_dp, 3.2522974861279704E+02_dp, 1.3143394779042333E+02_dp, & - -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.8863592203480596E+02_dp, & + -1.4623977249362667E+02_dp, -1.9485496537035539E+02_dp, 3.9309282560397878E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.8863592203480596E+02_dp, & 1.0528430973221714E+02_dp, -1.5857007223981109E+01_dp, 1.8276946029107571E+03_dp, & -4.8112032981737193E+03_dp, 6.1258592600600687E+03_dp, -4.0381542724034271E+03_dp, & 3.2440486268768652E+01_dp, 2.9756759864086989E+03_dp, -3.5826087401832801E+03_dp, & @@ -1587,9 +1590,9 @@ CONTAINS 1.4478597281785360E+02_dp, 1.1301880394535623E+01_dp, -1.5313609799645960E+02_dp, & 1.5075591149117258E+02_dp, -5.3325987923237058E+01_dp, 2.9560124699329253E+02_dp, & 1.7113342586626282E-04_dp, -2.4662390250801528E+02_dp, 2.1474962274139023E+02_dp, & - -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp] + -2.0392071197782663E+01_dp, -3.1789596824276714E+02_dp, 7.2496736168975849E+02_dp/) REAL(KIND=dp), DIMENSION(13, 16, 4), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03], [13, 16, 4]) + coefdata = RESHAPE((/c01, c02, c03/), (/13, 16, 4/)) INTEGER :: irange @@ -1631,7 +1634,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 18) :: fit_coef - REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = [-8.4609670938814907E+02_dp, & + REAL(KIND=dp), DIMENSION(136), PARAMETER :: c03 = (/-8.4609670938814907E+02_dp, & 5.2521889455815938E+02_dp, -1.8158803681882837E+01_dp, -1.9195843056246903E+02_dp, & 4.7038182235191250E+01_dp, 4.4962618821808661E+01_dp, 2.3952550076762327E+03_dp, & 7.3919658606953450E-04_dp, -3.3678854403725500E+03_dp, 2.7630103823335253E+03_dp, & @@ -1676,8 +1679,8 @@ CONTAINS 7.9756724721310873E-03_dp, -3.6633955682749525E+04_dp, 3.0054168139170702E+04_dp, & 3.0244619250697619E+04_dp, -8.9553753522321902E+04_dp, 7.9875735584514681E+04_dp, & 1.7524458945017868E+04_dp, -1.3188240705569120E+05_dp, 1.3592402872600380E+05_dp, & - -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.7491556688515650E-01_dp, & + -1.4644005644830598E+01_dp, -1.0996321547256157E+05_dp, 6.7843413283968956E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.7491556688515650E-01_dp, & -1.0138397977284885E-01_dp, -3.9049726894672010E-02_dp, 1.2625689412991524E-02_dp, & 1.2491380414983764E-02_dp, -3.7765616302317911E-03_dp, -5.1175283467075521E-03_dp, & 1.4632298825565039E-03_dp, 3.6642955364173022E-03_dp, -2.0156097072982762E-03_dp, & @@ -1810,8 +1813,8 @@ CONTAINS 2.9781052441439151E-02_dp, -1.4527696704126849E-02_dp, 1.7339641636383043E+01_dp, & -1.1465395481325789E+01_dp, -2.7302697069655961E+00_dp, 4.4629359221611402E+00_dp, & 7.1614646223286882E-01_dp, -1.4605259953560206E+00_dp, -1.0335490616197762E+00_dp, & - 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [8.6574572823904627E-01_dp, & + 1.1536772096440751E+00_dp, 7.7992282360725562E-01_dp, -1.5718730701413242E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/8.6574572823904627E-01_dp, & -1.6889080712338411E-01_dp, -3.8729713566779244E-03_dp, 4.1076303571384891E+01_dp, & -3.6684994925539350E+01_dp, -3.4268355391161074E+00_dp, 1.6994010089726881E+01_dp, & -1.2988970233372894E+00_dp, -6.3669393876591824E+00_dp, -1.4789915209996456E+00_dp, & @@ -1944,9 +1947,9 @@ CONTAINS 1.3132457381744328E+02_dp, -3.8713782602971918E+01_dp, -3.5040157951924371E+01_dp, & 3.7792017841024283E+01_dp, -1.0016991740016113E+01_dp, 4.5777593919577163E+02_dp, & 8.1637641969554641E-05_dp, -3.6580205008674420E+02_dp, 3.0011032726156765E+02_dp, & - -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp] + -1.3953035592512641E+01_dp, -3.7345160055057738E+02_dp, 7.4221682637239917E+02_dp/) REAL(KIND=dp), DIMENSION(13, 18, 4), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03], [13, 18, 4]) + coefdata = RESHAPE((/c01, c02, c03/), (/13, 18, 4/)) INTEGER :: irange @@ -1988,7 +1991,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 20) :: fit_coef - REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = [-6.3360994610628929E-01_dp, & + REAL(KIND=dp), DIMENSION(240), PARAMETER :: c03 = (/-6.3360994610628929E-01_dp, & 9.7649518951989356E-01_dp, -1.0559988395317237E+00_dp, 7.8078414899977844E-01_dp, & -3.5500159005989329E-01_dp, 7.4673135592582374E-02_dp, 2.6285615412587124E+00_dp, & 1.5860173767897436E-07_dp, -3.6913389708324101E-01_dp, 3.7465972064134995E-01_dp, & @@ -2068,8 +2071,8 @@ CONTAINS -1.0102666755386532E+05_dp, 1.0253508247597031E+05_dp, 1.0602636418265585E+05_dp, & -4.0728952867028292E+05_dp, 4.6976444940836332E+05_dp, 5.8500781101532266E+04_dp, & -1.2055500949944141E+06_dp, 2.3598896259778733E+06_dp, -2.5585975849316372E+06_dp, & - 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [2.5561005851553148E-01_dp, & + 1.5841592037308544E+06_dp, -4.3843418788217887E+05_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/2.5561005851553148E-01_dp, & -9.8727639373792656E-02_dp, -3.5824853081321391E-02_dp, 1.3639809429163310E-02_dp, & 1.2140312218587666E-02_dp, -4.6051578600266093E-03_dp, -5.2440292404026837E-03_dp, & 1.6141788048728977E-03_dp, 4.9068438183985687E-03_dp, -3.8643109440260576E-03_dp, & @@ -2202,8 +2205,8 @@ CONTAINS 1.4996446737543528E+02_dp, -3.0374236420884017E+01_dp, 2.5318787052609042E+00_dp, & -4.5232522380132079E-01_dp, -2.4894203765998704E-01_dp, 3.7844517569960621E-02_dp, & 6.7481113092261444E-02_dp, -1.8350883302710324E-03_dp, -3.7893183999051401E-02_dp, & - 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.4867222607997398E-03_dp, & + 6.9921199011088479E-03_dp, 1.7385860790483609E-02_dp, -5.9031381997973701E-03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.4867222607997398E-03_dp, & 7.4160230219779905E-03_dp, -1.8338341118192985E-03_dp, 3.6656246502838239E+00_dp, & -1.0862821007061922E+00_dp, -4.7299838594788851E-01_dp, 2.1791529395255307E-01_dp, & 1.6235258776392880E-01_dp, -5.9164629917823931E-02_dp, -1.0182204867540855E-01_dp, & @@ -2336,9 +2339,9 @@ CONTAINS 2.0849621635227758E-01_dp, -2.2855126470711301E-01_dp, 1.7151231132777350E-01_dp, & -7.9338970506037887E-02_dp, 1.7034794798258115E-02_dp, 1.1561315825459209E+00_dp, & 4.6876842564306299E-08_dp, -1.0903099661435091E-01_dp, 1.1066333209885304E-01_dp, & - -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp] + -9.7910572631274409E-02_dp, -7.4543419120169617E-03_dp, 2.5924139627124398E-01_dp/) REAL(KIND=dp), DIMENSION(13, 20, 4), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03], [13, 20, 4]) + coefdata = RESHAPE((/c01, c02, c03/), (/13, 20, 4/)) INTEGER :: irange @@ -2380,7 +2383,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 22) :: fit_coef - REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = [-2.5319035989384675E+00_dp, & + REAL(KIND=dp), DIMENSION(230), PARAMETER :: c04 = (/-2.5319035989384675E+00_dp, & -3.1868909327109335E-01_dp, 7.3902114944100665E+00_dp, -1.8431274144078589E+01_dp, & 2.9378426424405447E+01_dp, -3.3161724592145767E+01_dp, 2.5816413812770147E+01_dp, & -1.2469330304705172E+01_dp, 2.8128079338690761E+00_dp, 2.4584353206019742E+01_dp, & @@ -2457,8 +2460,8 @@ CONTAINS 2.1221227425035721E+05_dp, 1.9513181165124831E+05_dp, -8.3228931356148690E+05_dp, & 1.0686042433396007E+06_dp, -1.6890882361242565E+05_dp, -2.0275393275062682E+06_dp, & 4.3886071943292571E+06_dp, -4.9464312502375301E+06_dp, 3.1275647455199584E+06_dp, & - -8.7618952854779735E+05_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.9140383852290629E-01_dp, & + -8.7618952854779735E+05_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.9140383852290629E-01_dp, & -6.8714312208041611E-02_dp, -9.1979524758077930E-03_dp, 4.0542016308222793E-03_dp, & 1.3043896673939879E-03_dp, -3.3077626826676678E-04_dp, -1.1713733973944338E-04_dp, & 7.6096932007647678E-05_dp, 1.6862094749663900E-05_dp, -1.8859482112709049E-05_dp, & @@ -2591,8 +2594,8 @@ CONTAINS -3.8649136037865522E-01_dp, 2.2567746326676860E-01_dp, 7.4213954026122252E+01_dp, & -1.4804950267684572E+02_dp, 1.2495507784125873E+02_dp, -2.4776264817547396E+01_dp, & -4.2930419560902017E+01_dp, 2.9472395507465627E+01_dp, 1.0097402469676231E+01_dp, & - -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.4561539999459816E+01_dp, & + -1.5262809248340325E+01_dp, -7.2300215031127406E+00_dp, 2.0357934514863608E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.4561539999459816E+01_dp, & 4.8544787554718685E+00_dp, -6.3387746031848102E-01_dp, 1.5731981998839461E+02_dp, & -3.7106120150889751E+02_dp, 4.0538316285381757E+02_dp, -1.9862435563464234E+02_dp, & -4.2159595434504858E+01_dp, 1.1123116084380190E+02_dp, -3.2616679588589356E+01_dp, & @@ -2725,8 +2728,8 @@ CONTAINS 2.4122252521897924E+00_dp, -9.7999682646599489E+00_dp, 7.9639626818274714E+00_dp, & -2.9529703827741800E+00_dp, 4.3437020501980872E-01_dp, 1.3418598639315178E+02_dp, & -1.4639064170062176E+02_dp, 7.9688822975923612E+00_dp, 6.9963146941480773E+01_dp, & - -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2105999150585166E+01_dp, & + -1.9798038249044243E+01_dp, -2.9411357486525350E+01_dp, 6.3698447544865715E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2105999150585166E+01_dp, & -2.2551854693657698E+00_dp, -3.0252257829864192E+01_dp, 3.2690274416605568E+01_dp, & -1.5006475584487145E+01_dp, 2.7494470603903425E+00_dp, 3.4045498207568971E+02_dp, & -4.7133760448357106E+02_dp, 1.1327780050673924E+02_dp, 2.2523014020490135E+02_dp, & @@ -2859,9 +2862,9 @@ CONTAINS -1.1263108188627524E-02_dp, 2.3148160729056904E+00_dp, -5.9940875579716151E+00_dp, & 9.7525037514957766E+00_dp, -1.1202621964616382E+01_dp, 8.8723971586232349E+00_dp, & -4.3615551235670349E+00_dp, 1.0019327026030862E+00_dp, 1.0890417035686898E+01_dp, & - -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp] + -2.2965810094845916E-07_dp, -2.7617022482760696E+00_dp, 2.9519410935497650E+00_dp/) REAL(KIND=dp), DIMENSION(13, 22, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04], [13, 22, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 22, 5/)) INTEGER :: irange @@ -2908,7 +2911,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 24) :: fit_coef - REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = [-3.4185637511153556E+02_dp, & + REAL(KIND=dp), DIMENSION(360), PARAMETER :: c04 = (/-3.4185637511153556E+02_dp, & 3.0668182445881496E+02_dp, -4.1209664021967029E+02_dp, 3.7330789502174974E+02_dp, & -2.3245333897278655E+02_dp, 1.3019687281058577E+02_dp, -7.4166370900253412E+01_dp, & 3.1434861912054572E+01_dp, -6.1992398402862987E+00_dp, 3.3062345634073872E+03_dp, & @@ -3028,8 +3031,8 @@ CONTAINS -3.7306629896332178E+05_dp, 4.1394566251683736E+05_dp, 3.3744969046701316E+05_dp, & -1.5791948214027057E+06_dp, 2.1917044569001873E+06_dp, -7.9115467427151953E+05_dp, & -3.0601023356753197E+06_dp, 7.4427363873937679E+06_dp, -8.7248223821029570E+06_dp, & - 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8031277973538481E-01_dp, & + 5.6367831322922539E+06_dp, -1.6014423862358064E+06_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8031277973538481E-01_dp, & -6.7333985536224536E-02_dp, -8.9222590966419636E-03_dp, 4.3313443199331000E-03_dp, & 1.3612994231258369E-03_dp, -4.2134528860866431E-04_dp, -1.3958926498276367E-04_dp, & 1.0459985085575114E-04_dp, 2.4321788489287324E-05_dp, -2.5628407616984446E-05_dp, & @@ -3162,8 +3165,8 @@ CONTAINS -3.8414425007098330E-01_dp, 7.5502828561301874E-02_dp, 1.5429572442140103E+01_dp, & -1.9205543991334537E+01_dp, 7.1837956925844102E+00_dp, 4.1527008022568523E+00_dp, & -3.9604373888031548E+00_dp, -1.2184620720634423E+00_dp, 2.1268242758491254E+00_dp, & - 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [1.1553671463453488E+00_dp, & + 4.8977374234146870E-01_dp, -1.3567457043687021E+00_dp, -1.4342868044936791E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/1.1553671463453488E+00_dp, & -7.6780781804979914E-01_dp, 1.7390307652239254E-01_dp, 2.8165264234356147E+01_dp, & -4.2781018965163859E+01_dp, 2.3179056548048951E+01_dp, 5.2439089413556950E+00_dp, & -1.1643001503346785E+01_dp, 4.5770373921564939E-01_dp, 5.5851597940226441E+00_dp, & @@ -3296,8 +3299,8 @@ CONTAINS 1.9287416985295423E-02_dp, -9.7735471490287135E-03_dp, -5.4153420961059818E-03_dp, & 6.2996178645704911E-03_dp, -1.6741808988248179E-03_dp, 3.2323307090443092E+00_dp, & -7.5868899537917556E-01_dp, -3.6403112314198777E-01_dp, 1.3638032105863709E-01_dp, & - 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.5411208403973456E-02_dp, & + 1.2454451915538212E-01_dp, -3.5272622120219609E-02_dp, -7.9465036314149431E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.5411208403973456E-02_dp, & 5.7808629859203861E-02_dp, -5.0196351778645114E-02_dp, 5.2149034144752344E-03_dp, & 9.5271530622531974E-03_dp, -3.3982153227889275E-03_dp, 5.4948218832066447E+00_dp, & -1.9768544283573861E+00_dp, -7.8540931963005123E-01_dp, 5.1224166160961682E-01_dp, & @@ -3430,9 +3433,9 @@ CONTAINS 8.6197068058446064E+01_dp, -1.1457176948523994E+02_dp, 1.0089516510941472E+02_dp, & -7.0493679332727382E+01_dp, 4.8625058388200841E+01_dp, -2.9732088584351676E+01_dp, & 1.1947228503152537E+01_dp, -2.1840920197937304E+00_dp, 1.0166774272757106E+03_dp, & - -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp] + -6.5774062040784861E+02_dp, -3.4819173908900984E+02_dp, 5.8698390708558020E+02_dp/) REAL(KIND=dp), DIMENSION(13, 24, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04], [13, 24, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04/), (/13, 24, 5/)) INTEGER :: irange @@ -3479,7 +3482,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 26) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8838771004380783E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8838771004380783E-01_dp, & -7.8098504554216852E-02_dp, -1.5170263296839995E-02_dp, 8.2399169935392508E-03_dp, & 3.5286892847422469E-03_dp, -1.8215194066877041E-03_dp, -9.0884305814463765E-04_dp, & 6.8756727909990219E-04_dp, 3.7413977081317160E-04_dp, -2.6705465221031334E-04_dp, & @@ -3612,8 +3615,8 @@ CONTAINS -3.7209893008122726E-02_dp, 4.6211560443511707E-03_dp, 4.9425542029764467E+00_dp, & -3.3299793049425701E+00_dp, -1.5240471603939173E-02_dp, 9.6617116551502813E-01_dp, & -5.4487412666999822E-02_dp, -4.4981543663568441E-01_dp, 5.4235895382646740E-02_dp, & - 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [3.5632823078643500E-01_dp, & + 1.9616328040136954E-01_dp, 1.1396958212193117E-01_dp, -4.2101103801084033E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/3.5632823078643500E-01_dp, & -1.4001776162509430E-01_dp, 2.2286666712875530E-02_dp, 8.7125285885676789E+00_dp, & -7.4679426200738366E+00_dp, 8.3805209926335500E-01_dp, 2.2477163058559704E+00_dp, & -6.0060735276290700E-01_dp, -1.0331040612400506E+00_dp, 3.9698448728282515E-01_dp, & @@ -3746,8 +3749,8 @@ CONTAINS -1.5690448976060742E+00_dp, -1.4469520844727743E+01_dp, 1.5229016181347497E+01_dp, & -6.7413191274813640E+00_dp, 1.1871712862612187E+00_dp, 2.8292219949744720E+02_dp, & -3.3466585644002333E+02_dp, 6.5399374381441106E+01_dp, 1.3547954808764075E+02_dp, & - -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.1951406154569082E+01_dp, & + -7.2400177578816127E+01_dp, -4.7247337505445195E+01_dp, 3.5254490079699167E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.1951406154569082E+01_dp, & -2.7863833003973856E+01_dp, -2.4615790099798474E+01_dp, 4.4154903132889864E+01_dp, & -2.4321043128719936E+01_dp, 5.0336537486842516E+00_dp, 7.0657858026784504E+02_dp, & -1.0528573743078830E+03_dp, 4.1625512279061735E+02_dp, 3.6427444425345516E+02_dp, & @@ -3880,8 +3883,8 @@ CONTAINS 5.9384272779209310E-02_dp, -6.6034549944533560E-02_dp, 6.3165197301667780E-02_dp, & -5.8533667022985264E-02_dp, 4.7080124186021241E-02_dp, -2.8040678094242519E-02_dp, & 1.0590404330460124E-02_dp, -1.8887168866975497E-03_dp, 3.2950022547352660E+00_dp, & - -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-7.8836509708512373E-02_dp, & + -2.4869033985187267E-01_dp, -2.1951170275277102E-01_dp, 9.0239524034429530E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-7.8836509708512373E-02_dp, & 1.3178061660818258E-01_dp, -1.4891101086305505E-01_dp, 1.4038052557472530E-01_dp, & -1.2827505792189706E-01_dp, 1.0306674552536969E-01_dp, -6.1520533848826123E-02_dp, & 2.3216931723502306E-02_dp, -4.1222161991565217E-03_dp, 5.6592328962619902E+00_dp, & @@ -4014,8 +4017,8 @@ CONTAINS -1.7064535222921169E+01_dp, 1.9476350353952395E+01_dp, -1.8590436540559089E+01_dp, & 3.1925275522724674E+00_dp, 4.1158324783342913E+01_dp, -1.1921515605115852E+02_dp, & 2.0979218330367425E+02_dp, -2.5985281813994447E+02_dp, 2.2199832068654112E+02_dp, & - -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp] - REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = [-2.7907357414271074E-05_dp, & + -1.1767584219618503E+02_dp, 2.9097217542476354E+01_dp, 1.1295662396434658E+02_dp/) + REAL(KIND=dp), DIMENSION(90), PARAMETER :: c05 = (/-2.7907357414271074E-05_dp, & -4.8826106427338516E+01_dp, 5.5726828156877396E+01_dp, -5.0511477178292488E+01_dp, & 2.9783692652581260E+00_dp, 1.2761594545085276E+02_dp, -3.5194583503612256E+02_dp, & 6.0567238480576850E+02_dp, -7.3810346857458831E+02_dp, 6.2201716742048916E+02_dp, & @@ -4045,9 +4048,9 @@ CONTAINS -6.7753046300068102E+05_dp, 7.7323771401862660E+05_dp, 5.5823523395335092E+05_dp, & -2.8474678682125942E+06_dp, 4.1915016169727501E+06_dp, -2.1435582467267131E+06_dp, & -4.2583193954617819E+06_dp, 1.1939190162504816E+07_dp, -1.4588866431316955E+07_dp, & - 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp] + 9.6445890214436613E+06_dp, -2.7844693650067835E+06_dp/) REAL(KIND=dp), DIMENSION(13, 26, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 26, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 26, 5/)) INTEGER :: irange @@ -4094,7 +4097,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 28) :: fit_coef - REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = [-4.9474578762585689E-04_dp, & + REAL(KIND=dp), DIMENSION(220), PARAMETER :: c05 = (/-4.9474578762585689E-04_dp, & -2.5939403957639643E+03_dp, 3.0352874416549189E+03_dp, -1.9742442806612846E+03_dp, & -1.5969761709828460E+03_dp, 9.5497831811419619E+03_dp, -2.1791219784053799E+04_dp, & 3.4007167063977518E+04_dp, -3.8426789298450683E+04_dp, 3.0290020612758195E+04_dp, & @@ -4167,8 +4170,8 @@ CONTAINS -2.4363178639415667E-01_dp, -1.2048752475226286E+06_dp, 1.4098050382019044E+06_dp, & 9.0383108002498816E+05_dp, -5.0245780711403918E+06_dp, 7.7751430360333202E+06_dp, & -4.9183263330898508E+06_dp, -5.5122178990547452E+06_dp, 1.8712359903900910E+07_dp, & - -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8855631887642382E-01_dp, & + -2.3939217503688838E+07_dp, 1.6218284186391968E+07_dp, -4.7629949218999417E+06_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8855631887642382E-01_dp, & -8.1829231046632769E-02_dp, -1.8950903102790816E-02_dp, 1.1349898287774197E-02_dp, & 5.7338935886024562E-03_dp, -3.6475885523936957E-03_dp, -2.1458998142384776E-03_dp, & 1.4787405505064602E-03_dp, 1.8498537181843471E-03_dp, -1.9614757255708645E-03_dp, & @@ -4301,8 +4304,8 @@ CONTAINS 1.1382083100254657E-03_dp, -3.9779179490065093E-04_dp, 1.4924251913695632E+00_dp, & -5.1831019334185813E-01_dp, -1.0671352469554986E-01_dp, 9.3839903685068102E-02_dp, & 3.2490232771881414E-02_dp, -3.4916436688308940E-02_dp, -1.3379509563995902E-02_dp, & - 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [7.7725039723149673E-03_dp, & + 1.3447654845333435E-02_dp, 1.4076996424835847E-02_dp, -2.0087908870094155E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/7.7725039723149673E-03_dp, & 1.1145706792479703E-04_dp, -5.6097890673260616E-04_dp, 2.6197138414537928E+00_dp, & -1.1878855591113402E+00_dp, -1.3669541461047707E-01_dp, 2.5880924857422194E-01_dp, & 3.9410663226141771E-02_dp, -1.0161291074659663E-01_dp, -1.4845376770825033E-02_dp, & @@ -4435,8 +4438,8 @@ CONTAINS 1.8202124035828973E-01_dp, -2.3777194345333863E-01_dp, 9.8820369139971026E-02_dp, & -6.2744671316908003E-03_dp, -4.3699523495120468E-03_dp, 1.1856221271082283E+01_dp, & -5.2568207235502564E+00_dp, -1.5969164750173954E+00_dp, 1.6461069205315015E+00_dp, & - 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [3.7852818456494469E-01_dp, & + 5.9172061051969216E-01_dp, -6.4697064642905655E-01_dp, -4.3622701630183242E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/3.7852818456494469E-01_dp, & 4.8067555347683755E-01_dp, -7.7452581263261322E-01_dp, 4.1934407249887440E-01_dp, & -8.9234614648328783E-02_dp, 1.6775465007990663E-03_dp, 2.2972132228999541E+01_dp, & -1.2898901071815617E+01_dp, -2.9797860863789967E+00_dp, 4.6560435611069622E+00_dp, & @@ -4569,8 +4572,8 @@ CONTAINS 8.7770738779350062E+00_dp, -1.1095172356986756E+01_dp, 1.0314862293028543E+01_dp, & -8.8233143705921826E+00_dp, 7.0699089843034164E+00_dp, -4.4024286308950149E+00_dp, & 1.7350313146222107E+00_dp, -3.1699935067362639E-01_dp, 1.3246229877703036E+02_dp, & - -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-1.7228109793468004E+01_dp, & + -4.5573195710967674E+01_dp, -3.2154929851246941E+01_dp, 3.0089567929013004E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-1.7228109793468004E+01_dp, & 2.4108285826088757E+01_dp, -3.1362122687167119E+01_dp, 2.9105748579791722E+01_dp, & -2.4011018345543842E+01_dp, 1.8874442598138845E+01_dp, -1.1844908362658735E+01_dp, & 4.7389221341553531E+00_dp, -8.7620232886140437E-01_dp, 3.1319177678658934E+02_dp, & @@ -4703,9 +4706,9 @@ CONTAINS -6.6016663782193780E+02_dp, 7.7249587755502171E+02_dp, -6.0564642881603584E+02_dp, & -1.6334533603788654E+02_dp, 2.0809169575290675E+03_dp, -5.2520819705711947E+03_dp, & 8.7142803953445527E+03_dp, -1.0381449011333283E+04_dp, 8.6066748064158692E+03_dp, & - -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp] + -4.4514243053148093E+03_dp, 1.0783194357224340E+03_dp, 2.6999974727364965E+03_dp/) REAL(KIND=dp), DIMENSION(13, 28, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 28, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 28, 5/)) INTEGER :: irange @@ -4752,7 +4755,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 30) :: fit_coef - REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = [-3.0692468631051978E-08_dp, & + REAL(KIND=dp), DIMENSION(350), PARAMETER :: c05 = (/-3.0692468631051978E-08_dp, & -3.9609383383921665E-01_dp, 4.7587580740675417E-01_dp, -5.5706375318965173E-01_dp, & 3.4546263714113901E-01_dp, 5.4776062905207357E-01_dp, -2.4141552540426781E+00_dp, & 4.9577847041515470E+00_dp, -6.8295343742172383E+00_dp, 6.3573367557181761E+00_dp, & @@ -4869,8 +4872,8 @@ CONTAINS 2.5461696440140237E+06_dp, 1.4577959403430095E+06_dp, -8.8776723555507679E+06_dp, & 1.4429270679797074E+07_dp, -1.0764718275979346E+07_dp, -6.0081024069717359E+06_dp, & 2.8423455083762139E+07_dp, -3.8351286309245549E+07_dp, 2.6572649225598279E+07_dp, & - -7.9000536567775914E+06_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8728308171438685E-01_dp, & + -7.9000536567775914E+06_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8728308171438685E-01_dp, & -7.4958225804522882E-02_dp, -1.7654418697317781E-02_dp, 1.0337296188123402E-02_dp, & 5.3074367941912289E-03_dp, -3.4737735619981940E-03_dp, -2.0980081422520588E-03_dp, & 1.3332352270175691E-03_dp, 1.8928638178553657E-03_dp, -2.0371064972525598E-03_dp, & @@ -5003,8 +5006,8 @@ CONTAINS 3.0587066325522777E+01_dp, -9.7246696807779784E+00_dp, 2.3046596783109666E-01_dp, & -5.0266863054748409E-02_dp, -1.7179737588739360E-02_dp, 5.4654515693096711E-03_dp, & 4.7852361622912525E-03_dp, -1.7421101769864551E-03_dp, -1.9440310548800761E-03_dp, & - 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-2.3785652584517211E-04_dp, & + 6.0661250198343168E-04_dp, 1.3341594386686755E-03_dp, -8.7661120974839130E-04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-2.3785652584517211E-04_dp, & 4.0415260781371566E-04_dp, -1.1566827381466792E-04_dp, 7.4614843698202982E-01_dp, & -1.8831297390879426E-01_dp, -5.5307781300718430E-02_dp, 2.5755321163507486E-02_dp, & 1.6130804272204945E-02_dp, -8.8949071784985307E-03_dp, -6.6594057854666763E-03_dp, & @@ -5137,8 +5140,8 @@ CONTAINS 1.6273475095842586E-03_dp, -8.9025885910407965E-04_dp, -3.6671922956720823E-04_dp, & 4.8507440460371750E-04_dp, -1.3211072877791544E-04_dp, 8.5654480285554591E-01_dp, & -1.1200920153309295E-01_dp, -6.0375651330303620E-02_dp, 1.2480943363126322E-02_dp, & - 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.2061351968797813E-03_dp, & + 1.7766988818178821E-02_dp, -2.1391630741560913E-03_dp, -1.0741465894792950E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.2061351968797813E-03_dp, & 7.2651800654771788E-03_dp, -4.9666091131882828E-03_dp, -6.0509045722459322E-04_dp, & 1.7074706793122701E-03_dp, -5.0886032182887841E-04_dp, 1.7258143200373688E+00_dp, & -2.9884323352649256E-01_dp, -1.4775030321223576E-01_dp, 4.7248271588260116E-02_dp, & @@ -5271,8 +5274,8 @@ CONTAINS 2.2562073529423785E-02_dp, -2.5951410486921640E-02_dp, 2.5567379426983138E-02_dp, & -2.4333781051323347E-02_dp, 2.0151995146635144E-02_dp, -1.2400482709093779E-02_dp, & 4.8452373650168124E-03_dp, -8.9294844328912499E-04_dp, 1.8352119311378547E+00_dp, & - -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-3.6931298185134437E-02_dp, & + -1.1605842392533414E-01_dp, -1.0141001120766774E-01_dp, 4.1699067057004879E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-3.6931298185134437E-02_dp, & 6.2239013775737956E-02_dp, -7.2288174936489244E-02_dp, 7.0693666064322772E-02_dp, & -6.6776211112181863E-02_dp, 5.5274684972707100E-02_dp, -3.4069532004586962E-02_dp, & 1.3318163740503416E-02_dp, -2.4516852040202333E-03_dp, 3.4526910112953169E+00_dp, & @@ -5405,9 +5408,9 @@ CONTAINS -1.5296272228579366E-01_dp, 1.8377288757765206E-01_dp, -2.1880198683428151E-01_dp, & 1.4228504563245828E-01_dp, 1.9523650997654252E-01_dp, -9.0945729598550951E-01_dp, & 1.8916140218456958E+00_dp, -2.6232469600311217E+00_dp, 2.4527671312473118E+00_dp, & - -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp] + -1.4022183672866397E+00_dp, 3.6967613733809346E-01_dp, 3.5186336824147015E+00_dp/) REAL(KIND=dp), DIMENSION(13, 30, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05], [13, 30, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05/), (/13, 30, 5/)) INTEGER :: irange @@ -5454,7 +5457,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 32) :: fit_coef - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8440983439459679E-01_dp, & + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8440983439459679E-01_dp, & -7.0479249003300562E-02_dp, -1.6832381157590469E-02_dp, 9.9837323526780937E-03_dp, & 5.1989041899428937E-03_dp, -3.5423416042951205E-03_dp, -2.1543663571483209E-03_dp, & 1.3096125508292179E-03_dp, 2.2049401312140603E-03_dp, -2.5023058617921153E-03_dp, & @@ -5587,8 +5590,8 @@ CONTAINS 9.8497860011119158E+00_dp, -3.3639190612129344E+00_dp, 5.9487274112930379E+02_dp, & -1.7978611801015538E+03_dp, 2.7622843520701335E+03_dp, -2.5880461605405826E+03_dp, & 1.4022414211295804E+03_dp, -2.0359258628022113E+02_dp, -2.6091417556034258E+02_dp, & - 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [2.9539145031653501E+01_dp, & + 1.2051226872116960E+02_dp, 8.5298374145724267E+01_dp, -1.0115805307780569E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/2.9539145031653501E+01_dp, & 4.7715049407002184E+00_dp, -3.2712144543127324E+00_dp, 2.2264348078485641E+03_dp, & -6.6288008445597088E+03_dp, 1.0084012629385183E+04_dp, -9.4383385665132246E+03_dp, & 5.2647790264708256E+03_dp, -1.0875754774918837E+03_dp, -5.8837187049175338E+02_dp, & @@ -5721,8 +5724,8 @@ CONTAINS -1.7628434198318345E+01_dp, 3.9655688909902926E+02_dp, -3.7408946589251713E+02_dp, & 1.5787812785698458E+02_dp, -2.7089362134634474E+01_dp, 2.0614418378112468E+03_dp, & -5.6578757894510300E+03_dp, 7.1620850676558530E+03_dp, -4.4041308675995369E+03_dp, & - -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.5703600920047631E+02_dp, & + -5.1684129400340517E+01_dp, 2.0625349133742861E+03_dp, -9.2575644960768261E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.5703600920047631E+02_dp, & 6.8515562434659739E+02_dp, 1.8173876061092901E+02_dp, -5.6990417291447488E+02_dp, & 3.3635689037567329E+02_dp, -7.1542971828322536E+01_dp, 4.8609029109261082E+03_dp, & -1.4519102949367327E+04_dp, 2.1140422991455973E+04_dp, -1.7456530345889521E+04_dp, & @@ -5855,8 +5858,8 @@ CONTAINS -6.5694865280062390E+02_dp, 5.9368339749825054E+02_dp, 7.7692645932202890E+02_dp, & -1.0697937873179803E+03_dp, 3.8548984201540087E+01_dp, 6.7608544747530505E+02_dp, & -4.8167622236142665E+02_dp, 1.1263022376557032E+02_dp, 4.9024755081192952E+03_dp, & - -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-4.7874743699806668E+03_dp, & + -8.6785968466350550E+03_dp, 3.9572621953771327E+03_dp, 4.0485213527526844E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-4.7874743699806668E+03_dp, & -8.5329386064550408E+02_dp, 2.7526945075798449E+03_dp, 1.9553980517436300E+03_dp, & -5.9289564226732664E+03_dp, 4.4771348003328458E+03_dp, -1.0901273950898408E+03_dp, & -3.0130386512273043E+02_dp, 1.6238769196873562E+02_dp, 1.3563319365162426E+04_dp, & @@ -5989,8 +5992,8 @@ CONTAINS -3.7066724475406403E+02_dp, 4.4339421427221095E+02_dp, -2.5185768559746347E+02_dp, & 3.0387188886435422E+02_dp, -4.1221355071839258E+02_dp, 3.9500349025307065E+02_dp, & -3.1942180687176204E+02_dp, 2.4606495659517455E+02_dp, -1.5690263401286234E+02_dp, & - 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.8663851312283325E+03_dp, & + 6.5084151112193439E+01_dp, -1.2528409779731549E+01_dp, 3.2752436692089077E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.8663851312283325E+03_dp, & -1.0423380612707174E+03_dp, 1.5483806206375675E+03_dp, -9.0806872083263704E+02_dp, & 9.4017350130709883E+02_dp, -1.2957349086372242E+03_dp, 1.2616460034642841E+03_dp, & -9.6943667338306091E+02_dp, 7.0087846283955878E+02_dp, -4.4162263728305550E+02_dp, & @@ -6123,8 +6126,8 @@ CONTAINS 2.6878483032699012E+02_dp, 5.8309882443897629E+02_dp, 6.7807520171925752E-05_dp, & -3.0064117576976992E+02_dp, 3.6682509804999006E+02_dp, -3.7040717157728307E+02_dp, & 1.3406424149107912E+02_dp, 6.4428398410363116E+02_dp, -2.1519786183493156E+03_dp, & - 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp] - REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = [-2.7780629763055545E+03_dp, & + 4.1011295900086225E+03_dp, -5.4383331157833045E+03_dp, 4.9469571799236483E+03_dp/) + REAL(KIND=dp), DIMENSION(80), PARAMETER :: c06 = (/-2.7780629763055545E+03_dp, & 7.2394748688135314E+02_dp, 1.4141872703259592E+03_dp, 1.9924393057961005E-04_dp, & -8.8514298674834572E+02_dp, 1.0799982553752052E+03_dp, -1.0299886964497700E+03_dp, & 2.4613962885626509E+02_dp, 2.1496502911088132E+03_dp, -6.6513723885247055E+03_dp, & @@ -6151,9 +6154,9 @@ CONTAINS 4.3939694879051335E+06_dp, 2.2270474259830317E+06_dp, -1.4748142024036435E+07_dp, & 2.4772021603756029E+07_dp, -2.0427694973111704E+07_dp, -5.1425641553283399E+06_dp, & 4.1035528362137891E+07_dp, -5.8536317653180525E+07_dp, 4.1604269769282125E+07_dp, & - -1.2580153353393231E+07_dp] + -1.2580153353393231E+07_dp/) REAL(KIND=dp), DIMENSION(13, 32, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 32, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 32, 5/)) INTEGER :: irange @@ -6200,7 +6203,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 34) :: fit_coef - REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = [1.8370815219029825E+05_dp, & + REAL(KIND=dp), DIMENSION(252), PARAMETER :: c07 = (/1.8370815219029825E+05_dp, & -2.2571407833669311E+05_dp, 1.9425009817913763E+05_dp, -1.0472915274294355E+05_dp, & 2.6504347685948280E+04_dp, 4.7817002324082285E+04_dp, 2.5450661362359097E-02_dp, & -6.6225824542394374E+04_dp, 8.1048394804074065E+04_dp, -4.3435260565217926E+04_dp, & @@ -6284,8 +6287,8 @@ CONTAINS -5.8978754757524757E+06_dp, 7.2176798918735152E+06_dp, 3.1998615207433747E+06_dp, & -2.2851538821395889E+07_dp, 3.8978847055747673E+07_dp, -3.3766691905692071E+07_dp, & -3.6817494449235639E+06_dp, 5.8417659409558006E+07_dp, -8.7460434017794341E+07_dp, & - 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.3076079314075767E-01_dp, & + 6.4007727007001713E+07_dp, -1.9852653644652657E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.3076079314075767E-01_dp, & -3.1204465976027999E-02_dp, -1.7122144125202067E-03_dp, 7.1244719472004776E-04_dp, & 9.7914036643084913E-05_dp, -1.6905608998459976E-05_dp, -7.4913349592830019E-05_dp, & 3.9524844540922514E-04_dp, -1.3207548101866621E-03_dp, 2.4893343556511901E-03_dp, & @@ -6418,8 +6421,8 @@ CONTAINS -7.2938082345320598E-01_dp, 1.1849370069427336E+00_dp, 3.0981138444088945E+01_dp, & -3.2826924199015650E+01_dp, 1.8061271201881183E+01_dp, -5.9402359654032049E+00_dp, & 1.0560336370860732E+00_dp, -1.3076665170325774E-03_dp, -9.1952845171647243E-02_dp, & - 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-1.2901998665259486E+00_dp, & + 2.9356117158718775E-01_dp, -9.6956307740968917E-01_dp, 1.8269216521737346E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-1.2901998665259486E+00_dp, & -1.1234438324718303E+00_dp, 1.8249388295785653E+00_dp, 5.3052663877251987E+01_dp, & -5.6300287553126552E+01_dp, 3.1510803678504963E+01_dp, -1.0839542135686512E+01_dp, & 2.1894315183922908E+00_dp, -1.2602122478496375E-01_dp, -1.3889457312206924E-01_dp, & @@ -6552,8 +6555,8 @@ CONTAINS -2.5103650595979259E+00_dp, 4.0981205243496870E+00_dp, -1.9744886540859123E+00_dp, & 2.7900551212540414E-01_dp, 3.9609099066905094E-02_dp, 4.9480572244963817E+01_dp, & -1.0554295952164991E+02_dp, 9.7784802913758284E+01_dp, -3.3609900633466118E+01_dp, & - -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [-6.8292295875978279E+00_dp, & + -1.6293722769181993E+01_dp, 1.6978324437699740E+01_dp, 2.3989997683487170E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/-6.8292295875978279E+00_dp, & -2.5859581635928466E+00_dp, 8.2643295812249669E+00_dp, -5.7320634779870945E+00_dp, & 1.7650956249120218E+00_dp, -1.9567508222089966E-01_dp, 7.7834138139689216E+01_dp, & -1.8267266020330240E+02_dp, 1.9349073152056008E+02_dp, -9.1481588588459843E+01_dp, & @@ -6686,8 +6689,8 @@ CONTAINS -2.8967923413102912E+00_dp, 1.3681886836307373E+00_dp, 1.3955776856915574E+00_dp, & -1.5897239290899864E-01_dp, -2.5212216600023445E+00_dp, 2.8219668706971945E+00_dp, & -1.3307700093912902E+00_dp, 2.4913514170866757E-01_dp, 3.6963550418790938E+01_dp, & - -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-6.7963494820353745E+00_dp, & + -4.2781735704421529E+01_dp, 1.1468857291085394E+01_dp, 1.1956021064279158E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-6.7963494820353745E+00_dp, & -5.2037548606327730E+00_dp, 4.1015955423288375E+00_dp, 2.6719939603737344E+00_dp, & -2.0314435192987417E+00_dp, -3.5279015440942261E+00_dp, 5.3011832033957269E+00_dp, & -2.8122613024625087E+00_dp, 5.6915484145040629E-01_dp, 6.4926664043803811E+01_dp, & @@ -6820,8 +6823,8 @@ CONTAINS -8.6651521700026635E-01_dp, 4.9374292598778025E-01_dp, 3.4952603809371302E-01_dp, & -1.7396151407323862E-01_dp, -2.5934913691469813E-01_dp, 9.2007238929733004E-02_dp, & 3.3903391371774966E-01_dp, -4.2381412446029582E-01_dp, 2.1088118199107522E-01_dp, & - -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.2539604263036663E+00_dp, & + -4.1855791726591811E-02_dp, 3.8884987212805058E-04_dp, 1.1321884964418704E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.2539604263036663E+00_dp, & -1.7332279212896191E+00_dp, 1.2863899425408518E+00_dp, 7.2978346101421798E-01_dp, & -5.0542068060802536E-01_dp, -5.6453129220842824E-01_dp, 2.6844891959416117E-01_dp, & 8.2065620557106000E-01_dp, -1.1421990003730462E+00_dp, 6.4148861901481036E-01_dp, & @@ -6954,8 +6957,8 @@ CONTAINS 1.8297112165331673E+04_dp, 2.0796368651156318E+00_dp, -7.1211773323306998E-02_dp, & -6.5222594833814318E-02_dp, 2.4758880150403027E-02_dp, -2.6172471480240402E-02_dp, & 4.2607134478414486E-02_dp, -4.9952200375915141E-02_dp, 5.1244059328384543E-02_dp, & - -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [1.0378429926308540E-02_dp, & + -5.0035111663177034E-02_dp, 4.1920311429239167E-02_dp, -2.6111046961287777E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/1.0378429926308540E-02_dp, & -1.9521878957809889E-03_dp, 2.6944073713370376E+00_dp, -1.3634250253884062E-01_dp, & -1.2248962009310110E-01_dp, 5.1739894797576326E-02_dp, -4.9861795300424228E-02_dp, & 8.1764747263490686E-02_dp, -9.6628896510658951E-02_dp, 9.8409054684497427E-02_dp, & @@ -7088,9 +7091,9 @@ CONTAINS -6.0517025375512349E+04_dp, 5.4074356432769353E+04_dp, -3.0109150792826324E+04_dp, & 7.8344472467430223E+03_dp, 1.3254579477277694E+04_dp, 5.1532479271565908E-03_dp, & -1.3351228791461199E+04_dp, 1.6339623735533780E+04_dp, -1.2301930953556473E+04_dp, & - -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp] + -3.6684681819111252E+03_dp, 4.2559142880279360E+04_dp, -1.0831862123749210E+05_dp/) REAL(KIND=dp), DIMENSION(13, 34, 6), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07], [13, 34, 6]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07/), (/13, 34, 6/)) INTEGER :: irange @@ -7142,7 +7145,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 36) :: fit_coef - REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = [-4.2209902072425757E+02_dp, & + REAL(KIND=dp), DIMENSION(340), PARAMETER :: c06 = (/-4.2209902072425757E+02_dp, & 1.1367036683435998E+02_dp, 2.4004100563047302E+02_dp, 2.6442809338541683E-05_dp, & -9.2920139462935452E+01_dp, 1.1857226657184384E+02_dp, -1.3712334751086243E+02_dp, & 8.9614212066663356E+01_dp, 1.2954531399327851E+02_dp, -6.1204117014894439E+02_dp, & @@ -7255,8 +7258,8 @@ CONTAINS 2.7482124839381648E+00_dp, -1.0319720350104814E+07_dp, 1.3167559540232308E+07_dp, & 5.3141307787938649E+06_dp, -4.2806172437992170E+07_dp, 7.7700737994820118E+07_dp, & -7.6880123309893116E+07_dp, 1.7343391064140473E+07_dp, 7.7860350009209916E+07_dp, & - -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.8104907156518354E-01_dp, & + -1.3364460712376091E+08_dp, 1.0093529309506236E+08_dp, -3.1433866759847842E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.8104907156518354E-01_dp, & -6.1817005353024562E-02_dp, -1.5365071642354823E-02_dp, 9.1489217818269322E-03_dp, & 4.9967787273344161E-03_dp, -3.5367914652488903E-03_dp, -2.2075007488833458E-03_dp, & 1.2029276142200300E-03_dp, 2.8328851353903797E-03_dp, -3.4438772536686739E-03_dp, & @@ -7389,8 +7392,8 @@ CONTAINS 1.0488104966880156E+01_dp, -1.6444555466331974E+00_dp, 1.2763045722861104E+02_dp, & -3.2766564765272250E+02_dp, 3.7973217630740623E+02_dp, -1.9781100978811261E+02_dp, & -3.0157621574998899E+01_dp, 9.3237621383503154E+01_dp, -1.4664555123007290E+01_dp, & - -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-5.0683586321199940E+01_dp, & + -3.8610014643549675E+01_dp, 1.9561581150219733E+00_dp, 4.9178714877907694E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-5.0683586321199940E+01_dp, & 2.2685614985361322E+01_dp, -4.0911306259362732E+00_dp, 2.0692715444769155E+02_dp, & -5.7784708851700361E+02_dp, 7.5313473849594516E+02_dp, -4.9591356082585395E+02_dp, & 4.6934746915158954E+01_dp, 1.7278593891248715E+02_dp, -7.9461883488471031E+01_dp, & @@ -7523,8 +7526,8 @@ CONTAINS 1.7192575597177209E-01_dp, -1.9796532433429683E+00_dp, 1.9593380309152029E+00_dp, & -8.5836023264597161E-01_dp, 1.5125817632192159E-01_dp, 3.3681131542986975E+01_dp, & -3.4585438137019239E+01_dp, 6.9509291872553263E+00_dp, 9.6987345107099117E+00_dp, & - -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [2.0123022827718544E+00_dp, & + -4.0173741038954836E+00_dp, -4.2756064482503922E+00_dp, 2.4041920018559479E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/2.0123022827718544E+00_dp, & -5.8064769221536761E-01_dp, -3.3561931133425400E+00_dp, 3.9944119179735149E+00_dp, & -1.9296809249289084E+00_dp, 3.6684710023030970E-01_dp, 5.8314392583364203E+01_dp, & -6.9071915064420764E+01_dp, 2.0273316780786242E+01_dp, 1.8091276263426014E+01_dp, & @@ -7657,8 +7660,8 @@ CONTAINS -1.2172815962913154E-02_dp, -4.0308427219634048E-02_dp, 7.7287143244938123E-03_dp, & 4.0019771312533585E-02_dp, -3.7854821497454338E-02_dp, 1.0769335283667015E-02_dp, & 1.9476127553671263E-03_dp, -1.2801087884499606E-03_dp, 3.6694426304025538E+00_dp, & - -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [1.3124621600522313E-01_dp, & + -7.3185799640057625E-01_dp, -3.6064251381359935E-01_dp, 1.4504547183962732E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/1.3124621600522313E-01_dp, & -4.3574928379419176E-02_dp, -8.9899230702256708E-02_dp, 2.4290637640954200E-02_dp, & 9.8569915866746516E-02_dp, -1.0636170473106374E-01_dp, 4.0918764154109298E-02_dp, & -1.9272580657675622E-03_dp, -1.9052149763963443E-03_dp, 5.9890800326505680E+00_dp, & @@ -7791,8 +7794,8 @@ CONTAINS -1.9257015318780568E+03_dp, 3.2472036360073544E+03_dp, -1.9642544031850207E+03_dp, & 1.8422466462758632E+03_dp, -2.5561629910519391E+03_dp, 2.5895289445906710E+03_dp, & -2.0116564542023402E+03_dp, 1.4283611462124322E+03_dp, -8.9489172870925711E+02_dp, & - 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-1.4073380941871266E+04_dp, & + 3.8577334167655448E+02_dp, -7.8417479541745152E+01_dp, 1.8326761523831301E+04_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-1.4073380941871266E+04_dp, & -5.4884212128021491E+03_dp, 1.3338114839397269E+04_dp, -9.1704389994968824E+03_dp, & 6.9234192947715492E+03_dp, -8.9848495511906458E+03_dp, 9.4904838722939803E+03_dp, & -7.0131996973248588E+03_dp, 4.2053129160131894E+03_dp, -2.2892321189981762E+03_dp, & @@ -7925,9 +7928,9 @@ CONTAINS 4.8018190809835360E+01_dp, 1.1735957000719010E+02_dp, 1.0796734300526574E-05_dp, & -3.7912420090540877E+01_dp, 4.8378813528148328E+01_dp, -5.7435863659353501E+01_dp, & 4.0377808851989506E+01_dp, 4.5658311276489918E+01_dp, -2.3911739347016501E+02_dp, & - 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp] + 5.2031388028459696E+02_dp, -7.4739624739763394E+02_dp, 7.1994201689992678E+02_dp/) REAL(KIND=dp), DIMENSION(13, 36, 5), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06], [13, 36, 5]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06/), (/13, 36, 5/)) INTEGER :: irange @@ -7974,7 +7977,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 38) :: fit_coef - REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = [1.0499223216920694E+01_dp, & + REAL(KIND=dp), DIMENSION(164), PARAMETER :: c08 = (/1.0499223216920694E+01_dp, & 4.4951728164305678E+00_dp, -4.0844623976889828E+01_dp, 9.6469089733765301E+01_dp, & -1.4457308237433509E+02_dp, 1.4358591897299843E+02_dp, -8.6337055270254567E+01_dp, & 2.3772804326078404E+01_dp, 6.6359118115924133E+01_dp, -2.8591296818375736E-06_dp, & @@ -8029,8 +8032,8 @@ CONTAINS 2.1377543596431356E+07_dp, 7.5558560062402077E+06_dp, -6.6595246625963897E+07_dp, & 1.2300183044218574E+08_dp, -1.2663664724774376E+08_dp, 4.1031313200280927E+07_dp, & 1.0283971430652012E+08_dp, -1.9310895904024291E+08_dp, 1.5058167673706385E+08_dp, & - -4.7897275226966202E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4159553890012480E-01_dp, & + -4.7897275226966202E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4159553890012480E-01_dp, & -3.2212259532342614E-02_dp, -2.5211569112270739E-03_dp, 1.0259263161798598E-03_dp, & 1.7009451604343799E-04_dp, -7.4233588848268952E-05_dp, -1.4091849072407304E-05_dp, & 8.9792205912272354E-06_dp, -6.1068721080120308E-07_dp, 2.3673956901460579E-06_dp, & @@ -8163,8 +8166,8 @@ CONTAINS -9.8650715039269197E-04_dp, 8.4812423349403076E-04_dp, 1.9235334619586016E+01_dp, & -2.1430578544580889E+01_dp, 1.0935348023770239E+01_dp, -2.5703290931021043E+00_dp, & -9.3684439339661404E-02_dp, 1.9608483863631485E-01_dp, -1.2873315513389102E-02_dp, & - -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [-8.1899012855183456E-04_dp, & + -1.6635857332202259E-02_dp, 1.3017736724714114E-03_dp, 3.0919884927816301E-03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/-8.1899012855183456E-04_dp, & -1.3697632531141069E-03_dp, 1.2268039489488590E-03_dp, 2.6982367118180953E+01_dp, & -3.2203467268313922E+01_dp, 1.8094671738936693E+01_dp, -5.1291575498824864E+00_dp, & 2.2721945369117036E-01_dp, 3.0848319451415068E-01_dp, -5.4944705448018556E-02_dp, & @@ -8297,8 +8300,8 @@ CONTAINS 3.2103644959620231E-02_dp, -1.4486824002301485E-01_dp, 1.2355203927413878E-01_dp, & -4.8092052541477776E-02_dp, 7.5259001655546970E-03_dp, 4.4383894095260246E+00_dp, & -3.5679718788094252E+00_dp, 5.1476908985660208E-01_dp, 8.0172648142794001E-01_dp, & - -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4079316176694362E-01_dp, & + -2.2976447620038551E-01_dp, -3.2956771002295171E-01_dp, 1.2448866609398915E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4079316176694362E-01_dp, & 1.0204817722398823E-02_dp, -2.5165636141352937E-01_dp, 2.5091425850523480E-01_dp, & -1.0907652615992168E-01_dp, 1.8995561214566335E-02_dp, 6.6017064494743369E+00_dp, & -6.3396206574849705E+00_dp, 1.4645915581906761E+00_dp, 1.3567138102239846E+00_dp, & @@ -8431,8 +8434,8 @@ CONTAINS 4.7301818737714882E+02_dp, 1.3863635256023798E+02_dp, -2.1631236718932931E+02_dp, & -9.4803921196274686E+01_dp, 2.5426811844807858E+02_dp, -1.6576110763951490E+02_dp, & 4.7407189814529652E+01_dp, -4.5099294020295337E+00_dp, 2.9586882462973167E+03_dp, & - -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-9.1855299569510419E+02_dp, & + -6.6390589153338169E+03_dp, 6.6755402509804217E+03_dp, -2.7894432451376142E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-9.1855299569510419E+02_dp, & 1.5086598025400613E+03_dp, -1.6982251398122094E+02_dp, -5.5006675710728985E+02_dp, & 8.6766882152744344E+01_dp, 4.7256010495026828E+02_dp, -4.6889366551390941E+02_dp, & 1.9581559031410015E+02_dp, -3.2716661828879559E+01_dp, 6.2548032409521911E+03_dp, & @@ -8565,8 +8568,8 @@ CONTAINS -5.9070868285783193E+00_dp, 7.0462234223485760E+00_dp, 2.3163307108458544E+00_dp, & -3.1353286429629565E+00_dp, -1.8613396596490337E+00_dp, 1.7553943424387961E+00_dp, & 3.1455571650317942E+00_dp, -5.5222826187397756E+00_dp, 3.6478129213769028E+00_dp, & - -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-4.3207068963149325E+01_dp, & + -1.1619081276403027E+00_dp, 1.4446834803157857E-01_dp, 7.5710886366993023E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-4.3207068963149325E+01_dp, & -1.0554104925448858E+01_dp, 1.6886407464491334E+01_dp, 3.8180534827516577E+00_dp, & -7.9351781128404237E+00_dp, -3.3784899123822600E+00_dp, 4.6319521704833901E+00_dp, & 6.7239240450100590E+00_dp, -1.3642372104076109E+01_dp, 9.8589344031369794E+00_dp, & @@ -8699,8 +8702,8 @@ CONTAINS -2.0360724244160395E-04_dp, 7.8600093766184087E-01_dp, -2.7552722482330382E-02_dp, & -2.4320818015224920E-02_dp, 9.3274629486534248E-03_dp, -9.2079352354389778E-03_dp, & 1.5452692636155842E-02_dp, -1.8450575101340298E-02_dp, 1.9063757888167280E-02_dp, & - -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [4.0992188628857576E-03_dp, & + -1.8832830863784338E-02_dp, 1.6057085510439863E-02_dp, -1.0174585816282621E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/4.0992188628857576E-03_dp, & -7.7827564716362676E-04_dp, 1.5427835617899610E+00_dp, -6.9505394993586406E-02_dp, & -6.0594885888198051E-02_dp, 2.4860739271249380E-02_dp, -2.3168221093078572E-02_dp, & 3.9027511015698728E-02_dp, -4.6867833756562442E-02_dp, 4.8230445510777237E-02_dp, & @@ -8833,8 +8836,8 @@ CONTAINS 5.4224742270029606E+02_dp, -3.5283793388597093E+02_dp, 1.4803941533425319E+02_dp, & -2.8871200173717554E+01_dp, 5.6772385530114016E+03_dp, -2.9062895360890998E+03_dp, & -1.7148517487548181E+03_dp, 2.2947989851698503E+03_dp, -1.3525758366401831E+03_dp, & - 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-1.8635835707916260E+03_dp, & + 1.5626038948903565E+03_dp, -2.1964155478564353E+03_dp, 2.2203872701695277E+03_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-1.8635835707916260E+03_dp, & 1.4615094004676805E+03_dp, -9.4860776301801513E+02_dp, 4.0324630910185732E+02_dp, & -7.9802696400978931E+01_dp, 1.4580340019039370E+04_dp, -8.9648221759975659E+03_dp, & -4.7160531127075310E+03_dp, 7.7970756952852253E+03_dp, -4.7953125668139064E+03_dp, & @@ -8967,9 +8970,9 @@ CONTAINS 1.6548760224475922E+00_dp, -1.7934154017551453E+01_dp, 4.3051248399276048E+01_dp, & -6.4961623842017133E+01_dp, 6.4774151275958900E+01_dp, -3.9049982184732009E+01_dp, & 1.0772159604979572E+01_dp, 3.5239797671962883E+01_dp, -1.2791831843911305E-06_dp, & - -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp] + -7.7116293148741368E+00_dp, 9.9038942846037248E+00_dp, -1.2509090324776968E+01_dp/) REAL(KIND=dp), DIMENSION(13, 38, 6), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 38, 6]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 38, 6/)) INTEGER :: irange @@ -9021,7 +9024,7 @@ CONTAINS REAL(KIND=dp) :: Rc, L_b, U_b REAL(KIND=dp), DIMENSION(13, 40) :: fit_coef - REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = [3.4482542694423209E+03_dp, & + REAL(KIND=dp), DIMENSION(320), PARAMETER :: c08 = (/3.4482542694423209E+03_dp, & 9.3380638606834109E+03_dp, -3.6141948437832449E+04_dp, 7.3811576243227406E+04_dp, & -1.0360614380245237E+05_dp, 9.9273882530972987E+04_dp, -5.8503038150581720E+04_dp, & 1.5941507970166829E+04_dp, 1.9245609411100908E+04_dp, 1.5758311389454111E-03_dp, & @@ -9128,8 +9131,8 @@ CONTAINS 3.4369174208174527E+07_dp, 1.0603207649981629E+07_dp, -1.0297545596222048E+08_dp, & 1.9337680822524059E+08_dp, -2.0606965563558266E+08_dp, 8.3351497204227954E+07_dp, & 1.3400532965008634E+08_dp, -2.7949474181137478E+08_dp, 2.2551932538988832E+08_dp, & - -7.3358489823807165E+07_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = [1.4818427186393188E-01_dp, & + -7.3358489823807165E+07_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c01 = (/1.4818427186393188E-01_dp, & -3.9684125490741781E-02_dp, -4.5544691512272280E-03_dp, 2.2868531356116861E-03_dp, & 5.4988095348367525E-04_dp, -3.2090841260734175E-04_dp, -9.2010045248866118E-05_dp, & 6.1214638366653809E-05_dp, 2.2665438652455234E-05_dp, -1.8900573386763588E-05_dp, & @@ -9262,8 +9265,8 @@ CONTAINS -5.9740661993351847E-03_dp, 1.4691884865455198E-03_dp, 1.7073926981017319E+01_dp, & -2.1963630226832553E+01_dp, 1.2134829552891802E+01_dp, -2.2528424944623944E+00_dp, & -9.3240764730384440E-01_dp, 4.6660358949448766E-01_dp, 1.0216844176487623E-01_dp, & - -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = [5.9915911031709962E-03_dp, & + -9.3824494827588173E-02_dp, -1.3105510915164605E-02_dp, 1.7849498315239853E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c02 = (/5.9915911031709962E-03_dp, & -8.6423694074923528E-03_dp, 2.4291300518560965E-03_dp, 2.4071366084770816E+01_dp, & -3.3716515170389293E+01_dp, 2.0906788438349480E+01_dp, -5.2492585742829574E+00_dp, & -1.0597221453010373E+00_dp, 9.1826115756590143E-01_dp, 5.3116568030487622E-02_dp, & @@ -9396,8 +9399,8 @@ CONTAINS 1.2466570600707088E-02_dp, -1.3874197741980808E-02_dp, 4.1907856070478042E-03_dp, & 7.5271368574731106E-04_dp, -5.1647877466666774E-04_dp, 1.7444005611942730E+00_dp, & -5.6824316669549102E-01_dp, -9.5567270387908632E-02_dp, 9.5953975937291464E-02_dp, & - 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = [1.4012464467116794E-02_dp, & + 2.9440932840795256E-02_dp, -3.7050946327260699E-02_dp, -1.2287347330040912E-02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c03 = (/1.4012464467116794E-02_dp, & 1.7870937744543961E-02_dp, -2.8284778305657239E-02_dp, 1.4614940139686226E-02_dp, & -2.7014027690474133E-03_dp, -7.8952988099918739E-05_dp, 2.2522270551584125E+00_dp, & -9.9237513069804251E-01_dp, -7.1665511461607434E-02_dp, 1.9968203248776958E-01_dp, & @@ -9530,8 +9533,8 @@ CONTAINS -1.7263628579210469E+01_dp, 1.2547672408466081E+01_dp, 8.4591865266308197E+00_dp, & -5.6249151706448863E+00_dp, -1.1592672327907211E+01_dp, 1.6508808139297699E+01_dp, & -8.5771693846067460E+00_dp, 1.7125060439946929E+00_dp, 2.3966601282404417E+02_dp, & - -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = [-5.7499561390798192E+01_dp, & + -2.9090772769614887E+02_dp, 9.4528375241536281E+01_dp, 7.5979855023555004E+01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c04 = (/-5.7499561390798192E+01_dp, & -2.8667295698939792E+01_dp, 3.3623712254987076E+01_dp, 1.4613232172192909E+01_dp, & -2.2425748408516260E+01_dp, -1.0625183610714041E+01_dp, 2.7811282349984850E+01_dp, & -1.6721270864181005E+01_dp, 3.6190172602275243E+00_dp, 4.3864077011236401E+02_dp, & @@ -9664,8 +9667,8 @@ CONTAINS -7.3049415971812165E-02_dp, 1.6928103093679515E-02_dp, 1.8417725387954376E-02_dp, & -1.9453592218161570E-03_dp, -1.1634328023640639E-02_dp, 3.4714019819061617E-03_dp, & 5.3490931351907831E-03_dp, -3.1907950343243647E-03_dp, -1.4616713023815479E-03_dp, & - 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = [-3.2389785098025670E-01_dp, & + 1.8903207684751867E-03_dp, -5.1679973398017858E-04_dp, 2.4951739894697100E+00_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c05 = (/-3.2389785098025670E-01_dp, & -1.5588421416935677E-01_dp, 4.6469218783312088E-02_dp, 4.1557942308222309E-02_dp, & -7.5142092188104671E-03_dp, -2.6806031107589168E-02_dp, 9.2275566818059377E-03_dp, & 1.3149892067901462E-02_dp, -9.4462212865469193E-03_dp, -1.9880182010796601E-03_dp, & @@ -9798,8 +9801,8 @@ CONTAINS 1.1110268324191310E+01_dp, 2.6853251507125306E+03_dp, -2.6690269182691513E+03_dp, & 7.2463711925762794E+01_dp, 1.2014230806845137E+03_dp, -2.9322356189139873E+02_dp, & -4.8871486180307096E+02_dp, 8.0189444854946785E+01_dp, 3.5253998447998373E+02_dp, & - -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = [-2.2712994716763473E+02_dp, & + -4.4344999858279763E+00_dp, -4.9961491943629647E+02_dp, 5.1183627581614923E+02_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c06 = (/-2.2712994716763473E+02_dp, & 4.0385181038065113E+01_dp, 6.0197819306524152E+03_dp, -6.9664015206915119E+03_dp, & 8.8000828312450119E+02_dp, 3.2181044508507798E+03_dp, -1.3451011011345620E+03_dp, & -1.2427951210535916E+03_dp, 5.4994829125785282E+02_dp, 9.7855377199584927E+02_dp, & @@ -9932,8 +9935,8 @@ CONTAINS 1.6768202331832444E-01_dp, -1.0515504828494937E-01_dp, 4.2563447502959498E-02_dp, & -8.2219895159869709E-03_dp, 9.5923398264069970E+00_dp, -9.1351432511338171E-01_dp, & -7.2002060302993121E-01_dp, 3.4478262562537942E-01_dp, -2.6236445928893765E-01_dp, & - 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp] - REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = [-4.3224032563729953E-01_dp, & + 4.1080033835374796E-01_dp, -4.7515478577796189E-01_dp, 4.6235013115468138E-01_dp/) + REAL(KIND=dp), DIMENSION(400), PARAMETER :: c07 = (/-4.3224032563729953E-01_dp, & 3.5758483946236974E-01_dp, -2.2431923396808751E-01_dp, 9.0777959192790053E-02_dp, & -1.7518061809443625E-02_dp, 1.6725498665042689E+01_dp, -1.9435939058523524E+00_dp, & -1.5082483802542699E+00_dp, 7.7123067496772879E-01_dp, -5.6050187357065773E-01_dp, & @@ -10066,9 +10069,9 @@ CONTAINS 2.5970516090366850E+03_dp, -1.1583854023864891E+04_dp, 2.4553873694398699E+04_dp, & -3.5160886963347439E+04_dp, 3.4138635891960170E+04_dp, -2.0309554368209294E+04_dp, & 5.5733463618645619E+03_dp, 7.3092031064017010E+03_dp, 4.9005183646288716E-04_dp, & - -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp] + -5.1024325120903641E+03_dp, 6.5955046072210243E+03_dp, -6.8957569912961944E+03_dp/) REAL(KIND=dp), DIMENSION(13, 40, 6), PARAMETER :: & - coefdata = RESHAPE([c01, c02, c03, c04, c05, c06, c07, c08], [13, 40, 6]) + coefdata = RESHAPE((/c01, c02, c03, c04, c05, c06, c07, c08/), (/13, 40, 6/)) INTEGER :: irange @@ -10163,7 +10166,7 @@ CONTAINS E_ratio = 1.0_dp END IF aw(:) = aw(:)/E_ratio - END SUBROUTINE rescale_grid + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -10181,7 +10184,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 799.0_dp) THEN E_ratio = 799.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13642311899920728_dp, & 0.4200545572769177_dp, & 0.7370807753440111_dp, & @@ -10233,9 +10236,9 @@ CONTAINS 175.19453971323657_dp, & 301.19411259128674_dp, & 645.6383267719649_dp, & - 2472.504957810595_dp] + 2472.504957810595_dp/) ELSE IF (E_range < 995.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13925292153649474_dp, & 0.4292451559612877_dp, & 0.7548554587233549_dp, & @@ -10287,9 +10290,9 @@ CONTAINS 211.68822580031673_dp, & 364.5832859080767_dp, & 780.7919711700442_dp, & - 2983.4784258039044_dp] + 2983.4784258039044_dp/) ELSE IF (E_range < 1293.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14255313239112444_dp, & 0.44000221057671707_dp, & 0.7757923584694003_dp, & @@ -10341,9 +10344,9 @@ CONTAINS 265.33605383413214_dp, & 458.1910477032067_dp, & 980.4158381921823_dp, & - 3736.258588894085_dp] + 3736.258588894085_dp/) ELSE IF (E_range < 1738.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1461752355773306_dp, & 0.45185762356828396_dp, & 0.7990360544025357_dp, & @@ -10395,9 +10398,9 @@ CONTAINS 342.31559687568875_dp, & 593.3221880856304_dp, & 1268.7961696472178_dp, & - 4820.528614472729_dp] + 4820.528614472729_dp/) ELSE IF (E_range < 2238.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1491837006061548_dp, & 0.46174475862674996_dp, & 0.8185592742668346_dp, & @@ -10449,9 +10452,9 @@ CONTAINS 425.4335136047249_dp, & 740.2128400786926_dp, & 1582.657563073928_dp, & - 5997.255668095278_dp] + 5997.255668095278_dp/) ELSE IF (E_range < 3009.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15260234927102537_dp, & 0.47302539641929003_dp, & 0.840991102837249_dp, & @@ -10503,9 +10506,9 @@ CONTAINS 548.3643432689413_dp, & 959.1555990081102_dp, & 2051.35284281865_dp, & - 7749.544195896773_dp] + 7749.544195896773_dp/) ELSE IF (E_range < 4377.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15677016271388225_dp, & 0.4868453590049744_dp, & 0.8687054372436632_dp, & @@ -10557,9 +10560,9 @@ CONTAINS 755.1838770980437_dp, & 1331.5355795873638_dp, & 2851.124163900499_dp, & - 10729.678598478598_dp] + 10729.678598478598_dp/) ELSE IF (E_range < 6256.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16057542542593983_dp, & 0.49952962028824754_dp, & 0.8943731123892699_dp, & @@ -10611,9 +10614,9 @@ CONTAINS 1022.6891506041642_dp, & 1819.6861630933722_dp, & 3904.600906393468_dp, & - 14642.034530501202_dp] + 14642.034530501202_dp/) ELSE IF (E_range < 9034.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16432089011213946_dp, & 0.5120783448939726_dp, & 0.9199886972681118_dp, & @@ -10665,9 +10668,9 @@ CONTAINS 1393.996082618058_dp, & 2507.6502273684464_dp, & 5398.730047404666_dp, & - 20174.243482162154_dp] + 20174.243482162154_dp/) ELSE IF (E_range < 15564.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16955168876185606_dp, & 0.5297128492681893_dp, & 0.9563682595025127_dp, & @@ -10719,9 +10722,9 @@ CONTAINS 2193.7537015644107_dp, & 4023.287609783773_dp, & 8726.293698066565_dp, & - 32456.229019326278_dp] + 32456.229019326278_dp/) ELSE IF (E_range < 19500.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17161078656390408_dp, & 0.5366905364814994_dp, & 0.97088881076514_dp, & @@ -10773,9 +10776,9 @@ CONTAINS 2641.8070030495096_dp, & 4889.503800534578_dp, & 10648.322208945656_dp, & - 39537.49857015622_dp] + 39537.49857015622_dp/) ELSE IF (E_range < 22300.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1728061198835349_dp, & 0.5407506981101403_dp, & 0.9793714038026303_dp, & @@ -10827,9 +10830,9 @@ CONTAINS 2948.8741403686568_dp, & 5489.390378606207_dp, & 11987.379922744534_dp, & - 44468.08958434164_dp] + 44468.08958434164_dp/) ELSE IF (E_range < 24783.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1737308948597355_dp, & 0.5438966877521114_dp, & 0.9859610380912929_dp, & @@ -10881,9 +10884,9 @@ CONTAINS 3214.1964330189876_dp, & 6011.5393853613305_dp, & 13158.00196550311_dp, & - 48777.36298097777_dp] + 48777.36298097777_dp/) ELSE IF (E_range < 41198.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17799130240706984_dp, & 0.558445410809649_dp, & 1.0166297309491044_dp, & @@ -10935,9 +10938,9 @@ CONTAINS 4842.950527196566_dp, & 9285.588160319077_dp, & 20597.325965171356_dp, & - 76161.8596274348_dp] + 76161.8596274348_dp/) ELSE IF (E_range < 94407.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18427327646299554_dp, & 0.5800678142111884_dp, & 1.062813174396542_dp, & @@ -10989,9 +10992,9 @@ CONTAINS 9266.732583950343_dp, & 18647.213606093355_dp, & 42656.46566405554_dp, & - 157660.6216097217_dp] + 157660.6216097217_dp/) ELSE IF (E_range < 189080.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1889166187549335_dp, & 0.5961850834729495_dp, & 1.097718788260886_dp, & @@ -11043,9 +11046,9 @@ CONTAINS 15593.849284273198_dp, & 32917.0364973997_dp, & 78051.06376348506_dp, & - 289942.76429117593_dp] + 289942.76429117593_dp/) ELSE IF (E_range < 457444.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.194043824675455_dp, & 0.6141201650984125_dp, & 1.137056339966442_dp, & @@ -11097,9 +11100,9 @@ CONTAINS 29125.998944110084_dp, & 65928.95446339808_dp, & 166172.86831676983_dp, & - 628359.6031461136_dp] + 628359.6031461136_dp/) ELSE IF (E_range < 2101965.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.20097761439605452_dp, & 0.6386142361636943_dp, & 1.1916436123207983_dp, & @@ -11151,9 +11154,9 @@ CONTAINS 75639.29476513214_dp, & 196582.0757874882_dp, & 575257.5915715584_dp, & - 2362446.5347060743_dp] + 2362446.5347060743_dp/) ELSE IF (E_range < 14140999.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.20658002404396444_dp, & 0.6586140986839257_dp, & 1.2369737792708104_dp, & @@ -11205,9 +11208,9 @@ CONTAINS 186203.45469776812_dp, & 576894.7309753906_dp, & 2152261.8479348915_dp, & - 11566361.80487531_dp] + 11566361.80487531_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.20878089337233605_dp, & 0.6665236543193817_dp, & 1.2550931614146674_dp, & @@ -11259,9 +11262,9 @@ CONTAINS 277390.3096379278_dp, & 946568.3924295901_dp, & 4140822.150621181_dp, & - 30376446.323901277_dp] + 30376446.323901277_dp/) END IF - END SUBROUTINE get_coeff_26 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -11279,7 +11282,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 1545.0_dp) THEN E_ratio = 1545.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13575757270404953_dp, & 0.4178973639556045_dp, & 0.7329236428021971_dp, & @@ -11335,9 +11338,9 @@ CONTAINS 333.52874619054023_dp, & 573.9031161499247_dp, & 1229.5973040920514_dp, & - 4703.444164101694_dp] + 4703.444164101694_dp/) ELSE IF (E_range < 2002.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13875490228933057_dp, & 0.4276255171652803_dp, & 0.7517156037290086_dp, & @@ -11393,9 +11396,9 @@ CONTAINS 417.7474719630637_dp, & 720.4456660885186_dp, & 1542.1360738637661_dp, & - 5884.200372654236_dp] + 5884.200372654236_dp/) ELSE IF (E_range < 2600.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14170133198228974_dp, & 0.4372217263238123_dp, & 0.7703667410153948_dp, & @@ -11451,9 +11454,9 @@ CONTAINS 524.1575321727823_dp, & 906.5045080905089_dp, & 1939.0883159241562_dp, & - 7379.912745615771_dp] + 7379.912745615771_dp/) ELSE IF (E_range < 3300.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1443213439813841_dp, & 0.4457831750819166_dp, & 0.7871040955754438_dp, & @@ -11509,9 +11512,9 @@ CONTAINS 644.5187891323013_dp, & 1118.0760747835973_dp, & 2390.794104288915_dp, & - 9077.664025334678_dp] + 9077.664025334678_dp/) ELSE IF (E_range < 4000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14638817647917096_dp, & 0.4525562304919969_dp, & 0.8004113661058508_dp, & @@ -11567,9 +11570,9 @@ CONTAINS 761.3056079394062_dp, & 1324.411398249371_dp, & 2831.738972704671_dp, & - 10731.431828374814_dp] + 10731.431828374814_dp/) ELSE IF (E_range < 5000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14873276811274175_dp, & 0.4602604435552678_dp, & 0.8156202251610892_dp, & @@ -11625,9 +11628,9 @@ CONTAINS 923.1971063861915_dp, & 1612.0060664213056_dp, & 3447.1144071775916_dp, & - 13034.665823606138_dp] + 13034.665823606138_dp/) ELSE IF (E_range < 5800.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1502608626762777_dp, & 0.46529381929136415_dp, & 0.8255984287192656_dp, & @@ -11683,9 +11686,9 @@ CONTAINS 1049.2452864243335_dp, & 1837.0994387864066_dp, & 3929.4241467171732_dp, & - 14836.654624922767_dp] + 14836.654624922767_dp/) ELSE IF (E_range < 7000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15216067096721872_dp, & 0.471565223326128_dp, & 0.8380780093696487_dp, & @@ -11741,9 +11744,9 @@ CONTAINS 1233.5478315642981_dp, & 2167.935258865102_dp, & 4639.411026254049_dp, & - 17485.041970829057_dp] + 17485.041970829057_dp/) ELSE IF (E_range < 8500.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1540799216139811_dp, & 0.47791627634651673_dp, & 0.850769563354445_dp, & @@ -11799,9 +11802,9 @@ CONTAINS 1457.1994566202313_dp, & 2571.939694554795_dp, & 5508.2172091289185_dp, & - 20720.162172438253_dp] + 20720.162172438253_dp/) ELSE IF (E_range < 11000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15656226451877622_dp, & 0.4861541997731515_dp, & 0.8673131850431656_dp, & @@ -11857,9 +11860,9 @@ CONTAINS 1816.6489638049509_dp, & 3226.5521973584873_dp, & 6920.118346610322_dp, & - 25967.01374573565_dp] + 25967.01374573565_dp/) ELSE IF (E_range < 14000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15881564616129193_dp, & 0.4936556598653273_dp, & 0.8824588841815081_dp, & @@ -11915,9 +11918,9 @@ CONTAINS 2230.6304097502575_dp, & 3987.780431784136_dp, & 8568.294988757902_dp, & - 32079.26783423429_dp] + 32079.26783423429_dp/) ELSE IF (E_range < 18000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1610939781339949_dp, & 0.5012631407780889_dp, & 0.8978984268667602_dp, & @@ -11973,9 +11976,9 @@ CONTAINS 2759.7196504068343_dp, & 4970.842422998521_dp, & 10706.437123051388_dp, & - 39993.678157447954_dp] + 39993.678157447954_dp/) ELSE IF (E_range < 22000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16286202517738316_dp, & 0.5071829401058993_dp, & 0.9099691167949224_dp, & @@ -12031,9 +12034,9 @@ CONTAINS 3268.0690080523195_dp, & 5925.0502577809875_dp, & 12791.74491637296_dp, & - 47700.6553314684_dp] + 47700.6553314684_dp/) ELSE IF (E_range < 30000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16550588765942553_dp, & 0.516062009336416_dp, & 0.9281674926129342_dp, & @@ -12089,9 +12092,9 @@ CONTAINS 4236.78509184323_dp, & 7766.730019457065_dp, & 16842.450828736164_dp, & - 62648.76273159001_dp] + 62648.76273159001_dp/) ELSE IF (E_range < 40000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1678624984386396_dp, & 0.5240039277065677_dp, & 0.9445413343768262_dp, & @@ -12147,9 +12150,9 @@ CONTAINS 5379.192173747507_dp, & 9973.306180469173_dp, & 21737.4521360814_dp, & - 80688.08263620315_dp] + 80688.08263620315_dp/) ELSE IF (E_range < 55000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17036496307430077_dp, & 0.5324663182632273_dp, & 0.9620895318113227_dp, & @@ -12205,9 +12208,9 @@ CONTAINS 6988.303443289154_dp, & 13136.528535241805_dp, & 28826.90535778617_dp, & - 106792.5668680263_dp] + 106792.5668680263_dp/) ELSE IF (E_range < 75000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17269556592412857_dp, & 0.5403748964029321_dp, & 0.9785852679690707_dp, & @@ -12263,9 +12266,9 @@ CONTAINS 8991.001468037319_dp, & 17151.64888313862_dp, & 37936.68288424044_dp, & - 140330.3757792011_dp] + 140330.3757792011_dp/) ELSE IF (E_range < 100000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17476493191141415_dp, & 0.5474193940515534_dp, & 0.9933573948794411_dp, & @@ -12321,9 +12324,9 @@ CONTAINS 11326.739601304256_dp, & 21929.575378095506_dp, & 48923.087093047834_dp, & - 180801.94440922138_dp] + 180801.94440922138_dp/) ELSE IF (E_range < 140000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17707349703529857_dp, & 0.5553034658173043_dp, & 1.0099791730991756_dp, & @@ -12379,9 +12382,9 @@ CONTAINS 14783.538737749648_dp, & 29163.479733223845_dp, & 65827.4645722146_dp, & - 243179.26518144744_dp] + 243179.26518144744_dp/) ELSE IF (E_range < 200000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17939121623291196_dp, & 0.5632460962554191_dp, & 1.0268207360191903_dp, & @@ -12437,9 +12440,9 @@ CONTAINS 19511.673781213012_dp, & 39328.72129742758_dp, & 90071.79118231079_dp, & - 332938.41349157074_dp] + 332938.41349157074_dp/) ELSE IF (E_range < 280000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18145787532761345_dp, & 0.5703516980411364_dp, & 1.041969987100468_dp, & @@ -12495,9 +12498,9 @@ CONTAINS 25223.35236302233_dp, & 51966.7592745666_dp, & 120920.32428947231_dp, & - 447736.17541344964_dp] + 447736.17541344964_dp/) ELSE IF (E_range < 400000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18352365749998711_dp, & 0.5774767415391759_dp, & 1.0572402465072317_dp, & @@ -12553,9 +12556,9 @@ CONTAINS 32921.61554906603_dp, & 69533.14758216766_dp, & 164947.39394785516_dp, & - 612800.2731138045_dp] + 612800.2731138045_dp/) ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1865127174002091_dp, & 0.5878264119237888_dp, & 1.0795642254870847_dp, & @@ -12611,9 +12614,9 @@ CONTAINS 49336.106221828624_dp, & 108694.3328979675_dp, & 267237.7291173849_dp, & - 1002021.1700926761_dp] + 1002021.1700926761_dp/) ELSE IF (E_range < 1200000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18910898992309827_dp, & 0.5968553778314455_dp, & 1.099179600396227_dp, & @@ -12669,9 +12672,9 @@ CONTAINS 71590.44785506214_dp, & 164831.2803483035_dp, & 422312.83970923733_dp, & - 1607194.846517409_dp] + 1607194.846517409_dp/) ELSE IF (E_range < 2000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19132297837375925_dp, & 0.6045842212401715_dp, & 1.116075239909931_dp, & @@ -12727,9 +12730,9 @@ CONTAINS 100098.51304747425_dp, & 240936.64519318528_dp, & 645993.0255202315_dp, & - 2511145.760363479_dp] + 2511145.760363479_dp/) ELSE IF (E_range < 4500000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19436594608582472_dp, & 0.6152519388154075_dp, & 1.1395565637382394_dp, & @@ -12785,9 +12788,9 @@ CONTAINS 163720.9776403595_dp, & 424479.54068993696_dp, & 1238540.16298379_dp, & - 5075528.538071685_dp] + 5075528.538071685_dp/) ELSE IF (E_range < 10000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19682681061058516_dp, & 0.6239175967168831_dp, & 1.1587697829037367_dp, & @@ -12843,9 +12846,9 @@ CONTAINS 251532.47511127745_dp, & 702946.2892638468_dp, & 2257925.6950304266_dp, & - 10050972.42119658_dp] + 10050972.42119658_dp/) ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.20028753559878754_dp, & 0.636163845466183_dp, & 1.1861370761903154_dp, & @@ -12901,9 +12904,9 @@ CONTAINS 488713.1004068534_dp, & 1569108.161138_dp, & 6194788.779558858_dp, & - 36612022.104547605_dp] + 36612022.104547605_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.20148359962188625_dp, & 0.6404126846191118_dp, & 1.1956914499421463_dp, & @@ -12959,9 +12962,9 @@ CONTAINS 627349.5338890508_dp, & 2140772.611660053_dp, & 9364952.860952146_dp, & - 68700022.28914484_dp] + 68700022.28914484_dp/) END IF - END SUBROUTINE get_coeff_28 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -12980,7 +12983,7 @@ CONTAINS IF (E_range < 2906.0_dp) THEN E_ratio = 2906.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13472077973006066_dp, & 0.41454012407362284_dp, & 0.7264650127115554_dp, & @@ -13040,9 +13043,9 @@ CONTAINS 619.9912456625073_dp, & 1067.5959324975324_dp, & 2286.544806677275_dp, & - 8738.901002766614_dp] + 8738.901002766614_dp/) ELSE IF (E_range < 3236.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13585569926755156_dp, & 0.41821529920891193_dp, & 0.7335359382994969_dp, & @@ -13102,9 +13105,9 @@ CONTAINS 681.1401603164769_dp, & 1173.9561106510982_dp, & 2513.427330670278_dp, & - 9596.45252078042_dp] + 9596.45252078042_dp/) ELSE IF (E_range < 3810.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1375558839742156_dp, & 0.4237299246561157_dp, & 0.7441765936480988_dp, & @@ -13164,9 +13167,9 @@ CONTAINS 785.6426382482606_dp, & 1356.1465778665718_dp, & 2902.1064912290262_dp, & - 11063.595563099649_dp] + 11063.595563099649_dp/) ELSE IF (E_range < 4405.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13904406912216055_dp, & 0.4285658262322887_dp, & 0.7535381269110286_dp, & @@ -13226,9 +13229,9 @@ CONTAINS 891.8325474154066_dp, & 1541.8004917177743_dp, & 3298.2637895129933_dp, & - 12556.72637834854_dp] + 12556.72637834854_dp/) ELSE IF (E_range < 5400.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1410960680209205_dp, & 0.43524771510986004_dp, & 0.7665207024486466_dp, & @@ -13288,9 +13291,9 @@ CONTAINS 1065.3146704916662_dp, & 1846.16967438266_dp, & 3948.0236905716197_dp, & - 15001.510222225108_dp] + 15001.510222225108_dp/) ELSE IF (E_range < 6800.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1433674220737173_dp, & 0.4426628898148459_dp, & 0.7809932553639084_dp, & @@ -13350,9 +13353,9 @@ CONTAINS 1302.3421015152915_dp, & 2264.016465253404_dp, & 4840.7455216590715_dp, & - 18353.395351716823_dp] + 18353.395351716823_dp/) ELSE IF (E_range < 8400.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14540131106958792_dp, & 0.4493201231807535_dp, & 0.7940459513320671_dp, & @@ -13412,9 +13415,9 @@ CONTAINS 1565.1330028308446_dp, & 2729.7495636084445_dp, & 5836.893913938098_dp, & - 22085.748007810864_dp] + 22085.748007810864_dp/) ELSE IF (E_range < 10000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14704498509396693_dp, & 0.4547122051327194_dp, & 0.8046596707087634_dp, & @@ -13474,9 +13477,9 @@ CONTAINS 1820.9007070932764_dp, & 3185.3327939434785_dp, & 6812.567149441103_dp, & - 25734.79348292465_dp] + 25734.79348292465_dp/) ELSE IF (E_range < 12000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14873028953425532_dp, & 0.46025228447257244_dp, & 0.815604068464183_dp, & @@ -13536,9 +13539,9 @@ CONTAINS 2132.484724545273_dp, & 3743.164994620193_dp, & 8008.935958082978_dp, & - 30201.87390773344_dp] + 30201.87390773344_dp/) ELSE IF (E_range < 15000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15074658869167354_dp, & 0.4668958035836203_dp, & 0.8287813045866178_dp, & @@ -13598,9 +13601,9 @@ CONTAINS 2585.9493214732233_dp, & 4560.104639212192_dp, & 9764.47140618184_dp, & - 36744.78826999934_dp] + 36744.78826999934_dp/) ELSE IF (E_range < 20000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15327074211168326_dp, & 0.47523666558201105_dp, & 0.8454081293698346_dp, & @@ -13660,9 +13663,9 @@ CONTAINS 3312.4890760215126_dp, & 5880.358930845362_dp, & 12610.246229383727_dp, & - 47327.426186591925_dp] + 47327.426186591925_dp/) ELSE IF (E_range < 28000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15611582449200168_dp, & 0.484670676531795_dp, & 0.864327133672447_dp, & @@ -13722,9 +13725,9 @@ CONTAINS 4418.177298699454_dp, & 7913.127380453787_dp, & 17012.044780129974_dp, & - 63654.92138377425_dp] + 63654.92138377425_dp/) ELSE IF (E_range < 38000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1585986414808211_dp, & 0.49293227874864953_dp, & 0.8809949627642996_dp, & @@ -13784,9 +13787,9 @@ CONTAINS 5728.411572233089_dp, & 10353.785071731596_dp, & 22327.676016416055_dp, & - 83326.1396670659_dp] + 83326.1396670659_dp/) ELSE IF (E_range < 50000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16074983925508995_dp, & 0.5001125329781305_dp, & 0.895558007331798_dp, & @@ -13846,9 +13849,9 @@ CONTAINS 7222.917612404246_dp, & 13174.2778180717_dp, & 28509.267725054422_dp, & - 106160.2639173599_dp] + 106160.2639173599_dp/) ELSE IF (E_range < 64000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16262039381403579_dp, & 0.5063730793021797_dp, & 0.9083149017898943_dp, & @@ -13908,9 +13911,9 @@ CONTAINS 8885.07671917959_dp, & 16351.40165928286_dp, & 35518.56312434257_dp, & - 132016.67889946306_dp] + 132016.67889946306_dp/) ELSE IF (E_range < 84000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16461121992013572_dp, & 0.5130537467027886_dp, & 0.9219891409850267_dp, & @@ -13970,9 +13973,9 @@ CONTAINS 11143.129516033901_dp, & 20727.354533996564_dp, & 45246.467731381585_dp, & - 167864.82966862986_dp] + 167864.82966862986_dp/) ELSE IF (E_range < 110000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16651351865477473_dp, & 0.519454577907408_dp, & 0.9351507515667731_dp, & @@ -14032,9 +14035,9 @@ CONTAINS 13921.767968244894_dp, & 26195.561124088643_dp, & 57512.80156760765_dp, & - 213037.54770361463_dp] + 213037.54770361463_dp/) ELSE IF (E_range < 160000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1690396225959909_dp, & 0.527980783630836_dp, & 0.9527749551685267_dp, & @@ -14094,9 +14097,9 @@ CONTAINS 18902.03087469423_dp, & 36195.04534310194_dp, & 80228.85952678222_dp, & - 296685.58400527935_dp] + 296685.58400527935_dp/) ELSE IF (E_range < 220000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17108080746256005_dp, & 0.5348926066785868_dp, & 0.9671403722271738_dp, & @@ -14156,9 +14159,9 @@ CONTAINS 24425.382905474227_dp, & 47540.939727448866_dp, & 106401.9838008185_dp, & - 393145.5653859997_dp] + 393145.5653859997_dp/) ELSE IF (E_range < 370000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.174208015078396_dp, & 0.5455214527091232_dp, & 0.9893700986809595_dp, & @@ -14218,9 +14221,9 @@ CONTAINS 36827.67063798521_dp, & 73825.92204301585_dp, & 168436.45444117606_dp, & - 622444.873239739_dp] + 622444.873239739_dp/) ELSE IF (E_range < 520000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1761202582043389_dp, & 0.5520447609872519_dp, & 1.0030974507555772_dp, & @@ -14280,9 +14283,9 @@ CONTAINS 47901.44750228873_dp, & 98085.01445426073_dp, & 227192.3617986822_dp, & - 840731.2172617969_dp] + 840731.2172617969_dp/) ELSE IF (E_range < 700000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1777047921517639_dp, & 0.5574641492548221_dp, & 1.0145511230139452_dp, & @@ -14342,9 +14345,9 @@ CONTAINS 60011.99599547493_dp, & 125336.8664775516_dp, & 294698.3519483209_dp, & - 1092989.8333233916_dp] + 1092989.8333233916_dp/) ELSE IF (E_range < 1100000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1799647702096782_dp, & 0.5652158330702483_dp, & 1.0310122635781176_dp, & @@ -14404,9 +14407,9 @@ CONTAINS 83848.098471279_dp, & 180849.87459593892_dp, & 436512.7424947387_dp, & - 1628215.5545881148_dp] + 1628215.5545881148_dp/) ELSE IF (E_range < 1800000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1822263529525982_dp, & 0.5729996377421059_dp, & 1.047635792810745_dp, & @@ -14466,9 +14469,9 @@ CONTAINS 119209.6009779448_dp, & 267043.87988619285_dp, & 666555.4805450162_dp, & - 2511681.1233505663_dp] + 2511681.1233505663_dp/) ELSE IF (E_range < 3300000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1847328901237733_dp, & 0.5816579181920506_dp, & 1.06623831659397_dp, & @@ -14528,9 +14531,9 @@ CONTAINS 180141.95260617262_dp, & 424305.6328571203_dp, & 1112162.6633453001_dp, & - 4275158.808925236_dp] + 4275158.808925236_dp/) ELSE IF (E_range < 6000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18691650786522696_dp, & 0.5892282516421157_dp, & 1.082601142199495_dp, & @@ -14590,9 +14593,9 @@ CONTAINS 264080.7768830504_dp, & 655640.4058250692_dp, & 1818602.1997626221_dp, & - 7205611.5064693205_dp] + 7205611.5064693205_dp/) ELSE IF (E_range < 18000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19022370155321527_dp, & 0.600743360402157_dp, & 1.1076668599949147_dp, & @@ -14652,9 +14655,9 @@ CONTAINS 494979.5222323457_dp, & 1359946.1830275727_dp, & 4269995.133188314_dp, & - 18594665.56920044_dp] + 18594665.56920044_dp/) ELSE IF (E_range < 50000000.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.19253210390672987_dp, & 0.6088167991143922_dp, & 1.1253694421581641_dp, & @@ -14714,9 +14717,9 @@ CONTAINS 801312.2270425739_dp, & 2415145.5599759216_dp, & 8639654.807896439_dp, & - 43666635.56753933_dp] + 43666635.56753933_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.1949107095730563_dp, & 0.6171672239307736_dp, & 1.143792172436484_dp, & @@ -14776,9 +14779,9 @@ CONTAINS 1380639.0831843547_dp, & 4711303.6808049455_dp, & 20609904.76278654_dp, & - 151191206.84136662_dp] + 151191206.84136662_dp/) END IF - END SUBROUTINE get_coeff_30 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -14796,7 +14799,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 4862.0_dp) THEN E_ratio = 4862.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13254275519610229_dp, & 0.4075002434334006_dp, & 0.7129653611128071_dp, & @@ -14860,9 +14863,9 @@ CONTAINS 1039.6543728256195_dp, & 1789.9748349736915_dp, & 3833.9681364720745_dp, & - 14655.44632366239_dp] + 14655.44632366239_dp/) ELSE IF (E_range < 5846.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1343248849882633_dp, & 0.4132592119099152_dp, & 0.7240043390799359_dp, & @@ -14926,9 +14929,9 @@ CONTAINS 1222.611932252175_dp, & 2108.162233431274_dp, & 4512.831122628449_dp, & - 17222.120678400817_dp] + 17222.120678400817_dp/) ELSE IF (E_range < 6665.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13557338601660668_dp, & 0.41730065260389615_dp, & 0.7317746815552322_dp, & @@ -14992,9 +14995,9 @@ CONTAINS 1371.947991018934_dp, & 2368.536327804507_dp, & 5068.399861166353_dp, & - 19319.551508880766_dp] + 19319.551508880766_dp/) ELSE IF (E_range < 7800.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1370499857872464_dp, & 0.422087838650514_dp, & 0.7410040914005517_dp, & @@ -15058,9 +15061,9 @@ CONTAINS 1575.1576866889702_dp, & 2723.745097867967_dp, & 5826.475195617796_dp, & - 22177.608473258828_dp] + 22177.608473258828_dp/) ELSE IF (E_range < 10044.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1393751435556022_dp, & 0.4296428076126454_dp, & 0.7556269118458908_dp, & @@ -15124,9 +15127,9 @@ CONTAINS 1966.3786822155184_dp, & 3410.3262356194664_dp, & 7292.46886903304_dp, & - 27693.855354838164_dp] + 27693.855354838164_dp/) ELSE IF (E_range < 14058.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14237486453944107_dp, & 0.4394200534952092_dp, & 0.7746555330683098_dp, & @@ -15190,9 +15193,9 @@ CONTAINS 2639.3168711629464_dp, & 4598.936377351543_dp, & 9833.306219117254_dp, & - 37228.01191754706_dp] + 37228.01191754706_dp/) ELSE IF (E_range < 19114.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14502370796551703_dp, & 0.4480829010539378_dp, & 0.7916157981286331_dp, & @@ -15256,9 +15259,9 @@ CONTAINS 3450.91828637881_dp, & 6043.794023233803_dp, & 12927.644737686549_dp, & - 48805.08862191054_dp] + 48805.08862191054_dp/) ELSE IF (E_range < 25870.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14754727473790832_dp, & 0.4563621690490255_dp, & 0.8079150128057052_dp, & @@ -15322,9 +15325,9 @@ CONTAINS 4489.970449108518_dp, & 7909.344598672393_dp, & 16932.78473977757_dp, & - 63749.23270457554_dp] + 63749.23270457554_dp/) ELSE IF (E_range < 35180.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15002348519433922_dp, & 0.46451130342750646_dp, & 0.824045021042684_dp, & @@ -15388,9 +15391,9 @@ CONTAINS 5859.209649832797_dp, & 10391.307380953114_dp, & 22278.529118569048_dp, & - 83643.6346001724_dp] + 83643.6346001724_dp/) ELSE IF (E_range < 58986.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15399032986872938_dp, & 0.4776194738561411_dp, & 0.8501753043803365_dp, & @@ -15454,9 +15457,9 @@ CONTAINS 9137.412009720016_dp, & 16424.470778988587_dp, & 35351.12874442453_dp, & - 132131.62635064372_dp] + 132131.62635064372_dp/) ELSE IF (E_range < 85052.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15665201491118563_dp, & 0.48645255086696204_dp, & 0.8679140908633145_dp, & @@ -15520,9 +15523,9 @@ CONTAINS 12481.117979830125_dp, & 22687.396569080272_dp, & 49029.27213151443_dp, & - 182714.99577064996_dp] + 182714.99577064996_dp/) ELSE IF (E_range < 126612.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15940855323823325_dp, & 0.4956331404107984_dp, & 0.8864643437510178_dp, & @@ -15586,9 +15589,9 @@ CONTAINS 17463.261532301312_dp, & 32186.387908159864_dp, & 69962.03966745277_dp, & - 259964.04274551442_dp] + 259964.04274551442_dp/) ELSE IF (E_range < 247709.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16373958436697705_dp, & 0.5101264978608379_dp, & 0.9159896069529507_dp, & @@ -15652,9 +15655,9 @@ CONTAINS 30505.194880449075_dp, & 57794.75930208428_dp, & 127350.9867284555_dp, & - 471374.61882211326_dp] + 471374.61882211326_dp/) ELSE IF (E_range < 452410.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16729345587752817_dp, & 0.5220837915443625_dp, & 0.9405741148525995_dp, & @@ -15718,9 +15721,9 @@ CONTAINS 49765.1843652489_dp, & 97101.2613405646_dp, & 217655.43736295513_dp, & - 804161.4023302288_dp] + 804161.4023302288_dp/) ELSE IF (E_range < 1104308.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17199827765823103_dp, & 0.5380059294727404_dp, & 0.9736341997615289_dp, & @@ -15784,9 +15787,9 @@ CONTAINS 100319.89810256775_dp, & 206207.35016280194_dp, & 478990.19443877833_dp, & - 1773158.149536881_dp] + 1773158.149536881_dp/) ELSE IF (E_range < 2582180.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.17588045499160682_dp, & 0.5512257021498627_dp, & 1.0013703118630188_dp, & @@ -15850,9 +15853,9 @@ CONTAINS 189213.13598878586_dp, & 412506.46573426365_dp, & 1004859.506854019_dp, & - 3757500.169762731_dp] + 3757500.169762731_dp/) ELSE IF (E_range < 10786426.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.18118431919794764_dp, & 0.569409896731795_dp, & 1.0399575954447753_dp, & @@ -15916,9 +15919,9 @@ CONTAINS 501508.5608275271_dp, & 1228961.4319415095_dp, & 3359678.97519788_dp, & - 13198823.17240385_dp] + 13198823.17240385_dp/) ELSE IF (E_range < 72565710.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.1860758083606257_dp, & 0.5863105731285033_dp, & 1.0762838189916888_dp, & @@ -15982,9 +15985,9 @@ CONTAINS 1439654.5954696422_dp, & 4195690.360297783_dp, & 14287820.480068853_dp, & - 67797329.79665162_dp] + 67797329.79665162_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.18894944364096963_dp, & 0.5962994473518639_dp, & 1.0979679811546372_dp, & @@ -16048,9 +16051,9 @@ CONTAINS 2964362.2649549907_dp, & 10115616.277159294_dp, & 44251495.17814687_dp, & - 324622278.5292175_dp] + 324622278.5292175_dp/) END IF - END SUBROUTINE get_coeff_32 + END SUBROUTINE ! ************************************************************************************************** !> \brief ... @@ -16068,7 +16071,7 @@ CONTAINS E_ratio = 1.0_dp IF (E_range < 9649.0_dp) THEN E_ratio = 9649.0_dp/E_range - aw(:) = [ & + aw(:) = (/ & 0.13207515772844727_dp, & 0.405991108403864_dp, & 0.7100791180957539_dp, & @@ -16136,9 +16139,9 @@ CONTAINS 2025.283801158086_dp, & 3491.3059333297665_dp, & 7474.317631875756_dp, & - 28531.55532533201_dp] + 28531.55532533201_dp/) ELSE IF (E_range < 15161.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.13599210879419024_dp, & 0.41865733842571035_dp, & 0.734387462880487_dp, & @@ -16206,9 +16209,9 @@ CONTAINS 3017.958277485201_dp, & 5225.5076295652025_dp, & 11175.8295539236_dp, & - 42493.69287150706_dp] + 42493.69287150706_dp/) ELSE IF (E_range < 29986.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14157456993085618_dp, & 0.43680814305293825_dp, & 0.7695603918544728_dp, & @@ -16276,9 +16279,9 @@ CONTAINS 5497.180237430633_dp, & 9607.611108068526_dp, & 20546.39934902344_dp, & - 77652.80170951472_dp] + 77652.80170951472_dp/) ELSE IF (E_range < 49196.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.14537972365704172_dp, & 0.44924937732846576_dp, & 0.7939069438582139_dp, & @@ -16346,9 +16349,9 @@ CONTAINS 8473.557800314775_dp, & 14944.543756287507_dp, & 32001.381350595566_dp, & - 120417.37064242488_dp] + 120417.37064242488_dp/) ELSE IF (E_range < 109833.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15111478683237578_dp, & 0.46811081455805653_dp, & 0.8311975658154092_dp, & @@ -16416,9 +16419,9 @@ CONTAINS 16981.74160635827_dp, & 30536.056841551963_dp, & 65732.37502124789_dp, & - 245660.71368655932_dp] + 245660.71368655932_dp/) ELSE IF (E_range < 276208.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.15704353232796245_dp, & 0.4877544479660704_dp, & 0.8705376156017336_dp, & @@ -16486,9 +16489,9 @@ CONTAINS 37197.937321555175_dp, & 68943.1032010462_dp, & 150241.71258102785_dp, & - 557720.3208697784_dp] + 557720.3208697784_dp/) ELSE IF (E_range < 852991.0_dp) THEN - aw(:) = [ & + aw(:) = (/ & 0.16336922513552726_dp, & 0.5088837963863347_dp, & 0.9134464251208241_dp, & @@ -16556,9 +16559,9 @@ CONTAINS 94285.04834791286_dp, & 183730.02847568074_dp, & 411506.64532360405_dp, & - 1520426.766419325_dp] + 1520426.766419325_dp/) ELSE - aw(:) = [ & + aw(:) = (/ & 0.1835103101234003_dp, & 0.5774305061474206_dp, & 1.057140472868453_dp, & @@ -16626,8 +16629,8 @@ CONTAINS 6223266.011027118_dp, & 21236461.045184538_dp, & 92901077.9747871_dp, & - 681507114.6255051_dp] + 681507114.6255051_dp/) END IF - END SUBROUTINE get_coeff_34 + END SUBROUTINE END MODULE minimax_rpa diff --git a/src/mixed_cdft_methods.F b/src/mixed_cdft_methods.F index d5e1d7c4cc..74f7a80279 100644 --- a/src/mixed_cdft_methods.F +++ b/src/mixed_cdft_methods.F @@ -122,21 +122,6 @@ MODULE mixed_cdft_methods CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mixed_cdft_methods' LOGICAL, PARAMETER, PRIVATE :: debug_this_module = .FALSE. - TYPE buffers_idx_irr - INTEGER :: imap(6) = 0 - INTEGER, DIMENSION(:), & - POINTER :: iv => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :) :: r3 => null() - REAL(KIND=dp), POINTER, & - DIMENSION(:, :, :, :) :: r4 => null() - END TYPE buffers_idx_irr - - TYPE buffers_bi - LOGICAL, POINTER, DIMENSION(:) :: bv => NULL() - INTEGER, POINTER, DIMENSION(:) :: iv => NULL() - END TYPE buffers_bi - PUBLIC :: mixed_cdft_init, & mixed_cdft_build_weight, & mixed_cdft_calculate_coupling @@ -195,16 +180,14 @@ CONTAINS mixed_env%do_mixed_cdft = .TRUE. IF (mixed_env%do_mixed_cdft) THEN ! Sanity check - IF (nforce_eval < 2) THEN + IF (nforce_eval < 2) & CALL cp_abort(__LOCATION__, & "Mixed CDFT calculation requires at least 2 force_evals.") - END IF mapping_section => section_vals_get_subs_vals(mixed_section, "MAPPING") CALL section_vals_get(mapping_section, explicit=explicit) ! The sub_force_envs must share the same geometrical structure - IF (explicit) THEN + IF (explicit) & CPABORT("Please disable section &MAPPING for mixed CDFT calculations") - END IF CALL section_vals_val_get(mixed_section, "MIXED_CDFT%COUPLING", i_val=et_freq) IF (et_freq < 0) THEN mixed_env%do_mixed_et = .FALSE. @@ -261,10 +244,9 @@ CONTAINS IF (is_parallel) THEN ! Treat states in parallel, build weight function and gradients in parallel before SCF process mixed_cdft%run_type = mixed_cdft_parallel - IF (.NOT. nforce_eval == 2) THEN + IF (.NOT. nforce_eval == 2) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT calculation supports only 2 force_evals.") - END IF ELSE ! Treat states in parallel, but each states builds its own weight function and gradients mixed_cdft%run_type = mixed_cdft_parallel_nobuild @@ -317,9 +299,8 @@ CONTAINS END IF ! Inversion method CALL section_vals_val_get(mixed_section, "MIXED_CDFT%EPS_SVD", r_val=mixed_cdft%eps_svd) - IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) THEN + IF (mixed_cdft%eps_svd < 0.0_dp .OR. mixed_cdft%eps_svd > 1.0_dp) & CPABORT("Illegal value for EPS_SVD. Value must be between 0.0 and 1.0.") - END IF ! MD related settings CALL force_env_get(force_env, root_section=root_section) md_section => section_vals_get_subs_vals(root_section, "MOTION%MD") @@ -465,7 +446,6 @@ CONTAINS INTEGER, DIMENSION(2, 3) :: bo INTEGER, DIMENSION(:), POINTER :: lb, sendbuffer_i, ub REAL(KIND=dp) :: t1, t2 - TYPE(buffers_idx_irr), DIMENSION(:), POINTER :: recvbuffer TYPE(cdft_control_type), POINTER :: cdft_control, cdft_control_target TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys_mix @@ -480,6 +460,17 @@ CONTAINS TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: force_env_section, print_section + TYPE buffers + INTEGER :: imap(6) + INTEGER, DIMENSION(:), & + POINTER :: iv => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :) :: r3 => null() + REAL(KIND=dp), POINTER, & + DIMENSION(:, :, :, :) :: r4 => null() + END TYPE buffers + TYPE(buffers), DIMENSION(:), POINTER :: recvbuffer + NULLIFY (subsys_mix, force_env_qs, particles_mix, force_env_section, print_section, & mixed_env, mixed_cdft, pw_env, auxbas_pw_pool, mixed_auxbas_pw_pool, & qs_env, dft_control, sendbuffer_i, lb, ub, req_total, recvbuffer, & @@ -618,9 +609,8 @@ CONTAINS IF (mixed_cdft%dlb_control%recv_work_repl(1) .OR. mixed_cdft%dlb_control%recv_work_repl(2)) THEN DO j = 1, 2 recv_offset = 0 - IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN + IF (mixed_cdft%dlb_control%recv_work_repl(j)) & recv_offset = SUM(mixed_cdft%dlb_control%recv_info(j)%target_list(2, :)) - END IF IF (mixed_cdft%is_pencil) THEN recvbuffer(j)%imap(1) = recvbuffer(j)%imap(1) + recv_offset ELSE @@ -822,17 +812,15 @@ CONTAINS IF (ANY(mixed_cdft%dlb_control%recv_work_repl)) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%recv_work_repl) IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN - IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%recv_info(j)%target_list)) & DEALLOCATE (mixed_cdft%dlb_control%recv_info(j)%target_list) - END IF DEALLOCATE (mixed_cdft%dlb_control%recvbuff(j)%buffs) END IF END DO DEALLOCATE (mixed_cdft%dlb_control%recv_info, mixed_cdft%dlb_control%recvbuff) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%target_list)) & DEALLOCATE (mixed_cdft%dlb_control%target_list) - END IF DEALLOCATE (mixed_cdft%dlb_control%recv_work_repl) END IF DEALLOCATE (recvbuffer) @@ -994,9 +982,8 @@ CONTAINS END IF ! Atomic weight functions needed for CDFT charges IF (cdft_control_source%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control_target%charge)) THEN + IF (.NOT. ASSOCIATED(cdft_control_target%charge)) & ALLOCATE (cdft_control_target%charge(cdft_control_target%natoms)) - END IF DO iatom = 1, cdft_control_target%natoms CALL auxbas_pw_pool_target%create_pw(cdft_control_target%charge(iatom)) CALL pw_copy(cdft_control_source%charge(iatom), cdft_control_target%charge(iatom)) @@ -1245,14 +1232,12 @@ CONTAINS CALL cp_fm_get_info(mixed_mo_coeff(1, ispin), ncol_global=check_mo(1), nrow_global=check_ao(1)) DO iforce_eval = 2, nforce_eval CALL cp_fm_get_info(mixed_mo_coeff(iforce_eval, ispin), ncol_global=check_mo(2), nrow_global=check_ao(2)) - IF (check_ao(1) /= check_ao(2)) THEN + IF (check_ao(1) /= check_ao(2)) & CALL cp_abort(__LOCATION__, & "The number of atomic orbitals must be the same in every CDFT state.") - END IF - IF (check_mo(1) /= check_mo(2)) THEN + IF (check_mo(1) /= check_mo(2)) & CALL cp_abort(__LOCATION__, & "The number of molecular orbitals must be the same in every CDFT state.") - END IF END DO END DO ! Allocate work @@ -1281,15 +1266,13 @@ CONTAINS ALLOCATE (homo(nforce_eval, nspins)) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL section_vals_val_get(mixed_cdft_section, "EPS_OCCUPIED", r_val=eps_occupied) - IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) THEN + IF (eps_occupied > 1.0_dp .OR. eps_occupied < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Keyword EPS_OCCUPIED only accepts values between 0.0 and 1.0") - END IF - IF (mixed_cdft%eps_svd == 0.0_dp) THEN + IF (mixed_cdft%eps_svd == 0.0_dp) & CALL cp_warn(__LOCATION__, & "The usage of SVD based matrix inversions with fractionally occupied "// & "orbitals is strongly recommended to screen nearly orthogonal states.") - END IF CALL section_vals_val_get(mixed_cdft_section, "SCALE_WITH_OCCUPATION_NUMBERS", l_val=should_scale) END IF ! Start the actual calculation @@ -1321,9 +1304,8 @@ CONTAINS nelectron_mismatch = .FALSE. nelectron_tot = SUM(mixed_cdft%occupations(1, ispin)%array(1:nmo)) DO istate = 2, nforce_eval - IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) THEN + IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) & nelectron_mismatch = .TRUE. - END IF END DO IF (ANY(homo(:, ispin) /= nmo)) THEN IF (ispin == 1) THEN @@ -1386,10 +1368,9 @@ CONTAINS name="MO_COEFF_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_" & //TRIM(ADJUSTL(cp_to_string(ispin)))//"_MATRIX") CALL cp_fm_to_fm(tmp2, mixed_mo_coeff(iforce_eval, ispin)) - IF (should_scale) THEN + IF (should_scale) & CALL cp_fm_column_scale(mixed_mo_coeff(iforce_eval, ispin), & mixed_cdft%occupations(iforce_eval, ispin)%array(1:nmo)) - END IF DEALLOCATE (mixed_cdft%occupations(iforce_eval, ispin)%array) END DO END IF @@ -1403,13 +1384,12 @@ CONTAINS CALL parallel_gemm('T', 'N', nmo, nmo, nao, 1.0_dp, & mixed_mo_coeff(jstate, ispin), & tmp2, 0.0_dp, mo_overlap(ipermutation)) - IF (print_mo) THEN + IF (print_mo) & CALL cp_fm_write_formatted(mo_overlap(ipermutation), mounit, & "# MO overlap matrix (step "//TRIM(ADJUSTL(cp_to_string(mixed_cdft%sim_step)))// & "): CDFT states "//TRIM(ADJUSTL(cp_to_string(istate)))//" and "// & TRIM(ADJUSTL(cp_to_string(jstate)))//" (spin "// & TRIM(ADJUSTL(cp_to_string(ispin)))//")") - END IF END DO END DO ! calculate the MO-representations of the restraint matrices of all CDFT states @@ -1509,10 +1489,9 @@ CONTAINS END SELECT END DO ! Compute density matrix difference P = P_j - P_i - IF (mixed_cdft%calculate_metric) THEN + IF (mixed_cdft%calculate_metric) & CALL dbcsr_add(density_matrix_diff(ipermutation, ispin)%matrix, & density_matrix(jstate, ispin)%matrix, -1.0_dp, 1.0_dp) - END IF ! CALL force_env%para_env%sum(a(ispin, :, ipermutation)) CALL force_env%para_env%sum(b(ispin, :, ipermutation)) @@ -1539,14 +1518,12 @@ CONTAINS DEALLOCATE (homo) DEALLOCATE (mixed_cdft%occupations) END IF - IF (print_mo) THEN + IF (print_mo) & CALL cp_print_key_finished_output(mounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) - END IF - IF (print_mo_eigval) THEN + IF (print_mo_eigval) & CALL cp_print_key_finished_output(moeigvalunit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO", on_file=.TRUE.) - END IF ! solve eigenstates for the projector matrix ALLOCATE (Wda(nvar, npermutations)) ALLOCATE (Sda(npermutations)) @@ -1672,10 +1649,9 @@ CONTAINS ! Compute coupling also with the wavefunction overlap method, see Migliore2009 ! Requires the unconstrained KS ground state wavefunction as input IF (mixed_cdft%wfn_overlap_method) THEN - IF (.NOT. uniform_occupation) THEN + IF (.NOT. uniform_occupation) & CALL cp_abort(__LOCATION__, & "Wavefunction overlap method supports only uniformly occupied MOs.") - END IF CALL mixed_cdft_wfn_overlap_method(force_env, mixed_cdft, ncol_mo, nrow_mo) END IF ! Release remaining work @@ -1982,10 +1958,9 @@ CONTAINS END DO DEALLOCATE (H_block, S_block, eigenvalues, blocks) END DO ! recursion - IF (iounit > 0) THEN + IF (iounit > 0) & WRITE (iounit, '(T3,A)') & - '------------------------------------------------------------------------------' - END IF + '------------------------------------------------------------------------------' CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -2026,9 +2001,8 @@ CONTAINS ALLOCATE (evals(ncol_mo(ispin))) DO ipermutation = 1, npermutations ! Take into account doubly occupied orbitals without LSD - IF (nspins == 1) THEN + IF (nspins == 1) & CALL dbcsr_scale(density_matrix_diff(ipermutation, 1)%matrix, alpha_scalar=0.5_dp) - END IF ! Diagonalize difference density matrix CALL cp_dbcsr_syevd(density_matrix_diff(ipermutation, ispin)%matrix, e_vectors, evals, & para_env=force_env%para_env, blacs_env=mixed_cdft%blacs_env) @@ -2119,35 +2093,31 @@ CONTAINS ALLOCATE (mo_set(ispin)%occupation_numbers(nmo)) END DO ! Read wfn file (note we assume that the basis set is the same) - IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN + IF (force_env%mixed_env%do_mixed_qmmm_cdft) & ! This really shouldnt be a problem? CALL cp_abort(__LOCATION__, & "QMMM + wavefunction overlap method not supported.") - END IF CALL force_env_get(force_env=force_env, subsys=subsys_mix) mixed_cdft_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT") CALL cp_subsys_get(subsys_mix, atomic_kind_set=atomic_kind_set, particle_set=particle_set) CPASSERT(ASSOCIATED(mixed_cdft%qs_kind_set)) - IF (force_env%para_env%is_source()) THEN + IF (force_env%para_env%is_source()) & CALL wfn_restart_file_name(file_name, exist, mixed_cdft_section, logger) - END IF CALL force_env%para_env%bcast(exist) CALL force_env%para_env%bcast(file_name) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CALL cp_abort(__LOCATION__, & "User requested to restart the wavefunction from the file named: "// & TRIM(file_name)//". This file does not exist. Please check the existence of"// & " the file or change properly the value of the keyword WFN_RESTART_FILE_NAME in"// & " section FORCE_EVAL\MIXED\MIXED_CDFT.") - END IF CALL read_mo_set_from_restart(mo_array=mo_set, qs_kind_set=mixed_cdft%qs_kind_set, particle_set=particle_set, & para_env=force_env%para_env, id_nr=0, multiplicity=mixed_cdft%multiplicity, & dft_section=mixed_cdft_section, natom_mismatch=natom_mismatch, & cdft=.TRUE.) - IF (natom_mismatch) THEN + IF (natom_mismatch) & CALL cp_abort(__LOCATION__, & "Restart wfn file has a wrong number of atoms") - END IF ! Orthonormalize wfn DO ispin = 1, nspins IF (mixed_cdft%has_unit_metric) THEN @@ -2380,11 +2350,10 @@ CONTAINS CASE (becke_cutoff_global) cdft_control%becke_control%cutoffs(:) = cdft_control%becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%cutoffs_tmp)) & CALL cp_abort(__LOCATION__, & "Size of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does "// & "not match number of atomic kinds in the input coordinate file.") - END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -2410,23 +2379,20 @@ CONTAINS is_constraint = .FALSE. END IF in_memory = calculate_forces .AND. cdft_control%becke_control%in_memory - IF (in_memory .NEQV. calculate_forces) THEN + IF (in_memory .NEQV. calculate_forces) & CALL cp_abort(__LOCATION__, & "The flag BECKE_CONSTRAINT\IN_MEMORY must be activated "// & "for the calculation of mixed CDFT forces") - END IF IF (in_memory .OR. mixed_cdft%first_iteration) ALLOCATE (coefficients(natom)) DO i = 1, cdft_control%natoms catom(i) = cdft_control%atoms(i) IF (cdft_control%save_pot .OR. & cdft_control%becke_control%cavity_confine .OR. & cdft_control%becke_control%should_skip .OR. & - mixed_cdft%first_iteration) THEN + mixed_cdft%first_iteration) & is_constraint(catom(i)) = .TRUE. - END IF - IF (in_memory .OR. mixed_cdft%first_iteration) THEN + IF (in_memory .OR. mixed_cdft%first_iteration) & coefficients(catom(i)) = cdft_control%group(1)%coeff(i) - END IF END DO CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_pw_pool=auxbas_pw_pool) bo = auxbas_pw_pool%pw_grid%bounds_local @@ -2458,7 +2424,7 @@ CONTAINS pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - R12(iatom, jatom) = NORM2(dist_vec) + R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) R12(jatom, iatom) = R12(iatom, jatom) IF (build) THEN CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & @@ -2555,9 +2521,8 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=cdft_control%becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) THEN + IF (ASSOCIATED(radii_list)) & DEALLOCATE (radii_list) - END IF END IF NULLIFY (rs_cavity) CALL pw_env_get(pw_env=mixed_cdft%pw_env, auxbas_rs_grid=rs_cavity, & @@ -2657,10 +2622,9 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (force_env%para_env%is_source() .AND. unit_nr < 1) THEN + IF (force_env%para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") - END IF CALL cp_pw_to_cube(cdft_control%becke_control%cavity, & unit_nr, "CAVITY", particles=particles, & stride=stride, mpi_io=mpi_io) @@ -2669,20 +2633,17 @@ CONTAINS END IF END IF bo_conf = bo - IF (cdft_control%becke_control%cavity_confine) THEN + IF (cdft_control%becke_control%cavity_confine) & bo_conf(:, 3) = cdft_control%becke_control%confine_bounds - END IF ! Load balance - IF (mixed_cdft%dlb) THEN + IF (mixed_cdft%dlb) & CALL mixed_becke_constraint_dlb(force_env, mixed_cdft, my_work, & my_work_size, natom, bo, bo_conf) - END IF ! The bounds have been finalized => time to allocate storage for working matrices offset_dlb = 0 IF (mixed_cdft%dlb) THEN - IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) THEN + IF (mixed_cdft%dlb_control%send_work .AND. .NOT. mixed_cdft%is_special) & offset_dlb = SUM(mixed_cdft%dlb_control%target_list(2, :)) - END IF END IF IF (cdft_control%becke_control%cavity_confine) THEN ! Get rid of the zero part of the confinement cavity (cr3d -> real(:,:,:)) @@ -2772,7 +2733,6 @@ CONTAINS INTEGER, PARAMETER :: should_deallocate = 7000, & uninitialized = -7000 - CHARACTER(len=2) :: dummy INTEGER :: actually_sent, exhausted_work, handle, i, ind, iounit, ispecial, j, max_targets, & more_work, my_pos, my_special_work, my_target, no_overloaded, no_underloaded, nsend, & nsend_limit, nsend_max, offset, offset_proc, offset_special, send_total, tags(2) @@ -2784,13 +2744,19 @@ CONTAINS REAL(kind=dp) :: average_work, load_scale, & very_overloaded, work_factor REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: cavity - TYPE(buffers_bi), DIMENSION(:), POINTER :: recvbuffer, sbuff TYPE(cdft_control_type), POINTER :: cdft_control TYPE(cp_logger_type), POINTER :: logger TYPE(mp_request_type), DIMENSION(4) :: req TYPE(mp_request_type), DIMENSION(:), POINTER :: req_recv, req_total TYPE(section_vals_type), POINTER :: force_env_section, print_section + TYPE buffers + LOGICAL, POINTER, DIMENSION(:) :: bv + INTEGER, POINTER, DIMENSION(:) :: iv + END TYPE buffers + TYPE(buffers), POINTER, DIMENSION(:) :: recvbuffer, sbuff + CHARACTER(len=2) :: dummy + logger => cp_get_default_logger() CALL timeset(routineN, handle) mixed_cdft%dlb_control%recv_work = .FALSE. @@ -2855,9 +2821,8 @@ CONTAINS ! We store the unsorted expected work to refine the estimate on subsequent calls to this routine mixed_cdft%dlb_control%expected_work = expected_work ! Take into account the prediction error of the last step - IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & expected_work = expected_work - mixed_cdft%dlb_control%prediction_error - END IF ! average_work = REAL(SUM(expected_work), dp)/REAL(force_env%para_env%num_pe, dp) ALLOCATE (work_index(force_env%para_env%num_pe), & @@ -2959,9 +2924,8 @@ CONTAINS ! Prevent over redistribution: leave at least (1-work_factor)*nsend_limit slices to my_pos IF (nsend > NINT(work_factor*nsend_limit - send_total)) THEN nsend = NINT(work_factor*nsend_limit - send_total) - IF (debug_this_module) THEN + IF (debug_this_module) & should_warn(force_env%para_env%mepos + 1) = 1 - END IF END IF mixed_cdft%dlb_control%target_list(1, i) = work_index(my_target) - 1 ! This is the actual processor rank IF (mixed_cdft%is_special) THEN @@ -3004,10 +2968,9 @@ CONTAINS EXIT END IF i = i + 1 - IF (i > max_targets) THEN + IF (i > max_targets) & CALL cp_abort(__LOCATION__, & "Load balancing error: increase max_targets") - END IF END DO IF (.NOT. mixed_cdft%is_special) THEN CALL reallocate(mixed_cdft%dlb_control%target_list, 1, 3, 1, i) @@ -3030,12 +2993,11 @@ CONTAINS CALL force_env%para_env%sum(targets) IF (debug_this_module) THEN CALL force_env%para_env%sum(should_warn) - IF (ANY(should_warn == 1)) THEN + IF (ANY(should_warn == 1)) & CALL cp_warn(__LOCATION__, & "MIXED_CDFT DLB: Attempted to redistribute more array"// & " slices than actually available. Leaving a fraction of the total"// & " slices on the overloaded processor. Perhaps you have set LOAD_SCALE too high?") - END IF DEALLOCATE (should_warn) END IF ! check that there is one-to-one mapping between over- and underloaded processors @@ -3274,12 +3236,11 @@ CONTAINS CALL force_env%para_env%irecv(msgout=recvbuffer(i)%bv, & source=mixed_cdft%source_list(i), & request=req_total(i), tag=1) - IF (mixed_cdft%is_special) THEN + IF (mixed_cdft%is_special) & CALL force_env%para_env%irecv(msgout=recvbuffer(i)%iv, & source=mixed_cdft%source_list(i), & request=req_total(i + SIZE(mixed_cdft%source_list)), & tag=2) - END IF END DO DO i = 1, my_special_work DO j = 1, SIZE(mixed_cdft%dest_list) @@ -3297,9 +3258,8 @@ CONTAINS IF (touched(j)) THEN nsend = 0 DO ispecial = 1, SIZE(mixed_cdft%dlb_control%target_list, 2) - IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) THEN + IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) & nsend = nsend + 1 - END IF END DO sbuff(j)%iv(3) = nsend nsend_proc(j) = nsend @@ -3311,11 +3271,10 @@ CONTAINS CALL force_env%para_env%isend(msgin=sbuff(j)%bv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind), tag=1) - IF (mixed_cdft%is_special) THEN + IF (mixed_cdft%is_special) & CALL force_env%para_env%isend(msgin=sbuff(j)%iv, & dest=mixed_cdft%dest_list(j) + (i - 1)*force_env%para_env%num_pe/2, & request=req_total(ind + 2*SIZE(mixed_cdft%dest_list)), tag=2) - END IF END DO END DO CALL mp_waitall(req_total) @@ -3390,9 +3349,8 @@ CONTAINS IF (mixed_cdft%dlb_control%send_work) THEN ind = COUNT(mixed_cdft%dlb_control%recv_work_repl) + 1 DO i = 1, 2 - IF (i == 2) THEN + IF (i == 2) & mixed_cdft%dlb_control%target_list(3, :) = mixed_cdft%dlb_control%target_list(3, :) + 3*max_targets - END IF CALL force_env%para_env%isend(msgin=mixed_cdft%dlb_control%target_list, & dest=mixed_cdft%dest_list(i), & request=req_total(ind)) @@ -3888,9 +3846,8 @@ CONTAINS END DO END IF ! Poll to prevent starvation - IF (ASSOCIATED(req_recv)) THEN + IF (ASSOCIATED(req_recv)) & completed_recv = mp_testall(req_recv) - END IF ! DO i = LBOUND(weight, 3), UBOUND(weight, 3) IF (cdft_control%becke_control%cavity_confine) THEN @@ -3928,7 +3885,7 @@ CONTAINS IF (distances(iatom) == 0.0_dp) THEN r = position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) distance_vecs(:, iatom) = dist_vec distances(iatom) = dist1 ELSE @@ -3941,7 +3898,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -3957,7 +3914,7 @@ CONTAINS IF (distances(jatom) == 0.0_dp) THEN r1 = position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) distance_vecs(:, jatom) = dist_vec distances(jatom) = dist2 ELSE @@ -3970,7 +3927,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (in_memory) THEN IF (store_vectors) THEN @@ -4033,30 +3990,27 @@ CONTAINS IF (in_memory) THEN dP_i_dRi(:, iatom) = cell_functions(iatom)*dP_i_dRi(:, iatom) d_sum_Pm_dR(:, iatom) = d_sum_Pm_dR(:, iatom) + dP_i_dRi(:, iatom) - IF (is_constraint(iatom)) THEN + IF (is_constraint(iatom)) & d_sum_const_dR(:, iatom) = d_sum_const_dR(:, iatom) + dP_i_dRi(:, iatom)* & coefficients(iatom) - END IF DO jatom = 1, natom IF (jatom /= iatom) THEN IF (jatom < iatom) THEN IF (.NOT. skip_me(jatom)) THEN dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) THEN + IF (is_constraint(iatom)) & d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + & dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) - END IF CYCLE END IF END IF dP_i_dRj(:, iatom, jatom) = cell_functions(iatom)*dP_i_dRj(:, iatom, jatom) d_sum_Pm_dR(:, jatom) = d_sum_Pm_dR(:, jatom) + dP_i_dRj(:, iatom, jatom) - IF (is_constraint(iatom)) THEN + IF (is_constraint(iatom)) & d_sum_const_dR(:, jatom) = d_sum_const_dR(:, jatom) + dP_i_dRj(:, iatom, jatom)* & coefficients(iatom) - END IF END IF END DO END IF @@ -4096,9 +4050,8 @@ CONTAINS END IF END DO END IF - IF (ABS(sum_cell_f_all) > 0.000001) THEN + IF (ABS(sum_cell_f_all) > 0.000001) & weight(k, j, i) = sum_cell_f_constr/sum_cell_f_all - END IF END DO ! i END DO ! j END DO ! k @@ -4161,26 +4114,20 @@ CONTAINS END DO CALL mp_waitall(req_total) DEALLOCATE (req_total) - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & DEALLOCATE (mixed_cdft%dlb_control%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%gradients) - END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) - END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4189,26 +4136,20 @@ CONTAINS IF (should_communicate) THEN CALL mp_waitall(req_send) END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%weight)) & DEALLOCATE (mixed_cdft%dlb_control%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%gradients) - END IF IF (mixed_cdft%is_special) THEN DO j = 1, SIZE(mixed_cdft%dlb_control%sendbuff) - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%cavity)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%cavity) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%weight)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%weight) - END IF - IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) THEN + IF (ASSOCIATED(mixed_cdft%dlb_control%sendbuff(j)%gradients)) & DEALLOCATE (mixed_cdft%dlb_control%sendbuff(j)%gradients) - END IF END DO DEALLOCATE (mixed_cdft%dlb_control%sendbuff) END IF @@ -4221,9 +4162,8 @@ CONTAINS IF (mixed_cdft%dlb) THEN CALL force_env%para_env%sum(work) CALL force_env%para_env%sum(work_dlb) - IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) THEN + IF (.NOT. ASSOCIATED(mixed_cdft%dlb_control%prediction_error)) & ALLOCATE (mixed_cdft%dlb_control%prediction_error(force_env%para_env%num_pe)) - END IF mixed_cdft%dlb_control%prediction_error = mixed_cdft%dlb_control%expected_work - work IF (debug_this_module .AND. iounit > 0) THEN DO i = 1, SIZE(work, 1) @@ -4234,9 +4174,8 @@ CONTAINS DEALLOCATE (work, work_dlb, mixed_cdft%dlb_control%expected_work) END IF NULLIFY (gradients, weight, cavity) - IF (ALLOCATED(coefficients)) THEN + IF (ALLOCATED(coefficients)) & DEALLOCATE (coefficients) - END IF IF (in_memory) THEN DEALLOCATE (ds_dR_j) DEALLOCATE (ds_dR_i) @@ -4250,30 +4189,25 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) THEN + IF (ALLOCATED(is_constraint)) & DEALLOCATE (is_constraint) - END IF DEALLOCATE (catom) DEALLOCATE (R12) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) - IF (ALLOCATED(completed)) THEN + IF (ALLOCATED(completed)) & DEALLOCATE (completed) - END IF - IF (ASSOCIATED(nsent)) THEN + IF (ASSOCIATED(nsent)) & DEALLOCATE (nsent) - END IF IF (store_vectors) THEN DEALLOCATE (distances) DEALLOCATE (distance_vecs) DEALLOCATE (position_vecs) END IF - IF (ASSOCIATED(req_send)) THEN + IF (ASSOCIATED(req_send)) & DEALLOCATE (req_send) - END IF - IF (ASSOCIATED(req_recv)) THEN + IF (ASSOCIATED(req_recv)) & DEALLOCATE (req_recv) - END IF CALL cp_print_key_finished_output(iounit, logger, force_env_section, & "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) diff --git a/src/mixed_cdft_types.F b/src/mixed_cdft_types.F index 1fa57726d9..5a05d67a39 100644 --- a/src/mixed_cdft_types.F +++ b/src/mixed_cdft_types.F @@ -310,55 +310,41 @@ CONTAINS INTEGER :: i, j CALL pw_env_release(cdft_control%pw_env) - IF (ASSOCIATED(cdft_control%dest_list)) THEN + IF (ASSOCIATED(cdft_control%dest_list)) & DEALLOCATE (cdft_control%dest_list) - END IF - IF (ASSOCIATED(cdft_control%dest_list_save)) THEN + IF (ASSOCIATED(cdft_control%dest_list_save)) & DEALLOCATE (cdft_control%dest_list_save) - END IF - IF (ASSOCIATED(cdft_control%dest_list_bo)) THEN + IF (ASSOCIATED(cdft_control%dest_list_bo)) & DEALLOCATE (cdft_control%dest_list_bo) - END IF - IF (ASSOCIATED(cdft_control%dest_bo_save)) THEN + IF (ASSOCIATED(cdft_control%dest_bo_save)) & DEALLOCATE (cdft_control%dest_bo_save) - END IF - IF (ASSOCIATED(cdft_control%source_list)) THEN + IF (ASSOCIATED(cdft_control%source_list)) & DEALLOCATE (cdft_control%source_list) - END IF - IF (ASSOCIATED(cdft_control%source_list_save)) THEN + IF (ASSOCIATED(cdft_control%source_list_save)) & DEALLOCATE (cdft_control%source_list_save) - END IF - IF (ASSOCIATED(cdft_control%source_list_bo)) THEN + IF (ASSOCIATED(cdft_control%source_list_bo)) & DEALLOCATE (cdft_control%source_list_bo) - END IF - IF (ASSOCIATED(cdft_control%source_bo_save)) THEN + IF (ASSOCIATED(cdft_control%source_bo_save)) & DEALLOCATE (cdft_control%source_bo_save) - END IF - IF (ASSOCIATED(cdft_control%recv_bo)) THEN + IF (ASSOCIATED(cdft_control%recv_bo)) & DEALLOCATE (cdft_control%recv_bo) - END IF - IF (ASSOCIATED(cdft_control%weight)) THEN + IF (ASSOCIATED(cdft_control%weight)) & DEALLOCATE (cdft_control%weight) - END IF - IF (ASSOCIATED(cdft_control%cavity)) THEN + IF (ASSOCIATED(cdft_control%cavity)) & DEALLOCATE (cdft_control%cavity) - END IF - IF (ALLOCATED(cdft_control%constraint_type)) THEN + IF (ALLOCATED(cdft_control%constraint_type)) & DEALLOCATE (cdft_control%constraint_type) - END IF IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations, 1) DO j = 1, SIZE(cdft_control%occupations, 2) - IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) THEN + IF (ASSOCIATED(cdft_control%occupations(i, j)%array)) & DEALLOCATE (cdft_control%occupations(i, j)%array) - END IF END DO END DO DEALLOCATE (cdft_control%occupations) END IF - IF (ASSOCIATED(cdft_control%dlb_control)) THEN + IF (ASSOCIATED(cdft_control%dlb_control)) & CALL mixed_cdft_dlb_release(cdft_control%dlb_control) - END IF IF (ASSOCIATED(cdft_control%sendbuff)) THEN DO i = 1, SIZE(cdft_control%sendbuff) CALL mixed_cdft_buffers_release(cdft_control%sendbuff(i)) @@ -369,12 +355,10 @@ CONTAINS CALL cdft_control_release(cdft_control%cdft_control) DEALLOCATE (cdft_control%cdft_control) END IF - IF (ASSOCIATED(cdft_control%blacs_env)) THEN + IF (ASSOCIATED(cdft_control%blacs_env)) & CALL cp_blacs_env_release(cdft_control%blacs_env) - END IF - IF (ASSOCIATED(cdft_control%qs_kind_set)) THEN + IF (ASSOCIATED(cdft_control%qs_kind_set)) & CALL deallocate_qs_kind_set(cdft_control%qs_kind_set) - END IF IF (ASSOCIATED(cdft_control%sub_logger)) THEN DO i = 1, SIZE(cdft_control%sub_logger) CALL cp_logger_release(cdft_control%sub_logger(i)%p) @@ -397,9 +381,8 @@ CONTAINS INTEGER :: i - IF (ASSOCIATED(dlb_control%recv_work_repl)) THEN + IF (ASSOCIATED(dlb_control%recv_work_repl)) & DEALLOCATE (dlb_control%recv_work_repl) - END IF IF (ASSOCIATED(dlb_control%sendbuff)) THEN DO i = 1, SIZE(dlb_control%sendbuff) CALL mixed_cdft_buffers_release(dlb_control%sendbuff(i)) @@ -414,36 +397,27 @@ CONTAINS END IF IF (ASSOCIATED(dlb_control%recv_info)) THEN DO i = 1, SIZE(dlb_control%recv_info) - IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) THEN + IF (ASSOCIATED(dlb_control%recv_info(i)%matrix_info)) & DEALLOCATE (dlb_control%recv_info(i)%matrix_info) - END IF - IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) THEN + IF (ASSOCIATED(dlb_control%recv_info(i)%target_list)) & DEALLOCATE (dlb_control%recv_info(i)%target_list) - END IF END DO DEALLOCATE (dlb_control%recv_info) END IF - IF (ASSOCIATED(dlb_control%bo)) THEN + IF (ASSOCIATED(dlb_control%bo)) & DEALLOCATE (dlb_control%bo) - END IF - IF (ASSOCIATED(dlb_control%expected_work)) THEN + IF (ASSOCIATED(dlb_control%expected_work)) & DEALLOCATE (dlb_control%expected_work) - END IF - IF (ASSOCIATED(dlb_control%prediction_error)) THEN + IF (ASSOCIATED(dlb_control%prediction_error)) & DEALLOCATE (dlb_control%prediction_error) - END IF - IF (ASSOCIATED(dlb_control%target_list)) THEN + IF (ASSOCIATED(dlb_control%target_list)) & DEALLOCATE (dlb_control%target_list) - END IF - IF (ASSOCIATED(dlb_control%cavity)) THEN + IF (ASSOCIATED(dlb_control%cavity)) & DEALLOCATE (dlb_control%cavity) - END IF - IF (ASSOCIATED(dlb_control%weight)) THEN + IF (ASSOCIATED(dlb_control%weight)) & DEALLOCATE (dlb_control%weight) - END IF - IF (ASSOCIATED(dlb_control%gradients)) THEN + IF (ASSOCIATED(dlb_control%gradients)) & DEALLOCATE (dlb_control%gradients) - END IF DEALLOCATE (dlb_control) END SUBROUTINE mixed_cdft_dlb_release @@ -456,15 +430,12 @@ CONTAINS SUBROUTINE mixed_cdft_buffers_release(buffer) TYPE(buffers) :: buffer - IF (ASSOCIATED(buffer%cavity)) THEN + IF (ASSOCIATED(buffer%cavity)) & DEALLOCATE (buffer%cavity) - END IF - IF (ASSOCIATED(buffer%weight)) THEN + IF (ASSOCIATED(buffer%weight)) & DEALLOCATE (buffer%weight) - END IF - IF (ASSOCIATED(buffer%gradients)) THEN + IF (ASSOCIATED(buffer%gradients)) & DEALLOCATE (buffer%gradients) - END IF END SUBROUTINE mixed_cdft_buffers_release diff --git a/src/mixed_cdft_utils.F b/src/mixed_cdft_utils.F index cba3f032cf..89fcedfe23 100644 --- a/src/mixed_cdft_utils.F +++ b/src/mixed_cdft_utils.F @@ -209,11 +209,10 @@ CONTAINS CALL force_env_get(force_env_qs, qs_env=qs_env) END IF CALL get_qs_env(qs_env, pw_env=pw_env, dft_control=dft_control) - IF (.NOT. dft_control%qs_control%cdft) THEN + IF (.NOT. dft_control%qs_control%cdft) & CALL cp_abort(__LOCATION__, & "A mixed CDFT simulation with multiple force_evals was requested, "// & "but CDFT constraints were not active in the QS section of all force_evals!") - END IF cdft_control => dft_control%qs_control%cdft_control CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) settings%bo = auxbas_pw_pool%pw_grid%bounds_local @@ -228,15 +227,13 @@ CONTAINS settings%rs_dims(:, iforce_eval) = auxbas_pw_pool%pw_grid%para%group%num_pe_cart IF (auxbas_pw_pool%pw_grid%grid_span == HALFSPACE) settings%odd(iforce_eval) = 1 ! Becke constraint atoms/coeffs - IF (cdft_control%natoms > SIZE(settings%atoms, 1)) THEN + IF (cdft_control%natoms > SIZE(settings%atoms, 1)) & CALL cp_abort(__LOCATION__, & "More CDFT constraint atoms than defined in mixed section. "// & "Use default values for MIXED\MAPPING.") - END IF settings%atoms(1:cdft_control%natoms, iforce_eval) = cdft_control%atoms - IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (mixed_cdft%run_type == mixed_cdft_parallel) & settings%coeffs(1:cdft_control%natoms, iforce_eval) = cdft_control%group(1)%coeff - END IF ! Integer type settings IF (cdft_control%type == outer_scf_becke_constraint) THEN settings%si(1, iforce_eval) = cdft_control%becke_control%cutoff_type @@ -277,46 +274,41 @@ CONTAINS IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN nkinds = SIZE(cdft_control%becke_control%cutoffs_tmp) - IF (nkinds > settings%max_nkinds) THEN + IF (nkinds > settings%max_nkinds) & CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ELEMENT_CUTOFF. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") - END IF settings%cutoffs(1:nkinds, iforce_eval) = cdft_control%becke_control%cutoffs_tmp(:) END IF IF (cdft_control%becke_control%adjust) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) & CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF nkinds = SIZE(cdft_control%becke_control%radii_tmp) - IF (nkinds > settings%max_nkinds) THEN + IF (nkinds > settings%max_nkinds) & CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in BECKE_CONSTRAINT\ATOMIC_RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") - END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%becke_control%radii_tmp(:) END IF END IF IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN IF (ASSOCIATED(cdft_control%hirshfeld_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) & CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT&RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF nkinds = SIZE(cdft_control%hirshfeld_control%radii) - IF (nkinds > settings%max_nkinds) THEN + IF (nkinds > settings%max_nkinds) & CALL cp_abort(__LOCATION__, & "More than "//TRIM(cp_to_string(settings%max_nkinds))// & " unique elements were defined in HIRSHFELD_CONSTRAINT&RADII. Are you sure"// & " your input is correct? If yes, please increase max_nkinds and recompile.") - END IF settings%radii(1:nkinds, iforce_eval) = cdft_control%hirshfeld_control%radii(:) END IF END IF @@ -341,17 +333,15 @@ CONTAINS is_match = is_match .AND. (settings%rs_dims(2, 1) == settings%rs_dims(2, iforce_eval)) is_match = is_match .AND. (settings%odd(1) == settings%odd(iforce_eval)) END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &MGRID settings of the CDFT force_evals.") - END IF IF (settings%spherical(1) == 1) settings%is_spherical = .TRUE. IF (settings%odd(1) == 1) settings%is_odd = .TRUE. ! Make sure CDFT settings are consistent CALL force_env%para_env%sum(settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (mixed_cdft%run_type == mixed_cdft_parallel) & CALL force_env%para_env%sum(settings%coeffs) - END IF settings%ncdft = 0 DO i = 1, SIZE(settings%atoms, 1) DO iforce_eval = 2, nforce_eval @@ -362,13 +352,12 @@ CONTAINS END DO IF (settings%atoms(i, 1) /= 0) settings%ncdft = settings%ncdft + 1 END DO - IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT section of the CDFT force_evals. "// & "Parallel mode mixed CDFT requires identical constraint definitions in both CDFT states. "// & "Switch to serial mode or disable keyword PARALLEL_BUILD if you "// & "want to use nonidentical constraint definitions.") - END IF CALL force_env%para_env%sum(settings%si) CALL force_env%para_env%sum(settings%sr) DO i = 1, SIZE(settings%sb, 1) @@ -388,15 +377,13 @@ CONTAINS IF (settings%sr(i, 1) /= settings%sr(i, iforce_eval)) is_match = .FALSE. END DO END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &CDFT settings of the CDFT force_evals.") - END IF ! Some CDFT features are currently disabled for mixed calculations: check that these features were not requested - IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) THEN + IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT load balancing requires Gaussian cavity confinement.") - END IF ! Check for identical constraints in case of run type serial/parallel_nobuild IF (mixed_cdft%run_type /= mixed_cdft_parallel) THEN ! Get array sizes @@ -422,9 +409,8 @@ CONTAINS ! Sum up array sizes and check consistency CALL force_env%para_env%sum(array_sizes) IF (ANY(array_sizes(:, :, 1) /= array_sizes(1, 1, 1)) .OR. & - ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) THEN + ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) & mixed_cdft%identical_constraints = .FALSE. - END IF ! Check constraint definitions IF (mixed_cdft%identical_constraints) THEN ! Prepare temporary storage @@ -468,17 +454,14 @@ CONTAINS END DO DO iforce_eval = 2, nforce_eval DO iatom = 1, SIZE(atoms(1, i)%array) - IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) THEN + IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) & mixed_cdft%identical_constraints = .FALSE. - END IF - IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) THEN + IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) & mixed_cdft%identical_constraints = .FALSE. - END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO - IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) THEN + IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) & mixed_cdft%identical_constraints = .FALSE. - END IF IF (.NOT. mixed_cdft%identical_constraints) EXIT END DO IF (.NOT. mixed_cdft%identical_constraints) EXIT @@ -526,15 +509,12 @@ CONTAINS END DO IF (cdft_control%type == outer_scf_becke_constraint) THEN IF (.NOT. cdft_control%atomic_charges) DEALLOCATE (cdft_control%atoms) - IF (cdft_control%becke_control%cavity_confine) THEN + IF (cdft_control%becke_control%cavity_confine) & CALL release_hirshfeld_type(cdft_control%becke_control%cavity_env) - END IF - IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN + IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) & DEALLOCATE (cdft_control%becke_control%cutoffs_tmp) - END IF - IF (cdft_control%becke_control%adjust) THEN + IF (cdft_control%becke_control%adjust) & DEALLOCATE (cdft_control%becke_control%radii_tmp) - END IF END IF END IF END DO @@ -569,19 +549,16 @@ CONTAINS settings%radius = settings%sr(5, 1) ! Transfer settings only needed if the constraint should be built in parallel IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN - IF (settings%sb(6, 1)) THEN + IF (settings%sb(6, 1)) & CALL cp_abort(__LOCATION__, & "Calculation of atomic Becke charges not supported with parallel mode mixed CDFT") - END IF - IF (mixed_cdft%nconstraint /= 1) THEN + IF (mixed_cdft%nconstraint /= 1) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not yet support multiple constraints.") - END IF - IF (settings%si(5, 1) /= outer_scf_becke_constraint) THEN + IF (settings%si(5, 1) /= outer_scf_becke_constraint) & CALL cp_abort(__LOCATION__, & "Parallel mode mixed CDFT does not support Hirshfeld constraints.") - END IF ALLOCATE (mixed_cdft%cdft_control) CALL cdft_control_create(mixed_cdft%cdft_control) @@ -616,11 +593,10 @@ CONTAINS IF (settings%cutoffs(i, 1) /= settings%cutoffs(i, 2)) is_match = .FALSE. IF (settings%cutoffs(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ELEMENT_CUTOFF settings of the two force_evals.") - END IF ALLOCATE (cdft_control%becke_control%cutoffs_tmp(nkinds)) cdft_control%becke_control%cutoffs_tmp = settings%cutoffs(1:nkinds, 1) END IF @@ -631,11 +607,10 @@ CONTAINS IF (settings%radii(i, 1) /= settings%radii(i, 2)) is_match = .FALSE. IF (settings%radii(i, 1) /= 0.0_dp) nkinds = nkinds + 1 END DO - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Mismatch detected in the &BECKE_CONSTRAINT "// & "&ATOMIC_RADII settings of the two force_evals.") - END IF ALLOCATE (cdft_control%becke_control%radii(nkinds)) cdft_control%becke_control%radii = settings%radii(1:nkinds, 1) END IF @@ -731,9 +706,8 @@ CONTAINS mixed_cdft%is_special = .FALSE. ! Flag to control the last mapping ! With xc smoothing, the grid is always (ncpu/2,1) distributed ! and correct behavior cannot be guaranteed for ncpu/2 > nx, so we abort... - IF (ncpu/2 > settings%npts(1, 1)) THEN + IF (ncpu/2 > settings%npts(1, 1)) & CPABORT("ncpu/2 => nx: decrease ncpu or disable xc_smoothing") - END IF ! ALLOCATE (mixed_rs_dims(2)) IF (settings%rs_dims(2, 1) /= 1) mixed_cdft%is_pencil = .TRUE. @@ -766,12 +740,11 @@ CONTAINS ELSE IF (.NOT. pw_grid%para%group%num_pe_cart(2) == 1) is_match = .FALSE. END IF - IF (.NOT. is_match) THEN + IF (.NOT. is_match) & CALL cp_abort(__LOCATION__, & "Unable to create a suitable grid distribution "// & "for mixed CDFT calculations. Try decreasing the total number "// & "of processors or disabling xc_smoothing.") - END IF DEALLOCATE (mixed_rs_dims) ! Create the pool bo_mixed = pw_grid%bounds_local @@ -1037,9 +1010,8 @@ CONTAINS DEALLOCATE (settings%rs_dims) DEALLOCATE (settings%odd) DEALLOCATE (settings%atoms) - IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN + IF (mixed_cdft%run_type == mixed_cdft_parallel) & DEALLOCATE (settings%coeffs) - END IF DEALLOCATE (settings%cutoffs) DEALLOCATE (settings%radii) DEALLOCATE (settings%si) @@ -1116,17 +1088,15 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) CPASSERT(ASSOCIATED(dft_control)) nspins = dft_control%nspins - IF (force_env_qs%para_env%is_source()) THEN + IF (force_env_qs%para_env%is_source()) & has_occupation_numbers(iforce_eval) = ALLOCATED(dft_control%qs_control%cdft_control%occupations) - END IF END DO CALL force_env%para_env%sum(has_occupation_numbers(1)) DO iforce_eval = 2, nforce_eval CALL force_env%para_env%sum(has_occupation_numbers(iforce_eval)) - IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) THEN + IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) & CALL cp_abort(__LOCATION__, & "Mixing of uniform and non-uniform occupations is not allowed.") - END IF END DO uniform_occupation = .NOT. has_occupation_numbers(1) DEALLOCATE (has_occupation_numbers) @@ -1184,9 +1154,8 @@ CONTAINS ! Valgrind 3.12/gfortran 4.8.4 oddly complains here (unconditional jump) ! if mixed_cdft%calculate_metric = .FALSE. and the need to null the array ! is queried with IF (mixed_cdft%calculate_metric) & - IF (.NOT. uniform_occupation) THEN + IF (.NOT. uniform_occupation) & NULLIFY (occno_tmp(iforce_eval, ispin)%array) - END IF END DO IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE ! From this point onward, we access data local to the sub_force_envs @@ -1259,9 +1228,8 @@ CONTAINS ! Occupation numbers IF (.NOT. uniform_occupation) THEN DO ispin = 1, nspins - IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) THEN + IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) & CPABORT("Array dimensions dont match.") - END IF IF (force_env_qs%para_env%is_source()) THEN ALLOCATE (occno_tmp(iforce_eval, ispin)%array(ncol_mo(ispin))) occno_tmp(iforce_eval, ispin)%array = dft_control%qs_control%cdft_control%occupations(ispin)%array @@ -1280,9 +1248,8 @@ CONTAINS ! We use this method for the serial case (mixed_cdft%run_type == mixed_cdft_serial) as well to move the arrays to the ! correct blacs_env, which is impossible using a simple copy of the arrays ALLOCATE (mixed_wmat_tmp(nforce_eval, nvar)) - IF (mixed_cdft%calculate_metric) THEN + IF (mixed_cdft%calculate_metric) & ALLOCATE (mixed_matrix_p_tmp(nforce_eval, nspins)) - END IF DO iforce_eval = 1, nforce_eval ! MO coefficients DO ispin = 1, nspins @@ -1414,9 +1381,8 @@ CONTAINS WRITE (iounit, '(T3,A,I3,A,I3,A)') '###### CDFT states I =', istate, ' and J = ', jstate, ' ######' WRITE (iounit, '(T3,A)') REPEAT('#', 44) DO ivar = 1, nvar - IF (ivar > 1) THEN + IF (ivar > 1) & WRITE (iounit, '(A)') '' - END IF WRITE (iounit, '(T3,A,T60,(3X,I18))') 'Atomic group:', ivar WRITE (iounit, '(T3,A,T60,(3X,F18.12))') & 'Strength of constraint I:', mixed_cdft%results%strength(ivar, istate) @@ -1525,9 +1491,8 @@ CONTAINS INTEGER :: kcol, kpermutation, krow, npermutations npermutations = n*(n - 1)/2 ! Size of upper triangular part - IF (ipermutation > npermutations) THEN + IF (ipermutation > npermutations) & CPABORT("Permutation index out of bounds") - END IF kpermutation = 0 DO krow = 1, n DO kcol = krow + 1, n @@ -1645,20 +1610,18 @@ CONTAINS block_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT%BLOCK_DIAGONALIZE") CALL section_vals_get(block_section, explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CALL cp_abort(__LOCATION__, & "Block diagonalization of CDFT Hamiltonian was requested, but the "// & "corresponding input section is missing!") - END IF CALL section_vals_val_get(block_section, "BLOCK", n_rep_val=nblk) ALLOCATE (blocks(nblk)) DO i = 1, nblk NULLIFY (blocks(i)%array) CALL section_vals_val_get(block_section, "BLOCK", i_rep_val=i, i_vals=tmplist) - IF (SIZE(tmplist) < 1) THEN + IF (SIZE(tmplist) < 1) & CPABORT("Each BLOCK must contain at least 1 state.") - END IF ALLOCATE (blocks(i)%array(SIZE(tmplist))) blocks(i)%array(:) = tmplist(:) END DO @@ -1667,9 +1630,8 @@ CONTAINS ! Check that the requested states exist DO i = 1, nblk DO j = 1, SIZE(blocks(i)%array) - IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) THEN + IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) & CPABORT("Requested state does not exist.") - END IF END DO END DO ! Check for duplicates @@ -1701,10 +1663,9 @@ CONTAINS ELSE nrecursion = nblk/2 END IF - IF (nrecursion /= 1 .AND. .NOT. ignore_excited) THEN + IF (nrecursion /= 1 .AND. .NOT. ignore_excited) & CALL cp_abort(__LOCATION__, & "Keyword IGNORE_EXCITED must be active for recursive diagonalization.") - END IF END IF END SUBROUTINE mixed_cdft_read_block_diag @@ -1748,11 +1709,10 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_block(i)%array >= 0.0_dp)) THEN + IF (ANY(H_block(i)%array >= 0.0_dp)) & CALL cp_abort(__LOCATION__, & "At least one of the interaction energies within block "//TRIM(ADJUSTL(cp_to_string(i)))// & " is repulsive.") - END IF END DO END SUBROUTINE mixed_cdft_get_blocks @@ -1887,11 +1847,10 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_offdiag >= 0.0_dp)) THEN + IF (ANY(H_offdiag >= 0.0_dp)) & CALL cp_abort(__LOCATION__, & "At least one of the interaction energies between blocks "//TRIM(ADJUSTL(cp_to_string(i)))// & " and "//TRIM(ADJUSTL(cp_to_string(j)))//" is repulsive.") - END IF ! Now transform: C_i^T * H * C_j H_offdiag(:, :) = MATMUL(H_offdiag, H_block(j)%array) H_offdiag(:, :) = MATMUL(TRANSPOSE(H_block(i)%array), H_offdiag) diff --git a/src/mixed_environment_types.F b/src/mixed_environment_types.F index 267d51da65..0cb02288c5 100644 --- a/src/mixed_environment_types.F +++ b/src/mixed_environment_types.F @@ -321,12 +321,10 @@ CONTAINS IF (ASSOCIATED(mixed_env%group_distribution)) THEN DEALLOCATE (mixed_env%group_distribution) END IF - IF (ASSOCIATED(mixed_env%cdft_control)) THEN + IF (ASSOCIATED(mixed_env%cdft_control)) & CALL mixed_cdft_type_release(mixed_env%cdft_control) - END IF - IF (ASSOCIATED(mixed_env%strength)) THEN + IF (ASSOCIATED(mixed_env%strength)) & DEALLOCATE (mixed_env%strength) - END IF END SUBROUTINE mixed_env_release diff --git a/src/mode_selective.F b/src/mode_selective.F index 9877810b97..753dfb8bae 100644 --- a/src/mode_selective.F +++ b/src/mode_selective.F @@ -330,9 +330,8 @@ CONTAINS END IF END IF END IF - IF (ms_vib%select_id == 0) THEN + IF (ms_vib%select_id == 0) & CPABORT("no frequency, range or involved atoms specified ") - END IF ionode = para_env%is_source() SELECT CASE (guess) CASE (ms_guess_atomic) @@ -375,7 +374,7 @@ CONTAINS ms_vib%b_vec(jj, i) = ABS(globenv%gaussian_rng_stream%next()) END DO END DO - norm = NORM2(ms_vib%b_vec(:, i)) + norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO @@ -387,7 +386,7 @@ CONTAINS ms_vib%b_vec(:, j) = & ms_vib%b_vec(:, j) - DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, i))*ms_vib%b_vec(:, i) ms_vib%b_vec(:, j) = & - ms_vib%b_vec(:, j)/NORM2(ms_vib%b_vec(:, j)) + ms_vib%b_vec(:, j)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, j), ms_vib%b_vec(:, j))) END IF END DO END DO @@ -425,8 +424,8 @@ CONTAINS CALL para_env%bcast(ms_vib%b_vec) CALL para_env%bcast(ms_vib%delta_vec) DO i = 1, nrep - ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) - ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) + ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) + ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) END DO CALL timestop(handle) @@ -452,8 +451,8 @@ CONTAINS INTEGER :: nrep CHARACTER(LEN=default_path_length) :: hes_filename - INTEGER :: hesunit, i, istat, j, jj, k, natoms, & - ncoord, output_unit, stat + INTEGER :: hesunit, i, j, jj, k, natoms, ncoord, & + output_unit, stat INTEGER, DIMENSION(:), POINTER :: tmplist REAL(KIND=dp) :: my_val, norm REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp @@ -477,14 +476,12 @@ CONTAINS ALLOCATE (tmplist(ncoord)) ! should use the cp_fm_read_unformatted... - istat = 0 DO i = 1, ncoord READ (UNIT=hesunit, IOSTAT=stat) ms_vib%hes_bfgs(:, i) - istat = istat + stat END DO CALL close_file(hesunit) IF (output_unit > 0) THEN - IF (istat /= 0) THEN + IF (stat /= 0) THEN WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading HESSIAN **" ELSE WRITE (output_unit, FMT="(/,T2,A)") & @@ -520,7 +517,7 @@ CONTAINS CALL sort(tmp, ncoord, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = ms_vib%hes_bfgs(:, tmplist(i)) - norm = NORM2(ms_vib%b_vec(:, i)) + norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, SIZE(ms_vib%b_vec, 1) @@ -600,19 +597,18 @@ CONTAINS END IF IF (ionode) THEN statint = 0 - READ (UNIT=hesunit) ms_vib%b_mat + READ (UNIT=hesunit, IOSTAT=stat) ms_vib%b_mat READ (UNIT=hesunit, IOSTAT=stat) ms_vib%s_mat - IF (stat /= 0 .AND. output_unit > 0) THEN - WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" - END IF - IF (calc_intens) THEN - READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) - IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & - "intensities are requested but not present in restart file **" - END IF + IF (calc_intens) READ (UNIT=hesunit, IOSTAT=statint) ms_vib%dip_deriv(:, 1:ms_vib%mat_size) + IF (statint /= 0 .AND. output_unit > 0) WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART,", & + "intensities are requested but not present in restart file **" CALL close_file(hesunit) - IF (stat == 0 .AND. statint == 0 .AND. output_unit > 0) THEN - WRITE (output_unit, FMT="(/,T2,A)") "*** MS_RESTART has been read successfully ***" + IF (output_unit > 0) THEN + IF (stat /= 0) THEN + WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MS_RESTART **" + ELSE + WRITE (output_unit, FMT="(/,T2,A)") "*** RESTART has been read successfully ***" + END IF END IF END IF CALL para_env%bcast(ms_vib%b_mat) @@ -634,7 +630,7 @@ CONTAINS DO j = 1, ms_vib%mat_size ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i) + approx_H(j, ind(i))*ms_vib%b_mat(:, j) END DO - ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/NORM2(ms_vib%b_vec(:, i)) + ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) END DO DEALLOCATE (ms_vib%s_mat) @@ -704,8 +700,8 @@ CONTAINS unit_number=iw) END IF info = "" - READ (iw, *) info - READ (iw, *) info + READ (iw, *, IOSTAT=stat) info + READ (iw, *, IOSTAT=stat) info istat = 0 nvibs = 0 reading_vib = .FALSE. @@ -788,7 +784,7 @@ CONTAINS CALL sort(tmp, nvibs, tmplist) DO i = 1, nrep ms_vib%b_vec(:, i) = modes(:, tmplist(i))*mass(:) - norm = NORM2(ms_vib%b_vec(:, i)) + norm = SQRT(DOT_PRODUCT(ms_vib%b_vec(:, i), ms_vib%b_vec(:, i))) ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO DO i = 1, nrep @@ -924,8 +920,8 @@ CONTAINS END DO DO i = 1, nrep - ms_vib%step_r(i) = dx/NORM2(ms_vib%delta_vec(:, i)) - ms_vib%step_b(i) = NORM2(ms_vib%step_r(i)*ms_vib%b_vec(:, i)) + ms_vib%step_r(i) = dx/SQRT(DOT_PRODUCT(ms_vib%delta_vec(:, i), ms_vib%delta_vec(:, i))) + ms_vib%step_b(i) = SQRT(DOT_PRODUCT(ms_vib%step_r(i)*ms_vib%b_vec(:, i), ms_vib%step_r(i)*ms_vib%b_vec(:, i))) END DO converged = .FALSE. IF (MAXVAL(criteria(1, :)) <= ms_vib%eps(1) .AND. MAXVAL(criteria(2, :)) & @@ -950,14 +946,14 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) + tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) END DO IF (calc_intens) THEN DO i = 1, ms_vib%mat_size DO j = 1, ms_vib%mat_size tmp_s(:, i) = tmp_s(:, i) + ms_vib%dip_deriv(:, j)*approx_H(j, i) END DO - IF (calc_intens) intensities(i) = NORM2(tmp_s(:, i)) + IF (calc_intens) intensities(i) = SQRT(DOT_PRODUCT(tmp_s(:, i), tmp_s(:, i))) END DO END IF IF (calc_intens) THEN @@ -1045,7 +1041,7 @@ CONTAINS DO j = 1, ms_vib%mat_size tmp_b(:, i) = tmp_b(:, i) + approx_H(j, i)*ms_vib%b_mat(:, j)/mass(:) END DO - tmp_b(:, i) = tmp_b(:, i)/NORM2(tmp_b(:, i)) + tmp_b(:, i) = tmp_b(:, i)/SQRT(DOT_PRODUCT(tmp_b(:, i), tmp_b(:, i))) END DO tmp = 0._dp DO i = 1, ms_vib%mat_size @@ -1082,12 +1078,12 @@ CONTAINS IF (PRESENT(criteria)) THEN DO i = 1, nrep criteria(1, i) = MAXVAL((residuum(:, i))) - criteria(2, i) = NORM2(residuum(:, i)) + criteria(2, i) = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) END DO END IF DO i = 1, nrep - norm = NORM2(residuum(:, i)) + norm = SQRT(DOT_PRODUCT(residuum(:, i), residuum(:, i))) residuum(:, i) = residuum(:, i)/norm END DO @@ -1095,13 +1091,13 @@ CONTAINS DO j = 1, nrep DO i = 1, ms_vib%mat_size residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), ms_vib%b_mat(:, i))*ms_vib%b_mat(:, i) - residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) + residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) END DO IF (nrep > 1) THEN DO i = 1, nrep IF (i /= j) THEN residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), residuum(:, i))*residuum(:, i) - residuum(:, j) = residuum(:, j)/NORM2(residuum(:, j)) + residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) END IF END DO END IF @@ -1143,7 +1139,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), OPTIONAL :: intensities TYPE(cp_logger_type), POINTER :: logger - INTEGER :: i, j, msunit + INTEGER :: i, j, msunit, stat REAL(KIND=dp) :: crit_a, crit_b, fint, gintval REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: residuum TYPE(section_vals_type), POINTER :: ms_vib_section @@ -1176,7 +1172,7 @@ CONTAINS residuum(:) = residuum(:) - DOT_PRODUCT(residuum(:), ms_vib%b_mat(:, j))*ms_vib%b_mat(:, j) END DO crit_a = MAXVAL(residuum(:)) - crit_b = NORM2(residuum) + crit_b = SQRT(DOT_PRODUCT(residuum, residuum)) IF (PRESENT(intensities)) THEN gintval = fint*intensities(i)**2 IF (crit_a <= ms_vib%eps(1) .AND. crit_b <= ms_vib%eps(2)) THEN @@ -1204,10 +1200,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit) ms_vib%mat_size - WRITE (UNIT=msunit) ms_vib%b_mat - WRITE (UNIT=msunit) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & @@ -1221,10 +1217,10 @@ CONTAINS file_action="WRITE") IF (msunit > 0) THEN - WRITE (UNIT=msunit) ms_vib%mat_size - WRITE (UNIT=msunit) ms_vib%b_mat - WRITE (UNIT=msunit) ms_vib%s_mat - IF (calc_intens) WRITE (UNIT=msunit) ms_vib%dip_deriv + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%mat_size + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%b_mat + WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%s_mat + IF (calc_intens) WRITE (UNIT=msunit, IOSTAT=stat) ms_vib%dip_deriv END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & diff --git a/src/mol_force.F b/src/mol_force.F index 8788183cdc..fecd8c1f7a 100644 --- a/src/mol_force.F +++ b/src/mol_force.F @@ -53,17 +53,17 @@ CONTAINS SELECT CASE (id_type) CASE (do_ff_quartic) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 energy = (f12*k(1) + (f13*k(2) + f14*k(3)*disp)*disp)*disp*disp fscalar = ((k(1) + (k(2) + k(3)*disp)*disp)*disp)/dij CASE (do_ff_morse) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 energy = k(1)*((1 - EXP(-k(2)*disp))**2 - 1) fscalar = 2*k(1)*k(2)*EXP(-k(2)*disp)*(1 - EXP(-k(2)*disp))/dij CASE (do_ff_cubic) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 energy = k(1)*disp**2*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) fscalar = (2.0_dp*k(1)*disp*(1 + cs*disp + 7.0_dp/12.0_dp*cs**2*disp**2) + & @@ -76,7 +76,7 @@ CONTAINS energy = f14*k(1)*disp*disp fscalar = k(1)*disp CASE (do_ff_charmm, do_ff_amber) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -86,7 +86,7 @@ CONTAINS fscalar = 2.0_dp*k(1)*disp/dij END IF CASE (do_ff_harmonic, do_ff_g87) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = dij - r0 IF (ABS(disp) < EPSILON(1.0_dp)) THEN energy = 0.0_dp @@ -96,7 +96,7 @@ CONTAINS fscalar = k(1)*disp/dij END IF CASE (do_ff_fues) - dij = NORM2(rij) + dij = SQRT(DOT_PRODUCT(rij, rij)) disp = r0/dij energy = f12*k(1)*r0*r0*(1.0_dp + disp*(disp - 2.0_dp)) fscalar = k(1)*r0*disp*disp*(1.0_dp - disp)/dij @@ -507,7 +507,7 @@ CONTAINS b = DOT_PRODUCT(t41, t41) - D !inverse norm of t41 - is41 = 1.0_dp/NORM2(t41) + is41 = 1.0_dp/SQRT(DOT_PRODUCT(t41, t41)) cosphi = SQRT(b)*is41 IF (cosphi > 1.0_dp) cosphi = 1.0_dp diff --git a/src/molecular_dipoles.F b/src/molecular_dipoles.F index eb53cae2bb..90a768e113 100644 --- a/src/molecular_dipoles.F +++ b/src/molecular_dipoles.F @@ -76,7 +76,7 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dipole_set REAL(KIND=dp), DIMENSION(3) :: ci, gvec, rcc REAL(KIND=dp), DIMENSION(:), POINTER :: ref_point - REAL(KIND=dp), DIMENSION(:, :), POINTER :: center + REAL(KIND=dp), DIMENSION(:, :), POINTER :: center(:, :) TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(cell_type), POINTER :: cell TYPE(cp_logger_type), POINTER :: logger @@ -84,7 +84,7 @@ CONTAINS TYPE(distribution_1d_type), POINTER :: local_molecules TYPE(molecule_kind_type), POINTER :: molecule_kind TYPE(mp_para_env_type), POINTER :: para_env - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(particle_type), POINTER :: particle_set(:) TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set logger => cp_get_default_logger() @@ -224,7 +224,7 @@ CONTAINS dipole_set(:, :) = dipole_set(:, :)*debye ! Debye DO I = 1, SIZE(dipole_set, 2) WRITE (UNIT=iounit, FMT='(T8,I6,T21,5F12.6)') I, charge_set(I), dipole_set(1:3, I), & - NORM2(dipole_set(1:3, I)) + SQRT(DOT_PRODUCT(dipole_set(1:3, I), dipole_set(1:3, I))) END DO WRITE (UNIT=iounit, FMT="(T2,A,T61,E20.12)") ' DIPOLE : CheckSum =', SUM(dipole_set) END IF diff --git a/src/molsym.F b/src/molsym.F index 3d44715eae..466f6762b2 100644 --- a/src/molsym.F +++ b/src/molsym.F @@ -1210,12 +1210,10 @@ CONTAINS IF (.NOT. sym%linear) THEN DO icn = 2, sym%ncn DO isec = 1, sym%nsec(icn) - IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) THEN + IF (saxis(icn, sym%sec(:, isec, icn), sym, coord)) & CALL addses(icn, sym%sec(:, isec, icn), sym) - END IF - IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) THEN + IF (saxis(2*icn, sym%sec(:, isec, icn), sym, coord)) & CALL addses(2*icn, sym%sec(:, isec, icn), sym) - END IF END DO END DO END IF diff --git a/src/motion/bfgs_optimizer.F b/src/motion/bfgs_optimizer.F index 54e89bffa8..ef6ae345ea 100644 --- a/src/motion/bfgs_optimizer.F +++ b/src/motion/bfgs_optimizer.F @@ -194,14 +194,13 @@ CONTAINS ndf = SIZE(x0) nfree = gopt_env%nfree - IF (ndf > 3000) THEN + IF (ndf > 3000) & CALL cp_warn(__LOCATION__, & "The dimension of the Hessian matrix ("// & TRIM(ADJUSTL(cp_to_string(ndf)))//") is greater than 3000. "// & "The diagonalisation of the full Hessian matrix needed for BFGS "// & "is computationally expensive. You should consider to use the linear "// & "scaling variant L-BFGS instead.") - END IF ! Initialize hessian (hes = unitary matrix or model hessian ) CALL cp_blacs_env_create(blacs_env, para_env, globenv%blacs_grid_layout, & @@ -240,10 +239,8 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) - IF (output_unit > 0) THEN - WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, using unity as model Hessian." - END IF + IF (output_unit > 0) WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, using unity as model Hessian." ELSE DO its = 1, SIZE(eigval) IF (eigval(its) < 0.1_dp) eigval(its) = 0.1_dp @@ -376,10 +373,8 @@ CONTAINS ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF (info /= 0) THEN - IF (output_unit > 0) THEN - WRITE (output_unit, *) & - "BFGS: Matrix diagonalization failed, resetting Hessian to unity." - END IF + IF (output_unit > 0) WRITE (output_unit, *) & + "BFGS: Matrix diagonalization failed, resetting Hessian to unity." CALL cp_fm_set_all(hess_mat, alpha=zero, beta=one) CALL cp_fm_to_fm(hess_mat, hess_tmp) CALL choose_eigv_solver(hess_tmp, eigvec_mat, eigval) @@ -1092,7 +1087,7 @@ CONTAINS !pbc for a distance vector r_ij(j, i, :) = pbc(particles%els(i)%r, particles%els(j)%r, cell) r_ij(i, j, :) = -r_ij(j, i, :) - d_ij(j, i) = NORM2(r_ij(j, i, :)) + d_ij(j, i) = SQRT(DOT_PRODUCT(r_ij(j, i, :), r_ij(j, i, :))) d_ij(i, j) = d_ij(j, i) rho_ij(j, i) = EXP(alpha(jat_row, iat_row)*(r0(jat_row, iat_row)**2 - d_ij(j, i)**2)) rho_ij(i, j) = rho_ij(j, i) @@ -1109,28 +1104,25 @@ CONTAINS iat_row = (jglobal + 2)/3 IF (iat_row > natom) CYCLE IF (iat_row /= iat_col) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN + IF (d_ij(iat_row, iat_col) < 6.0_dp) & local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) - END IF ELSE local_data(j, i) = local_data(j, i) + & angle_second_deriv(r_ij, d_ij, rho_ij, iind, jind, iat_col, iat_row, natom) END IF IF (iat_col /= iat_row) THEN - IF (d_ij(iat_row, iat_col) < 6.0_dp) THEN + IF (d_ij(iat_row, iat_col) < 6.0_dp) & local_data(j, i) = local_data(j, i) - & dist_second_deriv(r_ij(iat_col, iat_row, :), & iind, jind, d_ij(iat_row, iat_col), rho_ij(iat_row, iat_col)) - END IF ELSE DO k = 1, natom IF (k == iat_col) CYCLE - IF (d_ij(iat_row, k) < 6.0_dp) THEN + IF (d_ij(iat_row, k) < 6.0_dp) & local_data(j, i) = local_data(j, i) + & dist_second_deriv(r_ij(iat_col, k, :), & iind, jind, d_ij(iat_row, k), rho_ij(iat_row, k)) - END IF END DO END IF IF (fixed(jind, iat_row) < 0.5_dp .OR. fixed(iind, iat_col) < 0.5_dp) THEN diff --git a/src/motion/cell_opt_utils.F b/src/motion/cell_opt_utils.F index 48b29fb216..ed25d9fb70 100644 --- a/src/motion/cell_opt_utils.F +++ b/src/motion/cell_opt_utils.F @@ -184,9 +184,8 @@ CONTAINS pres_ext = 0.0_dp CALL section_vals_val_get(geo_section, "EXTERNAL_PRESSURE", r_vals=pvals) check = (SIZE(pvals) == 1) .OR. (SIZE(pvals) == 9) - IF (.NOT. check) THEN + IF (.NOT. check) & CPABORT("EXTERNAL_PRESSURE can have 1 or 9 components only!") - END IF IF (SIZE(pvals) == 9) THEN ind = 0 @@ -426,8 +425,7 @@ CONTAINS gamma = angle(cell%hmat(:, 1), cell%hmat(:, 2)) cosg = COS(gamma) sing = SIN(gamma) - ! Here, g is the average derivative of the cell vector length ab_length, - ! and deriv_gamma is the derivative of the angle gamma + ! Here, g is the average derivative of the cell vector length ab_length, and deriv_gamma is the derivative of the angle gamma g = 0.5_dp*(gradient(1) + cosg*gradient(2) + sing*gradient(3)) deriv_gamma = (gradient(3)*cosg - gradient(2)*sing)/b_length gradient(1) = g diff --git a/src/motion/cg_utils.F b/src/motion/cg_utils.F index 017c5041f2..a2beb77590 100644 --- a/src/motion/cg_utils.F +++ b/src/motion/cg_utils.F @@ -163,7 +163,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: gradient2, ls_norm CALL timeset(routineN, handle) - norm_ls_vec = NORM2(ls_vec) + norm_ls_vec = SQRT(DOT_PRODUCT(ls_vec, ls_vec)) my_use_only_grad = .FALSE. IF (PRESENT(use_only_grad)) my_use_only_grad = use_only_grad IF (norm_ls_vec /= 0.0_dp) THEN @@ -260,7 +260,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:), POINTER :: tls_norm CALL timeset(routineN, handle) - norm_tls_vec = NORM2(tls_vec) + norm_tls_vec = SQRT(DOT_PRODUCT(tls_vec, tls_vec)) IF (norm_tls_vec /= 0.0_dp) THEN ALLOCATE (tls_norm(SIZE(tls_vec))) @@ -379,7 +379,7 @@ CONTAINS dimer_env%rot%g0 work = -2.0_dp*(work - dimer_env%rot%g0) work = work - DOT_PRODUCT(work, dimer_env%nvec)*dimer_env%nvec - opt_energy = NORM2(work) + opt_energy = SQRT(DOT_PRODUCT(work, work)) DEALLOCATE (work) END IF dimer_env%rot%angle2 = angle @@ -434,7 +434,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/NORM2(xicom) + xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -520,7 +520,7 @@ CONTAINS pcom = xvec xicom = xi - xicom = xicom/NORM2(xicom) + xicom = xicom/SQRT(DOT_PRODUCT(xicom, xicom)) step = step*0.8_dp ! target a little before the minimum for the first point ax = 0.0_dp xx = step @@ -866,10 +866,9 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(/,T2,A)") REPEAT("*", 79) WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,I7,T78,A)") & "***", "BRENT - NUMBER OF ENERGY EVALUATIONS : ", loc_iter, "***" - IF (iter == itmax + 1) THEN + IF (iter == itmax + 1) & WRITE (UNIT=output_unit, FMT="(T2,A,T22,A,T78,A)") & - "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" - END IF + "***", "BRENT - NUMBER OF ITERATIONS EXCEEDED ", "***" WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", 79) END IF CPASSERT(iter /= itmax + 1) @@ -1080,7 +1079,7 @@ CONTAINS g = h h = -xi*dimer_env%cg_rot%norm_theta + gam*dimer_env%cg_rot%norm_h*dimer_env%cg_rot%nvec_old h = h - DOT_PRODUCT(h, dimer_env%nvec)*dimer_env%nvec - norm_h = NORM2(h) + norm_h = SQRT(DOT_PRODUCT(h, h)) IF (norm_h < EPSILON(0.0_dp)) THEN h = 0.0_dp ELSE diff --git a/src/motion/cp_lbfgs.F b/src/motion/cp_lbfgs.F index 99ff16249c..8d245095e5 100644 --- a/src/motion/cp_lbfgs.F +++ b/src/motion/cp_lbfgs.F @@ -1460,9 +1460,8 @@ CONTAINS dtm = -f1/f2 tsum = zero nseg = 1 - IF (iprint >= 99) THEN + IF (iprint >= 99) & WRITE (wunit, 1011) nbreak - END IF nleft = nbreak iter = 1 @@ -3430,30 +3429,24 @@ CONTAINS ! algorithm enters the second stage. ftest = finit + stp*gtest - IF (stage == 1 .AND. f <= ftest .AND. g >= zero) THEN + IF (stage == 1 .AND. f <= ftest .AND. g >= zero) & stage = 2 - END IF ! Test for warnings. - IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) THEN + IF (brackt .AND. (stp <= stmin .OR. stp >= stmax)) & task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' - END IF - IF (brackt .AND. stmax - stmin <= xtol*stmax) THEN + IF (brackt .AND. stmax - stmin <= xtol*stmax) & task = 'WARNING: XTOL TEST SATISFIED' - END IF - IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) THEN + IF (stp == stpmax .AND. f <= ftest .AND. g <= gtest) & task = 'WARNING: STP = STPMAX' - END IF - IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) THEN + IF (stp == stpmin .AND. (f > ftest .OR. g >= gtest)) & task = 'WARNING: STP = STPMIN' - END IF ! Test for convergence. - IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) THEN + IF (f <= ftest .AND. ABS(g) <= gtol*(-ginit)) & task = 'CONVERGENCE' - END IF ! Test for termination. diff --git a/src/motion/cp_lbfgs_geo.F b/src/motion/cp_lbfgs_geo.F index 83701fccc3..ef4abb4441 100644 --- a/src/motion/cp_lbfgs_geo.F +++ b/src/motion/cp_lbfgs_geo.F @@ -114,9 +114,8 @@ CONTAINS END IF ! Stop if not implemented - IF (gopt_env%type_id == default_ts_method_id) THEN + IF (gopt_env%type_id == default_ts_method_id) & CPABORT("BFGS method not yet working with DIMER") - END IF ALLOCATE (optimizer) CALL cp_opt_gopt_create(optimizer, para_env=para_env, obj_funct=gopt_env, & diff --git a/src/motion/cp_lbfgs_optimizer_gopt.F b/src/motion/cp_lbfgs_optimizer_gopt.F index decb8d6681..92fcd24488 100644 --- a/src/motion/cp_lbfgs_optimizer_gopt.F +++ b/src/motion/cp_lbfgs_optimizer_gopt.F @@ -234,12 +234,10 @@ CONTAINS optimizer%gradient = 0.0_dp optimizer%dsave = 0.0_dp optimizer%work_array = 0.0_dp - IF (PRESENT(wanted_relative_f_delta)) THEN + IF (PRESENT(wanted_relative_f_delta)) & optimizer%wanted_relative_f_delta = wanted_relative_f_delta - END IF - IF (PRESENT(wanted_projected_gradient)) THEN + IF (PRESENT(wanted_projected_gradient)) & optimizer%wanted_projected_gradient = wanted_projected_gradient - END IF optimizer%kind_of_bound = 0 IF (PRESENT(kind_of_bound)) optimizer%kind_of_bound = kind_of_bound IF (PRESENT(lower_bound)) optimizer%lower_bound = lower_bound @@ -377,12 +375,10 @@ CONTAINS IF (PRESENT(obj_funct)) obj_funct = optimizer%obj_funct IF (PRESENT(m)) m = optimizer%m IF (PRESENT(max_f_per_iter)) max_f_per_iter = optimizer%max_f_per_iter - IF (PRESENT(wanted_projected_gradient)) THEN + IF (PRESENT(wanted_projected_gradient)) & wanted_projected_gradient = optimizer%wanted_projected_gradient - END IF - IF (PRESENT(wanted_relative_f_delta)) THEN + IF (PRESENT(wanted_relative_f_delta)) & wanted_relative_f_delta = optimizer%wanted_relative_f_delta - END IF IF (PRESENT(print_every)) print_every = optimizer%print_every IF (PRESENT(x)) x => optimizer%x IF (PRESENT(n_var)) n_var = SIZE(x) @@ -393,17 +389,15 @@ CONTAINS IF (PRESENT(last_f)) last_f = optimizer%last_f IF (PRESENT(f)) f = optimizer%f IF (PRESENT(at_end)) at_end = optimizer%status > 3 - IF (PRESENT(actual_projected_gradient)) THEN + IF (PRESENT(actual_projected_gradient)) & actual_projected_gradient = optimizer%projected_gradient - END IF IF (optimizer%master == optimizer%para_env%mepos) THEN IF (optimizer%isave(30) > 1 .AND. (optimizer%task(1:5) == "NEW_X" .OR. & optimizer%task(1:4) == "STOP" .AND. optimizer%task(7:9) == "CPU")) THEN ! nr iterations >1 .and. dsave contains the wanted data IF (PRESENT(last_f)) last_f = optimizer%dsave(2) - IF (PRESENT(actual_projected_gradient)) THEN + IF (PRESENT(actual_projected_gradient)) & actual_projected_gradient = optimizer%dsave(13) - END IF ELSE CPASSERT(.NOT. PRESENT(last_f)) CPASSERT(.NOT. PRESENT(actual_projected_gradient)) @@ -704,7 +698,8 @@ CONTAINS DEALLOCATE (xold) IF (PRESENT(f)) f = optimizer%f IF (PRESENT(last_f)) last_f = optimizer%last_f - IF (PRESENT(projected_gradient)) projected_gradient = optimizer%projected_gradient + IF (PRESENT(projected_gradient)) & + projected_gradient = optimizer%projected_gradient IF (PRESENT(n_iter)) n_iter = optimizer%n_iter CALL timestop(handle) @@ -740,7 +735,8 @@ CONTAINS IF (PRESENT(n_iter)) n_iter = NINT(results(1)) IF (PRESENT(f)) f = results(2) IF (PRESENT(last_f)) last_f = results(3) - IF (PRESENT(projected_gradient)) projected_gradient = results(4) + IF (PRESENT(projected_gradient)) & + projected_gradient = results(4) END SUBROUTINE cp_opt_gopt_bcast_res diff --git a/src/motion/dimer_methods.F b/src/motion/dimer_methods.F index 63b2ca9eba..c3b1e2c5cf 100644 --- a/src/motion/dimer_methods.F +++ b/src/motion/dimer_methods.F @@ -197,10 +197,10 @@ CONTAINS END IF IF (debug_this_module .AND. (iw > 0)) THEN WRITE (iw, *) "final gradient:", gradient - WRITE (iw, '(A,F20.10)') "norm gradient:", NORM2(gradient) + WRITE (iw, '(A,F20.10)') "norm gradient:", SQRT(DOT_PRODUCT(gradient, gradient)) END IF IF (.NOT. gopt_env%do_line_search) THEN - f = NORM2(gradient) + f = SQRT(DOT_PRODUCT(gradient, gradient)) ELSE f = -DOT_PRODUCT(gradient, dimer_env%tsl%tls_vec) END IF @@ -237,7 +237,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles) natoms = particles%n_els - norm_gradient_old = NORM2(gradient) + norm_gradient_old = SQRT(DOT_PRODUCT(gradient, gradient)) IF (norm_gradient_old > 0.0_dp) THEN IF (natoms > 1) THEN CALL rot_ana(particles%els, mat, dof, print_section, keep_rotations=.FALSE., & diff --git a/src/motion/dimer_types.F b/src/motion/dimer_types.F index 608a867801..840a3acc4a 100644 --- a/src/motion/dimer_types.F +++ b/src/motion/dimer_types.F @@ -193,9 +193,8 @@ CONTAINS CALL dimer_fixed_atom_control(dimer_env%nvec, subsys, unit_nr) ! Normalize dimer vector norm = SQRT(SUM(dimer_env%nvec**2)) - IF (norm <= EPSILON(0.0_dp)) THEN + IF (norm <= EPSILON(0.0_dp)) & CPABORT("The norm of the dimer vector is 0! Calculation cannot proceed further.") - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, "(T2,A,T9,A,T69,F12.6)") & "DIMER|", "Norm of dimer vector to be normalized by rescaling", norm @@ -415,9 +414,8 @@ CONTAINS CALL globenv%gaussian_rng_stream%fill(dimer_env%nvec) CASE (dimer_init_molden) CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CPABORT("INITIALIZATION_METHOD MOLDEN requires VIB_MOLDEN_NAME") - END IF CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", c_val=molden_name) IF (unit > 0) THEN WRITE (unit, "(/,T2,A,T9,A)") & @@ -443,12 +441,11 @@ CONTAINS CALL parser_get_next_line(parser, 1) READ (UNIT=parser%input_line, FMT=*, IOSTAT=ierr) & array_r(3*j - 2), array_r(3*j - 1), array_r(3*j) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CALL cp_abort(__LOCATION__, & "Error while reading MOLDEN file: cannot parse the line "// & TRIM(ADJUSTL(cp_to_string(j)))//" of <"//vib_name//"> "// & "for components of the normal mode") - END IF END DO dimer_env%nvec(:) = dimer_env%nvec(:) + array_r(:)*vib_wt_list(i) END DO Vib_modes diff --git a/src/motion/dimer_utils.F b/src/motion/dimer_utils.F index 9ecc75dfa1..d5006aa274 100644 --- a/src/motion/dimer_utils.F +++ b/src/motion/dimer_utils.F @@ -120,7 +120,7 @@ CONTAINS REAL(KIND=dp), INTENT(OUT) :: norm gradient = gradient - DOT_PRODUCT(gradient, dimer_env%nvec)*dimer_env%nvec - norm = NORM2(gradient) + norm = SQRT(DOT_PRODUCT(gradient, gradient)) IF (norm < EPSILON(0.0_dp)) THEN ! This means that NVEC is totally aligned with minimum curvature mode gradient = 0.0_dp diff --git a/src/motion/dumpdcd.F b/src/motion/dumpdcd.F index 9db62af431..8117ddef9f 100644 --- a/src/motion/dumpdcd.F +++ b/src/motion/dumpdcd.F @@ -31,8 +31,7 @@ PROGRAM dumpdcd ! The output in DCD format is in binary format. ! The input coordinates should be in Angstrom. Velocities and forces are expected to be in atomic units. -! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding -! variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -619,9 +618,9 @@ PROGRAM dumpdcd gamma_dcd = gamma END IF ! Overwrite cell information from DCD header - a = NORM2(hmat(1:3, 1)) - b = NORM2(hmat(1:3, 2)) - c = NORM2(hmat(1:3, 3)) + a = SQRT(DOT_PRODUCT(hmat(1:3, 1), hmat(1:3, 1))) + b = SQRT(DOT_PRODUCT(hmat(1:3, 2), hmat(1:3, 2))) + c = SQRT(DOT_PRODUCT(hmat(1:3, 3), hmat(1:3, 3))) ! Lattice vectors from DCD headers of VEL files are atomic units, but the CP2K cell file is in Angstrom IF (unit_string == "[a.u.]") THEN a = a/angstrom @@ -1015,8 +1014,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = NORM2(a) - length_of_b = NORM2(b) + length_of_a = SQRT(DOT_PRODUCT(a, a)) + length_of_b = SQRT(DOT_PRODUCT(b, b)) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion/free_energy_methods.F b/src/motion/free_energy_methods.F index 1af3620815..dc4f234ead 100644 --- a/src/motion/free_energy_methods.F +++ b/src/motion/free_energy_methods.F @@ -136,11 +136,10 @@ CONTAINS CASE (do_fe_ac) CALL initf(2) ! Alchemical Changes - IF (.NOT. ASSOCIATED(force_env%mixed_env)) THEN + IF (.NOT. ASSOCIATED(force_env%mixed_env)) & CALL cp_abort(__LOCATION__, & 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)// & ' Free Energy calculations require the definition of a mixed env!') - END IF my_par => force_env%mixed_env%par my_val => force_env%mixed_env%val dx = force_env%mixed_env%dx diff --git a/src/motion/geo_opt.F b/src/motion/geo_opt.F index 0a1aec4be0..af142047e5 100644 --- a/src/motion/geo_opt.F +++ b/src/motion/geo_opt.F @@ -103,9 +103,8 @@ CONTAINS ! Reset counter for next iteration, unless rm_restart_info==.FALSE. my_rm_restart_info = .TRUE. IF (PRESENT(rm_restart_info)) my_rm_restart_info = rm_restart_info - IF (my_rm_restart_info) THEN + IF (my_rm_restart_info) & CALL section_vals_val_set(geo_section, "STEP_START_VAL", i_val=0) - END IF DEALLOCATE (x0) CALL gopt_f_release(gopt_env) diff --git a/src/motion/glbopt_callback.F b/src/motion/glbopt_callback.F index a42d2bfc12..5c65c43d7c 100644 --- a/src/motion/glbopt_callback.F +++ b/src/motion/glbopt_callback.F @@ -69,21 +69,18 @@ CONTAINS ! check if we passed a minimum passed_minimum = .TRUE. DO i = 1, mdctrl_data%bump_steps_upwards - IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) THEN + IF (mdctrl_data%epot_history(i) <= mdctrl_data%epot_history(i + 1)) & passed_minimum = .FALSE. - END IF END DO DO i = mdctrl_data%bump_steps_upwards + 1, mdctrl_data%bump_steps_upwards + mdctrl_data%bump_steps_downwards - IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) THEN + IF (mdctrl_data%epot_history(i) >= mdctrl_data%epot_history(i + 1)) & passed_minimum = .FALSE. - END IF END DO ! count the passed bumps and stop md_run when md_bumps_max is reached. - IF (passed_minimum) THEN + IF (passed_minimum) & mdctrl_data%md_bump_counter = mdctrl_data%md_bump_counter + 1 - END IF IF (mdctrl_data%md_bump_counter >= mdctrl_data%md_bumps_max) THEN should_stop = .TRUE. diff --git a/src/motion/gopt_f77_methods.F b/src/motion/gopt_f77_methods.F index e7483d533b..8d5b6727fd 100644 --- a/src/motion/gopt_f77_methods.F +++ b/src/motion/gopt_f77_methods.F @@ -171,13 +171,12 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & CALL unpack_subsys_particles(subsys=subsys, r=x) CASE (default_cell_method_id) ! Check for VIRIAL - IF (.NOT. virial%pv_availability) THEN + IF (.NOT. virial%pv_availability) & CALL cp_abort(__LOCATION__, & "For a cell optimization task with CELL_OPT/TYPE "// & "DIRECT_CELL_OPT, the FORCE_EVAL/STRESS_TENSOR "// & "keyword MUST be defined in the input file for the "// & "evaluation of the stress tensor, but none is found!") - END IF IF (gopt_env%cell_env%keep_volume) THEN nparticle = force_env_get_nparticle(gopt_env%force_env) idg = 3*nparticle @@ -229,9 +228,8 @@ SUBROUTINE cp_eval_at(gopt_env, x, f, gradient, master, & ! some callers expect pres_int to be available on all ranks. Also, here master is not necessarily a single rank. ! Assume at least master==0 CALL para_env%bcast(gopt_env%cell_env%pres_int, 0) - IF (gopt_env%cell_env%constraint_id /= fix_none) THEN + IF (gopt_env%cell_env%constraint_id /= fix_none) & CALL para_env%bcast(gopt_env%cell_env%pres_constr, 0) - END IF END IF END BLOCK CASE (default_shellcore_method_id) diff --git a/src/motion/gopt_f_methods.F b/src/motion/gopt_f_methods.F index bf385d8762..65682a68ca 100644 --- a/src/motion/gopt_f_methods.F +++ b/src/motion/gopt_f_methods.F @@ -112,12 +112,10 @@ CONTAINS CASE (default_minimization_method_id, default_ts_method_id) CALL force_env_get(gopt_env%force_env, subsys=subsys) ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) THEN + IF (gopt_env%force_env%in_use == use_qmmm) & CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - END IF - IF (gopt_env%force_env%in_use == use_qmmmx) THEN + IF (gopt_env%force_env%in_use == use_qmmmx) & CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) - END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -126,12 +124,10 @@ CONTAINS ! Store reference cell gopt_env%h_ref = cell%hmat ! before starting we handle the case of translating coordinates (QM/MM) - IF (gopt_env%force_env%in_use == use_qmmm) THEN + IF (gopt_env%force_env%in_use == use_qmmm) & CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) - END IF - IF (gopt_env%force_env%in_use == use_qmmmx) THEN + IF (gopt_env%force_env%in_use == use_qmmmx) & CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) - END IF nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle + 6)) CALL pack_subsys_particles(subsys=subsys, r=x0) @@ -674,7 +670,7 @@ CONTAINS IF (PRESENT(pres_diff_constr) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff_constr) < ABS(pres_tol) - ELSE IF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN + ELSEIF (PRESENT(pres_diff) .AND. PRESENT(pres_tol)) THEN conv_p = ABS(pres_diff) < ABS(pres_tol) END IF @@ -900,9 +896,8 @@ CONTAINS CALL write_structure_data(particle_set, cell, motion_section) CALL write_restart(force_env=force_env, root_section=root_section) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (UNIT=output_unit, FMT="(/,T20,' Reevaluating energy at the minimum')") - END IF CALL cp_eval_at(gopt_env, x0, f=etot, master=master, final_evaluation=.TRUE., & para_env=para_env) diff --git a/src/motion/helium_common.F b/src/motion/helium_common.F index f37fda09d0..d979d518fd 100644 --- a/src/motion/helium_common.F +++ b/src/motion/helium_common.F @@ -94,21 +94,21 @@ CONTAINS rx = r(1)*cell_size_inv IF (rx > 0.5_dp) THEN rx = rx - REAL(INT(rx + 0.5_dp), dp) - ELSE IF (rx < -0.5_dp) THEN + ELSEIF (rx < -0.5_dp) THEN rx = rx - REAL(INT(rx - 0.5_dp), dp) END IF ry = r(2)*cell_size_inv IF (ry > 0.5_dp) THEN ry = ry - REAL(INT(ry + 0.5_dp), dp) - ELSE IF (ry < -0.5_dp) THEN + ELSEIF (ry < -0.5_dp) THEN ry = ry - REAL(INT(ry - 0.5_dp), dp) END IF rz = r(3)*cell_size_inv IF (rz > 0.5_dp) THEN rz = rz - REAL(INT(rz + 0.5_dp), dp) - ELSE IF (rz < -0.5_dp) THEN + ELSEIF (rz < -0.5_dp) THEN rz = rz - REAL(INT(rz - 0.5_dp), dp) END IF diff --git a/src/motion/helium_interactions.F b/src/motion/helium_interactions.F index 2544940b5e..d987d46f6f 100644 --- a/src/motion/helium_interactions.F +++ b/src/motion/helium_interactions.F @@ -765,7 +765,7 @@ CONTAINS DO i_com = 1, helium%nnp%n_committee !loop over committee members ! Predict energy CALL nnp_predict(helium%nnp%arc(ind), helium%nnp, i_com) - helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) + helium%nnp%atomic_energy(i, i_com) = helium%nnp%arc(ind)%layer(helium%nnp%n_layer)%node(1) ! + helium%nnp%atom_energies(ind) !Gradients IF (PRESENT(force)) THEN @@ -1068,7 +1068,7 @@ CONTAINS p = np db = db - 1 END DO - ELSE IF (delta_bead < 0) THEN + ELSEIF (delta_bead < 0) THEN bead = ref_bead p = part db = delta_bead diff --git a/src/motion/helium_sampling.F b/src/motion/helium_sampling.F index 252ada46cc..3733c09a9d 100644 --- a/src/motion/helium_sampling.F +++ b/src/motion/helium_sampling.F @@ -661,7 +661,7 @@ CONTAINS IF (x >= 0.01_dp) EXIT END DO z = -LOG(0.01_dp) - y = LOG(x)/z + 1.0_dp + y = LOG(x)/z + 1.0_dp; cyclen = INT(helium%maxcycle*y) + 1 IF (cyclen /= helium%m_value) EXIT END DO diff --git a/src/motion/helium_types.F b/src/motion/helium_types.F index aeed271a61..835b11bcec 100644 --- a/src/motion/helium_types.F +++ b/src/motion/helium_types.F @@ -121,8 +121,7 @@ MODULE helium_types REAL(KIND=dp), DIMENSION(3) :: origin = 0.0_dp!< origin of the cell (first voxel position) REAL(KIND=dp) :: droplet_radius = 0.0_dp !< radius of the droplet - REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of - ! periodic cell (if periodic) or COM of helium + REAL(KIND=dp), DIMENSION(3) :: center = 0.0_dp!< COM of solute (if present) or center of periodic cell (if periodic) or COM of helium INTEGER :: sampling_method = helium_sampling_ceperley ! worm sampling parameters @@ -152,8 +151,7 @@ MODULE helium_types LOGICAL :: worm_is_closed = .FALSE.!before isector=1 -> open; isector=0 -> closed INTEGER :: iter_norot = 0!< number of iterations to try for a given imaginary time slice rotation (num inner MC loop iters) - INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) - ! (num outer MC loop iters) + INTEGER :: iter_rot = 0!< number of rotations to try (total number of iterations is iter_norot*iter_rot) (num outer MC loop iters) ! INTEGER :: maxcycle = 0!< maximum cyclic permutation change to attempt INTEGER :: m_dist_type = 0!< distribution from which the cycle length m is sampled @@ -188,8 +186,7 @@ MODULE helium_types INTEGER(KIND=int_8) :: accepts = 0_int_8!< number of accepted new configurations ! REAL(KIND=dp), DIMENSION(:, :), POINTER :: tmatrix => NULL()!< ? permutation probability related - REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related - ! [use might change/new ones added/etc] + REAL(KIND=dp), DIMENSION(:, :), POINTER :: pmatrix => NULL()!< ? permutation probability related [use might change/new ones added/etc] REAL(KIND=dp) :: pweight = 0.0_dp!< ? permutation probability related REAL(KIND=dp), DIMENSION(:, :), POINTER :: ipmatrix => NULL() INTEGER, DIMENSION(:, :), POINTER :: nmatrix => NULL() @@ -211,8 +208,7 @@ MODULE helium_types TYPE(helium_vector_type) :: prarea2 = helium_vector_type()!< projected area squared TYPE(helium_vector_type) :: mominer = helium_vector_type()!< moment of inertia INTEGER :: averages_iweight = 0!< weight for restarted averages - LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages - ! have been restarted + LOGICAL :: averages_restarted = .FALSE.!< flag indicating whether the averages have been restarted REAL(KIND=dp) :: link_action = 0.0_dp, inter_action = 0.0_dp, pair_action = 0.0_dp @@ -270,10 +266,8 @@ MODULE helium_types INTEGER :: solute_beads = 0!< number of solute beads (pint_env%p) INTEGER :: get_helium_forces = 0!< parameter to determine whether the average or last MC force should be taken to MD CHARACTER(LEN=2), DIMENSION(:), POINTER :: solute_element => NULL()!< element names of solute atoms (pint_env%ndim/3) - TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) - ! (should be removed at some point) - REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent - ! on the solute DIM(p,ndim) + TYPE(cell_type), POINTER :: solute_cell => NULL()!< dimensions of the solvated system cell (a,b,c) (should be removed at some point) + REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_avrg => NULL()!< averaged forces exerted by He solvent on the solute DIM(p,ndim) REAL(KIND=dp), DIMENSION(:, :), POINTER :: force_inst => NULL()!< instantaneous forces exerted by He on the solute (p,ndim) CHARACTER(LEN=2), DIMENSION(:), POINTER :: ename => NULL() INTEGER :: enum = 0 diff --git a/src/motion/input_cp2k_restarts.F b/src/motion/input_cp2k_restarts.F index 13a66afdc8..f2db450a6f 100644 --- a/src/motion/input_cp2k_restarts.F +++ b/src/motion/input_cp2k_restarts.F @@ -231,7 +231,7 @@ CONTAINS IF (PRESENT(md_env)) THEN CALL get_md_env(md_env=md_env, force_env=my_force_env) - ELSE IF (PRESENT(force_env)) THEN + ELSEIF (PRESENT(force_env)) THEN my_force_env => force_env END IF @@ -551,9 +551,9 @@ CONTAINS ELSE IF (ASSOCIATED(force_env)) THEN para_env => force_env%para_env - ELSE IF (PRESENT(pint_env)) THEN + ELSEIF (PRESENT(pint_env)) THEN para_env => pint_env%logger%para_env - ELSE IF (PRESENT(helium_env)) THEN + ELSEIF (PRESENT(helium_env)) THEN ! Only needed in case that pure helium is simulated ! In this case write_restart is called only by processors ! with associated helium_env @@ -995,7 +995,7 @@ CONTAINS CALL section_vals_val_set(pint_section, "NOSE%VELOCITY%_DEFAULT_KEYWORD_", & r_vals_ptr=r_vals) - ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (tmpsec) tmpsec => section_vals_get_subs_vals(pint_section, "GLE") @@ -1326,9 +1326,8 @@ CONTAINS WRITE (stmp, *) reqlen err_str = TRIM(ADJUSTL(err_str))// & TRIM(ADJUSTL(stmp))//"'." - IF (msgLEN /= reqlen) THEN + IF (msgLEN /= reqlen) & CPABORT(err_str) - END IF ! allocate the buffer to be saved and fill it with forces ! forces should be the same on all processors, but we don't check that here @@ -1459,10 +1458,9 @@ CONTAINS ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(work_section%values, 2) == 1) EXIT @@ -1940,10 +1938,9 @@ CONTAINS CPASSERT(coord_section%ref_count > 0) section => coord_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(coord_section%values, 2) == 1) EXIT CALL section_vals_add_values(coord_section) @@ -2068,10 +2065,9 @@ CONTAINS CPASSERT(ss_section%ref_count > 0) section => ss_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(ss_section%values, 2) == 1) EXIT CALL section_vals_add_values(ss_section) @@ -2139,10 +2135,9 @@ CONTAINS CPASSERT(ds_section%ref_count > 0) section => ds_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(ds_section%values, 2) == 1) EXIT CALL section_vals_add_values(ds_section) @@ -2209,10 +2204,9 @@ CONTAINS CPASSERT(ww_section%ref_count > 0) section => ww_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(ww_section%values, 2) == 1) EXIT CALL section_vals_add_values(ww_section) @@ -2276,10 +2270,9 @@ CONTAINS CPASSERT(invdt_section%ref_count > 0) section => invdt_section%section ik = section_get_keyword_index(section, "_DEFAULT_KEYWORD_") - IF (ik == -2) THEN + IF (ik == -2) & CALL cp_abort(__LOCATION__, "section "//TRIM(section%name)//" does not contain keyword "// & "_DEFAULT_KEYWORD_") - END IF DO IF (SIZE(invdt_section%values, 2) == 1) EXIT CALL section_vals_add_values(invdt_section) diff --git a/src/motion/integrator.F b/src/motion/integrator.F index a8bd19ad1f..96de427a30 100644 --- a/src/motion/integrator.F +++ b/src/motion/integrator.F @@ -195,9 +195,8 @@ CONTAINS nshell=nshell, & particles=particles, & virial=virial) - IF (nshell /= 0) THEN + IF (nshell /= 0) & CPABORT("Langevin dynamics is not yet implemented for core-shell models") - END IF nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1652,11 +1651,10 @@ CONTAINS ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & CALL cp_abort(__LOCATION__, & "Reached the end of the Trajectory frames in the TRAJECTORY file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") - END IF END IF ! Read cell parameters from cell file if requested and if not yet available @@ -1666,11 +1664,10 @@ CONTAINS CPASSERT(trj_itimes == cell_itimes) ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN - IF (reftraj_env%isnap /= (simpar%nsteps - 1)) THEN + IF (reftraj_env%isnap /= (simpar%nsteps - 1)) & CALL cp_abort(__LOCATION__, & "Reached the end of the cell info frames in the CELL file. Number of "// & "missing frames ("//cp_to_string((simpar%nsteps - 1) - reftraj_env%isnap)//").") - END IF END IF END IF @@ -2530,10 +2527,9 @@ CONTAINS core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial - IF (simpar%constraint) THEN + IF (simpar%constraint) & CALL pv_constraint(gci, local_molecules, molecule_set, & molecule_kind_set, particle_set, virial, para_env) - END IF CALL virial_evaluate(atomic_kind_set, particle_set, & local_particles, virial, para_env) diff --git a/src/motion/integrator_utils.F b/src/motion/integrator_utils.F index 0e567938f2..eb6f960915 100644 --- a/src/motion/integrator_utils.F +++ b/src/motion/integrator_utils.F @@ -969,8 +969,8 @@ CONTAINS npt(:, :)%f = (1.0_dp + (3.0_dp*infree))*kin + fdotr - & 3.0_dp*simpar%p_ext*box%deth - ELSE IF (simpar%ensemble == npt_f_ensemble .OR. & - simpar%ensemble == npe_f_ensemble) THEN + ELSEIF (simpar%ensemble == npt_f_ensemble .OR. & + simpar%ensemble == npe_f_ensemble) THEN npt(:, :)%f = virial%pv_virial(:, :) + & pv_kin(:, :) + virial%pv_constraint(:, :) - & unit(:, :)*simpar%p_ext*box%deth + & @@ -980,8 +980,8 @@ CONTAINS trace = trace/3.0_dp npt(:, :)%f = trace*unit(:, :) END IF - ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. & - simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. & + simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v = box%deth vi = 1._dp/v v0 = simpar%v0 diff --git a/src/motion/mc/mc_control.F b/src/motion/mc/mc_control.F index e55faf23dd..7a9ca26164 100644 --- a/src/motion/mc/mc_control.F +++ b/src/motion/mc/mc_control.F @@ -372,9 +372,8 @@ CONTAINS CALL destroy_force_env(f_env_id, ierr, .FALSE.) IF (ierr /= 0) CPABORT("mc_create_force_env: destroy_force_env failed") - IF (PRESENT(globenv_new)) THEN + IF (PRESENT(globenv_new)) & CALL force_env_get(force_env, globenv=globenv_new) - END IF END SUBROUTINE mc_create_force_env @@ -409,10 +408,9 @@ CONTAINS TYPE(mc_input_file_type), POINTER :: mc_input_file LOGICAL, INTENT(IN) :: ionode - IF (ionode) THEN + IF (ionode) & CALL mc_make_dat_file_new(r(:, :), atom_symbols, nunits_tot, & box_length(:), 'bias_temp.dat', nchains(:), mc_input_file) - END IF CALL mc_create_force_env(bias_env, input_declaration, para_env, 'bias_temp.dat') diff --git a/src/motion/mc/mc_coordinates.F b/src/motion/mc/mc_coordinates.F index 68c12b10bf..d675054f4d 100644 --- a/src/motion/mc/mc_coordinates.F +++ b/src/motion/mc/mc_coordinates.F @@ -516,7 +516,7 @@ CONTAINS IF (exponent > exp_max_val) THEN boltz_weights(imove) = max_val - ELSE IF (exponent < exp_min_val) THEN + ELSEIF (exponent < exp_min_val) THEN boltz_weights(imove) = min_val ELSE boltz_weights(imove) = EXP(exponent) @@ -587,9 +587,8 @@ CONTAINS END IF ! make sure a configuration was chosen - IF (choosen == 0) THEN + IF (choosen == 0) & CPABORT('CBMC swap move failed to select config') - END IF ! if this is an old configuration, we always choose the first one IF (lremove) choosen = 1 @@ -762,7 +761,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSE IF (PRESENT(box)) THEN + ELSEIF (PRESENT(box)) THEN ! any molecule in box...need to find molecule type and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(:, box)), KIND=dp)) @@ -780,7 +779,7 @@ CONTAINS start_atom = start_atom + nunits(mol_type(start_mol + imolecule - 1)) END DO - ELSE IF (PRESENT(molecule_type_old)) THEN + ELSEIF (PRESENT(molecule_type_old)) THEN ! any molecule of type molecule_type_old...need to find box number and start atom rand = rng_stream%next() molecule_number = CEILING(rand*REAL(SUM(nchains(molecule_type_old, :)), KIND=dp)) diff --git a/src/motion/mc/mc_ensembles.F b/src/motion/mc/mc_ensembles.F index 1b9c1650ca..87c18a4743 100644 --- a/src/motion/mc/mc_ensembles.F +++ b/src/motion/mc/mc_ensembles.F @@ -426,9 +426,8 @@ CONTAINS ! if we're doing a discrete volume move, we need to set up the array ! that keeps track of which direction we can move in IF (ldiscrete) THEN - IF (nboxes /= 1) THEN + IF (nboxes /= 1) & CPABORT('ldiscrete=.true. ONLY for systems with 1 box') - END IF CALL create_discrete_array(abc(:, 1), discrete_array(:, :), & discrete_step) END IF @@ -550,7 +549,7 @@ CONTAINS END DO END IF - ELSE IF (rand < pmswap) THEN + ELSEIF (rand < pmswap) THEN ! try a swap move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN @@ -570,7 +569,7 @@ CONTAINS mol_type=mol_type, nchain_total=nchain_total, nunits=nunits, & atom_names=atom_names, mass=mass) - ELSE IF (rand < pmhmc) THEN + ELSEIF (rand < pmhmc) THEN ! try hybrid Monte Carlo IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting a hybrid Monte Carlo move" @@ -596,7 +595,7 @@ CONTAINS energy_check(box_number), r_old(:, :, box_number), & rng_stream) - ELSE IF (rand < pmavbmc) THEN + ELSEIF (rand < pmavbmc) THEN ! try an AVBMC move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting an AVBMC1 move" @@ -627,9 +626,8 @@ CONTAINS EXIT END IF END DO - IF (molecule_type_swap == 0) THEN + IF (molecule_type_swap == 0) & CPABORT('Did not choose a molecule type to swap...check AVBMC input') - END IF ! now pick a molecule, automatically rejecting the move if the ! box is empty or only has one molecule @@ -751,8 +749,8 @@ CONTAINS ! figure out what kind of move we're doing IF (rand < conf_prob(1, molecule_type)) THEN move_type = 'bond' - ELSE IF (rand < (conf_prob(1, molecule_type) + & - conf_prob(2, molecule_type))) THEN + ELSEIF (rand < (conf_prob(1, molecule_type) + & + conf_prob(2, molecule_type))) THEN move_type = 'angle' ELSE move_type = 'dihedral' @@ -768,7 +766,7 @@ CONTAINS move_type, lreject, rng_stream) IF (lreject) EXIT END IF - ELSE IF (rand < pmtrans) THEN + ELSEIF (rand < pmtrans) THEN ! translate a whole molecule in the system ! pick a molecule type IF (ionode) rand = rng_stream%next() @@ -785,11 +783,10 @@ CONTAINS 'Did not choose a molecule type to translate...PMTRANS_MOL should not be all 0.0') ! now pick a molecule of that type - IF (ionode) THEN + IF (ionode) & CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) - END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -801,7 +798,7 @@ CONTAINS start_atom, box_number, bias_energy(box_number), & molecule_type, lreject, rng_stream) IF (lreject) EXIT - ELSE IF (rand < pmcltrans) THEN + ELSEIF (rand < pmcltrans) THEN ! translate a whole cluster in the system ! first, pick a box to do it for IF (ionode) rand = rng_stream%next() @@ -838,11 +835,10 @@ CONTAINS __LOCATION__, & 'Did not choose a molecule type to rotate...PMROT_MOL should not be all 0.0') - IF (ionode) THEN + IF (ionode) & CALL find_mc_test_molecule(mc_molecule_info, & start_atom, box_number, idum, rng_stream, & molecule_type_old=molecule_type) - END IF CALL group%bcast(start_atom, source) CALL group%bcast(box_number, source) box_flag(box_number) = 1 @@ -1275,10 +1271,9 @@ CONTAINS CPABORT('The box needs to be cubic for a virial calculation (it is easiest).') END IF IF (virial_cutoffs(nintegral_divisions) > abc(1)/2.0E0_dp) THEN - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, *) "Box length ", abc(1)*angstrom, " virial cutoff ", & - virial_cutoffs(nintegral_divisions)*angstrom - END IF + virial_cutoffs(nintegral_divisions)*angstrom CPABORT('You need a bigger box to deal with this virial cutoff (see above).') END IF @@ -1376,7 +1371,7 @@ CONTAINS IF (exponent > exp_max_val) THEN exponent = exp_max_val - ELSE IF (exponent < exp_min_val) THEN + ELSEIF (exponent < exp_min_val) THEN exponent = exp_min_val END IF mayer(itemp, ibin) = mayer(itemp, ibin) + EXP(exponent) - 1.0_dp @@ -1387,9 +1382,8 @@ CONTAINS END DO ! write out some info that keeps track of where we are IF (iw > 0) THEN - IF (MOD(ivirial, iprint) == 0) THEN + IF (MOD(ivirial, iprint) == 0) & WRITE (iw, '(A,I6,A,I6)') ' Done with config ', ivirial, ' out of ', nvirial - END IF END IF END DO diff --git a/src/motion/mc/mc_ge_moves.F b/src/motion/mc/mc_ge_moves.F index 09393baaea..fad365147d 100644 --- a/src/motion/mc/mc_ge_moves.F +++ b/src/motion/mc/mc_ge_moves.F @@ -242,9 +242,8 @@ CONTAINS end_mol = start_mol + SUM(nchains(:, ibox)) - 1 CALL check_for_overlap(bias_env(ibox)%force_env, & nchains(:, ibox), nunits(:), loverlap, mol_type(start_mol:end_mol)) - IF (loverlap) THEN + IF (loverlap) & CPABORT('Quickstep move found an overlap in the old config') - END IF END IF bias_energy_old(ibox) = last_bias_energy(ibox) END DO @@ -255,7 +254,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= -1.0E-8) THEN w = 1.0_dp - ELSE IF (energies <= -500.0_dp) THEN + ELSEIF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -273,7 +272,7 @@ CONTAINS ! used to prevent over and underflows IF (energies >= 0.0_dp) THEN w = 1.0_dp - ELSE IF (energies <= -500.0_dp) THEN + ELSEIF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -368,10 +367,9 @@ CONTAINS DO iparticle = 1, nunits_tot(ibox) particles(ibox)%list%els(iparticle)%r(1:3) = & r_old(1:3, iparticle, ibox) - IF (lbias .AND. box_flag(ibox) == 1) THEN + IF (lbias .AND. box_flag(ibox) == 1) & particles_bias(ibox)%list%els(iparticle)%r(1:3) = & - r_old(1:3, iparticle, ibox) - END IF + r_old(1:3, iparticle, ibox) END DO END DO @@ -388,10 +386,9 @@ CONTAINS DO ibox = 1, nboxes CALL cp_subsys_set(subsys(ibox)%subsys, & particles=particles(ibox)%list) - IF (lbias .AND. box_flag(ibox) == 1) THEN + IF (lbias .AND. box_flag(ibox) == 1) & CALL cp_subsys_set(subsys_bias(ibox)%subsys, & particles=particles_bias(ibox)%list) - END IF END DO ! deallocate some stuff @@ -994,7 +991,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSE IF (del_quickstep_energy < exp_min_val) THEN + ELSEIF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = min_val ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -1248,13 +1245,11 @@ CONTAINS ! add to one box, subtract from the other IF (old_cell_length(1, 1)*old_cell_length(2, 1)* & - old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN + old_cell_length(3, 1) + vol_dis <= (3.0E0_dp/angstrom)**3) & CPABORT('GE_volume moves are trying to make box 1 smaller than 3') - END IF IF (old_cell_length(1, 2)*old_cell_length(2, 2)* & - old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) THEN + old_cell_length(3, 2) + vol_dis <= (3.0E0_dp/angstrom)**3) & CPABORT('GE_volume moves are trying to make box 2 smaller than 3') - END IF DO iside = 1, 3 new_cell_length(iside, 1) = (old_cell_length(1, 1)**3 + & diff --git a/src/motion/mc/mc_move_control.F b/src/motion/mc/mc_move_control.F index 7e5d6426bb..eeb70485d6 100644 --- a/src/motion/mc/mc_move_control.F +++ b/src/motion/mc/mc_move_control.F @@ -401,8 +401,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_bond%successes == 0) THEN rmbond(molecule_type) = rmbond(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_bond%successes == & - move_updates%bias_bond%attempts) THEN + ELSEIF (move_updates%bias_bond%successes == & + move_updates%bias_bond%attempts) THEN rmbond(molecule_type) = rmbond(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -429,8 +429,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_angle%successes == 0) THEN rmangle(molecule_type) = rmangle(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_angle%successes == & - move_updates%bias_angle%attempts) THEN + ELSEIF (move_updates%bias_angle%successes == & + move_updates%bias_angle%attempts) THEN rmangle(molecule_type) = rmangle(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -459,8 +459,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_dihedral%successes == 0) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_dihedral%successes == & - move_updates%bias_dihedral%attempts) THEN + ELSEIF (move_updates%bias_dihedral%successes == & + move_updates%bias_dihedral%attempts) THEN rmdihedral(molecule_type) = rmdihedral(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -489,8 +489,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_trans%successes == 0) THEN rmtrans(molecule_type) = rmtrans(molecule_type)/2.0E0_dp - ELSE IF (move_updates%bias_trans%successes == & - move_updates%bias_trans%attempts) THEN + ELSEIF (move_updates%bias_trans%successes == & + move_updates%bias_trans%attempts) THEN rmtrans(molecule_type) = rmtrans(molecule_type)*2.0E0_dp ELSE ! now for the middle case @@ -502,9 +502,8 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmtrans(molecule_type) > 10.0E0_dp) THEN + IF (rmtrans(molecule_type) > 10.0E0_dp) & rmtrans(molecule_type) = 10.0E0_dp - END IF ! clear the counters move_updates%bias_trans%attempts = 0 @@ -521,8 +520,8 @@ CONTAINS ! first account for the extreme cases IF (move_updates%bias_cltrans%successes == 0) THEN rmcltrans = rmcltrans/2.0E0_dp - ELSE IF (move_updates%bias_cltrans%successes == & - move_updates%bias_cltrans%attempts) THEN + ELSEIF (move_updates%bias_cltrans%successes == & + move_updates%bias_cltrans%attempts) THEN rmcltrans = rmcltrans*2.0E0_dp ELSE ! now for the middle case @@ -534,9 +533,8 @@ CONTAINS END IF ! make an upper bound...10 a.u. - IF (rmcltrans > 10.0E0_dp) THEN + IF (rmcltrans > 10.0E0_dp) & rmcltrans = 10.0E0_dp - END IF ! clear the counters move_updates%bias_cltrans%attempts = 0 @@ -556,8 +554,8 @@ CONTAINS IF (rmrot(molecule_type) > pi) rmrot(molecule_type) = pi - ELSE IF (move_updates%bias_rot%successes == & - move_updates%bias_rot%attempts) THEN + ELSEIF (move_updates%bias_rot%successes == & + move_updates%bias_rot%attempts) THEN rmrot(molecule_type) = rmrot(molecule_type)*2.0E0_dp ! more than pi rotation is meaningless @@ -594,8 +592,8 @@ CONTAINS IF (move_updates%volume%successes == 0) THEN rmvolume = rmvolume/2.0E0_dp - ELSE IF (move_updates%volume%successes == & - move_updates%volume%attempts) THEN + ELSEIF (move_updates%volume%successes == & + move_updates%volume%attempts) THEN rmvolume = rmvolume*2.0E0_dp ELSE ! now for the middle case diff --git a/src/motion/mc/mc_moves.F b/src/motion/mc/mc_moves.F index aabf5bcf1f..bced55b54c 100644 --- a/src/motion/mc/mc_moves.F +++ b/src/motion/mc/mc_moves.F @@ -261,7 +261,7 @@ CONTAINS CALL change_bond_length(r_old, r_new, mc_par, molecule_type, & molecule_kind, dis_length, particles, rng_stream) - ELSE IF (move_type == 'angle') THEN + ELSEIF (move_type == 'angle') THEN ! record the attempt moves%angle%attempts = moves%angle%attempts + 1 @@ -338,7 +338,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value)*dis_length**2 @@ -366,7 +366,7 @@ CONTAINS moves%bias_bond%successes = moves%bias_bond%successes + 1 move_updates%bias_bond%successes = & move_updates%bias_bond%successes + 1 - ELSE IF (move_type == 'angle') THEN + ELSEIF (move_type == 'angle') THEN moves%angle%qsuccesses = moves%angle%qsuccesses + 1 move_updates%angle%successes = & move_updates%angle%successes + 1 @@ -581,7 +581,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -780,7 +780,7 @@ CONTAINS IF (dir == 1) THEN lx = .TRUE. - ELSE IF (dir == 2) THEN + ELSEIF (dir == 2) THEN ly = .TRUE. END IF @@ -822,7 +822,7 @@ CONTAINS particles%els(iunit)%r(3) = rznew + nzcm END DO - ELSE IF (ly) THEN + ELSEIF (ly) THEN ! *** ROTATE UNITS OF I AROUND y-AXIS *** @@ -884,7 +884,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1208,9 +1208,8 @@ CONTAINS END IF END IF CALL group%bcast(ltoo_small, source) - IF (ltoo_small) THEN + IF (ltoo_small) & CPABORT("Attempted a volume move where box size got too small.") - END IF ! now compute the energy CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) @@ -1228,7 +1227,7 @@ CONTAINS value = -BETA*(energy_term + volume_term + pressure_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1375,7 +1374,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSE IF (bond_list(ibond)%b == iatom) THEN + ELSEIF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1422,7 +1421,7 @@ CONTAINS ! notice we weight by the opposite masses...therefore lighter segments ! will move further - old_length = NORM2(bond_a) + old_length = SQRT(DOT_PRODUCT(bond_a, bond_a)) new_length_a = dis_length*mass_b/(mass_a + mass_b) new_length_b = dis_length*mass_a/(mass_a + mass_b) @@ -1544,7 +1543,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSE IF (bond_list(ibond)%b == iatom) THEN + ELSEIF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1592,15 +1591,15 @@ CONTAINS bond_c(i) = r_new(i, bend_list(bend_number)%c) - & r_new(i, bend_list(bend_number)%b) END DO - old_length_a = NORM2(bond_a) - old_length_c = NORM2(bond_c) + old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) + old_length_c = SQRT(DOT_PRODUCT(bond_c, bond_c)) old_angle = ACOS(DOT_PRODUCT(bond_a, bond_c)/(old_length_a*old_length_c)) DO i = 1, 3 bisector(i) = bond_a(i)/old_length_a + & ! not yet normalized bond_c(i)/old_length_c END DO - bis_length = NORM2(bisector) + bis_length = SQRT(DOT_PRODUCT(bisector, bisector)) bisector(1:3) = bisector(1:3)/bis_length ! now we need to find the cross product of the B-A and B-C vectors and normalize @@ -1608,14 +1607,14 @@ CONTAINS cross_prod(1) = bond_a(2)*bond_c(3) - bond_a(3)*bond_c(2) cross_prod(2) = bond_a(3)*bond_c(1) - bond_a(1)*bond_c(3) cross_prod(3) = bond_a(1)*bond_c(2) - bond_a(2)*bond_c(1) - cross_prod(1:3) = cross_prod(1:3)/NORM2(cross_prod) + cross_prod(1:3) = cross_prod(1:3)/SQRT(DOT_PRODUCT(cross_prod, cross_prod)) ! we have two axis of a coordinate system...let's get the third cross_prod_plane(1) = cross_prod(2)*bisector(3) - cross_prod(3)*bisector(2) cross_prod_plane(2) = cross_prod(3)*bisector(1) - cross_prod(1)*bisector(3) cross_prod_plane(3) = cross_prod(1)*bisector(2) - cross_prod(2)*bisector(1) cross_prod_plane(1:3) = cross_prod_plane(1:3)/ & - NORM2(cross_prod_plane) + SQRT(DOT_PRODUCT(cross_prod_plane, cross_prod_plane)) ! now bisector is x, cross_prod_plane is the y vector (pointing towards c), ! and cross_prod is z @@ -1637,7 +1636,7 @@ CONTAINS temp(1:3) = r_new(1:3, iatom) - & DOT_PRODUCT(cross_prod(1:3), r_new(1:3, iatom))* & cross_prod(1:3) - temp_length = NORM2(temp) + temp_length = SQRT(DOT_PRODUCT(temp, temp)) ! we can now compute all three components of the new bond vector along the ! axis defined above @@ -1668,7 +1667,7 @@ CONTAINS cross_prod(1:3) END IF - ELSE IF (atom_c(iatom) == 1) THEN + ELSEIF (atom_c(iatom) == 1) THEN ! if the y-coordinate is less than zero, we need to switch the sign when we make the vector, ! as the angle computed by the dot product can't distinguish between that @@ -1806,7 +1805,7 @@ CONTAINS IF (bond_list(ibond)%a == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%b - ELSE IF (bond_list(ibond)%b == iatom) THEN + ELSEIF (bond_list(ibond)%b == iatom) THEN counter(iatom) = counter(iatom) + 1 connectivity(counter(iatom), iatom) = bond_list(ibond)%a END IF @@ -1847,7 +1846,7 @@ CONTAINS bond_a(i) = r_new(i, torsion_list(torsion_number)%c) - & r_new(i, torsion_list(torsion_number)%b) END DO - old_length_a = NORM2(bond_a) + old_length_a = SQRT(DOT_PRODUCT(bond_a, bond_a)) bond_a(1:3) = bond_a(1:3)/old_length_a ! figure out how much we move each side, since we're mass-weighting, by the @@ -1881,7 +1880,7 @@ CONTAINS temp(1:3) = temp(1:3) + r_new(1:3, torsion_list(torsion_number)%b) r_new(1:3, iatom) = temp(1:3) - ELSE IF (atom_d(iatom) == 1) THEN + ELSEIF (atom_d(iatom) == 1) THEN ! shift the coords so c is at the origin r_new(1:3, iatom) = r_new(1:3, iatom) - & @@ -2215,7 +2214,7 @@ CONTAINS .NOT. lin .AND. move_type == 'out') THEN ! standard Metropolis rule prefactor = 1.0_dp - ELSE IF (.NOT. lin .AND. move_type == 'in') THEN + ELSEIF (.NOT. lin .AND. move_type == 'in') THEN prefactor = (1.0_dp - pbias(molecule_type))*volume_in/(pbias(molecule_type)*volume_out) ELSE prefactor = pbias(molecule_type)*volume_out/((1.0_dp - pbias(molecule_type))*volume_in) @@ -2230,7 +2229,7 @@ CONTAINS IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSE IF (del_quickstep_energy < exp_min_val) THEN + ELSEIF (del_quickstep_energy < exp_min_val) THEN del_quickstep_energy = 0.0_dp ELSE del_quickstep_energy = EXP(del_quickstep_energy) @@ -2417,7 +2416,7 @@ CONTAINS value = -BETA*(energy_term) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -2675,7 +2674,7 @@ CONTAINS value = -BETA*(bias_energy_new - bias_energy_old) IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/mc/mc_types.F b/src/motion/mc/mc_types.F index 25ace61db2..71b691a80f 100644 --- a/src/motion/mc/mc_types.F +++ b/src/motion/mc/mc_types.F @@ -1751,9 +1751,8 @@ CONTAINS rcutsq_max = 0.0e0_dp DO itype = 1, SIZE(potparm%pot, 1) DO jtype = itype, SIZE(potparm%pot, 2) - IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) THEN + IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) & rcutsq_max = potparm%pot(itype, jtype)%pot%rcutsq - END IF END DO END DO @@ -1866,9 +1865,8 @@ CONTAINS DO itype = 1, ntypes lnew_type = .TRUE. DO jtype = 1, itype - 1 - IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) THEN + IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) & lnew_type = .FALSE. - END IF END DO IF (lnew_type) THEN nmol_types = nmol_types + 1 @@ -2070,24 +2068,19 @@ CONTAINS ! some ensembles require multiple boxes or molecule types SELECT CASE (mc_par%ensemble) CASE ("GEMC_NPT") - IF (nmol_types <= 1) THEN + IF (nmol_types <= 1) & CPABORT('Cannot have GEMC-NPT simulation with only one molecule type') - END IF - IF (nboxes <= 1) THEN + IF (nboxes <= 1) & CPABORT('Cannot have GEMC-NPT simulation with only one box') - END IF CASE ("GEMC_NVT") - IF (nboxes <= 1) THEN + IF (nboxes <= 1) & CPABORT('Cannot have GEMC-NVT simulation with only one box') - END IF CASE ("TRADITIONAL") - IF (mc_par%pmswap > 0.0E0_dp) THEN + IF (mc_par%pmswap > 0.0E0_dp) & CPABORT('You cannot do swap moves in a system with only one box') - END IF CASE ("VIRIAL") - IF (nchain_total /= 2) THEN + IF (nchain_total /= 2) & CPABORT('You need exactly two molecules in the box to compute the second virial.') - END IF END SELECT ! can't choose an AVBMC target atom number higher than the number diff --git a/src/motion/mc/tamc_run.F b/src/motion/mc/tamc_run.F index 7be1019e15..bff6b10485 100644 --- a/src/motion/mc/tamc_run.F +++ b/src/motion/mc/tamc_run.F @@ -269,6 +269,13 @@ CONTAINS IF (simpar%v0 == 0._dp) simpar%v0 = cell%deth END IF + ! Initialize velocities possibly applying constraints at the zeroth MD step +! ! ! CALL section_vals_val_get(motion_section,"PRINT%RESTART%SPLIT_RESTART_FILE",& +! ! ! l_val=write_binary_restart_file) +!! let us see if this created all the trouble +! CALL setup_velocities(force_env,simpar,globenv,md_env,md_section,constraint_section, & +! write_binary_restart_file) + ! Setup Free Energy Calculation (if required) CALL fe_env_create(fe_env, free_energy_section) CALL set_md_env(md_env=md_env, simpar=simpar, fe_env=fe_env, cell=cell, & @@ -287,6 +294,7 @@ CONTAINS force_env%meta_env%dt = force_env%meta_env%zdt CALL initialize_md_ener(md_ener, force_env, simpar) +! force_env%meta_env%dt=force_env%meta_env%zdt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MC setup up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -298,8 +306,11 @@ CONTAINS ! set some values...will use get_globenv if that ever comes around ! initialize the random numbers +! IF (para_env%is_source()) THEN rng_stream_mc = rng_stream_type(name="Random numbers for monte carlo acc/rej", & distribution_type=UNIFORM) +! ENDIF +!!!!! this should go in a routine hmc_read NULLIFY (mc_section) ALLOCATE (mc_par) @@ -317,6 +328,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "RANDOMTOSKIP", i_val=rand2skip) CPASSERT(rand2skip >= 0) temp = cp_unit_from_cp2k(simpar%temp_ext, "K") +! CALL set_mc_par(mc_par, ensemble=ensemble, nstep=nmccycles, iprint=iprint, temperature=temp, & beta=1.0_dp/temp/boltzmann*joule, exp_max_val=0.9_dp*LOG(HUGE(0.0_dp)), & @@ -360,12 +372,11 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file! "// & "You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR. "// & "Be sure the method you are using can compute the virial!") - END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -375,12 +386,11 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") - END IF END IF ! Computing Forces at zero MD step @@ -401,12 +411,15 @@ CONTAINS CALL section_vals_remove_values(work_section) END IF +! CALL force_env_calc_energy_force (force_env, calc_force=.TRUE.) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) CALL force_env_calc_energy_force(force_env, calc_force=.FALSE.) force_env%meta_env => meta_env_saved IF (ASSOCIATED(force_env%qs_env)) THEN +! force_env%qs_env%sim_time=time +! force_env%qs_env%sim_step=itimes force_env%qs_env%sim_time = 0.0_dp force_env%qs_env%sim_step = 0 END IF @@ -421,7 +434,26 @@ CONTAINS END DO END DO END IF +! IF (force_env%meta_env%well_tempered) THEN +! force_env%meta_env%wttemperature = simpar%temp_ext +! IF (force_env%meta_env%wtgamma>EPSILON(1._dp)) THEN +! dummy=force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma-1._dp) +! IF (force_env%meta_env%delta_t>EPSILON(1._dp)) THEN +! check=ABS(force_env%meta_env%delta_t-dummy)<1.E+3_dp*EPSILON(1._dp) +! IF(.NOT.check) CALL cp_abort(__LOCATION__,& +! "Inconsistency between DELTA_T and WTGAMMA (both specified):"//& +! " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") +! ELSE +! force_env%meta_env%delta_t = dummy +! ENDIF +! ELSE +! force_env%meta_env%wtgamma = 1._dp & +! + force_env%meta_env%delta_t/force_env%meta_env%wttemperature +! ENDIF +! force_env%meta_env%invdt = 1._dp/force_env%meta_env%delta_t +! ENDIF CALL tamc_force(force_env) +! CALL metadyn_write_colvar(force_env) END IF IF (simpar%do_respa) THEN @@ -429,10 +461,16 @@ CONTAINS calc_force=.TRUE.) END IF +! CALL force_env_get( force_env, subsys=subsys) +! +! CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& +! particles=particles) + CALL virial_evaluate(atomic_kinds%els, particles%els, local_particles, & virial, force_env%para_env) CALL md_energy(md_env, md_ener) +! CALL md_write_output(md_env) !inits the print env at itimes == 0 also writes trajectories md_stride = 1 ELSE CALL get_md_env(md_env, reftraj=reftraj) @@ -448,6 +486,7 @@ CONTAINS CALL init_mc_moves(moves) CALL init_mc_moves(gmoves) ALLOCATE (r(1:3, SIZE(particles%els))) +! ALLOCATE (r_old(1:3,size(particles%els))) CALL mc_averages_create(MCaverages) !!!!! some more buffers ! Allocate random number for Langevin Thermostat acting on COLVARS @@ -490,6 +529,7 @@ CONTAINS IF (output_unit > 0) THEN WRITE (output_unit, '(a)') "HMC|==== end initial average forces" END IF +! call set_md_env(md_env, init=.FALSE.) CALL metadyn_write_colvar(force_env) @@ -535,6 +575,8 @@ CONTAINS ! Free Energy calculation ! CALL free_energy_evaluate(md_env,should_stop,free_energy_section) + ![AME:UB] IF (should_stop) EXIT + ! Test for .EXIT_MD or for WALL_TIME to exit ! Default: ! IF so we don't overwrite the restart or append to the trajectory @@ -547,13 +589,30 @@ CONTAINS CALL external_control(should_stop, "MD", globenv=globenv) IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) +! CALL md_output(md_env,md_section,force_env%root_section,should_stop) EXIT END IF +! IF(simpar%ensemble /= reftraj_ensemble) THEN +! CALL md_energy(md_env, md_ener) +! CALL temperature_control(simpar, md_env, md_ener, force_env, logger) +! CALL comvel_control(md_ener, force_env, md_section, logger) +! CALL angvel_control(md_ener, force_env, md_section, logger) +! ELSE +! CALL md_ener_reftraj(md_env, md_ener) +! END IF + time_iter_stop = m_walltime() used_time = time_iter_stop - time_iter_start time_iter_start = time_iter_stop +!!!!! this writes the restart... +! CALL md_output(md_env,md_section,force_env%root_section,should_stop) + +! IF(simpar%ensemble == reftraj_ensemble ) THEN +! CALL write_output_reftraj(md_env) +! END IF + IF (output_unit > 0) THEN WRITE (output_unit, '(a,1x,i0)') "HMC| end z step ", istep WRITE (output_unit, '(a)') "HMC|===================================" @@ -568,6 +627,7 @@ CONTAINS CALL write_restart(md_env=md_env, root_section=force_env%root_section) ! if we need the final kinetic energy for Hybrid Monte Carlo +! hmc_ekin%final_ekin=md_ener%ekin ! Remove the iteration level CALL cp_rm_iter_level(logger%iter_info, "MD") @@ -579,12 +639,15 @@ CONTAINS DEALLOCATE (md_env) ! Clean restartable sections.. IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section) +! IF (para_env%is_source()) THEN +! ENDIF CALL MC_ENV_RELEASE(mc_env) DEALLOCATE (mc_env) DEALLOCATE (mc_par) CALL MC_MOVES_RELEASE(moves) CALL MC_MOVES_RELEASE(gmoves) DEALLOCATE (r) +! DEALLOCATE(r_old) DEALLOCATE (xieta) DEALLOCATE (An) DEALLOCATE (fz) @@ -946,6 +1009,10 @@ CONTAINS fz = 0.0_dp ishift = 0 END IF +! lrestart = .false. +! if (present(logger) .and. present(iter)) THEN +! lrestart=.true. +! ENDIF CALL get_mc_par(mc_par, nstep=nstep, iprint=iprint) meta_env_saved => force_env%meta_env NULLIFY (force_env%meta_env) @@ -1003,6 +1070,20 @@ CONTAINS WRITE (output_unit, '(a,f16.8)') "HMC| Running average for potential energy ", averages%ave_energy WRITE (output_unit, '(a,1x,i0)') "HMC|======== End Monte Carlo cycle ", i + ishift END IF +! IF (lrestart) THEN +! k=nstep/5 +! IF(MOD(i,k) == 0) THEN +! force_env%qs_env%sim_time=t1 +! force_env%qs_env%sim_step=it1 +! DO j=1,force_env%meta_env%n_colvar +! force_env%meta_env%metavar(j)%ff_s=fz(j)/real(i+ishift,dp) +! ENDDO +! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=-1) +! CALL section_vals_val_set(mcsec,"RANDOMTOSKIP",i_val=i+ishift) +! CALL write_restart(md_env=mdenv,root_section=force_env%root_section) +! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter) +! ENDIF +! ENDIF END DO force_env%qs_env%sim_time = t1 force_env%qs_env%sim_step = it1 @@ -1135,7 +1216,7 @@ CONTAINS ! to prevent overflows IF (value > exp_max_val) THEN w = 10.0_dp - ELSE IF (value < exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) diff --git a/src/motion/md_conserved_quantities.F b/src/motion/md_conserved_quantities.F index dc65d3fd8f..1c09efe72f 100644 --- a/src/motion/md_conserved_quantities.F +++ b/src/motion/md_conserved_quantities.F @@ -637,9 +637,8 @@ CONTAINS END DO END IF - IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) THEN + IF (ASSOCIATED(qmmm_env) .AND. ASSOCIATED(qmmmx_env)) & CPABORT("get_part_ke: qmmm bug") - END IF END SUBROUTINE get_part_ke ! ************************************************************************************************** diff --git a/src/motion/md_energies.F b/src/motion/md_energies.F index 099c430dbc..629579deb7 100644 --- a/src/motion/md_energies.F +++ b/src/motion/md_energies.F @@ -488,12 +488,11 @@ CONTAINS CALL cp_print_key_finished_output(tempkind, logger, motion_section, "MD%PRINT%TEMP_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") - END IF END IF !Thermal Region CALL print_thermal_regions_temperature(thermal_regions, itimes, time*femtoseconds, my_pos, my_act) @@ -559,12 +558,11 @@ CONTAINS "MD%PRINT%TEMP_SHELL_KIND") ELSE print_key => section_vals_get_subs_vals(motion_section, "MD%PRINT%TEMP_SHELL_KIND") - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) & CALL cp_warn(__LOCATION__, & "The print_key MD%PRINT%TEMP_SHELL_KIND has been activated but the "// & "calculation of the temperature per kind has not been requested. "// & "Please switch on the keyword MD%TEMP_KIND.") - END IF END IF END IF END IF diff --git a/src/motion/md_run.F b/src/motion/md_run.F index ababfdc8ac..fbf5728dfa 100644 --- a/src/motion/md_run.F +++ b/src/motion/md_run.F @@ -283,9 +283,8 @@ CONTAINS CALL get_md_env(md_env, ehrenfest_md=ehrenfest_md) !If requested set up the REFTRAJ run - IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) THEN + IF (simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md) & CPABORT("Ehrenfest MD does not support reftraj ensemble ") - END IF IF (simpar%ensemble == reftraj_ensemble) THEN reftraj_section => section_vals_get_subs_vals(md_section, "REFTRAJ") ALLOCATE (reftraj) @@ -339,12 +338,11 @@ CONTAINS (simpar%ensemble == nph_uniaxial_ensemble) .OR. & (simpar%ensemble == nph_uniaxial_damped_ensemble)) THEN check = virial%pv_availability - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for this run in the input file!"// & " You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR."// & " Be sure the method you are using can compute the virial!") - END IF IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN @@ -354,12 +352,11 @@ CONTAINS END IF END DO END IF - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Virial evaluation not requested for all the force_eval sections present in"// & " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR"// & " in each force_eval section. Be sure the method you are using can compute the virial!") - END IF END IF ! Computing Forces at zero MD step @@ -405,11 +402,10 @@ CONTAINS dummy = force_env%meta_env%wttemperature*(force_env%meta_env%wtgamma - 1._dp) IF (force_env%meta_env%delta_t > EPSILON(1._dp)) THEN check = ABS(force_env%meta_env%delta_t - dummy) < 1.E+3_dp*EPSILON(1._dp) - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "Inconsistency between DELTA_T and WTGAMMA (both specified):"// & " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE") - END IF ELSE force_env%meta_env%delta_t = dummy END IF @@ -530,9 +526,8 @@ CONTAINS IF (itimes >= simpar%max_steps) should_stop = .TRUE. ! call external hook e.g. from global optimization - IF (PRESENT(mdctrl)) THEN + IF (PRESENT(mdctrl)) & CALL mdctrl_callback(mdctrl, md_env, should_stop) - END IF IF (should_stop) THEN CALL cp_iterate(logger%iter_info, last=.TRUE., iter_nr=itimes) diff --git a/src/motion/md_vel_utils.F b/src/motion/md_vel_utils.F index 715e28439d..3bc1acde2b 100644 --- a/src/motion/md_vel_utils.F +++ b/src/motion/md_vel_utils.F @@ -269,7 +269,7 @@ CONTAINS my_ireg = ireg my_nfree = nfree my_temp = temp - ELSE IF (PRESENT(nfree)) THEN + ELSEIF (PRESENT(nfree)) THEN my_ireg = 0 my_nfree = nfree my_temp = simpar%temp_ext @@ -1257,9 +1257,8 @@ CONTAINS IF (simpar%soften_nsteps <= 0) RETURN !nothing todo - IF (ANY(is_fixed /= use_perd_none)) THEN + IF (ANY(is_fixed /= use_perd_none)) & CPABORT("Velocitiy softening with constraints is not supported.") - END IF !backup positions DO i = 1, SIZE(part) @@ -2002,9 +2001,8 @@ CONTAINS CALL get_molecule_kind(molecule_kind=molecule_kind, fixd_list=fixd_list) IF (ASSOCIATED(fixd_list)) THEN DO ifixd = 1, SIZE(fixd_list) - IF (.NOT. fixd_list(ifixd)%restraint%active) THEN + IF (.NOT. fixd_list(ifixd)%restraint%active) & is_fixed(fixd_list(ifixd)%fixd) = fixd_list(ifixd)%itype - END IF END DO END IF END DO @@ -2114,9 +2112,8 @@ CONTAINS CALL get_molecule_kind_set(molecule_kind_set=molecule_kinds%els, & nconstraint=nconstraint, & nconstraint_fixd=nconstraint_fixd) - IF (nconstraint - nconstraint_fixd /= 0) THEN + IF (nconstraint - nconstraint_fixd /= 0) & CPABORT("Only the fixed atom constraint is implemented for core-shell models") - END IF !MK CPPostcondition(.NOT.simpar%constraint,cp_failure_level,routineP,failure) CPASSERT(ASSOCIATED(shell_particles)) CPASSERT(ASSOCIATED(core_particles)) @@ -2254,9 +2251,8 @@ CONTAINS IF (init_cascade) THEN CALL section_vals_val_get(cascade_section, "ENERGY", r_val=energy) - IF (energy < 0.0_dp) THEN + IF (energy < 0.0_dp) & CPABORT("Error occurred reading &CASCADE section: Negative energy found") - END IF IF (iw > 0) THEN ekin = cp_unit_from_cp2k(energy, "keV") @@ -2270,9 +2266,8 @@ CONTAINS atom_list_section => section_vals_get_subs_vals(cascade_section, "ATOM_LIST") CALL section_vals_val_get(atom_list_section, "_DEFAULT_KEYWORD_", n_rep_val=natom) CALL section_vals_list_get(atom_list_section, "_DEFAULT_KEYWORD_", list=atom_list) - IF (natom <= 0) THEN + IF (natom <= 0) & CPABORT("Error occurred reading &CASCADE section: No atom list found") - END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,T11,A,3(11X,A),9X,A)") & @@ -2291,15 +2286,12 @@ CONTAINS no_read_error = .FALSE. READ (UNIT=line, FMT=*, ERR=999) atom_index(iatom), vatom(1:3, iatom), weight(iatom) no_read_error = .TRUE. -999 IF (.NOT. no_read_error) THEN +999 IF (.NOT. no_read_error) & CPABORT("Error occurred reading &CASCADE section. Last line read <"//TRIM(line)//">") - END IF - IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) THEN + IF ((atom_index(iatom) <= 0) .OR. ((atom_index(iatom) > nparticle))) & CPABORT("Error occurred reading &CASCADE section: Invalid atom index found") - END IF - IF (weight(iatom) < 0.0_dp) THEN + IF (weight(iatom) < 0.0_dp) & CPABORT("Error occurred reading &CASCADE section: Negative weight found") - END IF IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(T2,A,I10,4(1X,F14.6))") & "CASCADE| ", atom_index(iatom), vatom(1:3, iatom), weight(iatom) @@ -2319,7 +2311,7 @@ CONTAINS END DO weight(:) = matom(:)*weight(:)*energy/norm DO iatom = 1, natom - norm = NORM2(vatom(1:3, iatom)) + norm = SQRT(DOT_PRODUCT(vatom(1:3, iatom), vatom(1:3, iatom))) vatom(1:3, iatom) = vatom(1:3, iatom)/norm END DO diff --git a/src/motion/neb_io.F b/src/motion/neb_io.F index 1cd40721df..0e23a7bbb3 100644 --- a/src/motion/neb_io.F +++ b/src/motion/neb_io.F @@ -116,37 +116,33 @@ CONTAINS ! Before continuing let's do some consistency check between keywords IF (neb_env%pot_type /= pot_neb_full) THEN ! Requires the use of colvars - IF (.NOT. neb_env%use_colvar) THEN + IF (.NOT. neb_env%use_colvar) & CALL cp_abort(__LOCATION__, & "A potential energy function based on free energy or minimum energy"// & " was requested without enabling the usage of COLVARS. Both methods"// & " are based on COLVARS definition.") - END IF ! Moreover let's check if the proper sections have been defined.. SELECT CASE (neb_env%pot_type) CASE (pot_neb_fe) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%MD") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CALL cp_abort(__LOCATION__, & "A free energy BAND (colvars projected) calculation is requested"// & " but NONE MD section was defined in the input.") - END IF CASE (pot_neb_me) wrk_section => section_vals_get_subs_vals(neb_env%root_section, "MOTION%GEO_OPT") CALL section_vals_get(wrk_section, explicit=explicit) - IF (.NOT. explicit) THEN + IF (.NOT. explicit) & CALL cp_abort(__LOCATION__, & "A minimum energy BAND (colvars projected) calculation is requested"// & " but NONE GEO_OPT section was defined in the input.") - END IF END SELECT ELSE - IF (neb_env%use_colvar) THEN + IF (neb_env%use_colvar) & CALL cp_abort(__LOCATION__, & "A band calculation was requested with a full potential energy. USE_COLVAR cannot"// & " be set for this kind of calculation!") - END IF END IF ! String Method CALL section_vals_val_get(neb_section, "STRING_METHOD%SMOOTHING", r_val=neb_env%smoothing) @@ -267,10 +263,9 @@ CONTAINS END IF END DO - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" - END IF + routineN//": Done!" CALL cp_print_key_finished_output(iw, logger, neb_env%neb_section, "FINAL_BAND") diff --git a/src/motion/neb_methods.F b/src/motion/neb_methods.F index cba323ad65..9af2b50a23 100644 --- a/src/motion/neb_methods.F +++ b/src/motion/neb_methods.F @@ -462,16 +462,14 @@ CONTAINS IF (do_ls .AND. (.NOT. skip_ls)) THEN CALL neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces, & vels, particle_set, iw, output_unit, distances, diis_section, iw2) - IF (iw2 > 0) THEN + IF (iw2 > 0) & WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD after linesearch", & - stepsize - END IF + stepsize ELSE stepsize = MIN(norm*stepsize0, max_stepsize) - IF (iw2 > 0) THEN + IF (iw2 > 0) & WRITE (iw2, '(T2,A,T69,F12.6)') "SD| Stepsize in SD no linesearch performed", & - stepsize - END IF + stepsize END IF sline%wrk = stepsize*sline%wrk diis_on = accept_diis_step(istep > max_sd_steps, n_diis, err, crr, set_err, sline, coords, & diff --git a/src/motion/neb_opt_utils.F b/src/motion/neb_opt_utils.F index ea36fe5d36..3e1c06599d 100644 --- a/src/motion/neb_opt_utils.F +++ b/src/motion/neb_opt_utils.F @@ -228,7 +228,7 @@ CONTAINS LOGICAL, INTENT(IN) :: check_diis LOGICAL :: accepted - REAL(KIND=dp) :: costh, ref_norm, step_norm + REAL(KIND=dp) :: costh, norm1, norm2 REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp accepted = .TRUE. @@ -237,9 +237,9 @@ CONTAINS ! (a) The direction of the DIIS step, can be compared to the reference step. ! if the angle is grater than a specified value, the DIIS step is not ! acceptable. - ref_norm = NORM2(ref) - step_norm = NORM2(step) - costh = DOT_PRODUCT(ref, step)/(ref_norm*step_norm) + norm1 = SQRT(DOT_PRODUCT(ref, ref)) + norm2 = SQRT(DOT_PRODUCT(step, step)) + costh = DOT_PRODUCT(ref, step)/(norm1*norm2) IF (check_diis) THEN IF (costh < acceptance_factor(MIN(10, nv))) accepted = .FALSE. ELSE @@ -258,7 +258,7 @@ CONTAINS IF (accepted .AND. check_diis) THEN ! (b) The length of the DIIS step is limited to be no more than 10 times ! the reference step - IF (ref_norm > step_norm*10.0_dp) accepted = .FALSE. + IF (norm1 > norm2*10.0_dp) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "The length of the DIIS step is limited to be no more than 10 times", & @@ -267,10 +267,10 @@ CONTAINS END IF IF (accepted .AND. check_diis) THEN ! (d) If the DIIS matrix is nearly singular, the norm of the DIIS step - ! vector becomes small and cwrk/ref_norm becomes large, signaling a - ! numerical stability problems. If the magnitude of cwrk/ref_norm + ! vector becomes small and cwrk/norm1 becomes large, signaling a + ! numerical stability problems. If the magnitude of cwrk/norm1 ! exceeds 10^8 then the step size is assumed to be unacceptable - IF (ANY(ABS(cwrk(1:nv)/ref_norm) > 10**8_dp)) accepted = .FALSE. + IF (ANY(ABS(cwrk(1:nv)/norm1) > 10**8_dp)) accepted = .FALSE. IF (output_unit > 0 .AND. (.NOT. accepted)) THEN WRITE (output_unit, '(T2,"DIIS|",A)') & "If the DIIS matrix is nearly singular, the norm of the DIIS step", & diff --git a/src/motion/neb_utils.F b/src/motion/neb_utils.F index 7f38f3c615..264b4260d7 100644 --- a/src/motion/neb_utils.F +++ b/src/motion/neb_utils.F @@ -118,7 +118,8 @@ CONTAINS CALL rmsd3(particle_set, coords%xyz(:, i), coords%xyz(:, i0), & iw, rotate=my_rotate) END IF - distance = NORM2(coords%wrk(:, i) - coords%wrk(:, i0)) + distance = SQRT(DOT_PRODUCT(coords%wrk(:, i) - coords%wrk(:, i0), & + coords%wrk(:, i) - coords%wrk(:, i0))) END SUBROUTINE neb_replica_distance @@ -223,12 +224,11 @@ CONTAINS DO iatom = 1, natom ! Atom coordinates CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (my_end) THEN + IF (my_end) & CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format for REPLICA coordinates. Very probably the"// & " line with title is missing or is empty. Please check the XYZ file and rerun your job!") - END IF READ (parser%input_line, *) dummy_char, r(1:3) ic = 3*(iatom - 1) coords%xyz(ic + 1:ic + 3, i_rep) = r(1:3)*bohr @@ -737,7 +737,7 @@ CONTAINS ! String method.. tangent(:) = 0.0_dp END SELECT - distance0 = NORM2(tangent(:)) + distance0 = SQRT(DOT_PRODUCT(tangent(:), tangent(:))) IF (distance0 /= 0.0_dp) tangent(:) = tangent(:)/distance0 END SUBROUTINE get_tangent @@ -849,7 +849,7 @@ CONTAINS ALLOCATE (dtmp1(nsize_wrk)) dtmp1(:) = forces%wrk(:, i) - dot_product_band(neb_env, forces%wrk(:, i), tangent, Mmatrix)*tangent forces%wrk(:, i) = dtmp1 - tmp = NORM2(dtmp1) + tmp = SQRT(DOT_PRODUCT(dtmp1, dtmp1)) dtmp1(:) = dtmp1(:)/tmp ! Project out only the spring component interfering with the ! orthogonal gradient of the band diff --git a/src/motion/pint_methods.F b/src/motion/pint_methods.F index 8e9e1464c4..1f59bcbb61 100644 --- a/src/motion/pint_methods.F +++ b/src/motion/pint_methods.F @@ -182,7 +182,7 @@ CONTAINS CHARACTER(len=2*default_string_length) :: msg CHARACTER(len=default_path_length) :: output_file_name, project_name INTEGER :: handle, iat, ibead, icont, idim, idir, & - ierr, ig, itmp, nrep, prep + ierr, ig, itmp, nrep, prep, stat LOGICAL :: explicit, ltmp REAL(kind=dp) :: dt, mass, omega TYPE(cp_subsys_type), POINTER :: subsys @@ -377,7 +377,9 @@ CONTAINS pint_env%uf_h(pint_env%p, pint_env%ndim), & pint_env%centroid(pint_env%ndim), & pint_env%rtmp_ndim(pint_env%ndim), & - pint_env%rtmp_natom(pint_env%ndim/3)) + pint_env%rtmp_natom(pint_env%ndim/3), & + STAT=stat) + CPASSERT(stat == 0) pint_env%x = 0._dp pint_env%v = 0._dp pint_env%f = 0._dp @@ -474,6 +476,7 @@ CONTAINS pint_env%gle%loc_num_gle = pint_env%p*pint_env%ndim pint_env%gle%glob_num_gle = pint_env%gle%loc_num_gle ALLOCATE (pint_env%gle%map_info%index(pint_env%gle%loc_num_gle)) + CPASSERT(stat == 0) DO itmp = 1, pint_env%gle%loc_num_gle pint_env%gle%map_info%index(itmp) = itmp END DO @@ -1165,9 +1168,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & CPABORT("Invalid size of MOTION%PINT%BEADS%COORD") - END IF ic = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1335,9 +1337,8 @@ CONTAINS WRITE (stmp, *) n_rep_val msg = "Invalid number of atoms in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (3*n_rep_val /= pint_env%ndim) THEN + IF (3*n_rep_val /= pint_env%ndim) & CPABORT(msg) - END IF DO ia = 1, pint_env%ndim/3 CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & i_rep_val=ia, r_vals=r_vals) @@ -1346,9 +1347,8 @@ CONTAINS WRITE (stmp, *) itmp msg = "Number of coordinates != 3 in FORCE_EVAL%SUBSYS%VELOCITY ("// & TRIM(ADJUSTL(stmp))//")." - IF (itmp /= 3) THEN + IF (itmp /= 3) & CPABORT(msg) - END IF DO ib = 1, pint_env%p DO ic = 1, 3 idim = 3*(ia - 1) + ic @@ -1464,9 +1464,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim) & CPABORT("Invalid size of MOTION%PINT%BEAD%VELOCITY") - END IF itmp = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1643,9 +1642,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & CPABORT("Invalid size of MOTION%PINT%NOSE%COORD") - END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1672,9 +1670,8 @@ CONTAINS CPASSERT(n_rep_val == 1) CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_", & r_vals=r_vals) - IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) THEN + IF (SIZE(r_vals) /= pint_env%p*pint_env%ndim*pint_env%nnos) & CPABORT("Invalid size of MOTION%PINT%NOSE%VELOCITY") - END IF ii = 0 DO idim = 1, pint_env%ndim DO ib = 1, pint_env%p @@ -1690,7 +1687,7 @@ CONTAINS END IF END IF - ELSE IF (pint_env%pimd_thermostat == thermostat_gle) THEN + ELSEIF (pint_env%pimd_thermostat == thermostat_gle) THEN NULLIFY (input_section) input_section => section_vals_get_subs_vals(pint_env%input, & "MOTION%PINT%GLE") diff --git a/src/motion/pint_piglet.F b/src/motion/pint_piglet.F index 781149afb0..0170324d7e 100644 --- a/src/motion/pint_piglet.F +++ b/src/motion/pint_piglet.F @@ -493,8 +493,7 @@ CONTAINS END DO END DO - ! the piglet is such a strong thermostat, that it messes up the "exact" integration. - ! The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) + ! the piglet is such a strong thermostat, that it messes up the "exact" integration. The thermostats energy will rise lineary, because "it will suck up its own mess" (quote from Michele Ceriotti) piglet_therm%thermostat_energy = piglet_therm%thermostat_energy - 0.5_dp*delta_ekin CALL timestop(handle) diff --git a/src/motion/pint_public.F b/src/motion/pint_public.F index c305ca9656..5d9d1bed66 100644 --- a/src/motion/pint_public.F +++ b/src/motion/pint_public.F @@ -148,7 +148,7 @@ CONTAINS np = 2**il ! number of points to be generated at this level dl = n/(2*np) ! interval betw points (in index numbers) - vrnc = vrnc/2.0_dp ! variance at this level (=t at level 0) + vrnc = vrnc/2.0_dp; ! variance at this level (=t at level 0) ! loop over points added in this level DO ip = 0, np - 1 diff --git a/src/motion/reftraj_util.F b/src/motion/reftraj_util.F index 00d61232d1..55daf473eb 100644 --- a/src/motion/reftraj_util.F +++ b/src/motion/reftraj_util.F @@ -112,22 +112,20 @@ CONTAINS END IF reftraj%isnap = nskip - IF (my_end) THEN + IF (my_end) & CALL cp_abort(__LOCATION__, & "Reached the end of the trajectory file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") - END IF ! Cell File IF (reftraj%info%variable_volume) THEN IF (nskip > 0) THEN CALL parser_get_next_line(reftraj%info%cell_parser, nskip, at_end=my_end) END IF - IF (my_end) THEN + IF (my_end) & CALL cp_abort(__LOCATION__, & "Reached the end of the cell file for REFTRAJ. Number of steps skipped "// & "equal to the number of steps present in the file.") - END IF END IF reftraj%natom = natom diff --git a/src/motion/rt_propagation.F b/src/motion/rt_propagation.F index 67170aa565..5e72c71fbc 100644 --- a/src/motion/rt_propagation.F +++ b/src/motion/rt_propagation.F @@ -294,8 +294,7 @@ CONTAINS CALL rt_initialize_rho_from_mos(rtp, mos) END IF ELSE - ! The wavefunction was minimized using a linear scaling method. - ! The density matrix is therefore taken from the ls_scf_env. + !The wavefunction was minimized using a linear scaling method. The density matrix is therefore taken from the ls_scf_env. CALL get_rtp(rtp=rtp, rho_old=rho_old, rho_new=rho_new) DO ispin = 1, SIZE(rho_old)/2 re = 2*ispin - 1 @@ -418,9 +417,8 @@ CONTAINS CALL cp_iterate(logger%iter_info, last=(i_step == max_steps), iter_nr=i_step) rtp%converged = .FALSE. DO i_iter = 1, max_iter - IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) THEN + IF (i_step == rtp%i_start + 1 .AND. i_iter == 2 .AND. rtp_control%hfx_redistribute) & CALL qs_ks_did_change(qs_env%ks_env, s_mstruct_changed=.TRUE.) - END IF rtp%iter = i_iter CALL propagation_step(qs_env, rtp, rtp_control) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) @@ -446,10 +444,9 @@ CONTAINS END DO CALL cp_rm_iter_level(logger%iter_info, "MD") - IF (.NOT. rtp%converged) THEN + IF (.NOT. rtp%converged) & CALL cp_abort(__LOCATION__, "propagation did not converge, "// & "either increase MAX_ITER or use a smaller TIMESTEP") - END IF CALL timestop(handle) @@ -620,9 +617,8 @@ CONTAINS CALL set_ks_env(ks_env, complex_ks=imag_ks) IF (imag_ks) THEN CALL qs_ks_allocate_basics(qs_env, is_complex=imag_ks) - IF (.NOT. dft_control%rtp_control%fixed_ions) THEN + IF (.NOT. dft_control%rtp_control%fixed_ions) & CALL rtp_create_SinvH_imag(rtp, dft_control%nspins) - END IF END IF ! h diff --git a/src/motion/simpar_methods.F b/src/motion/simpar_methods.F index b9b5058f74..0e25a66a64 100644 --- a/src/motion/simpar_methods.F +++ b/src/motion/simpar_methods.F @@ -320,19 +320,17 @@ CONTAINS CALL section_vals_get(tmp_section, explicit=simpar%constraint) IF (simpar%constraint) THEN CALL section_vals_val_get(tmp_section, "SHAKE_TOLERANCE", r_val=simpar%shake_tol) - IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN + IF (simpar%shake_tol <= EPSILON(0.0_dp)*1000.0_dp) & CALL cp_warn(__LOCATION__, & "Shake tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up shake_tol to 1000*EPSILON!") - END IF simpar%shake_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%shake_tol) CALL section_vals_val_get(tmp_section, "ROLL_TOLERANCE", r_val=simpar%roll_tol) - IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) THEN + IF (simpar%roll_tol <= EPSILON(0.0_dp)*1000.0_dp) & CALL cp_warn(__LOCATION__, & "Roll tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "// & "This may lead to numerical problems. Setting up roll_tol to 1000*EPSILON!") - END IF simpar%roll_tol = MAX(EPSILON(0.0_dp)*1000.0_dp, simpar%roll_tol) END IF diff --git a/src/motion/thermal_region_utils.F b/src/motion/thermal_region_utils.F index b90e95b7af..7d1a6aee4c 100644 --- a/src/motion/thermal_region_utils.F +++ b/src/motion/thermal_region_utils.F @@ -425,14 +425,12 @@ CONTAINS TRIM(my_reg)//" which is not allowed!") END IF ELSE - IF (.NOT. ipart > 0) THEN + IF (.NOT. ipart > 0) & CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is non-positive!") - END IF - IF (.NOT. ipart <= particles%n_els) THEN + IF (.NOT. ipart <= particles%n_els) & CALL cp_abort(__LOCATION__, & "Input atom index "//TRIM(my_part)//" is out of bounds!") - END IF END IF END SUBROUTINE set_t_region_index diff --git a/src/motion/thermostat/al_system_dynamics.F b/src/motion/thermostat/al_system_dynamics.F index 935d2959e4..c17af73a3b 100644 --- a/src/motion/thermostat/al_system_dynamics.F +++ b/src/motion/thermostat/al_system_dynamics.F @@ -72,23 +72,20 @@ CONTAINS my_shell_adiabatic = .FALSE. map_info => al%map_info - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "INIT") - END IF IF (al%tau_nh <= 0.0_dp) THEN CALL al_OU_step(0.5_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post OU") - END IF ELSE ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 1st OU") - END IF ! Compute the kinetic energy for the region to thermostat for the (T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & @@ -102,9 +99,8 @@ CONTAINS ! Recompute the kinetic energy for the region to thermostat (for the T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set, & local_molecules, molecule_set, group, vel=vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post rescale_vel") - END IF ! quarter step of chi CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.FALSE.) @@ -112,9 +108,8 @@ CONTAINS ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, vel) - IF (debug_this_module) THEN + IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 2nd OU") - END IF END IF ! Recompute the final kinetic energy for the region to thermostat @@ -192,7 +187,7 @@ CONTAINS iparticle_local, jj, last_atom, nmol_local, nparticle, nparticle_kind, nparticle_local LOGICAL :: check, present_vel REAL(KIND=dp) :: mass - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: w(:, :) TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(molecule_type), POINTER :: molecule diff --git a/src/motion/thermostat/al_system_init.F b/src/motion/thermostat/al_system_init.F index 776589c531..f68e657e98 100644 --- a/src/motion/thermostat/al_system_init.F +++ b/src/motion/thermostat/al_system_init.F @@ -130,10 +130,9 @@ CONTAINS work_section => section_vals_get_subs_vals(section_vals=al_section, & subsection_name="MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (restart .NEQV. explicit) THEN + IF (restart .NEQV. explicit) & CALL cp_abort(__LOCATION__, & "You need to define both CHI and MASS sections (or none) in the AD_LANGEVIN section") - END IF restart = restart .AND. explicit IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section, keyword_name="_DEFAULT_KEYWORD_", & diff --git a/src/motion/thermostat/barostat_types.F b/src/motion/thermostat/barostat_types.F index 0fcea72931..b5227e3243 100644 --- a/src/motion/thermostat/barostat_types.F +++ b/src/motion/thermostat/barostat_types.F @@ -118,16 +118,14 @@ CONTAINS ! User defined virial screening CALL section_vals_val_get(barostat_section, "VIRIAL", i_val=barostat%virial_components) check = barostat%virial_components == do_clv_xyz .OR. simpar%ensemble == npt_f_ensemble - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "The screening of the components of "// & "the virial is available only with the NPT_F ensemble!") - END IF ELSE - IF (explicit) THEN + IF (explicit) & CALL cp_warn(__LOCATION__, & "A barostat has been defined with an MD ensemble which does not support barostat! "// & "Its definition will be ignored!") - END IF END IF END SUBROUTINE create_barostat_type diff --git a/src/motion/thermostat/barostat_utils.F b/src/motion/thermostat/barostat_utils.F index 9c03aa5a03..0028cd607a 100644 --- a/src/motion/thermostat/barostat_utils.F +++ b/src/motion/thermostat/barostat_utils.F @@ -75,7 +75,7 @@ CONTAINS baro_kin = baro_kin + 0.5_dp*npt(i, j)%v**2*npt(i, j)%mass END DO END DO - ELSE IF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN + ELSEIF (simpar%ensemble == nph_uniaxial_ensemble .OR. simpar%ensemble == nph_uniaxial_damped_ensemble) THEN v0 = simpar%v0 iv0 = 1._dp/v0 v_shock = simpar%v_shock diff --git a/src/motion/thermostat/extended_system_init.F b/src/motion/thermostat/extended_system_init.F index 733677c944..1f3feae8b0 100644 --- a/src/motion/thermostat/extended_system_init.F +++ b/src/motion/thermostat/extended_system_init.F @@ -126,10 +126,9 @@ CONTAINS restart = explicit work_section2 => section_vals_get_subs_vals(work_section, "MASS") CALL section_vals_get(work_section2, explicit=explicit) - IF (restart .NEQV. explicit) THEN + IF (restart .NEQV. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "MASS section (or none) in the BAROSTAT section") - END IF restart = explicit .AND. restart END IF @@ -617,24 +616,21 @@ CONTAINS restart = explicit work_section => section_vals_get_subs_vals(nose_section, "COORD") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) THEN + IF (.NOT. restart .AND. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") - END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "MASS") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) THEN + IF (.NOT. restart .AND. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") - END IF restart = explicit .AND. restart work_section => section_vals_get_subs_vals(nose_section, "FORCE") CALL section_vals_get(work_section, explicit=explicit) - IF (.NOT. restart .AND. explicit) THEN + IF (.NOT. restart .AND. explicit) & CALL cp_abort(__LOCATION__, "You need to define both VELOCITY and "// & "COORD and MASS and FORCE section (or none) in the NOSE section") - END IF restart = explicit .AND. restart END IF diff --git a/src/motion/thermostat/extended_system_mapping.F b/src/motion/thermostat/extended_system_mapping.F index de819b53ab..24296d6be1 100644 --- a/src/motion/thermostat/extended_system_mapping.F +++ b/src/motion/thermostat/extended_system_mapping.F @@ -333,9 +333,8 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 - END IF END DO END DO @@ -429,9 +428,8 @@ CONTAINS map_info%s_kin = 0.0_dp DO i = 1, 3 DO j = 1, natoms_local - IF (ASSOCIATED(map_info%p_kin(i, j)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(i, j)%point)) & map_info%p_kin(i, j)%point = map_info%p_kin(i, j)%point + 1 - END IF END DO END DO diff --git a/src/motion/thermostat/gle_system_dynamics.F b/src/motion/thermostat/gle_system_dynamics.F index 819e98448c..9bbbf2728d 100644 --- a/src/motion/thermostat/gle_system_dynamics.F +++ b/src/motion/thermostat/gle_system_dynamics.F @@ -289,7 +289,7 @@ CONTAINS L(i, i) = 1.0_dp D(i) = SST(i, i) DO j = 1, i - 1 - L(i, j) = SST(i, j) + L(i, j) = SST(i, j); DO k = 1, j - 1 L(i, j) = L(i, j) - L(i, k)*L(j, k)*D(k) END DO diff --git a/src/motion/thermostat/thermostat_utils.F b/src/motion/thermostat/thermostat_utils.F index 3cfc8a24bb..f3e5828f48 100644 --- a/src/motion/thermostat/thermostat_utils.F +++ b/src/motion/thermostat/thermostat_utils.F @@ -384,9 +384,8 @@ CONTAINS DO ipart = first_atom, last_atom natom_local = natom_local + 1 ! only map the correct region to the thermostat - IF (thermolist(ipart) /= HUGE(0)) THEN + IF (thermolist(ipart) /= HUGE(0)) & thermostat_info%map_loc_thermo_gen(natom_local) = thermolist(ipart) - END IF END DO END DO END DO @@ -453,7 +452,7 @@ CONTAINS qmmm_env) TYPE(section_vals_type), POINTER :: region_sections INTEGER, INTENT(INOUT), OPTIONAL :: sum_of_thermostats - INTEGER, POINTER :: thermolist(:) + INTEGER, DIMENSION(:), POINTER :: thermolist(:) TYPE(molecule_kind_type), POINTER :: molecule_kind_set(:) TYPE(molecule_list_type), POINTER :: molecules TYPE(particle_list_type), POINTER :: particles @@ -653,21 +652,19 @@ CONTAINS nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) THEN + IF (sum_of_thermostats < 1) & CALL cp_abort(__LOCATION__, & "A thermostat type DEFINED is requested but no thermostat "// & "regions are defined in THERMOSTAT/DEFINE_REGION.") - END IF CASE (do_region_thermal) ! Similar to defined region above, but in THERMAL_REGION%DEFINE_REGION nointer = .FALSE. ! Determine the number of thermostats defined in the input CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) - IF (sum_of_thermostats < 1) THEN + IF (sum_of_thermostats < 1) & CALL cp_abort(__LOCATION__, & "A thermostat type THERMAL is requested but no thermal "// & "regions are defined in THERMAL_REGION/DEFINE_REGION.") - END IF END SELECT ! Here we decide which parallel algorithm to use. @@ -1085,25 +1082,19 @@ CONTAINS atomic_kind => particle_set(ipart)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, mass=mass) IF (present_vel) THEN - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*vel(1, ipart)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*vel(2, ipart)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*vel(3, ipart)**2 - END IF ELSE - IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(1, ii)%point)) & map_info%p_kin(1, ii)%point = map_info%p_kin(1, ii)%point + mass*particle_set(ipart)%v(1)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(2, ii)%point)) & map_info%p_kin(2, ii)%point = map_info%p_kin(2, ii)%point + mass*particle_set(ipart)%v(2)**2 - END IF - IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) THEN + IF (ASSOCIATED(map_info%p_kin(3, ii)%point)) & map_info%p_kin(3, ii)%point = map_info%p_kin(3, ii)%point + mass*particle_set(ipart)%v(3)**2 - END IF END IF END DO END DO diff --git a/src/motion/vibrational_analysis.F b/src/motion/vibrational_analysis.F index cdefc2aa4d..88128bdefa 100644 --- a/src/motion/vibrational_analysis.F +++ b/src/motion/vibrational_analysis.F @@ -653,7 +653,7 @@ CONTAINS DO j = 1, nvib D_deriv(:) = D_deriv(:) + dip_deriv(:, j)*Hint2(j, i) END DO - intensities_d(i) = NORM2(D_deriv) + intensities_d(i) = SQRT(DOT_PRODUCT(D_deriv, D_deriv)) P_deriv = 0._dp DO j = 1, nvib ! P_deriv has units bohr^2/sqrt(a.u.) @@ -970,7 +970,7 @@ CONTAINS work(:) = work - norm*D(:, i) END DO ! Check norm of the new generated vector - norm = NORM2(work) + norm = SQRT(DOT_PRODUCT(work, work)) IF (norm >= 10E4_dp*thrs_motion) THEN ! Accept new vector ifound = ifound + 1 diff --git a/src/motion/xyz2dcd.F b/src/motion/xyz2dcd.F index 91cacc54bc..7ccc80c0aa 100644 --- a/src/motion/xyz2dcd.F +++ b/src/motion/xyz2dcd.F @@ -13,8 +13,7 @@ PROGRAM xyz2dcd ! ! Note: The input coordinates and the cell vectors should be in Angstrom. -! Uncomment the following line if this module is available (e.g. with gfortran) -! and comment the corresponding variable declarations below +! Uncomment the following line if this module is available (e.g. with gfortran) and comment the corresponding variable declarations below ! USE ISO_FORTRAN_ENV, ONLY: error_unit,input_unit,output_unit IMPLICIT NONE @@ -368,9 +367,9 @@ PROGRAM xyz2dcd a(1:3) = h(1:3, 1) b(1:3) = h(1:3, 2) c(1:3) = h(1:3, 3) - abc(1) = NORM2(a(1:3)) - abc(2) = NORM2(b(1:3)) - abc(3) = NORM2(c(1:3)) + abc(1) = SQRT(DOT_PRODUCT(a(1:3), a(1:3))) + abc(2) = SQRT(DOT_PRODUCT(b(1:3), b(1:3))) + abc(3) = SQRT(DOT_PRODUCT(c(1:3), c(1:3))) alpha = angle(b(1:3), c(1:3))*degree beta = angle(a(1:3), c(1:3))*degree gamma = angle(a(1:3), b(1:3))*degree @@ -580,8 +579,8 @@ CONTAINS REAL(KIND=dp) :: length_of_a, length_of_b REAL(KIND=dp), DIMENSION(SIZE(a, 1)) :: a_norm, b_norm - length_of_a = NORM2(a) - length_of_b = NORM2(b) + length_of_a = SQRT(DOT_PRODUCT(a, a)) + length_of_b = SQRT(DOT_PRODUCT(b, b)) IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN a_norm(:) = a(:)/length_of_a diff --git a/src/motion_utils.F b/src/motion_utils.F index 518479b9b3..d83916a8e3 100644 --- a/src/motion_utils.F +++ b/src/motion_utils.F @@ -180,7 +180,7 @@ CONTAINS END DO ! Normalize Translations DO i = 1, 3 - norm = NORM2(Tr(:, i)) + norm = SQRT(DOT_PRODUCT(Tr(:, i), Tr(:, i))) Tr(:, i) = Tr(:, i)/norm END DO dof = 3 @@ -445,9 +445,8 @@ CONTAINS CALL section_vals_val_get(root_section, "MOTION%PRINT%TRAJECTORY%CHARGE_EXTENDED", & l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) THEN + IF (i > 1) & CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected, ") - END IF END IF IF (new_file) THEN CALL m_timestamp(timestamp) diff --git a/src/mp2_cphf.F b/src/mp2_cphf.F index b79c447ade..17064b72ff 100644 --- a/src/mp2_cphf.F +++ b/src/mp2_cphf.F @@ -1204,9 +1204,8 @@ CONTAINS precond(ispin)%local_data(:, :)*residual(ispin)%local_data(:, :) END DO ELSE - IF (mp2_env%ri_grad%polak_ribiere) THEN + IF (mp2_env%ri_grad%polak_ribiere) & residual_new_dot_diff_search_vec_old = accurate_dot_product_spin(residual, diff_search_vector) - END IF DO ispin = 1, nspins diff_search_vector(ispin)%local_data(:, :) = & @@ -1811,8 +1810,7 @@ CONTAINS deb = force(1)%overlap_admm(1:3, 1) IF (use_virial) e_dummy = third_tr(virial%pv_virial) END IF - ! Add the second half of the projector deriatives contracting the first order - ! density matrix with the fockian in the auxiliary basis + ! Add the second half of the projector deriatives contracting the first order density matrix with the fockian in the auxiliary basis IF (do_exx) THEN CALL admm_projection_derivative(qs_env, matrix_ks_aux, matrix_p_mp2) ELSE diff --git a/src/mp2_eri.F b/src/mp2_eri.F index 41e5c51153..0f8887f897 100644 --- a/src/mp2_eri.F +++ b/src/mp2_eri.F @@ -743,11 +743,9 @@ CONTAINS basis_set_a => basis_set_list_a(ikind)%gto_basis_set ! When RI_AUX NONE is invoked, the pointers to basis_set_a and basis_set_b are created, ! but not filled. Therefore, we check for the association and the number of entries. - IF (.NOT. ASSOCIATED(basis_set_a)) CYCLE - IF (SUM(basis_set_a%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_a) .OR. SUM(basis_set_a%nsgf_set) <= 0) CYCLE basis_set_b => basis_set_list_b(jkind)%gto_basis_set - IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE - IF (SUM(basis_set_b%nsgf_set) <= 0) CYCLE + IF (.NOT. ASSOCIATED(basis_set_b) .OR. SUM(basis_set_b%nsgf_set) <= 0) CYCLE atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) diff --git a/src/mp2_gpw.F b/src/mp2_gpw.F index 46cb0e6a20..98525dd116 100644 --- a/src/mp2_gpw.F +++ b/src/mp2_gpw.F @@ -559,9 +559,8 @@ CONTAINS starts_array_mc, ends_array_mc, & starts_array_mc_block, ends_array_mc_block, calc_forces) - IF (mp2_env%ri_rpa%do_rse) THEN + IF (mp2_env%ri_rpa%do_rse) & CALL rse_energy(qs_env, mp2_env, para_env, dft_control, mo_coeff, homo, Eigenval) - END IF IF (do_im_time) THEN IF (ASSOCIATED(mat_P_global%matrix)) THEN diff --git a/src/mp2_grids.F b/src/mp2_grids.F index 85dd1350ba..b252e372b8 100644 --- a/src/mp2_grids.F +++ b/src/mp2_grids.F @@ -133,13 +133,12 @@ CONTAINS my_regularization = regularization IF (num_integ_points > 20 .AND. e_range < 100.0_dp) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL cp_warn(__LOCATION__, & "You requested a large minimax grid (> 20 points) for a small minimax range R (R < 100). "// & "That may lead to numerical "// & "instabilities when computing minimax grid weights. You can prevent small ranges by choosing "// & "a larger basis set with higher angular momenta or alternatively using all-electron calculations.") - END IF END IF IF (.NOT. do_ri_sos_laplace_mp2) THEN diff --git a/src/mp2_ri_2c.F b/src/mp2_ri_2c.F index 4ff515a0c1..33beee71d0 100644 --- a/src/mp2_ri_2c.F +++ b/src/mp2_ri_2c.F @@ -916,9 +916,9 @@ CONTAINS hab=L_local_col, first_b=my_group_L_start, last_b=my_group_L_end, & eri_method=eri_method) - ELSE IF (eri_method == do_eri_gpw .OR. & - (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & - .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN + ELSEIF (eri_method == do_eri_gpw .OR. & + (potential_type == do_potential_long .AND. qs_env%mp2_env%eri_method == do_eri_os) & + .OR. (potential_type == do_potential_id .AND. qs_env%mp2_env%eri_method == do_eri_mme)) THEN CALL mp2_eri_2c_integrate_gpw(qs_env, para_env_sub, my_group_L_start, my_group_L_end, & natom, potential, sab_orb_sub, L_local_col, kind_of) diff --git a/src/mp2_ri_gpw.F b/src/mp2_ri_gpw.F index 39ce98dfc8..93e6956add 100644 --- a/src/mp2_ri_gpw.F +++ b/src/mp2_ri_gpw.F @@ -384,8 +384,7 @@ CONTAINS END IF END DO IF (my_alpha_beta_case .AND. calc_forces) THEN - ! Is just an approximation, but the call does not allow it, - ! it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI + ! Is just an approximation, but the call does not allow it, it ought to be (virtual_i*B_size_j+virtual_j*B_size_i)*dimen_RI CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(ispin) + my_B_size(jspin), dimen_RI) ELSE CALL dgemm_counter_stop(dgemm_counter, virtual(ispin), my_B_size(jspin), dimen_RI) @@ -452,12 +451,11 @@ CONTAINS my_Emp2_Ex = my_Emp2_Ex + sym_fac*local_ab(a_global, b)*external_ab(b, a)/ & (Eigenval(homo(ispin) + a_global, ispin) + Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) - IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) THEN + IF (calc_forces .AND. (.NOT. my_alpha_beta_case)) & t_ab(a_global, b) = -(amp_fac*local_ab(a_global, b) - mp2_env%scale_T*external_ab(b, a))/ & (Eigenval(homo(ispin) + a_global, ispin) + & Eigenval(homo(ispin) + b_global, ispin) - & Eigenval(my_i + iiB - 1, ispin) - Eigenval(my_j + jjB - 1, ispin)) - END IF END DO END DO END DO @@ -675,9 +673,8 @@ CONTAINS ! We do not need this matrix later, so deallocate it here to safe memory IF (calc_forces) DEALLOCATE (mp2_env%ri_grad%PQ_half) - IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) THEN + IF (calc_forces .AND. .NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) & DEALLOCATE (mp2_env%ri_grad%operator_half) - END IF CALL dgemm_counter_write(dgemm_counter, para_env) @@ -1397,8 +1394,7 @@ CONTAINS ! 2*(NR/NG)+2*(1-(NR/NG))*(o/NB+NB-2)/NG = (NR/NG)*(1-(o/NB+NB-2)/NG)+(o/NB+NB-2)/NG ! We are looking for the minimum of the communication volume, ! thus, if the prefactor of (NR/NG) is smaller than zero, use the largest possible replication group size. - ! If the factor is larger than zero, set the replication group size to 1. - ! (For small systems and a large number of subgroups) + ! If the factor is larger than zero, set the replication group size to 1. (For small systems and a large number of subgroups) ! Replication group size = 1 implies that the integration group size equals the number of subgroups integ_group_size = ngroup @@ -2551,9 +2547,8 @@ CONTAINS DO iiB = 1, homo ! diagonal elements already updated DO jjB = iiB + 1, homo - IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) THEN + IF (ABS(Eigenval(jjB) - Eigenval(iiB)) < mp2_env%ri_grad%eps_canonical) & num_sing_ij = num_sing_ij + 1 - END IF END DO END DO diff --git a/src/mp2_ri_grad.F b/src/mp2_ri_grad.F index 266f1edd5d..9c98de42df 100644 --- a/src/mp2_ri_grad.F +++ b/src/mp2_ri_grad.F @@ -331,7 +331,7 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(matrix_P_munu_local) CALL dbcsr_deallocate_matrix_set(mat_munu_local) - ELSE IF (eri_method == do_eri_gpw) THEN + ELSEIF (eri_method == do_eri_gpw) THEN CALL get_qs_env(qs_env, ks_env=ks_env) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind) diff --git a/src/mpiwrap/message_passing.F b/src/mpiwrap/message_passing.F index 15f8d39d2c..3c62f4ee9b 100644 --- a/src/mpiwrap/message_passing.F +++ b/src/mpiwrap/message_passing.F @@ -33,8 +33,7 @@ MODULE message_passing #include "../base/base_uses.f90" -! To simplify the transition between the old MPI module and the F08-style module, -! we introduce these constants to switch between the required handle types +! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types ! Unfortunately, Fortran does not offer something like typedef in C++ #if defined(__parallel) && defined(__MPI_F08) #define MPI_DATA_TYPE TYPE(MPI_Datatype) @@ -61,11 +60,9 @@ MODULE message_passing #endif #if defined(__parallel) -! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines -! (problems with types and ranks explosion), +! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion), ! we do not quite know what is in the module, so we can not include any.... -! to nevertheless get checking for what is included, we use the mpi module -! without use clause, getting all there is +! to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is #if defined(__MPI_F08) USE mpi_f08 #else diff --git a/src/mpiwrap/mp_perf_env.F b/src/mpiwrap/mp_perf_env.F index 7a28a50ebc..9c331367a6 100644 --- a/src/mpiwrap/mp_perf_env.F +++ b/src/mpiwrap/mp_perf_env.F @@ -13,8 +13,6 @@ MODULE mp_perf_env USE kinds, ONLY: dp #include "../base/base_uses.f90" - IMPLICIT NONE - PRIVATE PUBLIC :: mp_perf_env_type diff --git a/src/mpiwrap/mp_perf_test.F b/src/mpiwrap/mp_perf_test.F index 675e5b675d..3e9a701fbc 100644 --- a/src/mpiwrap/mp_perf_test.F +++ b/src/mpiwrap/mp_perf_test.F @@ -34,8 +34,6 @@ MODULE mp_perf_test #endif #endif - IMPLICIT NONE - PRIVATE PUBLIC :: mpi_perf_test @@ -336,9 +334,8 @@ CONTAINS END IF rcount = Nloc DO itests = 1, 3 - IF (ionode .AND. output_unit > 0) THEN + IF (ionode .AND. output_unit > 0) & WRITE (output_unit, *) "------------------------------- test ", itests, " ------------------------" - END IF ! *** reference *** DO j = 1, Nprocs DO i = 1, Nloc diff --git a/src/mscfg_methods.F b/src/mscfg_methods.F index 823de2c554..ee2a906e27 100644 --- a/src/mscfg_methods.F +++ b/src/mscfg_methods.F @@ -191,10 +191,8 @@ CONTAINS smear_almo_scf = qs_env%scf_control%smear%do_smear IF (smear_almo_scf) THEN scf_section => section_vals_get_subs_vals(dft_section, "SCF") - !! Get total number of added MOs - CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) - !! Get total number of atoms (assume consecutive atoms) - tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 + CALL section_vals_val_get(scf_section, "added_mos", i_val=tot_added_mos) !! Get total number of added MOs + tot_isize = last_atom_of_frag(nfrags) - first_atom_of_frag(1) + 1 !! Get total number of atoms (assume consecutive atoms) !! Check that number of added MOs matches the number of atoms !! (to ensure compatibility, since each fragment will be computed with such parameters) IF (tot_isize /= tot_added_mos) THEN @@ -202,8 +200,7 @@ CONTAINS END IF !! Get total number of MOs CALL get_qs_env(qs_env, mos=mos) - !! Unrestricted ALMO is not implemented yet - IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") + IF (SIZE(mos) > 1) CPABORT("Unrestricted ALMO methods are NYI") !! Unrestricted ALMO is not implemented yet CALL get_mo_set(mo_set=mos(1), nmo=nmo) !! Initialize storage of MO energies for ALMO smearing CPASSERT(ASSOCIATED(almo_scf_env)) diff --git a/src/mulliken.F b/src/mulliken.F index 0f77d12cf9..d1fe760821 100644 --- a/src/mulliken.F +++ b/src/mulliken.F @@ -726,7 +726,7 @@ CONTAINS charges(i) = charges(i) + p_block(i, j)*s_block(i, j) END DO END DO - ELSE IF (iblock_col == iatom) THEN + ELSEIF (iblock_col == iatom) THEN DO j = 1, SIZE(p_block, 2) DO i = 1, SIZE(p_block, 1) charges(j) = charges(j) + p_block(i, j)*s_block(i, j) diff --git a/src/negf_control_types.F b/src/negf_control_types.F index 0defb5e2e0..8d9c718239 100644 --- a/src/negf_control_types.F +++ b/src/negf_control_types.F @@ -183,19 +183,16 @@ CONTAINS IF (ALLOCATED(negf_control%contacts)) THEN DO i = SIZE(negf_control%contacts), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) THEN + IF (ALLOCATED(negf_control%contacts(i)%atomlist_bulk)) & DEALLOCATE (negf_control%contacts(i)%atomlist_bulk) - END IF - IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) THEN + IF (ALLOCATED(negf_control%contacts(i)%atomlist_screening)) & DEALLOCATE (negf_control%contacts(i)%atomlist_screening) - END IF IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell)) THEN DO j = SIZE(negf_control%contacts(i)%atomlist_cell), 1, -1 - IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) THEN + IF (ALLOCATED(negf_control%contacts(i)%atomlist_cell(j)%vector)) & DEALLOCATE (negf_control%contacts(i)%atomlist_cell(j)%vector) - END IF END DO DEALLOCATE (negf_control%contacts(i)%atomlist_cell) END IF @@ -368,9 +365,8 @@ CONTAINS CALL section_vals_val_get(negf_section, "INTEGRATION_MIN_POINTS", i_val=negf_control%integr_min_points) CALL section_vals_val_get(negf_section, "INTEGRATION_MAX_POINTS", i_val=negf_control%integr_max_points) - IF (negf_control%integr_max_points < negf_control%integr_min_points) THEN + IF (negf_control%integr_max_points < negf_control%integr_min_points) & negf_control%integr_max_points = negf_control%integr_min_points - END IF CALL section_vals_val_get(negf_section, "MAX_SCF", i_val=negf_control%max_scf) @@ -432,9 +428,8 @@ CONTAINS DO i_rep = 1, n_rep IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN - IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) THEN + IF (ALLOCATED(negf_control%contacts(i_rep)%atomlist_screening)) & natoms_total = natoms_total + SIZE(negf_control%contacts(i_rep)%atomlist_screening) - END IF END IF END DO diff --git a/src/negf_env_types.F b/src/negf_env_types.F index f4d2564279..7ddea351b0 100644 --- a/src/negf_env_types.F +++ b/src/negf_env_types.F @@ -290,10 +290,9 @@ CONTAINS (icontact, sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, & para_env, negf_env, sub_env, negf_control, negf_section, log_unit, is_separate=.TRUE.) ELSE - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the separate bulk DFT calculation" - END IF + " from the separate bulk DFT calculation" CALL force_env_get(sub_force_env(negf_control%contacts(icontact)%force_env_index)%force_env, qs_env=qs_env_contact) CALL qs_energies(qs_env_contact, consistent_energies=.FALSE., calc_forces=.FALSE.) CALL negf_env_contact_init_matrices(contact_env=negf_env%contacts(icontact), sub_env=sub_env, & @@ -315,10 +314,9 @@ CONTAINS CALL negf_env_contact_read_write_hs(icontact, force_env, para_env, negf_env, sub_env, negf_control, negf_section, & log_unit, is_separate=.FALSE., is_dft_entire=is_dft_entire) ELSE - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(/,T2,A,T70,I11,/,A)') "NEGF| Construct the Kohn-Sham matrix for the contact", icontact, & - " from the entire system bulk DFT calculation" - END IF + " from the entire system bulk DFT calculation" IF (.NOT. is_dft_entire) CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) is_dft_entire = .TRUE. CALL negf_env_contact_init_matrices_gamma(contact_env=negf_env%contacts(icontact), & @@ -331,9 +329,8 @@ CONTAINS END DO ! stage 3: obtain an initial KS-matrix for the scattering region - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(/,T2,A,T70)') "NEGF| Construct the Kohn-Sham matrix for the scattering region" - END IF IF (negf_control%read_write_HS) THEN CALL negf_env_scatt_read_write_hs(force_env, para_env, negf_env, sub_env, negf_control, negf_section, log_unit, & is_dft_entire=is_dft_entire) @@ -918,22 +915,18 @@ CONTAINS CALL cp_abort(__LOCATION__, & "Primary and secondary bulk contact cells should not overlap ") ELSE IF (r2_origin_cell(1) < r2_origin_cell(2)) THEN - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(1)%vector))) - END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(1)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(2)%vector))) - END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(2)%vector(:) ELSE - IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell0)) & ALLOCATE (contact_env%atomlist_cell0(SIZE(contact_control%atomlist_cell(2)%vector))) - END IF contact_env%atomlist_cell0(:) = contact_control%atomlist_cell(2)%vector(:) - IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) THEN + IF (.NOT. ALLOCATED(contact_env%atomlist_cell1)) & ALLOCATE (contact_env%atomlist_cell1(SIZE(contact_control%atomlist_cell(1)%vector))) - END IF contact_env%atomlist_cell1(:) = contact_control%atomlist_cell(1)%vector(:) END IF IF (.NOT. contact_control%read_write_HS) THEN @@ -1697,9 +1690,8 @@ CONTAINS natoms_cell0 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) THEN + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min) & natoms_cell0 = natoms_cell0 + 1 - END IF END DO ALLOCATE (atomlist_cell0(natoms_cell0)) @@ -1779,9 +1771,8 @@ CONTAINS natoms_cell1 = 0 DO iatom = 1, natoms_bulk - IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) THEN + IF (atom_map(iatom)%cell(direction_axis_abs) == dir_axis_min + offset) & natoms_cell1 = natoms_cell1 + 1 - END IF END DO ALLOCATE (atomlist_cell1(natoms_cell1)) diff --git a/src/negf_green_methods.F b/src/negf_green_methods.F index bc0d5076e0..f7ff34dbbf 100644 --- a/src/negf_green_methods.F +++ b/src/negf_green_methods.F @@ -363,9 +363,8 @@ CONTAINS ! omega * S_S - H_S - V_Hartree CALL cp_fm_to_cfm(msourcer=s_s, mtarget=g_ret_s) CALL cp_cfm_scale_and_add_fm(omega, g_ret_s, z_mone, h_s) - IF (PRESENT(v_hartree_s)) THEN + IF (PRESENT(v_hartree_s)) & CALL cp_cfm_scale_and_add_fm(z_one, g_ret_s, z_one, v_hartree_s) - END IF ! g_ret_s = [omega * S_S - H_S - \sum_{contact} self_energy_{contact}^{ret.} ]^-1 CALL cp_cfm_scale_and_add(z_one, g_ret_s, z_mone, self_energy_ret_sum) diff --git a/src/negf_integr_cc.F b/src/negf_integr_cc.F index 87d553d2c0..c4facd0f4f 100644 --- a/src/negf_integr_cc.F +++ b/src/negf_integr_cc.F @@ -173,9 +173,8 @@ CONTAINS ! rescale all but the end-points, as they are transformed into themselves (-1.0 -> -1.0; 0.0 -> 0.0). ! Moreover, by applying this rescaling transformation to the end-points we cannot guarantee the exact ! result due to rounding errors in evaluation of COS function. - IF (nnodes_half > 2) THEN + IF (nnodes_half > 2) & CALL rescale_nodes_cos(nnodes_half - 2, cc_env%tnodes(2:)) - END IF SELECT CASE (interval_id) CASE (cc_interval_full) diff --git a/src/negf_integr_simpson.F b/src/negf_integr_simpson.F index d732913bdf..9d57abd95c 100644 --- a/src/negf_integr_simpson.F +++ b/src/negf_integr_simpson.F @@ -312,9 +312,8 @@ CONTAINS END IF IF (nintervals > 0) THEN - IF (SIZE(xnodes_unity) < 4*nintervals) THEN + IF (SIZE(xnodes_unity) < 4*nintervals) & nintervals = SIZE(xnodes_unity)/4 - END IF DO interval = 1, nintervals xnodes_unity(4*interval - 3) = 0.125_dp* & @@ -554,16 +553,14 @@ CONTAINS DO interval = 1, nintervals_exist errors(interval) = subintervals(interval)%error - IF (subintervals(interval)%error > subintervals(interval)%conv) THEN + IF (subintervals(interval)%error > subintervals(interval)%conv) & nintervals = nintervals + 1 - END IF END DO CALL sort(errors, nintervals_exist, inds) - IF (nintervals > 0) THEN + IF (nintervals > 0) & ALLOCATE (sr_env%subintervals(nintervals)) - END IF nintervals = 0 DO ipoint = nintervals_exist, 1, -1 diff --git a/src/negf_integr_utils.F b/src/negf_integr_utils.F index 82651f58fa..4cb86ead5f 100644 --- a/src/negf_integr_utils.F +++ b/src/negf_integr_utils.F @@ -81,9 +81,11 @@ CONTAINS SELECT CASE (shape_id) CASE (contour_shape_linear) - IF (PRESENT(xnodes)) CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) + IF (PRESENT(xnodes)) & + CALL rescale_nodes_linear(nnodes, tnodes, a, b, xnodes) - IF (PRESENT(weights)) weights(:) = b - a + IF (PRESENT(weights)) & + weights(:) = b - a CASE (contour_shape_arc) ALLOCATE (tnodes_angle(nnodes)) @@ -91,7 +93,8 @@ CONTAINS tnodes_angle(:) = tnodes(:) CALL rescale_nodes_pi_phi(a, b, nnodes, tnodes_angle) - IF (PRESENT(xnodes)) CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) + IF (PRESENT(xnodes)) & + CALL rescale_nodes_arc(nnodes, tnodes_angle, a, b, xnodes) IF (PRESENT(weights)) THEN rscale = (pi - get_arc_smallest_angle(a, b))*get_arc_radius(a, b) diff --git a/src/negf_matrix_utils.F b/src/negf_matrix_utils.F index 5e957b06c3..5b55feab07 100644 --- a/src/negf_matrix_utils.F +++ b/src/negf_matrix_utils.F @@ -342,9 +342,8 @@ CONTAINS DO ic = 1, ncell rep = i_to_c(direction_axis_abs, ic) - IF (ABS(rep) <= 2) THEN + IF (ABS(rep) <= 2) & CALL dbcsr_add(matrix_cells_raw(rep)%matrix, mat_nosym(ic)%matrix, 1.0_dp, 1.0_dp) - END IF END DO IF (direction_axis >= 0) THEN @@ -470,17 +469,15 @@ CONTAINS block=rblock, found=found) IF (found) THEN iproc = rank_contact(irow, icol) - IF (iproc > 0) THEN + IF (iproc > 0) & send_nelems(iproc) = send_nelems(iproc) + SIZE(rblock) - END IF END IF CALL dbcsr_get_block_p(matrix=matrix_contact, row=irow, col=icol, block=rblock, found=found) IF (found) THEN iproc = rank_device(irow, icol) - IF (iproc > 0) THEN + IF (iproc > 0) & recv_nelems(iproc) = recv_nelems(iproc) + SIZE(rblock) - END IF END IF END DO END DO @@ -488,16 +485,14 @@ CONTAINS ! pack blocks ALLOCATE (recv_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & ALLOCATE (recv_packed_blocks(iproc)%vector(recv_nelems(iproc))) - END IF END DO ALLOCATE (send_packed_blocks(para_env%num_pe)) DO iproc = 1, para_env%num_pe - IF (send_nelems(iproc) > 0) THEN + IF (send_nelems(iproc) > 0) & ALLOCATE (send_packed_blocks(iproc)%vector(send_nelems(iproc))) - END IF END DO send_nelems(:) = 0 @@ -561,17 +556,15 @@ CONTAINS CALL para_env%irecv(recv_packed_blocks(iproc)%vector, iproc - 1, recv_handlers(iproc), 1) END IF ELSE - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & CALL MOVE_ALLOC(send_packed_blocks(iproc)%vector, recv_packed_blocks(iproc)%vector) - END IF END IF END DO ! unpack blocks DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) THEN + IF (iproc /= mepos_plus1 .AND. recv_nelems(iproc) > 0) & CALL recv_handlers(iproc)%wait() - END IF END DO recv_nelems(:) = 0 @@ -608,25 +601,22 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) THEN + IF (iproc /= mepos_plus1 .AND. send_nelems(iproc) > 0) & CALL send_handlers(iproc)%wait() - END IF END DO ! release memory DEALLOCATE (recv_handlers, send_handlers) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(send_packed_blocks(iproc)%vector)) THEN + IF (ALLOCATED(send_packed_blocks(iproc)%vector)) & DEALLOCATE (send_packed_blocks(iproc)%vector) - END IF END DO DEALLOCATE (send_packed_blocks) DO iproc = para_env%num_pe, 1, -1 - IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) THEN + IF (ALLOCATED(recv_packed_blocks(iproc)%vector)) & DEALLOCATE (recv_packed_blocks(iproc)%vector) - END IF END DO DEALLOCATE (recv_packed_blocks) @@ -754,9 +744,8 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & nomirror = nomirror + 1 - END IF END DO ! create the mirror imgs diff --git a/src/negf_methods.F b/src/negf_methods.F index 8487a70d82..8fda96399e 100644 --- a/src/negf_methods.F +++ b/src/negf_methods.F @@ -304,9 +304,8 @@ CONTAINS ! restart.hs ! ---------- - IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) THEN + IF (para_env_global%is_source() .AND. negf_control%write_common_restart_file) & CALL negf_write_restart(filename, negf_env, negf_control) - END IF ! current ! ------- @@ -966,9 +965,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_circular(ispin)) - END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_fm(ispin), & @@ -985,9 +983,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_linear(ispin)) - END IF END DO IF (nspins > 1) THEN @@ -1152,9 +1149,8 @@ CONTAINS END IF END IF - IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) THEN + IF (negf_control%update_HS .AND. (.NOT. negf_control%is_dft_entire)) & CALL qs_energies(qs_env, consistent_energies=.FALSE., calc_forces=.FALSE.) - END IF CALL get_qs_env(qs_env, blacs_env=blacs_env, do_kpoints=do_kpoints, dft_control=dft_control, & matrix_ks_kp=matrix_ks_qs_kp, para_env=para_env, rho=rho_struct, subsys=subsys) @@ -1399,9 +1395,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.TRUE., & g_surf_cache=g_surf_circular(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_circular(ispin)) - END IF ! closed contour: L-path CALL negf_add_rho_equiv_low(rho_ao_fm=rho_ao_new_fm(ispin), & @@ -1418,9 +1413,8 @@ CONTAINS matrix_s_global=matrix_s_fm, & is_circular=.FALSE., & g_surf_cache=g_surf_linear(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_linear(ispin)) - END IF ! non-equilibrium part delta = 0.0_dp @@ -1445,9 +1439,8 @@ CONTAINS base_contact=base_contact, & matrix_s_global=matrix_s_fm, & g_surf_cache=g_surf_nonequiv(ispin)) - IF (negf_control%disable_cache) THEN + IF (negf_control%disable_cache) & CALL green_functions_cache_release(g_surf_nonequiv(ispin)) - END IF END IF END DO @@ -2141,9 +2134,8 @@ CONTAINS DO ipoint = 1, npoints IF (ASSOCIATED(g_ret_s(ipoint)%matrix_struct)) THEN CALL cp_cfm_finish_copy_general(g_ret_s(ipoint), info1(ipoint)) - IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) THEN + IF (ASSOCIATED(g_ret_s_group(ipoint)%matrix_struct)) & CALL cp_cfm_cleanup_copy_general(info1(ipoint)) - END IF END IF END DO diff --git a/src/negf_subgroup_types.F b/src/negf_subgroup_types.F index 2eb0b3a5a6..e5efda48c6 100644 --- a/src/negf_subgroup_types.F +++ b/src/negf_subgroup_types.F @@ -137,9 +137,8 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) THEN + IF (ALLOCATED(sub_env%group_distribution)) & DEALLOCATE (sub_env%group_distribution) - END IF sub_env%ngroups = 0 diff --git a/src/offload/offload_api.F b/src/offload/offload_api.F index c9c4b8c48c..e9f508ee05 100644 --- a/src/offload/offload_api.F +++ b/src/offload/offload_api.F @@ -158,9 +158,8 @@ CONTAINS device_id = offload_get_chosen_device_c() - IF (device_id < 0) THEN + IF (device_id < 0) & CPABORT("No offload device has been chosen.") - END IF END FUNCTION offload_get_chosen_device diff --git a/src/openpmd_api.F b/src/openpmd_api.F index 00265196e0..82de3ca08c 100644 --- a/src/openpmd_api.F +++ b/src/openpmd_api.F @@ -24,14 +24,11 @@ MODULE openpmd_api USE kinds, ONLY: default_string_length, dp, sp USE message_passing, ONLY: mp_comm_type #include "./base/base_uses.f90" -#endif IMPLICIT NONE PRIVATE -#ifdef __OPENPMD - INTEGER, PARAMETER :: openpmd_access_create = 0 INTEGER, PARAMETER :: openpmd_access_read_only = 1 @@ -262,6 +259,7 @@ MODULE openpmd_api #:for dim in dimensions PUBLIC :: openpmd_dynamic_memory_view_type_${dim}$d #:endfor + #endif CONTAINS @@ -1216,5 +1214,6 @@ MODULE openpmd_api CALL openpmd_c_mesh_set_unit_dimension(this%c_ptr, unitDimension) END SUBROUTINE openpmd_mesh_set_unit_dimension + #endif END MODULE openpmd_api diff --git a/src/optimize_basis.F b/src/optimize_basis.F index 9fbbeb1eb1..813e9e52a9 100644 --- a/src/optimize_basis.F +++ b/src/optimize_basis.F @@ -196,9 +196,8 @@ CONTAINS DO iopt = 0, opt_bas%powell_param%maxfun CALL compute_residuum_vectors(opt_bas, f_env_id, matrix_S_inv, tot_time, & para_env_top, para_env, iopt) - IF (para_env_top%is_source()) THEN + IF (para_env_top%is_source()) & CALL powell_optimize(opt_bas%powell_param%nvar, opt_bas%x_opt, opt_bas%powell_param) - END IF CALL para_env_top%bcast(opt_bas%powell_param%state) CALL para_env_top%bcast(opt_bas%x_opt) CALL update_free_vars(opt_bas) @@ -363,10 +362,9 @@ CONTAINS icomb = MOD(icalc - 1, opt_bas%ncombinations) opt_bas%powell_param%f = opt_bas%powell_param%f + & (f_vec(icalc) + energy(icalc))*opt_bas%fval_weight(icomb) - IF (opt_bas%use_condition_number) THEN + IF (opt_bas%use_condition_number) & opt_bas%powell_param%f = opt_bas%powell_param%f + & LOG(cond_vec(icalc))*opt_bas%condition_weight(icomb) - END IF END DO ELSE f_vec = 0.0_dp; cond_vec = 0.0_dp; my_time = 0.0_dp; energy = 0.0_dp @@ -562,7 +560,8 @@ CONTAINS END DO DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & + SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) END DO CALL timestop(handle) @@ -668,9 +667,8 @@ CONTAINS tot_time = tot_time + my_time unit_nr = -1 - IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) THEN + IF (para_env_top%is_source() .AND. (MOD(iopt, opt_bas%write_frequency) == 0 .OR. iopt == opt_bas%powell_param%maxfun)) & unit_nr = cp_logger_get_default_unit_nr(logger) - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,I8)') "BASOPT| Information at iteration number:", iopt diff --git a/src/optimize_basis_types.F b/src/optimize_basis_types.F index de46ed724b..ec2b96dff3 100644 --- a/src/optimize_basis_types.F +++ b/src/optimize_basis_types.F @@ -177,9 +177,8 @@ CONTAINS IF (ALLOCATED(kind%deriv_info(iinfo)%in_use_set)) DEALLOCATE (kind%deriv_info(iinfo)%in_use_set) IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr)) THEN DO icont = 1, SIZE(kind%deriv_info(iinfo)%use_contr) - IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) THEN + IF (ALLOCATED(kind%deriv_info(iinfo)%use_contr(icont)%in_use)) & DEALLOCATE (kind%deriv_info(iinfo)%use_contr(icont)%in_use) - END IF END DO DEALLOCATE (kind%deriv_info(iinfo)%use_contr) END IF @@ -191,30 +190,22 @@ CONTAINS DO ibasis = 0, SIZE(kind%flex_basis) - 1 IF (ALLOCATED(kind%flex_basis(ibasis)%subset)) THEN DO iset = 1, SIZE(kind%flex_basis(ibasis)%subset) - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%l)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%l) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_coeff)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_coeff) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%coeff_x_ind) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exps)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exps) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%opt_exps)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%opt_exps) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_x_ind)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_x_ind) - END IF - IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) THEN + IF (ALLOCATED(kind%flex_basis(ibasis)%subset(iset)%exp_const)) & DEALLOCATE (kind%flex_basis(ibasis)%subset(iset)%exp_const) - END IF END DO DEALLOCATE (kind%flex_basis(ibasis)%subset) END IF diff --git a/src/optimize_basis_utils.F b/src/optimize_basis_utils.F index 0646e2fe77..239226980e 100644 --- a/src/optimize_basis_utils.F +++ b/src/optimize_basis_utils.F @@ -83,9 +83,8 @@ CONTAINS CALL generate_initial_basis(kind_section, opt_bas, para_env) CALL section_vals_get(train_section, n_repetition=opt_bas%ntraining_sets) - IF (opt_bas%ntraining_sets == 0) THEN + IF (opt_bas%ntraining_sets == 0) & CPABORT("No training set was specified in the Input") - END IF ALLOCATE (opt_bas%training_input(opt_bas%ntraining_sets)) ALLOCATE (opt_bas%training_dir(opt_bas%ntraining_sets)) @@ -137,9 +136,8 @@ CONTAINS logger => cp_get_default_logger() unit_nr = -1 - IF (logger%para_env%is_source()) THEN + IF (logger%para_env%is_source()) & unit_nr = cp_logger_get_default_unit_nr(logger) - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,A)') "BASOPT| Total number of calculations ", & @@ -296,16 +294,14 @@ CONTAINS CALL section_vals_val_get(optbas_section, "GROUP_PARTITION", i_vals=i_vals) isize = SIZE(i_vals) nptot = SUM(i_vals) - IF (nptot /= nproc) THEN + IF (nptot /= nproc) & CALL cp_abort(__LOCATION__, & "Number of processors in group distribution does not match number of MPI tasks."// & " Please change input.") - END IF - IF (.NOT. isize <= ncalc) THEN + IF (.NOT. isize <= ncalc) & CALL cp_abort(__LOCATION__, & "Number of Groups larger than number of calculations"// & " Please change input.") - END IF CPASSERT(nptot == nproc) ALLOCATE (opt_bas%comp_group(isize)) ALLOCATE (opt_bas%group_partition(0:isize - 1)) @@ -745,14 +741,12 @@ CONTAINS CALL section_vals_val_get(const_section, "USE_EXP", i_vals=def_exp, i_rep_section=irep) CALL section_vals_val_get(const_section, "BOUNDARIES", explicit=is_bound, i_rep_section=irep) CALL section_vals_val_get(const_section, "MAX_VAR_FRACTION", explicit=is_varlim, i_rep_section=irep) - IF (is_bound .AND. is_varlim) THEN + IF (is_bound .AND. is_varlim) & CALL cp_abort(__LOCATION__, "Exponent has two constraints. "// & "This is not possible at the moment. Please change input.") - END IF - IF (.NOT. is_bound .AND. .NOT. is_varlim) THEN + IF (.NOT. is_bound .AND. .NOT. is_varlim) & CALL cp_abort(__LOCATION__, "Exponent is declared to be constraint but none is given"// & " Please change input.") - END IF IF (def_exp(1) == -1) THEN DO iset = 1, flex_basis%nsets IF (def_exp(2) == -1) THEN @@ -760,30 +754,27 @@ CONTAINS CALL set_constraint(flex_basis, iset, ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (def_exp(2) <= flex_basis%subset(iset)%nexp) THEN + IF (def_exp(2) <= flex_basis%subset(iset)%nexp) & CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") - END IF CALL set_constraint(flex_basis, iset, def_exp(2), const_section, is_bound, is_varlim, irep) END IF END DO ELSE - IF (.NOT. def_exp(1) <= flex_basis%nsets) THEN + IF (.NOT. def_exp(1) <= flex_basis%nsets) & CALL cp_abort(__LOCATION__, & "Set number of constraint is larger than number of sets in the template basis set."// & " Please change input.") - END IF IF (def_exp(2) == -1) THEN DO ipgf = 1, flex_basis%subset(iset)%nexp CALL set_constraint(flex_basis, def_exp(1), ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) THEN + IF (.NOT. def_exp(2) <= flex_basis%subset(def_exp(1))%nexp) & CALL cp_abort(__LOCATION__, & "Exponent declared in constraint is larger than number of exponents in the set"// & " Please change input.") - END IF CALL set_constraint(flex_basis, def_exp(1), def_exp(2), const_section, is_bound, is_varlim, irep) END IF END IF @@ -814,11 +805,10 @@ CONTAINS REAL(KIND=dp) :: r_val REAL(KIND=dp), DIMENSION(:), POINTER :: r_vals - IF (flex_basis%subset(iset)%exp_has_const(ipgf)) THEN + IF (flex_basis%subset(iset)%exp_has_const(ipgf)) & CALL cp_abort(__LOCATION__, & "Multiple constraints due to collision in CONSTRAIN_EXPONENTS."// & " Please change input.") - END IF flex_basis%subset(iset)%exp_has_const(ipgf) = .TRUE. IF (is_bound) THEN flex_basis%subset(iset)%exp_const(ipgf)%const_type = 0 @@ -826,13 +816,12 @@ CONTAINS flex_basis%subset(iset)%exp_const(ipgf)%llim = MINVAL(r_vals) flex_basis%subset(iset)%exp_const(ipgf)%ulim = MAXVAL(r_vals) r_val = flex_basis%subset(iset)%exps(ipgf) - IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) THEN + IF (flex_basis%subset(iset)%exps(ipgf) > MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) < MINVAL(r_vals)) & CALL cp_abort(__LOCATION__, & "Exponent "//cp_to_string(r_val)// & " declared in constraint is out of bounds of constraint"//cp_to_string(MINVAL(r_vals))// & " to"//cp_to_string(MAXVAL(r_vals))// & " Please change input.") - END IF flex_basis%subset(iset)%exp_const(ipgf)%init = SUM(r_vals)/2.0_dp flex_basis%subset(iset)%exp_const(ipgf)%var_fac = MAXVAL(r_vals)/flex_basis%subset(iset)%exp_const(ipgf)%init - 1.0_dp END IF @@ -1150,7 +1139,8 @@ CONTAINS ! just to get an understandable basis normalize coefficients DO icon1 = 1, subset%ncon_tot - subset%coeff(:, icon1) = subset%coeff(:, icon1)/NORM2(subset%coeff(:, icon1)) + subset%coeff(:, icon1) = subset%coeff(:, icon1)/ & + SQRT(DOT_PRODUCT(subset%coeff(:, icon1), subset%coeff(:, icon1))) END DO DEALLOCATE (r_val) diff --git a/src/optimize_embedding_potential.F b/src/optimize_embedding_potential.F index 0c38b6568a..c36cbdd7aa 100644 --- a/src/optimize_embedding_potential.F +++ b/src/optimize_embedding_potential.F @@ -151,9 +151,8 @@ CONTAINS END DO ! Find out whether we need a spin-dependend embedding potential - IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) THEN + IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) & open_shell_embed = .TRUE. - END IF ! If it's open shell, we need to check spin states IF (open_shell_embed) THEN @@ -668,14 +667,12 @@ CONTAINS TYPE(opt_embed_pot_type) :: opt_embed ! Read the potential as a vector in the auxiliary basis - IF (opt_embed%read_embed_pot) THEN + IF (opt_embed%read_embed_pot) & CALL read_embed_pot_vector(qs_env, embed_pot, spin_embed_pot, section, & opt_embed%embed_pot_coef, opt_embed%open_shell_embed) - END IF ! Read the potential as a cube (two cubes for open shell) - IF (opt_embed%read_embed_pot_cube) THEN + IF (opt_embed%read_embed_pot_cube) & CALL read_embed_pot_cube(embed_pot, spin_embed_pot, section, opt_embed%open_shell_embed) - END IF END SUBROUTINE read_embed_pot @@ -698,9 +695,8 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CPABORT("Embedding cube file not found. ") - END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(embed_pot, filename, scaling_factor) @@ -710,9 +706,8 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_SPIN_CUBE_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CPABORT("Embedding spin cube file not found. ") - END IF scaling_factor = 1.0_dp CALL cp_cube_to_pw(spin_embed_pot, filename, scaling_factor) @@ -789,9 +784,8 @@ CONTAINS READ (restart_unit) dimen_restart_basis ! Check the dimensions of the bases: the actual and the restart one - IF (.NOT. (dimen_restart_basis == dimen_aux)) THEN + IF (.NOT. (dimen_restart_basis == dimen_aux)) & CPABORT("Wrong dimension of the embedding basis in the restart file.") - END IF ALLOCATE (coef_read(dimen_var_aux)) coef_read = 0.0_dp @@ -850,9 +844,8 @@ CONTAINS exist = .FALSE. CALL section_vals_val_get(section, "EMBED_RESTART_FILE_NAME", c_val=filename) INQUIRE (FILE=filename, exist=exist) - IF (.NOT. exist) THEN + IF (.NOT. exist) & CPABORT("Embedding restart file not found. ") - END IF END SUBROUTINE embed_restart_file_name @@ -1512,16 +1505,14 @@ CONTAINS ELSE ! Finite basis optimization ! If the previous step has been rejected, we go back to the previous expansion coefficients - IF (.NOT. opt_embed%accept_step) THEN + IF (.NOT. opt_embed%accept_step) & CALL cp_fm_scale_and_add(1.0_dp, opt_embed%embed_pot_coef, -1.0_dp, opt_embed%step) - END IF ! Do a simple steepest descent IF (opt_embed%steep_desc) THEN - IF (opt_embed%i_iter > 2) THEN + IF (opt_embed%i_iter > 2) & opt_embed%trust_rad = Barzilai_Borwein(opt_embed%step, opt_embed%prev_step, & opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad) - END IF IF (ABS(opt_embed%trust_rad) > opt_embed%max_trad) THEN IF (opt_embed%trust_rad > 0.0_dp) THEN opt_embed%trust_rad = opt_embed%max_trad @@ -1539,11 +1530,9 @@ CONTAINS ! First, update the Hessian inverse if needed IF (opt_embed%i_iter > 1) THEN - IF (opt_embed%accept_step) THEN - ! We don't update Hessian if the step has been rejected + IF (opt_embed%accept_step) & ! We don't update Hessian if the step has been rejected CALL symm_rank_one_update(opt_embed%embed_pot_grad, opt_embed%prev_embed_pot_grad, & opt_embed%step, opt_embed%prev_embed_pot_Hess, opt_embed%embed_pot_Hess) - END IF END IF ! Add regularization term to the Hessian @@ -2224,9 +2213,8 @@ CONTAINS ! If energy change is larger than the predicted one, increase trust radius twice ! Else (between 0 and 1) leave as it is, unless Newton step has been taken and if the step is less than max IF ((ener_ratio > 1.0_dp) .AND. (.NOT. opt_embed%newton_step) .AND. & - (opt_embed%trust_rad < opt_embed%max_trad)) THEN + (opt_embed%trust_rad < opt_embed%max_trad)) & opt_embed%trust_rad = 2.0_dp*opt_embed%trust_rad - END IF ELSE ! Energy decreases ! If the decrease is not too large we allow this step to be taken ! Otherwise, the step is rejected @@ -2234,9 +2222,8 @@ CONTAINS opt_embed%accept_step = .FALSE. END IF ! Trust radius is decreased 4 times unless it's smaller than the minimal allowed value - IF (opt_embed%trust_rad >= opt_embed%min_trad) THEN + IF (opt_embed%trust_rad >= opt_embed%min_trad) & opt_embed%trust_rad = 0.25_dp*opt_embed%trust_rad - END IF END IF IF (opt_embed%accept_step) opt_embed%last_accepted = opt_embed%i_iter diff --git a/src/optimize_input.F b/src/optimize_input.F index bf550ed1b4..318487e913 100644 --- a/src/optimize_input.F +++ b/src/optimize_input.F @@ -525,9 +525,8 @@ CONTAINS n_frames_current = 0 NULLIFY (pos_traj, energy_traj, force_traj) filename = oi_env%fm_env%ref_traj_file_name - IF (filename == "") THEN + IF (filename == "") & CPABORT("The reference trajectory file name is empty") - END IF CALL parser_create(local_parser, filename, para_env=para_env) DO CALL parser_read_line(local_parser, 1, at_end=at_end) @@ -560,9 +559,8 @@ CONTAINS ! now force reference trajectory filename = oi_env%fm_env%ref_force_file_name - IF (filename == "") THEN + IF (filename == "") & CPABORT("The reference force file name is empty") - END IF CALL parser_create(local_parser, filename, para_env=para_env) DO iframe = 1, n_frames CALL parser_read_line(local_parser, 1) diff --git a/src/pair_potential.F b/src/pair_potential.F index 3f56b1de2c..6e2d4af4f5 100644 --- a/src/pair_potential.F +++ b/src/pair_potential.F @@ -31,7 +31,7 @@ MODULE pair_potential USE pair_potential_types, ONLY: & ace_type, allegro_type, b4_type, bm_type, compare_pot, deepmd_type, ea_type, ft_type, & ftd_type, gal21_type, gal_type, gp_type, gw_type, ip_type, list_pot, lj_charmm_type, & - lj_type, mace_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & + lj_type, multi_type, nequip_type, nn_type, pair_potential_pp_type, & pair_potential_single_type, potential_single_allocation, siepmann_type, tab_type, & tersoff_type, wl_type USE pair_potential_util, ONLY: ener_pot,& @@ -188,8 +188,7 @@ CONTAINS DO k = 1, SIZE(pot%type) SELECT CASE (pot%type(k)) CASE (lj_type, lj_charmm_type, wl_type, gw_type, ft_type, ftd_type, ip_type, & - b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, mace_type, tab_type, & - deepmd_type, ace_type) + b4_type, bm_type, gp_type, ea_type, allegro_type, nequip_type, tab_type, deepmd_type, ace_type) pot%no_pp = .FALSE. CASE (tersoff_type) pot%no_mb = .FALSE. @@ -207,7 +206,7 @@ CONTAINS END SELECT ! Special case for EAM SELECT CASE (pot%type(k)) - CASE (ea_type, nequip_type, allegro_type, mace_type, deepmd_type, ace_type) + CASE (ea_type, nequip_type, allegro_type, deepmd_type, ace_type) pot%no_mb = .FALSE. END SELECT END DO @@ -606,7 +605,7 @@ CONTAINS nvar = 5 + nvar CASE (ea_type) nvar = 4 + nvar - CASE (nequip_type, mace_type) + CASE (nequip_type) nvar = 1 + nvar CASE (allegro_type) nvar = 1 + nvar @@ -689,7 +688,7 @@ CONTAINS pot_par(nk, 2) = potparm%pot(i, j)%pot%set(1)%eam%drhoar pot_par(nk, 3) = potparm%pot(i, j)%pot%set(1)%eam%acutal pot_par(nk, 4) = potparm%pot(i, j)%pot%set(1)%eam%npoints - CASE (nequip_type, allegro_type, mace_type) + CASE (nequip_type, allegro_type) pot_par(nk, 1) = str2id( & TRIM(potparm%pot(i, j)%pot%set(1)%nequip%pot_file_name)) CASE (ace_type) diff --git a/src/pair_potential_types.F b/src/pair_potential_types.F index 23aacc5225..ec797ee3f5 100644 --- a/src/pair_potential_types.F +++ b/src/pair_potential_types.F @@ -54,10 +54,9 @@ MODULE pair_potential_types gal21_type = 18, & tab_type = 19, & deepmd_type = 20, & - ace_type = 21, & - mace_type = 22 + ace_type = 21 - INTEGER, PUBLIC, PARAMETER, DIMENSION(22) :: list_pot = [nn_type, & + INTEGER, PUBLIC, PARAMETER, DIMENSION(21) :: list_pot = [nn_type, & lj_type, & lj_charmm_type, & ft_type, & @@ -77,8 +76,7 @@ MODULE pair_potential_types gal21_type, & tab_type, & deepmd_type, & - ace_type, & - mace_type] + ace_type] ! Shell model INTEGER, PUBLIC, PARAMETER :: nosh_nosh = 0, & @@ -470,7 +468,7 @@ CONTAINS CASE (deepmd_type) IF ((pot1%set(i)%deepmd%deepmd_file_name == pot2%set(i)%deepmd%deepmd_file_name) .AND. & (pot1%set(i)%deepmd%atom_deepmd_type == pot2%set(i)%deepmd%atom_deepmd_type)) mycompare = .TRUE. - CASE (nequip_type, allegro_type, mace_type) + CASE (nequip_type, allegro_type) IF ((pot1%set(i)%nequip%pot_file_name == pot2%set(i)%nequip%pot_file_name) .AND. & (pot1%set(i)%nequip%unit_length == pot2%set(i)%nequip%unit_length) .AND. & (pot1%set(i)%nequip%unit_forces == pot2%set(i)%nequip%unit_forces) .AND. & @@ -643,12 +641,10 @@ CONTAINS potparm%at1 = 'NULL' potparm%at2 = 'NULL' potparm%rcutsq = 0.0_dp - IF (ASSOCIATED(potparm%pair_spline_data)) THEN + IF (ASSOCIATED(potparm%pair_spline_data)) & CALL spline_data_p_release(potparm%pair_spline_data) - END IF - IF (ASSOCIATED(potparm%spl_f)) THEN + IF (ASSOCIATED(potparm%spl_f)) & CALL spline_factor_release(potparm%spl_f) - END IF DO i = 1, SIZE(potparm%type) potparm%set(i)%rmin = not_initialized @@ -1053,9 +1049,8 @@ CONTAINS IF (PRESENT(istart)) l_start = istart IF (PRESENT(iend)) l_end = iend DO i = l_start, l_end - IF (.NOT. ASSOCIATED(source%pot(i)%pot)) THEN + IF (.NOT. ASSOCIATED(source%pot(i)%pot)) & CALL pair_potential_single_create(source%pot(i)%pot) - END IF CALL pair_potential_single_copy(source%pot(i)%pot, dest%pot(i)%pot) END DO END SUBROUTINE pair_potential_p_copy @@ -1291,7 +1286,7 @@ CONTAINS CALL pair_potential_goodwin_create(p%pot(i)%pot%set(std_dim)%goodwin) CASE (ea_type) CALL pair_potential_eam_create(p%pot(i)%pot%set(std_dim)%eam) - CASE (nequip_type, allegro_type, mace_type) + CASE (nequip_type, allegro_type) CALL pair_potential_nequip_create(p%pot(i)%pot%set(std_dim)%nequip) CASE (ace_type) CALL pair_potential_ace_create(p%pot(i)%pot%set(std_dim)%ace) diff --git a/src/pair_potential_util.F b/src/pair_potential_util.F index 9e77235b32..bb0163846f 100644 --- a/src/pair_potential_util.F +++ b/src/pair_potential_util.F @@ -109,7 +109,7 @@ CONTAINS index = INT(r/pot%set(j)%eam%drar) + 1 IF (index > pot%set(j)%eam%npoints) THEN index = pot%set(j)%eam%npoints - ELSE IF (index < 1) THEN + ELSEIF (index < 1) THEN index = 1 END IF qq = r - pot%set(j)%eam%rval(index) @@ -119,17 +119,17 @@ CONTAINS ELSE IF (pot%type(j) == b4_type) THEN IF (r <= pot%set(j)%buck4r%r1) THEN pp = pot%set(j)%buck4r%a*EXP(-pot%set(j)%buck4r%b*r) - ELSE IF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN + ELSEIF (r > pot%set(j)%buck4r%r1 .AND. r <= pot%set(j)%buck4r%r2) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly1 pp = pp + pot%set(j)%buck4r%poly1(n)*r**n END DO - ELSE IF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN + ELSEIF (r > pot%set(j)%buck4r%r2 .AND. r <= pot%set(j)%buck4r%r3) THEN pp = 0.0_dp DO n = 0, pot%set(j)%buck4r%npoly2 pp = pp + pot%set(j)%buck4r%poly2(n)*r**n END DO - ELSE IF (r > pot%set(j)%buck4r%r3) THEN + ELSEIF (r > pot%set(j)%buck4r%r3) THEN pp = -pot%set(j)%buck4r%c/r**6 END IF lvalue = pp @@ -139,7 +139,7 @@ CONTAINS IF (index2 > pot%set(j)%tab%npoints) THEN index2 = pot%set(j)%tab%npoints index1 = index2 - 1 - ELSE IF (index1 < 1) THEN + ELSEIF (index1 < 1) THEN index1 = 1 index2 = 2 END IF @@ -156,9 +156,8 @@ CONTAINS ELSE IF (pot%type(j) == gp_type) THEN pot%set(j)%gp%values(1) = r lvalue = evalf(pot%set(j)%gp%myid, pot%set(j)%gp%values) - IF (EvalErrType > 0) THEN + IF (EvalErrType > 0) & CPABORT("Error evaluating generic potential energy function") - END IF ELSE lvalue = 0.0_dp END IF @@ -190,7 +189,7 @@ CONTAINS fac = pot%z1*pot%z2/evolt ener_zbl = fac/r*(0.1818_dp*EXP(-3.2_dp*x) + 0.5099_dp*EXP(-0.9423_dp*x) + & 0.2802_dp*EXP(-0.4029_dp*x) + 0.02817_dp*EXP(-0.2016_dp*x)) - ELSE IF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN + ELSEIF (r > pot%zbl_rcut(1) .AND. r <= pot%zbl_rcut(2)) THEN ener_zbl = pot%zbl_poly(0) + pot%zbl_poly(1)*r + pot%zbl_poly(2)*r*r + pot%zbl_poly(3)*r*r*r + & pot%zbl_poly(4)*r*r*r*r + pot%zbl_poly(5)*r*r*r*r*r ELSE diff --git a/src/pao_io.F b/src/pao_io.F index ac4c035268..166da4d769 100644 --- a/src/pao_io.F +++ b/src/pao_io.F @@ -121,9 +121,8 @@ CONTAINS END IF ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & CPABORT("Restart PAO parametrization does not match") - END IF ! check kinds DO ikind = 1, SIZE(kinds) @@ -131,15 +130,13 @@ CONTAINS END DO ! check number of atoms - IF (SIZE(positions, 1) /= natoms) THEN + IF (SIZE(positions, 1) /= natoms) & CPABORT("Number of atoms do not match") - END IF ! check atom2kind DO iatom = 1, natoms - IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) THEN + IF (atom2kind(iatom) /= particle_set(iatom)%atomic_kind%kind_number) & CPABORT("Restart atomic kinds do not match.") - END IF END DO ! check positions, warning only @@ -163,9 +160,8 @@ CONTAINS END IF CALL para_env%bcast(buffer) CALL dbcsr_get_block_p(matrix=pao%matrix_X, row=iatom, col=iatom, block=block_X, found=found) - IF (ASSOCIATED(block_X)) THEN + IF (ASSOCIATED(block_X)) & block_X = buffer - END IF DEALLOCATE (buffer) END DO @@ -216,9 +212,8 @@ CONTAINS ! check if file starts with proper header !TODO: introduce a more unique header READ (unit_nr, fmt=*) label, i1 - IF (TRIM(label) /= "Version") THEN + IF (TRIM(label) /= "Version") & CPABORT("PAO restart file appears to be corrupted.") - END IF IF (i1 /= file_format_version) CPABORT("Restart PAO file format version is wrong") DO WHILE (.TRUE.) @@ -345,9 +340,8 @@ CONTAINS atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) - IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) THEN + IF (ikind > SIZE(atomic_kind_set) .OR. ikind > SIZE(qs_kind_set)) & CPABORT("Some kinds are missing.") - END IF CALL get_atomic_kind(atomic_kind_set(ikind), z=z, name=name) CALL get_qs_kind(qs_kind_set(ikind), & @@ -356,27 +350,20 @@ CONTAINS pao_potentials=pao_potentials) CALL pao_param_count(pao, qs_env, ikind=ikind, nparams=nparams) - IF (pao_kind%nparams /= nparams) THEN + IF (pao_kind%nparams /= nparams) & CPABORT("Number of parameters do not match") - END IF - IF (TRIM(pao_kind%name) /= TRIM(name)) THEN + IF (TRIM(pao_kind%name) /= TRIM(name)) & CPABORT("Kind names do not match") - END IF - IF (pao_kind%z /= z) THEN + IF (pao_kind%z /= z) & CPABORT("Atomic numbers do not match") - END IF - IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) THEN + IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) & CPABORT("Primary Basis-set name does not match") - END IF - IF (pao_kind%prim_basis_size /= basis_set%nsgf) THEN + IF (pao_kind%prim_basis_size /= basis_set%nsgf) & CPABORT("Primary Basis-set size does not match") - END IF - IF (pao_kind%pao_basis_size /= pao_basis_size) THEN + IF (pao_kind%pao_basis_size /= pao_basis_size) & CPABORT("PAO basis size does not match") - END IF - IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) THEN + IF (SIZE(pao_kind%pao_potentials) /= SIZE(pao_potentials)) & CPABORT("Number of PAO_POTENTIALS does not match") - END IF DO ipot = 1, SIZE(pao_potentials) IF (pao_kind%pao_potentials(ipot)%maxl /= pao_potentials(ipot)%maxl) THEN @@ -434,9 +421,8 @@ CONTAINS CALL para_env%max(unit_max) IF (unit_max > 0) THEN IF (pao%iw > 0) WRITE (pao%iw, '(A,A)') " PAO| Writing restart file." - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL write_restart_header(pao, qs_env, energy, unit_nr) - END IF CALL pao_write_diagonal_blocks(para_env, pao%matrix_X, "Xblock", unit_nr) @@ -477,10 +463,8 @@ CONTAINS NULLIFY (local_block) CALL dbcsr_get_block_p(matrix=matrix, row=iatom, col=iatom, block=local_block, found=found) IF (ASSOCIATED(local_block)) THEN - IF (SIZE(local_block) > 0) THEN - ! catch corner-case + IF (SIZE(local_block) > 0) & ! catch corner-case mpi_buffer(:, :) = local_block(:, :) - END IF ELSE mpi_buffer(:, :) = 0.0_dp END IF diff --git a/src/pao_linpot_rotinv.F b/src/pao_linpot_rotinv.F index 12698d45c1..91c735c395 100644 --- a/src/pao_linpot_rotinv.F +++ b/src/pao_linpot_rotinv.F @@ -83,12 +83,10 @@ CONTAINS ! terms sensing neighboring atoms DO ipot = 1, npots pot_maxl = pao_potentials(ipot)%maxl ! maxl is taken from central atom - IF (pot_maxl < 0) THEN + IF (pot_maxl < 0) & CPABORT("ROTINV parametrization requires non-negative PAO_POTENTIAL%MAXL") - END IF - IF (MOD(pot_maxl, 2) /= 0) THEN + IF (MOD(pot_maxl, 2) /= 0) & CPABORT("ROTINV parametrization requires even-numbered PAO_POTENTIAL%MAXL") - END IF DO max_shell = 1, nshells DO min_shell = 1, max_shell DO lpot = 0, pot_maxl, 2 @@ -205,9 +203,8 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) THEN + IF (SIZE(jpao_potentials) /= npots) & CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") - END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom @@ -451,9 +448,8 @@ CONTAINS IF (jatom == iatom) CYCLE ! no self-interaction CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_potentials=jpao_potentials) - IF (SIZE(jpao_potentials) /= npots) THEN + IF (SIZE(jpao_potentials) /= npots) & CPABORT("Not all KINDs have the same number of PAO_POTENTIAL sections") - END IF ! initialize exponents pot_weight = jpao_potentials(ipot)%weight ! taken from remote atom diff --git a/src/pao_main.F b/src/pao_main.F index b4a61ce1ab..db6fcac257 100644 --- a/src/pao_main.F +++ b/src/pao_main.F @@ -279,9 +279,8 @@ CONTAINS EXIT END IF - IF (MOD(icycle, pao%write_cycles) == 0) THEN - CALL pao_write_restart(pao, qs_env, energy) - END IF ! write an intermediate restart file + IF (MOD(icycle, pao%write_cycles) == 0) & + CALL pao_write_restart(pao, qs_env, energy) ! write an intermediate restart file END IF ! check for early abort without convergence? diff --git a/src/pao_methods.F b/src/pao_methods.F index cdce9d2815..203df6946c 100644 --- a/src/pao_methods.F +++ b/src/pao_methods.F @@ -133,9 +133,8 @@ CONTAINS ! Load torch model. IF (LEN_TRIM(pao_model_file) > 0) THEN - IF (.NOT. ALLOCATED(pao%models)) THEN + IF (.NOT. ALLOCATED(pao%models)) & ALLOCATE (pao%models(SIZE(qs_kind_set))) - END IF CALL pao_model_load(pao, qs_env, ikind, pao_model_file, pao%models(ikind)) END IF @@ -291,9 +290,8 @@ CONTAINS CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind), pao_basis_size=M) CPASSERT(M > 0) - IF (blk_sizes_pri(iatom) < M) THEN + IF (blk_sizes_pri(iatom) < M) & CPABORT("PAO basis size exceeds primary basis size.") - END IF blk_sizes_aux(iatom) = M END DO @@ -556,9 +554,8 @@ CONTAINS CALL dbcsr_release(matrix_S_desym) - IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) THEN + IF (ABS(ls_scf_env%nelectron_total - trace_PS) > 0.5) & CPABORT("Number of electrons wrong. Trace(PS) ="//cp_to_string(trace_PS)) - END IF CALL timestop(handle) END SUBROUTINE pao_check_trace_PS @@ -986,15 +983,12 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) "PAO| Adding forces." IF (pao%max_pao /= 0) THEN - IF (pao%penalty_strength /= 0.0_dp) THEN + IF (pao%penalty_strength /= 0.0_dp) & CPABORT("PAO forces require PENALTY_STRENGTH or MAX_PAO set to zero") - END IF - IF (pao%linpot_regu_strength /= 0.0_dp) THEN + IF (pao%linpot_regu_strength /= 0.0_dp) & CPABORT("PAO forces require LINPOT_REGULARIZATION_STRENGTH or MAX_PAO set to zero") - END IF - IF (pao%regularization /= 0.0_dp) THEN + IF (pao%regularization /= 0.0_dp) & CPABORT("PAO forces require REGULARIZATION or MAX_PAO set to zero") - END IF END IF CALL get_qs_env(qs_env, & @@ -1005,13 +999,11 @@ CONTAINS ALLOCATE (forces(natoms, 3)) CALL pao_calc_AB(pao, qs_env, ls_scf_env, gradient=.TRUE., forces=forces) ! without penalty terms - IF (SIZE(pao%ml_training_set) > 0) THEN + IF (SIZE(pao%ml_training_set) > 0) & CALL pao_ml_forces(pao, qs_env, pao%matrix_G, forces) - END IF - IF (ALLOCATED(pao%models)) THEN + IF (ALLOCATED(pao%models)) & CALL pao_model_forces(pao, qs_env, pao%matrix_G, forces) - END IF CALL para_env%sum(forces) DO iatom = 1, natoms diff --git a/src/pao_ml.F b/src/pao_ml.F index 95de014193..b711d54387 100644 --- a/src/pao_ml.F +++ b/src/pao_ml.F @@ -95,9 +95,8 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO|ML| Initializing maschine learning...' - IF (pao%parameterization /= pao_rotinv_param) THEN + IF (pao%parameterization /= pao_rotinv_param) & CPABORT("PAO maschine learning requires ROTINV parametrization") - END IF CALL get_qs_env(qs_env, para_env=para_env, atomic_kind_set=atomic_kind_set) @@ -167,9 +166,8 @@ CONTAINS CALL pao_read_raw(filename, param, hmat, kinds, atom2kind, positions, xblocks, ml_range) ! check parametrization - IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) THEN + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & CPABORT("Restart PAO parametrization does not match") - END IF ! map read-in kinds onto kinds of this run CALL match_kinds(pao, qs_env, kinds, kindsmap) @@ -279,9 +277,8 @@ CONTAINS END DO END DO - IF (ANY(kindsmap < 1)) THEN + IF (ANY(kindsmap < 1)) & CPABORT("PAO: Could not match all kinds from training set") - END IF END SUBROUTINE match_kinds ! ************************************************************************************************** @@ -304,10 +301,8 @@ CONTAINS training_list => training_lists(ikind) IF (training_list%npoints > 0) CYCLE ! it's ok CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) - IF (pao_basis_size /= basis_set%nsgf) THEN - ! if this kind has pao enabled... + IF (pao_basis_size /= basis_set%nsgf) & ! if this kind has pao enabled... CPABORT("Found no training-points for kind: "//TRIM(training_list%kindname)) - END IF END DO END SUBROUTINE sanity_check @@ -348,12 +343,10 @@ CONTAINS ! figure out size of input and output inp_size = 0; out_size = 0 - IF (ALLOCATED(training_list%head%input)) THEN + IF (ALLOCATED(training_list%head%input)) & inp_size = SIZE(training_list%head%input) - END IF - IF (ALLOCATED(training_list%head%output)) THEN + IF (ALLOCATED(training_list%head%output)) & out_size = SIZE(training_list%head%output) - END IF CALL para_env%sum(inp_size) CALL para_env%sum(out_size) @@ -581,9 +574,8 @@ CONTAINS IF (pao%iw > 0) WRITE (pao%iw, "(A,E20.10,A,T71,I10)") " PAO|ML| max prediction variance:", & MAXVAL(variances), " for atom:", MAXLOC(variances) - IF (MAXVAL(variances) > pao%ml_tolerance) THEN + IF (MAXVAL(variances) > pao%ml_tolerance) & CPABORT("Variance of prediction above ML_TOLERANCE.") - END IF DEALLOCATE (variances) diff --git a/src/pao_ml_descriptor.F b/src/pao_ml_descriptor.F index 2550b05021..a99b71053e 100644 --- a/src/pao_ml_descriptor.F +++ b/src/pao_ml_descriptor.F @@ -138,9 +138,8 @@ CONTAINS Rab = pbc(ra, rb, cell) CALL get_atomic_kind(particle_set(jatom)%atomic_kind, kind_number=jkind) CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=pao_descriptors) - IF (SIZE(pao_descriptors) /= ndesc) THEN + IF (SIZE(pao_descriptors) /= ndesc) & CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") - END IF weight = pao_descriptors(idesc)%weight beta = pao_descriptors(idesc)%beta CALL pao_calc_gaussian(basis_set, block_V=block_V, Rab=Rab, lpot=0, beta=beta, weight=weight) @@ -151,9 +150,8 @@ CONTAINS CALL diamat_all(V_evecs, V_evals) ! use eigenvalues of V_block as descriptor - IF (PRESENT(descriptor)) THEN + IF (PRESENT(descriptor)) & descriptor((idesc - 1)*N + 1:idesc*N) = V_evals(:) - END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN @@ -256,9 +254,8 @@ CONTAINS ! check if N was chosen large enough IF (natoms > N) THEN - IF (neighbor_dist(N + 1) < screening_radius) THEN + IF (neighbor_dist(N + 1) < screening_radius) & CPABORT("PAO heuristic for descriptor size broke down") - END IF END IF DO idesc = 1, ndesc @@ -276,9 +273,8 @@ CONTAINS CALL get_qs_kind(qs_kind_set(jkind), pao_descriptors=jpao_descriptors) CALL get_atomic_kind(particle_set(katom)%atomic_kind, kind_number=kkind) CALL get_qs_kind(qs_kind_set(kkind), pao_descriptors=kpao_descriptors) - IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) THEN + IF (SIZE(jpao_descriptors) /= ndesc .OR. SIZE(kpao_descriptors) /= ndesc) & CPABORT("Not all KINDs have the same number of PAO_DESCRIPTOR sections") - END IF jweight = jpao_descriptors(idesc)%weight jbeta = jpao_descriptors(idesc)%beta kweight = kpao_descriptors(idesc)%weight @@ -308,9 +304,8 @@ CONTAINS CALL diamat_all(S_evecs, S_evals) ! use eigenvalues of S_block as descriptor - IF (PRESENT(descriptor)) THEN + IF (PRESENT(descriptor)) & descriptor((idesc - 1)*N + 1:idesc*N) = S_evals(:) - END IF ! FORCES ---------------------------------------------------------------------------------- IF (PRESENT(forces)) THEN diff --git a/src/pao_ml_gaussprocess.F b/src/pao_ml_gaussprocess.F index c73c250c12..b97e60b661 100644 --- a/src/pao_ml_gaussprocess.F +++ b/src/pao_ml_gaussprocess.F @@ -112,9 +112,8 @@ CONTAINS ! calculate prediction's variance variance = kernel(pao%gp_scale, descriptor, descriptor) - DOT_PRODUCT(weights, cov) - IF (variance < 0.0_dp) THEN + IF (variance < 0.0_dp) & CPABORT("PAO gaussian process found negative variance") - END IF DEALLOCATE (cov, weights) END SUBROUTINE pao_ml_gp_predict diff --git a/src/pao_model.F b/src/pao_model.F index 1fb7d10fcd..01dc20903a 100644 --- a/src/pao_model.F +++ b/src/pao_model.F @@ -120,24 +120,18 @@ CONTAINS ! Check compatibility CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, pao_basis_size=pao_basis_size) CALL get_atomic_kind(atomic_kind_set(ikind), name=kind_name, z=z) - IF (model%version /= 2) THEN + IF (model%version /= 2) & CPABORT("Model version not supported.") - END IF - IF (TRIM(model%kind_name) /= TRIM(kind_name)) THEN + IF (TRIM(model%kind_name) /= TRIM(kind_name)) & CPABORT("Kind name does not match.") - END IF - IF (model%atomic_number /= z) THEN + IF (model%atomic_number /= z) & CPABORT("Atomic number does not match.") - END IF - IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) THEN + IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) & CPABORT("Primary basis set name does not match.") - END IF - IF (model%prim_basis_size /= basis_set%nsgf) THEN + IF (model%prim_basis_size /= basis_set%nsgf) & CPABORT("Primary basis set size does not match.") - END IF - IF (model%pao_basis_size /= pao_basis_size) THEN + IF (model%pao_basis_size /= pao_basis_size) & CPABORT("PAO basis size does not match.") - END IF CALL omp_init_lock(model%lock) CALL timestop(handle) diff --git a/src/pao_optimizer.F b/src/pao_optimizer.F index 63a5329dd7..6b5a46b663 100644 --- a/src/pao_optimizer.F +++ b/src/pao_optimizer.F @@ -48,9 +48,8 @@ CONTAINS CALL dbcsr_copy(pao%matrix_D_preconed, pao%matrix_D) END IF - IF (pao%optimizer == pao_opt_bfgs) THEN + IF (pao%optimizer == pao_opt_bfgs) & CALL pao_opt_init_bfgs(pao) - END IF END SUBROUTINE pao_opt_init @@ -86,13 +85,11 @@ CONTAINS CALL dbcsr_release(pao%matrix_D) CALL dbcsr_release(pao%matrix_G_prev) - IF (pao%precondition) THEN + IF (pao%precondition) & CALL dbcsr_release(pao%matrix_D_preconed) - END IF - IF (pao%optimizer == pao_opt_bfgs) THEN + IF (pao%optimizer == pao_opt_bfgs) & CALL dbcsr_release(pao%matrix_BFGS) - END IF END SUBROUTINE pao_opt_finalize diff --git a/src/pao_param_equi.F b/src/pao_param_equi.F index 4f81db62e7..d0c64c33b3 100644 --- a/src/pao_param_equi.F +++ b/src/pao_param_equi.F @@ -49,9 +49,8 @@ CONTAINS SUBROUTINE pao_param_init_equi(pao) TYPE(pao_env_type), POINTER :: pao - IF (pao%precondition) THEN + IF (pao%precondition) & CPABORT("PAO preconditioning not supported for selected parametrization.") - END IF END SUBROUTINE pao_param_init_equi diff --git a/src/pao_param_exp.F b/src/pao_param_exp.F index 1aba9e19ac..f8a4897ba3 100644 --- a/src/pao_param_exp.F +++ b/src/pao_param_exp.F @@ -104,9 +104,8 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) THEN + IF (pao%precondition) & CPABORT("PAO preconditioning not supported for selected parametrization.") - END IF CALL timestop(handle) END SUBROUTINE pao_param_init_exp diff --git a/src/pao_param_fock.F b/src/pao_param_fock.F index 9ffed6bbec..023bbaae5c 100644 --- a/src/pao_param_fock.F +++ b/src/pao_param_fock.F @@ -95,10 +95,8 @@ CONTAINS ! calculate homo-lumo gap (it's useful for detecting numerical issues) gap = HUGE(dp) - IF (m < n) THEN - ! catch special case n==m + IF (m < n) & ! catch special case n==m gap = H_evals(m + 1) - H_evals(m) - END IF IF (PRESENT(penalty)) THEN ! penalty terms: occupied and virtual eigenvalues repel each other @@ -166,9 +164,8 @@ CONTAINS M5 = MATMUL(MATMUL(block_N, M4), block_N) ! add regularization gradient - IF (PRESENT(penalty)) THEN + IF (PRESENT(penalty)) & M5 = M5 + 2.0_dp*pao%regularization*V - END IF ! symmetrize G = 0.5_dp*(M5 + TRANSPOSE(M5)) ! the final gradient diff --git a/src/pao_param_gth.F b/src/pao_param_gth.F index 51fa85e990..31a8a8eda1 100644 --- a/src/pao_param_gth.F +++ b/src/pao_param_gth.F @@ -123,9 +123,8 @@ CONTAINS CALL dbcsr_iterator_stop(iter) !$OMP END PARALLEL - IF (pao%precondition) THEN + IF (pao%precondition) & CALL pao_param_gth_preconditioner(pao, qs_env, nterms) - END IF DEALLOCATE (row_blk_size, col_blk_size, nterms) CALL timestop(handle) @@ -209,9 +208,8 @@ CONTAINS CALL group%sum(block) CALL dbcsr_get_block_p(matrix=matrix_gth_overlap, row=iatom, col=jatom, block=block_overlap, found=found) - IF (ASSOCIATED(block_overlap)) THEN + IF (ASSOCIATED(block_overlap)) & block_overlap = block - END IF DEALLOCATE (block) END DO @@ -234,9 +232,8 @@ CONTAINS converged=converged) CALL dbcsr_release(matrix_gth_overlap) - IF (.NOT. converged) THEN + IF (.NOT. converged) & CPABORT("PAO: Sqrt of GTH-preconditioner did not converge.") - END IF CALL timestop(handle) END SUBROUTINE pao_param_gth_preconditioner @@ -384,9 +381,8 @@ CONTAINS DEALLOCATE (world_X, world_G) ! sum penalty energies across ranks - IF (PRESENT(penalty)) THEN + IF (PRESENT(penalty)) & CALL group%sum(penalty) - END IF ! print homo-lumo gap encountered by fock-layer CALL group%min(gaps) @@ -425,24 +421,20 @@ CONTAINS CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) CALL get_qs_kind(qs_kind_set(ikind), pao_potentials=pao_potentials) - IF (SIZE(pao_potentials) /= 1) THEN + IF (SIZE(pao_potentials) /= 1) & CPABORT("GTH parametrization requires exactly one PAO_POTENTIAL section per KIND") - END IF max_projector = pao_potentials(1)%max_projector maxl = pao_potentials(1)%maxl - IF (maxl < 0) THEN + IF (maxl < 0) & CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAXL") - END IF - IF (max_projector < 0) THEN + IF (max_projector < 0) & CPABORT("GTH parametrization requires non-negative PAO_POTENTIAL%MAX_PROJECTOR") - END IF - IF (MOD(maxl, 2) /= 0) THEN + IF (MOD(maxl, 2) /= 0) & CPABORT("GTH parametrization requires even-numbered PAO_POTENTIAL%MAXL") - END IF ncombis = (max_projector + 1)*(max_projector + 2)/2 nparams = ncombis*(maxl/2 + 1) diff --git a/src/pao_param_linpot.F b/src/pao_param_linpot.F index d32896a5ac..f4a1e21e2b 100644 --- a/src/pao_param_linpot.F +++ b/src/pao_param_linpot.F @@ -124,9 +124,8 @@ CONTAINS CALL pao_param_linpot_regularizer(pao) - IF (pao%precondition) THEN + IF (pao%precondition) & CALL pao_param_linpot_preconditioner(pao) - END IF CALL para_env%sync() ! ensure that timestop is not called too early @@ -446,23 +445,19 @@ CONTAINS CALL dbcsr_get_block_p(matrix=pao%matrix_V_terms, row=iatom, col=iatom, block=block_V_terms, found=found) CPASSERT(ASSOCIATED(block_V_terms)) nterms = SIZE(block_V_terms, 2) - IF (nterms > 0) THEN - ! protect against corner-case of zero pao parameters + IF (nterms > 0) & ! protect against corner-case of zero pao parameters vec_V = MATMUL(block_V_terms, block_X(:, 1)) - END IF block_V(1:n, 1:n) => vec_V(:) ! map vector into matrix ! symmetrize - IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) THEN + IF (MAXVAL(ABS(block_V - TRANSPOSE(block_V))/MAX(1.0_dp, MAXVAL(ABS(block_V)))) > 1e-12) & CPABORT("block_V not symmetric") - END IF block_V = 0.5_dp*(block_V + TRANSPOSE(block_V)) ! symmetrize exactly ! regularization energy ! protect against corner-case of zero pao parameters - IF (PRESENT(penalty) .AND. nterms > 0) THEN + IF (PRESENT(penalty) .AND. nterms > 0) & regu_energy = regu_energy + DOT_PRODUCT(block_X(:, 1), MATMUL(block_R, block_X(:, 1))) - END IF CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & gap=gaps(iatom), evals=evals(:, iatom)) @@ -478,18 +473,16 @@ CONTAINS !TODO: this 2nd call does double work. However, *sometimes* this branch is not taken. CALL pao_calc_U_block_fock(pao, iatom=iatom, penalty=penalty, V=block_V, U=block_U, & M1=block_M1, G=block_M2, gap=gaps(iatom), evals=evals(:, iatom)) - IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) THEN + IF (MAXVAL(ABS(block_M2 - TRANSPOSE(block_M2))) > 1e-14_dp) & CPABORT("matrix not symmetric") - END IF ! gradient dE/dX IF (PRESENT(matrix_G)) THEN CALL dbcsr_get_block_p(matrix=matrix_G, row=iatom, col=iatom, block=block_G, found=found) CPASSERT(ASSOCIATED(block_G)) block_G(:, 1) = MATMUL(vec_M2, block_V_terms) - IF (PRESENT(penalty)) THEN - block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) - END IF ! regularization gradient + IF (PRESENT(penalty)) & + block_G = block_G + 2.0_dp*MATMUL(block_R, block_X) ! regularization gradient END IF ! forced dE/dR diff --git a/src/pao_param_methods.F b/src/pao_param_methods.F index 37264fbec9..010af4c056 100644 --- a/src/pao_param_methods.F +++ b/src/pao_param_methods.F @@ -231,9 +231,8 @@ CONTAINS CALL group%max(delta_max) IF (pao%iw > 0) WRITE (pao%iw, *) 'PAO| checked unitaryness, max delta:', delta_max - IF (delta_max > pao%check_unitary_tol) THEN + IF (delta_max > pao%check_unitary_tol) & CPABORT("Found bad unitaryness:"//cp_to_string(delta_max)) - END IF CALL timestop(handle) END SUBROUTINE pao_assert_unitary diff --git a/src/pao_types.F b/src/pao_types.F index 1cb794451a..242f6095c4 100644 --- a/src/pao_types.F +++ b/src/pao_types.F @@ -121,8 +121,7 @@ MODULE pao_types !> \var constants_ready set when stuff, which does not depend of atomic positions is ready !> \var need_initial_scf set when the initial density matrix is not self-consistend !> \var matrix_X parameters of pao basis, which eventually determine matrix_U. Uses diag_distribution. -!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. -!> Uses diag_distribution. +!> \var matrix_U0 constant pre-rotation which serves as initial guess for exp-parametrization. Uses diag_distribution. !> \var matrix_H0 Diagonal blocks of core hamiltonian, uses diag_distribution !> \var matrix_Y selector matrix which translates between primary and pao basis. !> basically a block diagonal "rectangular identity matrix". Uses s_matrix-distribution. @@ -254,9 +253,8 @@ CONTAINS CALL dbcsr_release(pao%matrix_H0) DEALLOCATE (pao%ml_training_set) - IF (ALLOCATED(pao%ml_training_matrices)) THEN + IF (ALLOCATED(pao%ml_training_matrices)) & DEALLOCATE (pao%ml_training_matrices) - END IF IF (ALLOCATED(pao%models)) THEN DO i = 1, SIZE(pao%models) diff --git a/src/particle_methods.F b/src/particle_methods.F index 97a88055d6..e7336c66ad 100644 --- a/src/particle_methods.F +++ b/src/particle_methods.F @@ -1184,12 +1184,10 @@ CONTAINS count_list(elem_seen) = 1 END IF END IF - IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) THEN + IF (LEN_TRIM(cif_type_symbol(iatom)) > w_cif_type_symbol) & w_cif_type_symbol = LEN_TRIM(cif_type_symbol(iatom)) - END IF - IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) THEN + IF (LEN_TRIM(cif_label(iatom)) > w_cif_label) & w_cif_label = LEN_TRIM(cif_label(iatom)) - END IF END DO atom_loop ! Determine the format of each line in cif considering width of cif_type_symbol and cif_label @@ -1262,10 +1260,9 @@ CONTAINS file_unit = cp_print_key_unit_nr(logger, input_section, "PRINT%FINAL_STRUCTURE", & file_status="REPLACE", file_form="FORMATTED", & extension=".xyz") - IF (file_unit > 0) THEN + IF (file_unit > 0) & CALL write_particle_coordinates(particle_set, file_unit, dump_extxyz, "POS", title, & cell=cell, unit_conv=unit_conv, print_kind=print_kind) - END IF END IF ! Write CIF @@ -1433,10 +1430,9 @@ CONTAINS CALL section_release(tmp_cell_section) CALL cp_print_key_finished_output(file_unit, logger, input_section, & "PRINT%FINAL_STRUCTURE") - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (UNIT=output_unit, FMT='(/,T2,A)') & - routineN//": Done!" - END IF + routineN//": Done!" CALL timestop(handle) diff --git a/src/pexsi_interface.F b/src/pexsi_interface.F index e2d09937ab..fccdf461da 100644 --- a/src/pexsi_interface.F +++ b/src/pexsi_interface.F @@ -108,22 +108,17 @@ CONTAINS IF (PRESENT(muMin0)) pexsi_options%options%muMin0 = muMin0 IF (PRESENT(muMax0)) pexsi_options%options%muMax0 = muMax0 IF (PRESENT(mu0)) pexsi_options%options%mu0 = mu0 - IF (PRESENT(muInertiaTolerance)) THEN + IF (PRESENT(muInertiaTolerance)) & pexsi_options%options%muInertiaTolerance = muInertiaTolerance - END IF - IF (PRESENT(muInertiaExpansion)) THEN + IF (PRESENT(muInertiaExpansion)) & pexsi_options%options%muInertiaExpansion = muInertiaExpansion - END IF - IF (PRESENT(muPEXSISafeGuard)) THEN + IF (PRESENT(muPEXSISafeGuard)) & pexsi_options%options%muPEXSISafeGuard = muPEXSISafeGuard - END IF - IF (PRESENT(numElectronPEXSITolerance)) THEN + IF (PRESENT(numElectronPEXSITolerance)) & pexsi_options%options%numElectronPEXSITolerance = numElectronPEXSITolerance - END IF IF (PRESENT(matrixType)) pexsi_options%options%matrixType = matrixType - IF (PRESENT(isSymbolicFactorize)) THEN + IF (PRESENT(isSymbolicFactorize)) & pexsi_options%options%isSymbolicFactorize = isSymbolicFactorize - END IF IF (PRESENT(ordering)) pexsi_options%options%ordering = ordering IF (PRESENT(rowOrdering)) pexsi_options%options%rowOrdering = rowOrdering IF (PRESENT(npSymbFact)) pexsi_options%options%npSymbFact = npSymbFact @@ -210,22 +205,17 @@ CONTAINS IF (PRESENT(muMin0)) muMin0 = pexsi_options%options%muMin0 IF (PRESENT(muMax0)) muMax0 = pexsi_options%options%muMax0 IF (PRESENT(mu0)) mu0 = pexsi_options%options%mu0 - IF (PRESENT(muInertiaTolerance)) THEN + IF (PRESENT(muInertiaTolerance)) & muInertiaTolerance = pexsi_options%options%muInertiaTolerance - END IF - IF (PRESENT(muInertiaExpansion)) THEN + IF (PRESENT(muInertiaExpansion)) & muInertiaExpansion = pexsi_options%options%muInertiaExpansion - END IF - IF (PRESENT(muPEXSISafeGuard)) THEN + IF (PRESENT(muPEXSISafeGuard)) & muPEXSISafeGuard = pexsi_options%options%muPEXSISafeGuard - END IF - IF (PRESENT(numElectronPEXSITolerance)) THEN + IF (PRESENT(numElectronPEXSITolerance)) & numElectronPEXSITolerance = pexsi_options%options%numElectronPEXSITolerance - END IF IF (PRESENT(matrixType)) matrixType = pexsi_options%options%matrixType - IF (PRESENT(isSymbolicFactorize)) THEN + IF (PRESENT(isSymbolicFactorize)) & isSymbolicFactorize = pexsi_options%options%isSymbolicFactorize - END IF IF (PRESENT(ordering)) ordering = pexsi_options%options%ordering IF (PRESENT(rowOrdering)) rowOrdering = pexsi_options%options%rowOrdering IF (PRESENT(npSymbFact)) npSymbFact = pexsi_options%options%npSymbFact @@ -291,9 +281,8 @@ CONTAINS CALL timeset(routineN, handle) cp_pexsi_plan_initialize = f_ppexsi_plan_initialize(comm%get_handle(), numProcRow, & numProcCol, outputFileIndex, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(comm) @@ -340,9 +329,8 @@ CONTAINS CALL f_ppexsi_load_real_hs_matrix(plan, pexsi_options%options, nrows, nnz, nnzLocal, & numColLocal, colptrLocal, rowindLocal, & HnzvalLocal, isSIdentity, SnzvalLocal, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) @@ -355,11 +343,9 @@ CONTAINS CPABORT("Requires linking to the PEXSI library.") ! MARK_USED macro does not work on assumed shape variables - IF (.FALSE.) THEN - DO + IF (.FALSE.) THEN; DO IF (colptrLocal(1) > rowindLocal(1) .OR. HnzvalLocal(1) > SnzvalLocal(1)) EXIT - END DO - END IF + END DO; END IF #endif END SUBROUTINE cp_pexsi_load_real_hs_matrix @@ -410,9 +396,8 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) @@ -455,9 +440,8 @@ CONTAINS CALL f_ppexsi_retrieve_real_dft_matrix(plan, DMnzvalLocal, EDMnzvalLocal, & FDMnzvalLocal, totalEnergyH, & totalEnergyS, totalFreeEnergy, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) @@ -486,9 +470,8 @@ CONTAINS CALL timeset(routineN, handle) CALL f_ppexsi_plan_finalize(plan, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") - END IF CALL timestop(handle) #else MARK_USED(plan) diff --git a/src/pexsi_methods.F b/src/pexsi_methods.F index 3a8bb968b2..dc9c429e67 100644 --- a/src/pexsi_methods.F +++ b/src/pexsi_methods.F @@ -146,9 +146,8 @@ CONTAINS pexsi_env%num_ranks_per_pole = min_ranks_per_pole ! not a PEXSI option pexsi_env%csr_screening = csr_screening - IF (numElectronInitialTolerance < numElectronTargetTolerance) THEN + IF (numElectronInitialTolerance < numElectronTargetTolerance) & numElectronInitialTolerance = numElectronTargetTolerance - END IF pexsi_env%tol_nel_initial = numElectronInitialTolerance pexsi_env%tol_nel_target = numElectronTargetTolerance @@ -338,24 +337,20 @@ CONTAINS IF (first_call) THEN ! Assertion that matrices have the expected symmetry (both should be symmetric if no ! S preconditioning and no molecular clustering) - IF (.NOT. dbcsr_has_symmetry(matrix_ks)) THEN + IF (.NOT. dbcsr_has_symmetry(matrix_ks)) & CPABORT("PEXSI interface expects a non-symmetric DBCSR Kohn-Sham matrix") - END IF - IF (.NOT. dbcsr_has_symmetry(matrix_s)) THEN + IF (.NOT. dbcsr_has_symmetry(matrix_s)) & CPABORT("PEXSI interface expects a non-symmetric DBCSR overlap matrix") - END IF ! Assertion on datatype IF ((pexsi_env%csr_mat_s%nzval_local%data_type /= dbcsr_csr_type_real_8) & - .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) THEN + .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type /= dbcsr_csr_type_real_8)) & CPABORT("Complex data type not supported by PEXSI") - END IF ! Assertion on number of non-zero elements !(TODO: update when PEXSI changes to Long Int) - IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) THEN + IF (pexsi_env%csr_mat_s%nze_total >= INT(2, kind=int_8)**31) & CPABORT("Total number of non-zero elements of CSR matrix is too large to be handled by PEXSI") - END IF END IF CALL dbcsr_get_info(matrix_ks, distribution=dist) @@ -469,9 +464,8 @@ CONTAINS n_total_inertia_iter END IF - IF (.NOT. pexsi_convergence) THEN + IF (.NOT. pexsi_convergence) & CPABORT("PEXSI did not converge. Consider logPEXSI0 for more information.") - END IF ! Retrieve results from PEXSI IF (mynode < pexsi_env%mp_dims(1)*pexsi_env%mp_dims(2)) THEN diff --git a/src/pilaenv_hack.F b/src/pilaenv_hack.F index 89d89b4d54..4b59ed9474 100644 --- a/src/pilaenv_hack.F +++ b/src/pilaenv_hack.F @@ -18,8 +18,6 @@ !> \return ... ! ************************************************************************************************** INTEGER FUNCTION PILAENV(ICTXT, PREC) - IMPLICIT NONE - INTEGER :: ICTXT CHARACTER(LEN=1) :: PREC @@ -31,5 +29,5 @@ END FUNCTION PILAENV !> \brief ... ! ************************************************************************************************** SUBROUTINE NAG_dummy() - IMPLICIT NONE + END SUBROUTINE NAG_dummy diff --git a/src/pme.F b/src/pme.F index 6470a00c8b..d6703d8124 100644 --- a/src/pme.F +++ b/src/pme.F @@ -358,7 +358,7 @@ CONTAINS fgcore_coulomb(2, particle_set(p2)%shell_index) - fat(2)*dvols fgcore_coulomb(3, particle_set(p2)%shell_index) = & fgcore_coulomb(3, particle_set(p2)%shell_index) - fat(3)*dvols - ELSE IF (p2 /= 0) THEN + ELSEIF (p2 /= 0) THEN CALL dg_sum_patch_force_3d(drpot, rhos2, exp_igr%centre(:, p2), fat) fg_coulomb(1, p2) = fg_coulomb(1, p2) - fat(1)*dvols fg_coulomb(2, p2) = fg_coulomb(2, p2) - fat(2)*dvols @@ -505,7 +505,7 @@ CONTAINS ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) - ELSE IF (my_is1_core) THEN + ELSEIF (my_is1_core) THEN center1 => exp_igr%core_centre(:, particle_set(p1)%shell_index) ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) @@ -545,7 +545,7 @@ CONTAINS ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) - ELSE IF (my_is2_core) THEN + ELSEIF (my_is2_core) THEN center2 => exp_igr%core_centre(:, particle_set(p2)%shell_index) ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) @@ -633,7 +633,7 @@ CONTAINS ex1 => exp_igr%core_ex(:, particle_set(p1)%shell_index) ey1 => exp_igr%core_ey(:, particle_set(p1)%shell_index) ez1 => exp_igr%core_ez(:, particle_set(p1)%shell_index) - ELSE IF (my_is1_shell) THEN + ELSEIF (my_is1_shell) THEN ex1 => exp_igr%shell_ex(:, p1) ey1 => exp_igr%shell_ey(:, p1) ez1 => exp_igr%shell_ez(:, p1) @@ -659,7 +659,7 @@ CONTAINS ex2 => exp_igr%core_ex(:, particle_set(p2)%shell_index) ey2 => exp_igr%core_ey(:, particle_set(p2)%shell_index) ez2 => exp_igr%core_ez(:, particle_set(p2)%shell_index) - ELSE IF (my_is2_shell) THEN + ELSEIF (my_is2_shell) THEN ex2 => exp_igr%shell_ex(:, p2) ey2 => exp_igr%shell_ey(:, p2) ez2 => exp_igr%shell_ez(:, p2) diff --git a/src/population_analyses.F b/src/population_analyses.F index 715eeac5bf..2a0988a05a 100644 --- a/src/population_analyses.F +++ b/src/population_analyses.F @@ -187,11 +187,10 @@ CONTAINS ! Build full S^(1/2) matrix (computationally expensive) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) THEN + IF (ndep /= 0) & CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") - END IF ! Build Lowdin population matrix for each spin DO ispin = 1, nspin diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index 09ae1f3d75..2a0cc28187 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -1938,9 +1938,8 @@ CONTAINS CALL bs_env%para_env%max(z_end_global) n_z = z_end_global - z_start_global + 1 - IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) THEN + IF (ANY(ABS(bs_env%hmat(1:2, 3)) > 1.0E-6_dp) .OR. ANY(ABS(bs_env%hmat(3, 1:2)) > 1.0E-6_dp)) & CPABORT("Please choose a cell that has 90° angles to the z-direction.") - END IF ! for integration, we need the dz and the conversion from H -> eV and a_Bohr -> Å bs_env%unit_ldos_int_z_inv_Ang2_eV = bs_env%hmat(3, 3)/REAL(n_z, KIND=dp)/evolt/angstrom**2 diff --git a/src/preconditioner.F b/src/preconditioner.F index 15bbe74ebe..69d1ad3509 100644 --- a/src/preconditioner.F +++ b/src/preconditioner.F @@ -137,9 +137,8 @@ CONTAINS ! Thanks to the mess with the matrices we need to make sure in this case that the ! Previous inverse is properly stored as a sparse matrix, fm gets deallocated here ! if it wasn't anyway - IF (preconditioner_env%solver == ot_precond_solver_update) THEN + IF (preconditioner_env%solver == ot_precond_solver_update) & CALL transfer_fm_to_dbcsr(preconditioner_env%fm, preconditioner_env%dbcsr_matrix, matrix_h) - END IF needs_full_spectrum = .FALSE. needs_homo = .FALSE. @@ -262,8 +261,7 @@ CONTAINS DEALLOCATE (preconditioner(ispin)%preconditioner) END DO DEALLOCATE (preconditioner) - CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, & - ot_precond_full_single_inverse) ! these are 'independent' + CASE (ot_precond_none, ot_precond_full_kinetic, ot_precond_s_inverse, ot_precond_full_single_inverse) ! these are 'independent' ! do nothing CASE DEFAULT CPABORT("Unknown preconditioner type") @@ -390,7 +388,7 @@ CONTAINS co_rotate=qs_env%mo_derivs(ispin)%matrix, & para_env=para_env, & blacs_env=blacs_env) - ELSE IF (use_mo_coeff_b) THEN + ELSEIF (use_mo_coeff_b) THEN CALL calculate_subspace_eigenvalues(mo_coeff_b, matrix_ks(ispin)%matrix, & do_rotation=.TRUE., & para_env=para_env, & diff --git a/src/preconditioner_apply.F b/src/preconditioner_apply.F index e567636e74..0316f37bc9 100644 --- a/src/preconditioner_apply.F +++ b/src/preconditioner_apply.F @@ -167,9 +167,8 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) THEN + IF (.NOT. ASSOCIATED(preconditioner_env%dbcsr_matrix)) & CPABORT("NOT ASSOCIATED preconditioner_env%dbcsr_matrix") - END IF CALL dbcsr_multiply('N', 'N', 1.0_dp, preconditioner_env%dbcsr_matrix, matrix_in, & 0.0_dp, matrix_out) diff --git a/src/preconditioner_makes.F b/src/preconditioner_makes.F index 4dae5616cb..c83f6ce23e 100644 --- a/src/preconditioner_makes.F +++ b/src/preconditioner_makes.F @@ -93,9 +93,8 @@ CONTAINS precon_type = preconditioner_env%in_use SELECT CASE (precon_type) CASE (ot_precond_full_single) - IF (my_solver_type /= ot_precond_solver_default) THEN + IF (my_solver_type /= ot_precond_solver_default) & CPABORT("Only PRECOND_SOLVER DEFAULT for the moment") - END IF IF (PRESENT(matrix_s)) THEN CALL make_full_single(preconditioner_env, preconditioner_env%fm, & matrix_h, matrix_s, energy_homo, energy_gap) @@ -106,16 +105,14 @@ CONTAINS CASE (ot_precond_s_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. PRESENT(matrix_s)) THEN + IF (.NOT. PRESENT(matrix_s)) & CPABORT("Type for S=1 not implemented") - END IF CALL make_full_s_inverse(preconditioner_env, matrix_s) CASE (ot_precond_full_kinetic) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol - IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) THEN + IF (.NOT. (PRESENT(matrix_s) .AND. PRESENT(matrix_t))) & CPABORT("Type for S=1 not implemented") - END IF CALL make_full_kinetic(preconditioner_env, matrix_t, matrix_s, energy_gap) CASE (ot_precond_full_single_inverse) IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol @@ -748,9 +745,8 @@ CONTAINS matrices(1)%matrix => dbcsr_cThc CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=1.0E-3_dp, selection_crit=2, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) - IF (ASSOCIATED(preconditioner_env%max_ev_vector)) THEN + IF (ASSOCIATED(preconditioner_env%max_ev_vector)) & CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%max_ev_vector) - END IF CALL arnoldi_ev(matrices, arnoldi_env) max_ev = REAL(get_selected_ritz_val(arnoldi_env, 1), dp) @@ -780,9 +776,8 @@ CONTAINS CALL setup_arnoldi_env(arnoldi_env, matrices, max_iter=20, threshold=2.0E-2_dp, selection_crit=3, & nval_request=1, nrestarts=8, generalized_ev=.FALSE., iram=.FALSE.) END IF - IF (ASSOCIATED(preconditioner_env%min_ev_vector)) THEN + IF (ASSOCIATED(preconditioner_env%min_ev_vector)) & CALL set_arnoldi_initial_vector(arnoldi_env, preconditioner_env%min_ev_vector) - END IF ! compute the LUMO energy CALL arnoldi_ev(matrices, arnoldi_env) diff --git a/src/preconditioner_solvers.F b/src/preconditioner_solvers.F index 92670b6114..21834c0f22 100644 --- a/src/preconditioner_solvers.F +++ b/src/preconditioner_solvers.F @@ -91,9 +91,8 @@ CONTAINS ! make sure preconditioner_env is not destroyed in between occ_matrix = 1.0_dp IF (ASSOCIATED(preconditioner_env%sparse_matrix)) THEN - IF (preconditioner_env%condition_num < 0.0_dp) THEN + IF (preconditioner_env%condition_num < 0.0_dp) & CALL estimate_cond_num(preconditioner_env%sparse_matrix, preconditioner_env%condition_num) - END IF CALL dbcsr_filter(preconditioner_env%sparse_matrix, & 1.0_dp/preconditioner_env%condition_num*0.01_dp) occ_matrix = dbcsr_get_occupation(preconditioner_env%sparse_matrix) diff --git a/src/pw/dgs.F b/src/pw/dgs.F index 3124a68eb4..6f47d09e24 100644 --- a/src/pw/dgs.F +++ b/src/pw/dgs.F @@ -420,7 +420,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(1)) THEN + ELSEIF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -433,7 +433,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(2)) THEN + ELSEIF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -446,7 +446,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(3)) THEN + ELSEIF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -495,7 +495,7 @@ CONTAINS IF (ii < 0) THEN rs%px(ia) = ii + rs%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(1)) THEN + ELSEIF (ii >= rs%npts_local(1)) THEN rs%px(ia) = ii - rs%npts_local(1) + 1 folded = .TRUE. ELSE @@ -508,7 +508,7 @@ CONTAINS IF (ii < 0) THEN rs%py(ia) = ii + rs%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(2)) THEN + ELSEIF (ii >= rs%npts_local(2)) THEN rs%py(ia) = ii - rs%npts_local(2) + 1 folded = .TRUE. ELSE @@ -521,7 +521,7 @@ CONTAINS IF (ii < 0) THEN rs%pz(ia) = ii + rs%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= rs%npts_local(3)) THEN + ELSEIF (ii >= rs%npts_local(3)) THEN rs%pz(ia) = ii - rs%npts_local(3) + 1 folded = .TRUE. ELSE @@ -572,7 +572,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%npts_local(1)) THEN + ELSEIF (ii >= drpot(1)%npts_local(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%npts_local(1) + 1 folded = .TRUE. ELSE @@ -585,7 +585,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%npts_local(2)) THEN + ELSEIF (ii >= drpot(1)%npts_local(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%npts_local(2) + 1 folded = .TRUE. ELSE @@ -598,7 +598,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%npts_local(3)) THEN + ELSEIF (ii >= drpot(1)%npts_local(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%npts_local(3) + 1 folded = .TRUE. ELSE @@ -651,7 +651,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%npts_local(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(1)) THEN + ELSEIF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%npts_local(1) + 1 folded = .TRUE. ELSE @@ -664,7 +664,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%npts_local(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(2)) THEN + ELSEIF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%npts_local(2) + 1 folded = .TRUE. ELSE @@ -677,7 +677,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%npts_local(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(3)) THEN + ELSEIF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%npts_local(3) + 1 folded = .TRUE. ELSE @@ -724,7 +724,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%px(ia) = ii + drpot(1)%desc%npts(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%desc%npts(1)) THEN + ELSEIF (ii >= drpot(1)%desc%npts(1)) THEN drpot(1)%px(ia) = ii - drpot(1)%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -737,7 +737,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%py(ia) = ii + drpot(1)%desc%npts(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%desc%npts(2)) THEN + ELSEIF (ii >= drpot(1)%desc%npts(2)) THEN drpot(1)%py(ia) = ii - drpot(1)%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -750,7 +750,7 @@ CONTAINS IF (ii < 0) THEN drpot(1)%pz(ia) = ii + drpot(1)%desc%npts(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot(1)%desc%npts(3)) THEN + ELSEIF (ii >= drpot(1)%desc%npts(3)) THEN drpot(1)%pz(ia) = ii - drpot(1)%desc%npts(3) + 1 folded = .TRUE. ELSE @@ -798,7 +798,7 @@ CONTAINS IF (ii < 0) THEN drpot%px(ia) = ii + drpot%desc%npts(1) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(1)) THEN + ELSEIF (ii >= drpot%desc%npts(1)) THEN drpot%px(ia) = ii - drpot%desc%npts(1) + 1 folded = .TRUE. ELSE @@ -811,7 +811,7 @@ CONTAINS IF (ii < 0) THEN drpot%py(ia) = ii + drpot%desc%npts(2) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(2)) THEN + ELSEIF (ii >= drpot%desc%npts(2)) THEN drpot%py(ia) = ii - drpot%desc%npts(2) + 1 folded = .TRUE. ELSE @@ -824,7 +824,7 @@ CONTAINS IF (ii < 0) THEN drpot%pz(ia) = ii + drpot%desc%npts(3) + 1 folded = .TRUE. - ELSE IF (ii >= drpot%desc%npts(3)) THEN + ELSEIF (ii >= drpot%desc%npts(3)) THEN drpot%pz(ia) = ii - drpot%desc%npts(3) + 1 folded = .TRUE. ELSE diff --git a/src/pw/dirichlet_bc_methods.F b/src/pw/dirichlet_bc_methods.F index 69499538b4..6dc8e30b92 100644 --- a/src/pw/dirichlet_bc_methods.F +++ b/src/pw/dirichlet_bc_methods.F @@ -905,7 +905,7 @@ CONTAINS END SELECT alpha = linspace(0.0_dp, 2*pi, n_dbcs + 1) - alpha_rotd = alpha + delta_alpha + alpha_rotd = alpha + delta_alpha; SELECT CASE (parallel_axis) CASE (x_axis) DO j = 1, n_dbcs @@ -1180,7 +1180,7 @@ CONTAINS IF (direction == FWROT) THEN vec_tmp = MATMUL(Rmat, vec) vec_transfd = vec_tmp + Tp - ELSE IF (direction == BWROT) THEN + ELSEIF (direction == BWROT) THEN Rmat_inv = inv_3x3(Rmat) Tpoint(1) = Rmat_inv(1, 1)*Tp(1) + Rmat_inv(1, 2)*Tp(2) + Rmat_inv(1, 3)*Tp(3) Tpoint(2) = Rmat_inv(2, 1)*Tp(1) + Rmat_inv(2, 2)*Tp(2) + Rmat_inv(2, 3)*Tp(3) diff --git a/src/pw/fft/fftw3_lib.F b/src/pw/fft/fftw3_lib.F index 08de4d3143..b71f789160 100644 --- a/src/pw/fft/fftw3_lib.F +++ b/src/pw/fft/fftw3_lib.F @@ -162,10 +162,9 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_export_wisdom_to_filename(wisdom_file_name_c) - IF (isuccess == 0) THEN + IF (isuccess == 0) & CALL cp_warn(__LOCATION__, "Error exporting wisdom to file "//TRIM(wisdom_file)//". "// & "Wisdom was not exported.") - END IF END IF END IF @@ -192,9 +191,8 @@ CONTAINS LOGICAL :: file_exists isuccess = fftw_init_threads() - IF (isuccess == 0) THEN + IF (isuccess == 0) & CPABORT("Error initializing FFTW with threads") - END IF ! Read FFTW wisdom (if available) ! all nodes are opening the file here... @@ -214,11 +212,10 @@ CONTAINS END DO wisdom_file_name_c(file_name_length + 1) = C_NULL_CHAR isuccess = fftw_import_wisdom_from_filename(wisdom_file_name_c) - IF (isuccess == 0) THEN + IF (isuccess == 0) & CALL cp_warn(__LOCATION__, "Error importing wisdom from file "//TRIM(wisdom_file)//". "// & "Maybe the file was created with a different configuration than CP2K is run with. "// & "CP2K continues without importing wisdom.") - END IF END IF END IF #else @@ -1042,7 +1039,7 @@ CONTAINS IF (plan%fsign == +1 .AND. plan%trans) THEN istride = plan%m idist = 1 - ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN + ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN ostride = plan%m odist = 1 END IF @@ -1164,7 +1161,7 @@ CONTAINS !$ out_offset = 1 + plan%num_rows*my_id*plan%n !$ IF (plan%fsign == +1 .AND. plan%trans) THEN !$ in_offset = 1 + plan%num_rows*my_id -!$ ELSE IF (plan%fsign == -1 .AND. plan%trans) THEN +!$ ELSEIF (plan%fsign == -1 .AND. plan%trans) THEN !$ out_offset = 1 + plan%num_rows*my_id !$ END IF !$ scal_offset = 1 + plan%n*plan%num_rows*my_id diff --git a/src/pw/fft/mltfftsg_tools.F b/src/pw/fft/mltfftsg_tools.F index c1a5b01d5b..a81b903ac7 100644 --- a/src/pw/fft/mltfftsg_tools.F +++ b/src/pw/fft/mltfftsg_tools.F @@ -15,10 +15,7 @@ MODULE mltfftsg_tools #include "../../base/base_uses.f90" - IMPLICIT NONE - PRIVATE - INTEGER, PARAMETER :: ctrig_length = 1024 INTEGER, PARAMETER :: cache_size = 2048 PUBLIC :: mltfftsg diff --git a/src/pw/fft_tools.F b/src/pw/fft_tools.F index 0c0940b882..3f05511557 100644 --- a/src/pw/fft_tools.F +++ b/src/pw/fft_tools.F @@ -1135,7 +1135,7 @@ CONTAINS END IF END IF - ELSE IF (sign == BWFFT) THEN + ELSEIF (sign == BWFFT) THEN ! Stage 3 -> 1 bbuf => fft_scratch%a5buf @@ -1217,7 +1217,7 @@ CONTAINS CALL release_fft_scratch(fft_scratch) - ELSE IF (DIM(2) == 1) THEN + ELSEIF (DIM(2) == 1) THEN ! ! Second case; one stage of communication @@ -1277,7 +1277,7 @@ CONTAINS END IF END IF - ELSE IF (sign == BWFFT) THEN + ELSEIF (sign == BWFFT) THEN ! Stage 3 -> 1 IF (test) THEN diff --git a/src/pw/mt_util.F b/src/pw/mt_util.F index 365f65c469..148c8f3b92 100644 --- a/src/pw/mt_util.F +++ b/src/pw/mt_util.F @@ -110,9 +110,8 @@ CONTAINS g3d = fourpi/g2 screen_function%array(ig) = screen_function%array(ig) - g3d*EXP(-g2/(4.0E0_dp*alpha2)) END DO - IF (screen_function%pw_grid%have_g0) THEN + IF (screen_function%pw_grid%have_g0) & screen_function%array(1) = screen_function%array(1) + fourpi/(4.0E0_dp*alpha2) - END IF CASE (MT2D) iz = special_dimension ! iz is the direction with NO PBC zlength = slab_size ! zlength is the thickness of the cell diff --git a/src/pw/ps_implicit_methods.F b/src/pw/ps_implicit_methods.F index ba575985e8..705f5bbde2 100644 --- a/src/pw/ps_implicit_methods.F +++ b/src/pw/ps_implicit_methods.F @@ -274,9 +274,8 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -287,9 +286,8 @@ CONTAINS END DO CALL ps_implicit_print_convergence_msg(iter, max_iter, outp_unit) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & CALL pw_copy(v_new, ps_implicit_env%initial_guess) - END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -441,9 +439,8 @@ CONTAINS iter = iter + 1 reached_max_iter = iter > max_iter reached_tol = pres_error <= tol - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -457,9 +454,8 @@ CONTAINS CALL pw_shrink(neumann_directions, dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_local_shftd, v_new_xpndd, v_new) - IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & CALL pw_copy(v_new_xpndd, ps_implicit_env%initial_guess) - END IF IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric @@ -709,9 +705,8 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -999,9 +994,8 @@ CONTAINS reached_max_iter = iter > max_iter reached_tol = pres_error <= tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 - IF (pres_error > large_error) THEN + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") - END IF IF (reached_max_iter .OR. reached_tol) EXIT ! update @@ -1255,15 +1249,13 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) THEN + IF (info /= 0) & CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") - END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Inversion of R failed!") - END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) CALL pw_pool_release(pw_pool_xpndd) @@ -1386,15 +1378,13 @@ CONTAINS ! evaluate R^(-1) ps_implicit_env%Rinv(:, :) = R CALL DGETRF(n_tiles_tot + 1, n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, info) - IF (info /= 0) THEN + IF (info /= 0) & CALL cp_abort(__LOCATION__, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & "you need to reduce the number of tiles.") - END IF CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info /= 0) THEN + IF (info /= 0) & CPABORT("Inversion of R failed!") - END IF DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) diff --git a/src/pw/ps_wavelet_base.F b/src/pw/ps_wavelet_base.F index ad7d3efa69..2a9fc0f9b0 100644 --- a/src/pw/ps_wavelet_base.F +++ b/src/pw/ps_wavelet_base.F @@ -12,7 +12,6 @@ MODULE ps_wavelet_base USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_fft3d, ONLY: ctrig,& ctrig_length,& @@ -706,8 +705,9 @@ CONTAINS REAL(KIND=dp), INTENT(in) :: hx, hy, hz INTEGER :: i1, i2, j1, j2, j3 - REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2 + REAL(KIND=dp) :: fourpi2, ker, mu3, p1, p2, pi + pi = 4._dp*ATAN(1._dp) fourpi2 = 4._dp*pi**2 j3 = i3 !n3/2+1-abs(n3/2+2-i3) mu3 = REAL(j3 - 1, KIND=dp)/REAL(n3, KIND=dp) diff --git a/src/pw/ps_wavelet_fft3d.F b/src/pw/ps_wavelet_fft3d.F index cf470a0206..2381556718 100644 --- a/src/pw/ps_wavelet_fft3d.F +++ b/src/pw/ps_wavelet_fft3d.F @@ -112,14 +112,15 @@ CONTAINS ! Different factorizations affect the performance ! Factoring 64 as 4*4*4 might for example be faster on some machines than 8*8. INTEGER :: n - REAL(KIND=dp) :: trig(2, ctrig_length) - INTEGER :: after(7), before(7), now(7), isign, ic + REAL(KIND=dp) :: trig + INTEGER :: after, before, now, isign, ic CHARACTER(LEN=888) :: err INTEGER :: i, itt, j, nh - INTEGER, DIMENSION(7, 149) :: idata REAL(KIND=dp) :: angle, trigc, trigs, twopi + DIMENSION now(7), after(7), before(7), trig(2, ctrig_length) + INTEGER, DIMENSION(7, 149) :: idata ! The factor 6 is only allowed in the first place! DATA((idata(i, j), i=1, 7), j=1, 76)/ & 3, 3, 1, 1, 1, 1, 1, 4, 4, 1, 1, 1, 1, 1, & @@ -284,8 +285,7 @@ CONTAINS ! GNU General Public License, see http://www.gnu.org/copyleft/gpl.txt . INTEGER :: mm, nfft, m, nn, n - REAL(KIND=dp) :: zin(2, mm, m), zout(2, nn, n), & - trig(2, ctrig_length) + REAL(KIND=dp) :: zin, zout, trig INTEGER :: after, now, before, isign INTEGER :: atb, atn, ia, ias, ib, itrig, itt, j, & @@ -297,6 +297,7 @@ CONTAINS rt2i, s, s1, s2, s25, s3, s34, s4, s5, s6, s7, s8, sin2, sin4, ui1, ui2, ui3, ur1, ur2, & ur3, vi1, vi2, vi3, vr1, vr2, vr3 + DIMENSION trig(2, ctrig_length), zin(2, mm, m), zout(2, nn, n) atn = after*now atb = after*before @@ -320,8 +321,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO DO 2000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -342,8 +342,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -361,8 +360,7 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO - END DO + END DO; END DO END IF ELSE IF (4*ias == after) THEN IF (isign == 1) THEN @@ -384,8 +382,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -405,8 +402,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO END IF ELSE IF (4*ias == 3*after) THEN IF (isign == 1) THEN @@ -428,8 +424,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r2 + r1 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -449,8 +444,7 @@ CONTAINS zout(2, j, nout1) = s1 - s2 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s2 + s1 - END DO - END DO + END DO; END DO END IF ELSE itrig = ias*before + 1 @@ -474,8 +468,7 @@ CONTAINS zout(2, j, nout1) = s2 + s1 zout(1, j, nout2) = r1 - r2 zout(2, j, nout2) = s1 - s2 - END DO - END DO + END DO; END DO END IF 2000 CONTINUE ELSE IF (now == 4) THEN @@ -517,8 +510,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO DO 4000, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -562,8 +554,7 @@ CONTAINS s = r2 + r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO ELSE itt = ias*before itrig = itt + 1 @@ -617,8 +608,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO END IF 4000 CONTINUE ELSE @@ -659,8 +649,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO - END DO + END DO; END DO DO 4100, ia = 2, after ias = ia - 1 IF (2*ias == after) THEN @@ -704,8 +693,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO - END DO + END DO; END DO ELSE itt = ias*before itrig = itt + 1 @@ -759,8 +747,7 @@ CONTAINS s = r2 - r4 zout(2, j, nout2) = r - s zout(2, j, nout4) = r + s - END DO - END DO + END DO; END DO END IF 4100 CONTINUE END IF @@ -855,8 +842,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO DO 8000, ia = 2, after ias = ia - 1 itt = ias*before @@ -983,8 +969,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO 8000 CONTINUE ELSE @@ -1077,8 +1062,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO DO 8001, ia = 2, after ias = ia - 1 @@ -1206,8 +1190,7 @@ CONTAINS zout(2, j, nout4) = bp + dpp zout(1, j, nout8) = am - cp zout(2, j, nout8) = bp - dpp - END DO - END DO + END DO; END DO 8001 CONTINUE END IF @@ -1243,8 +1226,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO DO 3000, ia = 2, after ias = ia - 1 IF (4*ias == 3*after) THEN @@ -1277,8 +1259,7 @@ CONTAINS zout(2, j, nout2) = s1 - r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 + r2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1308,8 +1289,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 - s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO END IF ELSE IF (8*ias == 3*after) THEN IF (isign == 1) THEN @@ -1343,8 +1323,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1376,8 +1355,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO END IF ELSE itt = ias*before @@ -1419,8 +1397,7 @@ CONTAINS zout(2, j, nout2) = s1 + r2 zout(1, j, nout3) = r1 + s2 zout(2, j, nout3) = s1 - r2 - END DO - END DO + END DO; END DO END IF 3000 CONTINUE ELSE IF (now == 5) THEN @@ -1483,8 +1460,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO DO 5000, ia = 2, after ias = ia - 1 IF (8*ias == 5*after) THEN @@ -1543,8 +1519,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO ELSE nin1 = ia - after nout1 = ia - atn @@ -1600,8 +1575,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO END IF ELSE ias = ia - 1 @@ -1676,8 +1650,7 @@ CONTAINS s = sin4*r25 - sin2*r34 zout(2, j, nout3) = r + s zout(2, j, nout4) = r - s - END DO - END DO + END DO; END DO END IF 5000 CONTINUE ELSE IF (now == 6) THEN @@ -1751,8 +1724,7 @@ CONTAINS zout(2, j, nout2) = ui2 - vi2 zout(1, j, nout6) = ur3 - vr3 zout(2, j, nout6) = ui3 - vi3 - END DO - END DO + END DO; END DO ELSE CPABORT("error fftstp") END IF diff --git a/src/pw/ps_wavelet_kernel.F b/src/pw/ps_wavelet_kernel.F index b39df92602..c535a1fa43 100644 --- a/src/pw/ps_wavelet_kernel.F +++ b/src/pw/ps_wavelet_kernel.F @@ -12,7 +12,6 @@ MODULE ps_wavelet_kernel USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE message_passing, ONLY: mp_comm_type USE ps_wavelet_base, ONLY: scramble_unpack USE ps_wavelet_fft3d, ONLY: ctrig,& @@ -236,8 +235,8 @@ CONTAINS shift INTEGER, ALLOCATABLE, DIMENSION(:) :: after, before, now REAL(kind=dp) :: a, b, c, cp, d, diff, dx, feI, feR, foI, & - foR, fR, mu1, pion, ponx, pony, sp, & - value, x + foR, fR, mu1, pi, pion, ponx, pony, & + sp, value, x REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: kernel_scf, x_scf, y_scf REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: btrig, cossinarr REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: halfft_cache, kernel @@ -356,6 +355,9 @@ CONTAINS ALLOCATE (now(7)) ALLOCATE (before(7)) + !constants + pi = 4._dp*ATAN(1._dp) + !arrays for the halFFT CALL ctrig(n3/2, btrig, after, before, now, 1, ic) diff --git a/src/pw/ps_wavelet_methods.F b/src/pw/ps_wavelet_methods.F index 624bae7120..7ca3a4c95d 100644 --- a/src/pw/ps_wavelet_methods.F +++ b/src/pw/ps_wavelet_methods.F @@ -90,12 +90,10 @@ CONTAINS hz = pw_grid%dr(wavelet%axis(3)) IF (poisson_params%wavelet_method == WAVELET0D) THEN - IF (hx /= hy) THEN + IF (hx /= hy) & CPABORT("Poisson solver for non cubic cells not yet implemented") - END IF - IF (hz /= hy) THEN + IF (hz /= hy) & CPABORT("Poisson solver for non cubic cells not yet implemented") - END IF END IF CALL RS_z_slice_distribution(wavelet, pw_grid) diff --git a/src/pw/ps_wavelet_scaling_function.F b/src/pw/ps_wavelet_scaling_function.F index 6352c34555..1eed8a8d73 100644 --- a/src/pw/ps_wavelet_scaling_function.F +++ b/src/pw/ps_wavelet_scaling_function.F @@ -74,7 +74,9 @@ CONTAINS !open (unit=1,file='scfunction',status='unknown') DO i = 0, nd a(i) = 1._dp*i*ni/nd - (.5_dp*ni - 1._dp) + !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-1._dp),x(i) END DO + !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) END SUBROUTINE scaling_function @@ -126,7 +128,9 @@ CONTAINS !open (unit=1,file='wavelet',status='unknown') DO i = 0, nd - 1 a(i) = 1._dp*i*ni/nd - (.5_dp*ni - .5_dp) + !write(1,*) 1._dp*i*ni/nd-(.5_dp*ni-.5_dp),x(i) END DO + !close(1) DEALLOCATE (ch, cg, cgt, cht) DEALLOCATE (y) @@ -162,7 +166,7 @@ CONTAINS !> \param n ... !> \param x ... ! ************************************************************************************************** - PURE SUBROUTINE zero(n, x) + SUBROUTINE zero(n, x) INTEGER, INTENT(in) :: n REAL(KIND=dp), INTENT(out) :: x(n) diff --git a/src/pw/ps_wavelet_types.F b/src/pw/ps_wavelet_types.F index 464697a8d0..dfbfceb2db 100644 --- a/src/pw/ps_wavelet_types.F +++ b/src/pw/ps_wavelet_types.F @@ -55,12 +55,10 @@ CONTAINS TYPE(ps_wavelet_type), POINTER :: wavelet IF (ASSOCIATED(wavelet)) THEN - IF (ASSOCIATED(wavelet%karray)) THEN + IF (ASSOCIATED(wavelet%karray)) & DEALLOCATE (wavelet%karray) - END IF - IF (ASSOCIATED(wavelet%rho_z_sliced)) THEN + IF (ASSOCIATED(wavelet%rho_z_sliced)) & DEALLOCATE (wavelet%rho_z_sliced) - END IF DEALLOCATE (wavelet) END IF END SUBROUTINE ps_wavelet_release diff --git a/src/pw/pw_fpga.F b/src/pw/pw_fpga.F index 3819cd0749..3d26adb66c 100644 --- a/src/pw/pw_fpga.F +++ b/src/pw/pw_fpga.F @@ -117,9 +117,8 @@ CONTAINS CPABORT("OFFLOAD and FPGA cannot be configured concurrently! Recompile with -D__NO_OFFLOAD_PW.") #endif stat = pw_fpga_initialize() - IF (stat /= 0) THEN + IF (stat /= 0) & CPABORT("pw_fpga_init: failed") - END IF #endif #if (__PW_FPGA_SP && !(__PW_FPGA)) diff --git a/src/pw/pw_gpu.F b/src/pw/pw_gpu.F index 3e752e77da..2f6a055c4d 100644 --- a/src/pw/pw_gpu.F +++ b/src/pw/pw_gpu.F @@ -301,9 +301,8 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) THEN + IF (r_dim(1) == 1) & CPABORT("This processor distribution is not supported.") - END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) @@ -464,9 +463,8 @@ CONTAINS ! real space is distributed over x and y coordinate ! we have two stages of communication ! - IF (r_dim(1) == 1) THEN + IF (r_dim(1) == 1) & CPABORT("This processor distribution is not supported.") - END IF CALL get_fft_scratch(fft_scratch, tf_type=300, n=n, fft_sizes=fft_scratch_size) diff --git a/src/pw/pw_grid_types.F b/src/pw/pw_grid_types.F index 62a9f61387..b5c6024351 100644 --- a/src/pw/pw_grid_types.F +++ b/src/pw/pw_grid_types.F @@ -44,8 +44,7 @@ MODULE pw_grid_types INTEGER, DIMENSION(:), ALLOCATABLE :: nyzray ! number of g-space rays (pe) TYPE(mp_cart_type) :: group = mp_cart_type() ! real space group (2-dim cart) INTEGER, DIMENSION(:, :, :, :), ALLOCATABLE :: bo ! list of axis distribution - INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane - ! should go: hard-codes to plane distributed + INTEGER, DIMENSION(:), ALLOCATABLE :: pos_of_x ! what my_pos holds a given x plane....should go: hard-codes to plane distributed END TYPE pw_para_type ! all you always wanted to know about grids, but were... diff --git a/src/pw/pw_poisson_methods.F b/src/pw/pw_poisson_methods.F index 04910df1ab..89f8f65c32 100644 --- a/src/pw/pw_poisson_methods.F +++ b/src/pw/pw_poisson_methods.F @@ -537,9 +537,8 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & CPABORT("vhartree has a different grid than the poisson solver") - END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -949,9 +948,8 @@ CONTAINS ! point pw pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool%pw_grid - IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) THEN + IF (.NOT. pw_grid_compare(pw_pool%pw_grid, vhartree%pw_grid)) & CPABORT("vhartree has a different grid than the poisson solver") - END IF ! density in G space CALL pw_pool%create_pw(rhog) IF (PRESENT(aux_density)) THEN @@ -1294,12 +1292,12 @@ CONTAINS CALL timeset(routineN, handle) - IF (PRESENT(parameters)) poisson_env%parameters = parameters + IF (PRESENT(parameters)) & + poisson_env%parameters = parameters IF (PRESENT(cell_hmat)) THEN - IF (ANY(poisson_env%cell_hmat /= cell_hmat)) THEN + IF (ANY(poisson_env%cell_hmat /= cell_hmat)) & CALL pw_poisson_cleanup(poisson_env) - END IF poisson_env%cell_hmat(:, :) = cell_hmat(:, :) poisson_env%rebuild = .TRUE. END IF diff --git a/src/pw/pw_poisson_types.F b/src/pw/pw_poisson_types.F index 624cadd4c0..b73b8423cb 100644 --- a/src/pw/pw_poisson_types.F +++ b/src/pw/pw_poisson_types.F @@ -367,9 +367,8 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d*(1.0_dp - COS(rlength*gg)) END DO - IF (grid%have_g0) THEN + IF (grid%have_g0) & gf%array(1) = 0.5_dp*fourpi*rlength*rlength - END IF CASE (MT2D, MT1D, MT0D) @@ -378,9 +377,8 @@ CONTAINS g3d = fourpi/g2 gf%array(ig) = g3d + green%screen_fn%array(ig) END DO - IF (grid%have_g0) THEN + IF (grid%have_g0) & gf%array(1) = green%screen_fn%array(1) - END IF CASE (PS_IMPLICIT) @@ -454,12 +452,10 @@ CONTAINS DEALLOCATE (gftype%p3m_charge) END IF END IF - IF (ALLOCATED(gftype%p3m_bm2)) THEN + IF (ALLOCATED(gftype%p3m_bm2)) & DEALLOCATE (gftype%p3m_bm2) - END IF - IF (ALLOCATED(gftype%p3m_coeff)) THEN + IF (ALLOCATED(gftype%p3m_coeff)) & DEALLOCATE (gftype%p3m_coeff) - END IF END SUBROUTINE pw_green_release ! ************************************************************************************************** diff --git a/src/pw/pw_spline_utils.F b/src/pw/pw_spline_utils.F index 8459f07cb6..4e708be0a3 100644 --- a/src/pw/pw_spline_utils.F +++ b/src/pw/pw_spline_utils.F @@ -2116,7 +2116,7 @@ CONTAINS + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 + ww0(2)*vv7 + vv0*ww1(2) coarse_coeffs(i + 3, j, k) = coarse_coeffs(i + 3, j, k) & + ww1(4)*vv6 + ww0(3)*vv7 + vv0*ww1(3) - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv0 = fine_values(fi, fj, fk) vv1 = fine_values(fine_bo(1, 1), fj, fk) @@ -2158,7 +2158,7 @@ CONTAINS + ww1(3)*vv4 + ww0(2)*vv5 + ww1(2)*vv6 coarse_coeffs(i + 2, j, k) = coarse_coeffs(i + 2, j, k) & + ww1(4)*vv4 + ww0(3)*vv5 + ww1(3)*vv6 - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv6 = fine_values(fi, fj, fk) vv7 = fine_values(fine_bo(1, 1), fj, fk) @@ -2202,7 +2202,7 @@ CONTAINS + ww1(3)*vv2 + ww0(2)*vv3 + ww1(2)*vv4 coarse_coeffs(i + 1, j, k) = coarse_coeffs(i + 1, j, k) & + ww1(4)*vv2 + ww0(3)*vv3 + ww1(3)*vv4 - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv4 = fine_values(fi, fj, fk) vv5 = fine_values(fine_bo(1, 1), fj, fk) @@ -2244,7 +2244,7 @@ CONTAINS + ww1(3)*vv0 + ww0(2)*vv1 + ww1(2)*vv2 coarse_coeffs(i, j, k) = coarse_coeffs(i, j, k) & + ww1(4)*vv0 + ww0(3)*vv1 + ww1(3)*vv2 - ELSE IF (pbc .AND. .NOT. is_split) THEN + ELSEIF (pbc .AND. .NOT. is_split) THEN fi = fi + 1 vv2 = fine_values(fi, fj, fk) vv3 = fine_values(fine_bo(1, 1), fk, fk) @@ -2348,9 +2348,8 @@ CONTAINS send_offset(ip) = send_tot_size send_tot_size = send_tot_size + send_size(ip) END DO - IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) THEN + IF (send_tot_size /= (coarse_bo(2, 1) - coarse_bo(1, 1) + 1)*coarse_slice_size) & CPABORT("Error calculating send_tot_size") - END IF ALLOCATE (send_buf(0:send_tot_size - 1)) rcv_tot_size = 0 @@ -2375,12 +2374,10 @@ CONTAINS sent_size(p) = sent_size(p) + coarse_slice_size END DO - IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) THEN + IF (ANY(sent_size(0:n_procs - 2) /= send_offset(1:n_procs - 1))) & CPABORT("error 1 filling send buffer") - END IF - IF (sent_size(n_procs - 1) /= send_tot_size) THEN + IF (sent_size(n_procs - 1) /= send_tot_size) & CPABORT("error 2 filling send buffer") - END IF IF (local_data) THEN DEALLOCATE (coarse_coeffs) @@ -2444,12 +2441,10 @@ CONTAINS END DO - IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) THEN + IF (ANY(sent_size(0:n_procs - 2) /= rcv_offset(1:n_procs - 1))) & CPABORT("error 1 handling the rcv buffer") - END IF - IF (sent_size(n_procs - 1) /= rcv_tot_size) THEN + IF (sent_size(n_procs - 1) /= rcv_tot_size) & CPABORT("error 2 handling the rcv buffer") - END IF ! dealloc DEALLOCATE (send_size, send_offset, rcv_size, rcv_offset) diff --git a/src/pw/realspace_grid_cube.F b/src/pw/realspace_grid_cube.F index 05af7923fa..c470d2ac77 100644 --- a/src/pw/realspace_grid_cube.F +++ b/src/pw/realspace_grid_cube.F @@ -121,10 +121,9 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") - END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) @@ -269,9 +268,8 @@ CONTAINS ELSE size_of_z = CEILING(REAL(pw%pw_grid%bounds(2, 3) - pw%pw_grid%bounds(1, 3) + 1, dp)/REAL(my_stride(3), dp)) num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) THEN + IF (MODULO(size_of_z, num_entries_line) /= 0) & num_linebreak = num_linebreak + 1 - END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL mp_unit%set_handle(unit_nr) CALL pw_to_cube_parallel(pw, mp_unit, title, particles_r, particles_z, particles_zeff, & @@ -411,9 +409,8 @@ CONTAINS ! Each data line of a Gaussian cube contains max 6 entries with last line potentially containing less if nz % 6 /= 0 ! Thus, this size is simply the number of entries multiplied by the entry size + the number of line breaks num_linebreak = size_of_z/num_entries_line - IF (MODULO(size_of_z, num_entries_line) /= 0) THEN + IF (MODULO(size_of_z, num_entries_line) /= 0) & num_linebreak = num_linebreak + 1 - END IF msglen = (size_of_z*entry_len + num_linebreak)*mpi_character_size CALL cube_to_pw_parallel(grid, filename, scaling, msglen, silent=silent) END IF @@ -633,10 +630,9 @@ CONTAINS IF ((lbounds_local(1) <= i) .AND. (i <= ubounds_local(1)) .AND. (lbounds_local(2) <= j) & .AND. (j <= ubounds_local(2))) THEN !allow scaling of external potential values by factor 'scaling' (SCALING_FACTOR in input file) - IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) THEN + IF (ANY(grid%array(i, j, lbounds(3):ubounds(3)) /= buffer(lbounds(3):ubounds(3))*scaling)) & CALL cp_abort(__LOCATION__, & "Error in parallel read of input cube file.") - END IF END IF END DO @@ -828,9 +824,8 @@ CONTAINS END IF tmp = TRIM(tmp)//TRIM(value) counter = counter + 1 - IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) THEN + IF (MODULO(counter, num_entries_line) == 0 .OR. k == last_z) & tmp = TRIM(tmp)//NEW_LINE('C') - END IF END DO writebuffer(islice) = tmp islice = islice + 1 @@ -894,10 +889,9 @@ CONTAINS my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") - END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_cube_unittest.F b/src/pw/realspace_grid_cube_unittest.F index b1685dc56b..7732cea3ea 100644 --- a/src/pw/realspace_grid_cube_unittest.F +++ b/src/pw/realspace_grid_cube_unittest.F @@ -19,24 +19,20 @@ PROGRAM realspace_grid_cube_unittest REAL(KIND=dp), DIMENSION(7) :: slice_buffer, slice_reference WRITE (value, cube_value_format) 0.33004E-101_dp - IF (INDEX(value, "E-101") <= 0) THEN + IF (INDEX(value, "E-101") <= 0) & ERROR STOP "Cube value format must preserve three-digit negative exponents." - END IF reference = [0.0_dp, -0.91458E-35_dp, 0.33004E-101_dp, & -0.32487E-103_dp, 1.0_dp, -1.0_dp] WRITE (values(1:78), cube_values_format) reference values(79:79) = NEW_LINE("C") - IF (INDEX(values, "E-101") <= 0) THEN + IF (INDEX(values, "E-101") <= 0) & ERROR STOP "Cube line format must preserve E-101." - END IF - IF (INDEX(values, "E-103") <= 0) THEN + IF (INDEX(values, "E-103") <= 0) & ERROR STOP "Cube line format must preserve E-103." - END IF CALL cube_read_values(values, buffer) - IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) THEN + IF (MAXVAL(ABS(buffer - reference)) > 1.0E-12_dp) & ERROR STOP "Cube reader must parse adjacent explicit-exponent values." - END IF slice_reference(1:6) = reference slice_reference(7) = 0.27183E-123_dp @@ -44,8 +40,7 @@ PROGRAM realspace_grid_cube_unittest slice_values(79:79) = NEW_LINE("C") WRITE (slice_values(80:92), cube_value_format) slice_reference(7) CALL cube_read_values(slice_values, slice_buffer) - IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) THEN + IF (MAXVAL(ABS(slice_buffer - slice_reference)) > 1.0E-12_dp) & ERROR STOP "Cube reader must parse multi-line z-slices." - END IF END PROGRAM realspace_grid_cube_unittest diff --git a/src/pw/realspace_grid_openpmd.F b/src/pw/realspace_grid_openpmd.F index 131d0344ff..b64caaa0e6 100644 --- a/src/pw/realspace_grid_openpmd.F +++ b/src/pw/realspace_grid_openpmd.F @@ -340,10 +340,9 @@ CONTAINS IF (PRESENT(mpi_io)) parallel_write = mpi_io my_stride = 1 IF (PRESENT(stride)) THEN - IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) THEN + IF (SIZE(stride) /= 1 .AND. SIZE(stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 "// & "(the same for X,Y,Z) or 3 values. Correct your input file.") - END IF IF (SIZE(stride) == 1) THEN DO i = 1, 3 my_stride(i) = stride(1) diff --git a/src/pw/realspace_grid_types.F b/src/pw/realspace_grid_types.F index 57ac9540a9..b54f99a6ee 100644 --- a/src/pw/realspace_grid_types.F +++ b/src/pw/realspace_grid_types.F @@ -659,9 +659,8 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & CPABORT("Different rs and pw indentifiers") - END IF IF (rs%desc%distributed) THEN CALL transfer_rs2pw_distributed(rs, pw) @@ -703,9 +702,8 @@ CONTAINS CALL timeset(routineN, handle2) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string(CEILING(pw%pw_grid%cutoff/10)*10))), handle) - IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) THEN + IF (.NOT. ASSOCIATED(rs%desc%pw, pw%pw_grid)) & CPABORT("Different rs and pw indentifiers") - END IF IF (rs%desc%distributed) THEN CALL transfer_pw2rs_distributed(rs, pw) diff --git a/src/qcschema.F b/src/qcschema.F index 23ce8e1b05..a4eae93faf 100644 --- a/src/qcschema.F +++ b/src/qcschema.F @@ -407,12 +407,10 @@ CONTAINS IF (dft_control%dft_plus_u) CPABORT('WARNING: DFT+U not supported in QCSchema') IF (dft_control%do_sccs) CPABORT('WARNING: SCCS not supported in QCSchema') IF (qs_env%qmmm) CPABORT('WARNING: QM/MM not supported in QCSchema') - IF (dft_control%qs_control%mulliken_restraint) THEN + IF (dft_control%qs_control%mulliken_restraint) & CPABORT('WARNING: Mulliken restrains not supported in QCSchema') - END IF - IF (dft_control%qs_control%semi_empirical) THEN + IF (dft_control%qs_control%semi_empirical) & CPABORT('WARNING: semi_empirical methods not supported in QCSchema') - END IF IF (dft_control%qs_control%dftb) CPABORT('WARNING: DFTB not supported in QCSchema') IF (dft_control%qs_control%xtb) CPABORT('WARNING: xTB not supported in QCSchema') diff --git a/src/qmmm_create.F b/src/qmmm_create.F index 1cbe80ccf4..f15dd5d2f0 100644 --- a/src/qmmm_create.F +++ b/src/qmmm_create.F @@ -228,12 +228,11 @@ CONTAINS IF (explicit .AND. use_multipole == do_multipole_section_on) qmmm_env_qm%multipole = .TRUE. IF (qmmm_env_qm%periodic .AND. qmmm_env_qm%multipole) CALL cite_reference(Laino2006) IF (qmmm_coupl_type == do_qmmm_none) THEN - IF (qmmm_env_qm%periodic) THEN + IF (qmmm_env_qm%periodic) & CALL cp_warn(__LOCATION__, & "QMMM periodic calculation with coupling NONE was requested! "// & "Switching off the periodic keyword since periodic and non-periodic "// & "calculation with coupling NONE represent the same method! ") - END IF qmmm_env_qm%periodic = .FALSE. END IF @@ -299,9 +298,8 @@ CONTAINS CALL get_cell(mm_cell, abc=abc_mm) IF (qmmm_env_qm%image_charge) THEN - IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) THEN + IF (ANY(ABS(abc_mm - abc_qm) > 1.0E-12)) & CPABORT("QM and MM box need to have the same size when using image charges") - END IF END IF ! Assign charges and mm_el_pot_radius from fist_topology diff --git a/src/qmmm_elpot.F b/src/qmmm_elpot.F index da89a5d1a5..9774d16564 100644 --- a/src/qmmm_elpot.F +++ b/src/qmmm_elpot.F @@ -145,7 +145,7 @@ CONTAINS t = 2._dp/(rootpi*x*rc)*EXP(-(x/rc)**2) pot0_2(2, i) = (t - pot0_2(1, i)/x)*dx END DO - ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN ! S-wave expansion :: 1/x - exp(-2*x/rc) * ( 1/x - 1/rc ) pot0_2(1, 1) = 1.0_dp/rc pot0_2(2, 1) = 0.0_dp diff --git a/src/qmmm_force.F b/src/qmmm_force.F index a892769aff..4b4b876627 100644 --- a/src/qmmm_force.F +++ b/src/qmmm_force.F @@ -135,11 +135,10 @@ CONTAINS WRITE (unit=output_unit, fmt='("ip, j, pos, lat_pos ",2I6,6F12.5)') ip, j, & particles_qm(ip)%r, DOT_PRODUCT(qm_cell%h_inv(j, :), particles_qm(ip)%r) END IF - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, & "QM/MM QM atoms must be fully contained in the same image of the QM box "// & "- No wrapping of coordinates is allowed! ") - END IF END DO END DO diff --git a/src/qmmm_gaussian_init.F b/src/qmmm_gaussian_init.F index 7885a7c400..c588591b9e 100644 --- a/src/qmmm_gaussian_init.F +++ b/src/qmmm_gaussian_init.F @@ -163,7 +163,7 @@ CONTAINS IF (qmmm_coupl_type == do_qmmm_gauss) THEN CALL set_mm_potential_erf(qmmm_gaussian_fns, & compatibility, num_geep_gauss) - ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN CALL set_mm_potential_swave(qmmm_gaussian_fns, & num_geep_gauss) END IF diff --git a/src/qmmm_gpw_energy.F b/src/qmmm_gpw_energy.F index d62e251621..af8d7d34af 100644 --- a/src/qmmm_gpw_energy.F +++ b/src/qmmm_gpw_energy.F @@ -126,9 +126,8 @@ CONTAINS print_section => section_vals_get_subs_vals(input_section, "QMMM%PRINT") iw = cp_print_key_unit_nr(logger, print_section, "PROGRAM_RUN_INFO", & extension=".qmmmLog") - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(T2,"QMMM|",1X,A)') "Information on the QM/MM Electrostatic Potential:" - END IF ! ! Initializing vectors: ! Zeroing v_qmmm_rspace @@ -149,7 +148,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -173,10 +172,9 @@ CONTAINS CASE (do_qmmm_pcharge) CPABORT("Point Charge QM/MM electrostatic coupling not implemented for GPW/GAPW.") CASE (do_qmmm_gauss, do_qmmm_swave) - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(T2,"QMMM|",1X,A)') & - "QM/MM Coupling computed collocating the Gaussian Potential Functions." - END IF + "QM/MM Coupling computed collocating the Gaussian Potential Functions." interp_section => section_vals_get_subs_vals(input_section, & "QMMM%INTERPOLATOR") CALL qmmm_elec_with_gaussian(qmmm_env=qmmm_env, & @@ -809,9 +807,8 @@ CONTAINS IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm qt = mm_charges(LIndMM) - IF (shells) THEN + IF (shells) & ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - END IF ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) diff --git a/src/qmmm_gpw_forces.F b/src/qmmm_gpw_forces.F index a4246fdc39..f2ecb1a293 100644 --- a/src/qmmm_gpw_forces.F +++ b/src/qmmm_gpw_forces.F @@ -176,7 +176,7 @@ CONTAINS CASE DEFAULT CPABORT("Unknown QM/MM coupling") END SELECT - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN ! DFTB SELECT CASE (qmmm_env%qmmm_coupl_type) CASE (do_qmmm_none) @@ -1212,9 +1212,8 @@ CONTAINS LIndMM = pot%mm_atom_index(Imm) IndMM = mm_atom_index(LIndMM) ra(:) = pbc(mm_particles(IndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - IF (shells) THEN + IF (shells) & ra(:) = pbc(mm_particles(LIndMM)%r - dOmmOqm, mm_cell) + dOmmOqm - END IF qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1) > 0.0_dp) THEN @@ -1422,11 +1421,10 @@ CONTAINS Err(K) = (Analytical_Forces(K, I) - Num_Forces(K, I))/Num_Forces(K, I)*100.0_dp END IF END DO - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) IndMM, Analytical_Forces(1, I), Num_Forces(1, I), Err(1), & - Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & - Analytical_Forces(3, I), Num_Forces(3, I), Err(3) - END IF + Analytical_Forces(2, I), Num_Forces(2, I), Err(2), & + Analytical_Forces(3, I), Num_Forces(3, I), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1534,11 +1532,10 @@ CONTAINS Err(2) = (debug_force(2) - force(2))/force(2)*100.0_dp Err(3) = (debug_force(3) - force(3))/force(3)*100.0_dp END IF - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) Icount, debug_force(1), force(1), Err(1), & - debug_force(2), force(2), Err(2), & - debug_force(3), force(3), Err(3) - END IF + debug_force(2), force(2), Err(2), & + debug_force(3), force(3), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1641,10 +1638,9 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) - END IF + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1658,11 +1654,10 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) - END IF + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) @@ -1757,10 +1752,9 @@ CONTAINS energy(K) = pw_integral_ab(rho, grids(coarser_grid_level)) END DO Diff - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(A,I6,A,I3,A,2F15.9)') & - "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) - END IF + "DEBUG LR:: MM Atom = ", IndMM, " Coord = ", J, " Energies (+/-) :: ", energy(2), energy(1) Num_Forces(J, I) = (energy(2) - energy(1))/(2.0_dp*Dx) mm_particles(IndMM)%r(J) = Coord_save END DO Coords @@ -1774,11 +1768,10 @@ CONTAINS Err(2) = (debug_force(2, I) - Num_Forces(2, I))/Num_Forces(2, I)*100.0_dp Err(3) = (debug_force(3, I) - Num_Forces(3, I))/Num_Forces(3, I)*100.0_dp END IF - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, 100) IndMM, debug_force(1, I), Num_Forces(1, I), Err(1), & - debug_force(2, I), Num_Forces(2, I), Err(2), & - debug_force(3, I), Num_Forces(3, I), Err(3) - END IF + debug_force(2, I), Num_Forces(2, I), Err(2), & + debug_force(3, I), Num_Forces(3, I), Err(3) CPASSERT(ABS(Err(1)) <= MaxErr) CPASSERT(ABS(Err(2)) <= MaxErr) CPASSERT(ABS(Err(3)) <= MaxErr) diff --git a/src/qmmm_image_charge.F b/src/qmmm_image_charge.F index f721612be5..607d4db02f 100644 --- a/src/qmmm_image_charge.F +++ b/src/qmmm_image_charge.F @@ -587,12 +587,11 @@ CONTAINS CALL calculate_image_matrix(image_matrix=qs_env%image_matrix, & ipiv=qs_env%ipiv, qs_env=qs_env, qmmm_env=qmmm_env) qmmm_env%image_charge_pot%state_image_matrix = calc_once_done - IF (qmmm_env%center_qm_subsys0) THEN + IF (qmmm_env%center_qm_subsys0) & CALL cp_warn(__LOCATION__, & "The image atoms are fully "// & "constrained and the image matrix is only calculated once. "// & "To be safe, set CENTER to NEVER ") - END IF CASE (calc_once_done) ! do nothing image matrix is stored CASE DEFAULT diff --git a/src/qmmm_init.F b/src/qmmm_init.F index 3655e31cd0..a2499ee7c9 100644 --- a/src/qmmm_init.F +++ b/src/qmmm_init.F @@ -667,11 +667,10 @@ CONTAINS ELSE IF (qmmm_env%spherical_cutoff(2) <= 0.0_dp) qmmm_env%spherical_cutoff(2) = EPSILON(0.0_dp) tmp_radius = qmmm_env%spherical_cutoff(1) - 20.0_dp*qmmm_env%spherical_cutoff(2) - IF (tmp_radius <= 0.0_dp) THEN + IF (tmp_radius <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "SPHERICAL_CUTOFF(1) > 20*SPHERICAL_CUTOFF(1)! Please correct parameters for "// & "the Spherical Cutoff in order to satisfy the previous condition!") - END IF END IF ! ! Initialization of arrays and core_charge_radius... @@ -1033,15 +1032,12 @@ CONTAINS END SELECT END DO END IF - IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) THEN + IF (PRESENT(mm_link_scale_factor) .AND. (link_involv_mm /= 0)) & ALLOCATE (mm_link_scale_factor(link_involv_mm)) - END IF - IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) THEN + IF (PRESENT(fist_scale_charge_link) .AND. (link_involv_mm /= 0)) & ALLOCATE (fist_scale_charge_link(link_involv_mm)) - END IF - IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) THEN + IF (PRESENT(mm_link_atoms) .AND. (link_involv_mm /= 0)) & ALLOCATE (mm_link_atoms(link_involv_mm)) - END IF IF (PRESENT(qm_atom_index)) ALLOCATE (qm_atom_index(num_qm_atom_tot)) IF (PRESENT(qm_atom_type)) ALLOCATE (qm_atom_type(num_qm_atom_tot)) IF (PRESENT(qm_atom_index)) qm_atom_index = 0 @@ -1290,9 +1286,8 @@ CONTAINS CALL section_vals_val_get(move_section, "RADIUS", r_val=radius, i_rep_section=i_add) CALL section_vals_val_get(move_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) THEN + IF (n_rep_val == 1) & CALL section_vals_val_get(move_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) - END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1318,9 +1313,8 @@ CONTAINS CALL section_vals_val_get(add_section, "CHARGE", r_val=charge, i_rep_section=i_add) CALL section_vals_val_get(add_section, "CORR_RADIUS", n_rep_val=n_rep_val, i_rep_section=i_add) c_radius = radius - IF (n_rep_val == 1) THEN + IF (n_rep_val == 1) & CALL section_vals_val_get(add_section, "CORR_RADIUS", r_val=c_radius, i_rep_section=i_add) - END IF CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, charge, & mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius, & @@ -1502,9 +1496,8 @@ CONTAINS END IF DO j = i + 1, num_image_mm_atom atom_b = qmmm_env%image_charge_pot%image_mm_list(j) - IF (atom_a == atom_b) THEN + IF (atom_a == atom_b) & CPABORT("There are atoms doubled in image list.") - END IF END DO END DO diff --git a/src/qmmm_links_methods.F b/src/qmmm_links_methods.F index 671195819f..c7ca6d962e 100644 --- a/src/qmmm_links_methods.F +++ b/src/qmmm_links_methods.F @@ -63,20 +63,18 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") - END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") - END IF ip_mm = ip particles(ip_mm)%r = alpha*particles(ip_mm)%r + (1.0_dp - alpha)*particles(ip_qm)%r END DO @@ -112,20 +110,18 @@ CONTAINS DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == qm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "QM atom index ("//cp_to_string(qm_index)//") specified in the LINK section nr.("// & cp_to_string(ilink)//") is not defined as a QM atom! Please inspect your QM_KIND sections. ") - END IF ip_qm = ip DO ip = 1, SIZE(qm_atom_index) IF (qm_atom_index(ip) == mm_index) EXIT END DO - IF (ip == SIZE(qm_atom_index) + 1) THEN + IF (ip == SIZE(qm_atom_index) + 1) & CALL cp_abort(__LOCATION__, & "Error in setting up the MM atom index ("//cp_to_string(mm_index)// & ") specified in the LINK section nr.("//cp_to_string(ilink)//"). Please report this bug! ") - END IF ip_mm = ip particles_qm(ip_qm)%f = particles_qm(ip_qm)%f + particles_qm(ip_mm)%f*(1.0_dp - alpha) particles_qm(ip_mm)%f = particles_qm(ip_mm)%f*alpha diff --git a/src/qmmm_per_elpot.F b/src/qmmm_per_elpot.F index 1d46ede77e..c13f0ff4fe 100644 --- a/src/qmmm_per_elpot.F +++ b/src/qmmm_per_elpot.F @@ -173,7 +173,7 @@ CONTAINS g = SQRT(g2) IF (qmmm_coupl_type == do_qmmm_gauss) THEN LG(idim) = 4.0_dp*Pi/g2*EXP(-(g2*rc2)/4.0_dp) - ELSE IF (qmmm_coupl_type == do_qmmm_swave) THEN + ELSEIF (qmmm_coupl_type == do_qmmm_swave) THEN tmp = 4.0_dp/rc2 LG(idim) = 4.0_dp*Pi*tmp**2/(g2*(g2 + tmp)**2) END IF @@ -363,9 +363,8 @@ CONTAINS CALL ewald_env_get(ewald_env, ewald_type=ewald_type, do_multipoles=do_multipoles, & gmax=gmax, o_spline=o_spline, alpha=alpha, rcut=rcut) - IF (do_multipoles) THEN + IF (do_multipoles) & CPABORT("No multipole force fields allowed in QM-QM Ewald long range correction") - END IF SELECT CASE (qmmm_coupl_type) CASE (do_qmmm_coulomb) diff --git a/src/qmmm_tb_methods.F b/src/qmmm_tb_methods.F index a1d0aab62f..8058c41956 100644 --- a/src/qmmm_tb_methods.F +++ b/src/qmmm_tb_methods.F @@ -147,7 +147,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -159,7 +159,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -179,7 +179,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -263,7 +263,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -275,7 +275,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -363,7 +363,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -375,7 +375,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 0, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) END IF @@ -469,7 +469,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -512,7 +512,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN NULLIFY (xtb_kind) CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) @@ -644,7 +644,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -654,7 +654,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -675,7 +675,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -703,7 +703,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -743,7 +743,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN ! use all kinds END IF DO i = 1, SIZE(list) @@ -887,7 +887,7 @@ CONTAINS IF (dft_control%qs_control%dftb) THEN do_dftb = .TRUE. do_xtb = .FALSE. - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN do_dftb = .FALSE. do_xtb = .TRUE. ELSE @@ -897,7 +897,7 @@ CONTAINS NULLIFY (matrix_s) IF (do_dftb) THEN CALL build_dftb_overlap(qs_env, 1, matrix_s) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, sab_orb=sab_nl) CALL build_overlap_matrix(ks_env, matrix_s, nderivative=1, & basis_type_a='ORB', basis_type_b='ORB', sab_nl=sab_nl) @@ -917,7 +917,7 @@ CONTAINS IF (do_dftb) THEN CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, zeff=zeff) END IF @@ -1054,7 +1054,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1116,7 +1116,7 @@ CONTAINS ! use mm charge smearing for non-scc cases IF (.NOT. dftb_control%self_consistent) eta_a(0) = eta_mm IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN eta_a(0) = eta_mm END IF DO i = 1, SIZE(list) @@ -1159,7 +1159,7 @@ CONTAINS CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, defined=defined, natorb=natorb) IF (.NOT. defined .OR. natorb < 1) CYCLE - ELSE IF (do_xtb) THEN + ELSEIF (do_xtb) THEN ! END IF DO i = 1, SIZE(list) diff --git a/src/qmmm_topology_util.F b/src/qmmm_topology_util.F index ad9f796bdb..3ea4eaf263 100644 --- a/src/qmmm_topology_util.F +++ b/src/qmmm_topology_util.F @@ -139,9 +139,8 @@ CONTAINS molecule => molecule_set(imolecule) CALL get_molecule(molecule, molecule_kind=molecule_kind, & first_atom=first_atom, last_atom=last_atom) - IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) THEN + IF (ANY(qm_atom_index >= first_atom .AND. qm_atom_index <= last_atom)) & qm_mol_num = qm_mol_num + 1 - END IF END DO ! ALLOCATE (qm_molecule_index(qm_mol_num)) diff --git a/src/qmmm_util.F b/src/qmmm_util.F index 3357a6cfff..18cdfd5389 100644 --- a/src/qmmm_util.F +++ b/src/qmmm_util.F @@ -128,11 +128,10 @@ CONTAINS END IF IF (force_env%in_use == use_qmmmx) THEN - IF (iwall_type /= do_qmmm_wall_none) THEN + IF (iwall_type /= do_qmmm_wall_none) & CALL cp_warn(__LOCATION__, & "Reflective walls for QM/MM are not implemented (or useful) when "// & "force mixing is active. Skipping!") - END IF RETURN END IF @@ -620,7 +619,7 @@ CONTAINS REAL(KIND=dp) :: r, r0 - r = NORM2(rij) + r = SQRT(DOT_PRODUCT(rij, rij)) r0 = spherical_cutoff(1) - 20.0_dp*spherical_cutoff(2) factor = 0.5_dp*(1.0_dp - TANH((r - r0)/spherical_cutoff(2))) diff --git a/src/qmmmx_force.F b/src/qmmmx_force.F index 72afe1f591..1e69447e42 100644 --- a/src/qmmmx_force.F +++ b/src/qmmmx_force.F @@ -80,10 +80,9 @@ CONTAINS TYPE(section_vals_type), POINTER :: force_env_section IF (PRESENT(require_consistent_energy_force)) THEN - IF (require_consistent_energy_force) THEN + IF (require_consistent_energy_force) & CALL cp_abort(__LOCATION__, & "qmmmx_energy_and_forces got require_consistent_energy_force but force mixing is active. ") - END IF END IF ! Possibly translate the system @@ -119,9 +118,9 @@ CONTAINS IF (mom_conserv_region == do_fm_mom_conserv_core) THEN mom_conserv_min_label = force_mixing_label_QM_core - ELSE IF (mom_conserv_region == do_fm_mom_conserv_QM) THEN + ELSEIF (mom_conserv_region == do_fm_mom_conserv_QM) THEN mom_conserv_min_label = force_mixing_label_QM_dynamics - ELSE IF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN + ELSEIF (mom_conserv_region == do_fm_mom_conserv_buffer) THEN mom_conserv_min_label = force_mixing_label_buffer ELSE CPABORT("Got unknown MOMENTUM_CONSERVATION_REGION (not CORE, QM, or BUFFER) !") @@ -142,9 +141,8 @@ CONTAINS ELSE IF (mom_conserv_type == do_fm_mom_conserv_equal_a) THEN mom_conserv_mass = 0.0_dp DO ip = 1, SIZE(cur_indices) - IF (cur_labels(ip) >= mom_conserv_min_label) THEN + IF (cur_labels(ip) >= mom_conserv_min_label) & mom_conserv_mass = mom_conserv_mass + particles_qmmm_core(cur_indices(ip))%atomic_kind%mass - END IF END DO delta_a = total_f/mom_conserv_mass DO ip = 1, SIZE(cur_indices) diff --git a/src/qmmmx_util.F b/src/qmmmx_util.F index 6779e0100a..680cba631d 100644 --- a/src/qmmmx_util.F +++ b/src/qmmmx_util.F @@ -285,9 +285,8 @@ CONTAINS ![NB] need more sophisticated QM extended, buffer rules ! add QM using hysteretic selection (core_list, r_qm) + unbreakable bonds - IF (debug_this_module .AND. output_unit > 0) THEN + IF (debug_this_module .AND. output_unit > 0) & WRITE (output_unit, *) "BOB QM_extended_seed_is_core_list ", QM_extended_seed_is_core_list - END IF IF (QM_extended_seed_is_core_list) THEN QM_extended_seed_min_label_val = force_mixing_label_QM_core_list ELSE ! QM region seed is all of core, not just core list + unbreakable bonds @@ -379,19 +378,17 @@ CONTAINS EXIT END IF END DO - IF (old_index <= 0) THEN + IF (old_index <= 0) & CALL cp_abort(__LOCATION__, & "add_new_label found atom with a label "// & "already set, but not in new_indices array") - END IF new_labels(old_index) = label ELSE n_new = n_new + 1 - IF (n_new > max_n_qm) THEN + IF (n_new > max_n_qm) & CALL cp_abort(__LOCATION__, & "add_new_label tried to add more atoms "// & "than allowed by &FORCE_MIXING&MAX_N_QM!") - END IF IF (n_new > SIZE(new_indices)) CALL reallocate(new_indices, 1, n_new + 9) IF (n_new > SIZE(new_labels)) CALL reallocate(new_labels, 1, n_new + 9) new_indices(n_new) = ip @@ -486,9 +483,8 @@ CONTAINS adaptive_exclude = .FALSE. DO im_exclude = 1, SIZE(adaptive_exclude_molecules) IF (TRIM(molecule_set(im)%molecule_kind%name) == TRIM(adaptive_exclude_molecules(im_exclude)) .OR. & - TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) THEN + TRIM(molecule_set(im)%molecule_kind%name) == '_QM_'//TRIM(adaptive_exclude_molecules(im_exclude))) & adaptive_exclude = .TRUE. - END IF END DO IF (adaptive_exclude) CYCLE END IF @@ -497,17 +493,15 @@ CONTAINS IF (molec_in_inner) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) THEN + IF (new_full_labels(ip) < set_label_val) & CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) - END IF END DO ELSE IF (molec_in_outer) THEN IF (ANY(orig_full_labels(molecule_set(im)%first_atom:molecule_set(im)%last_atom) >= set_label_val)) THEN DO ip = molecule_set(im)%first_atom, molecule_set(im)%last_atom ! labels are being rebuild from scratch, so never overwrite new label that's higher level - IF (new_full_labels(ip) < set_label_val) THEN + IF (new_full_labels(ip) < set_label_val) & CALL add_new_label(ip, set_label_val, n_new, new_indices, new_labels, new_full_labels, max_n_qm) - END IF END DO END IF END IF @@ -650,9 +644,8 @@ CONTAINS ! get CUR_INDICES, CUR_LABELS CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels) - IF (SIZE(cur_indices) <= 0) THEN + IF (SIZE(cur_indices) <= 0) & CPABORT("cur_indices is empty, found no QM atoms") - END IF IF (debug_this_module .AND. output_unit > 0) THEN WRITE (output_unit, *) "cur_indices ", cur_indices @@ -672,23 +665,21 @@ CONTAINS EXIT END IF END DO - IF (.NOT. mapped) THEN + IF (.NOT. mapped) & CALL cp_abort(__LOCATION__, & "Force-mixing failed to find QM_KIND mapping for atom of type "// & TRIM(particles(cur_indices(ip))%atomic_kind%element_symbol)// & "! ") - END IF END IF END DO ! pre-existing QM_KIND section specifies list of core atom qm_kind_section => section_vals_get_subs_vals3(qmmm_section, "QM_KIND") CALL section_vals_get(qm_kind_section, n_repetition=i_rep_section_core) - IF (i_rep_section_core <= 0) THEN + IF (i_rep_section_core <= 0) & CALL cp_abort(__LOCATION__, & "Force-mixing QM didn't find any QM_KIND sections, "// & "so no core specified!") - END IF i_rep_section_extended = i_rep_section_core DO ielem = 1, n_elements new_element_core = .TRUE. @@ -809,9 +800,8 @@ CONTAINS n_labels = n_labels + SIZE(labels_entry) END DO - IF (n_indices /= n_labels) THEN + IF (n_indices /= n_labels) & CPABORT("got unequal numbers of force_mixing indices and labels!") - END IF END SUBROUTINE get_force_mixing_indices END MODULE qmmmx_util diff --git a/src/qs_2nd_kernel_ao.F b/src/qs_2nd_kernel_ao.F index dd4e7540c8..882a42af8d 100644 --- a/src/qs_2nd_kernel_ao.F +++ b/src/qs_2nd_kernel_ao.F @@ -301,9 +301,8 @@ CONTAINS CPASSERT(.NOT. dft_control%qs_control%gapw_xc) CPASSERT(.NOT. dft_control%qs_control%lrigpw) CPASSERT(.NOT. linres_control%lr_triplet) - IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) THEN + IF (.NOT. ASSOCIATED(p_env%kpp1_admm)) & CPABORT("kpp1_admm has to be associated if ADMM kernel calculations are requested") - END IF nspins = dft_control%nspins diff --git a/src/qs_active_space_methods.F b/src/qs_active_space_methods.F index 56c589cbd6..a4bcfd1e69 100644 --- a/src/qs_active_space_methods.F +++ b/src/qs_active_space_methods.F @@ -288,23 +288,19 @@ CONTAINS NULLIFY (kpoints) CALL get_qs_env(qs_env, do_kpoints=do_kpoints, dft_control=dft_control, kpoints=kpoints) IF (do_kpoints) THEN - IF (.NOT. ASSOCIATED(kpoints)) THEN + IF (.NOT. ASSOCIATED(kpoints)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - END IF CALL get_kpoint_info(kpoints, kp_scheme=kp_scheme, nkp=nkp, use_real_wfn=use_real_wfn) IF (TRIM(kp_scheme) /= "GAMMA" .OR. nkp /= 1 .OR. .NOT. use_real_wfn) THEN CALL cp_abort(__LOCATION__, & "Only Gamma-point DFT%KPOINTS are supported in the active space module") END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env)) THEN + IF (.NOT. ASSOCIATED(kpoints%kp_env)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) THEN + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point environment for active space module") - END IF - IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) THEN + IF (.NOT. ASSOCIATED(kpoints%kp_env(1)%kpoint_env%mos)) & CALL cp_abort(__LOCATION__, "Missing Gamma-point MOs for active space module") - END IF END IF ! adiabatic rescaling? @@ -790,7 +786,7 @@ CONTAINS END IF mo_set_active%eigenvalues(i) = eigenvalues(i, ispin) ! if it was not an active orbital, check whether it is an inactive orbital - ELSE IF (nmo_inactive_remaining > 0) THEN + ELSEIF (nmo_inactive_remaining > 0) THEN CALL cp_fm_to_fm(fm_dummy, fm_target_inactive, 1, i, i) ! store on the fly the mapping of inactive orbitals active_space_env%inactive_orbitals(nmo_inactive - nmo_inactive_remaining + 1, ispin) = i @@ -823,7 +819,7 @@ CONTAINS DO j = 0, jm IF (ANY(active_space_env%active_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [A]" - ELSE IF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN + ELSEIF (ANY(active_space_env%inactive_orbitals(:, ispin) == i + j)) THEN WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [I]" ELSE WRITE (iw, '(T3,F12.6,A5)', advance="no") eigenvalues(i + j, ispin), " [V]" @@ -1000,7 +996,7 @@ CONTAINS IF (i == 1) THEN n1 = nmo n2 = nmo - ELSE IF (i == 2) THEN + ELSEIF (i == 2) THEN n1 = nmo n2 = nmo ELSE @@ -1455,9 +1451,8 @@ CONTAINS ! Check the input group CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) IF (eri_env%eri_gpw%group_size < 1) eri_env%eri_gpw%group_size = para_env%num_pe - IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) THEN + IF (MOD(para_env%num_pe, eri_env%eri_gpw%group_size) /= 0) & CPABORT("Group size must be a divisor of the total number of processes!") - END IF ! Create a new para_env or reuse the old one IF (eri_env%eri_gpw%group_size == para_env%num_pe) THEN eri_env%para_env_sub => para_env @@ -1779,7 +1774,7 @@ CONTAINS ! DEALLOCATE (eri, eri_index) END DO - ELSE IF (eri_env%method == eri_method_full_gpw) THEN + ELSEIF (eri_env%method == eri_method_full_gpw) THEN DO isp2 = isp1, nspins CALL get_mo_set(mo_set=mos(isp2), nmo=nmo2) nx = (nmo2*(nmo2 + 1))/2 @@ -2198,7 +2193,7 @@ CONTAINS CALL section_vals_val_get(input, "STRIDE", i_vals=istride) IF (SIZE(istride) == 1) THEN str(1:3) = istride(1) - ELSE IF (SIZE(istride) == 3) THEN + ELSEIF (SIZE(istride) == 3) THEN str(1:3) = istride(1:3) ELSE CPABORT("STRIDE arguments inconsistent") @@ -3141,7 +3136,7 @@ CONTAINS END IF converged = .TRUE. EXIT - ELSE IF (ABS(delta_E) <= eps_iter) THEN + ELSEIF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" @@ -3323,7 +3318,7 @@ CONTAINS converged = .TRUE. EXIT ! check for convergence - ELSE IF (ABS(delta_E) <= eps_iter) THEN + ELSEIF (ABS(delta_E) <= eps_iter) THEN IF (iw > 0) THEN WRITE (UNIT=iw, FMT="(/,T3,A,I5,A)") & "*** rs-DFT embedding run converged in ", iter, " iteration(s) ***" diff --git a/src/qs_active_space_mixing.F b/src/qs_active_space_mixing.F index 5813e70d75..b39d14d962 100644 --- a/src/qs_active_space_mixing.F +++ b/src/qs_active_space_mixing.F @@ -256,7 +256,8 @@ CONTAINS active_space_env%as_mix_x_buffer(ib, :) = p_old active_space_env%as_mix_r_buffer(ib, :) = p_solver - p_old - res_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) + res_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & + active_space_env%as_mix_r_buffer(ib, :))) IF (nb == 1 .OR. res_norm < 1.E-14_dp) THEN CALL active_space_direct_mix(p_old, p_solver, mixing_store%alpha, p_mixed) @@ -336,7 +337,7 @@ CONTAINS ALLOCATE (p_res(ndim)) p_res(:) = p_solver(:) - p_old(:) - res_norm = NORM2(p_res) + res_norm = SQRT(DOT_PRODUCT(p_res, p_res)) mixing_store%ncall = mixing_store%ncall + 1 IF (mixing_store%ncall == 1) THEN @@ -357,7 +358,8 @@ CONTAINS active_space_env%as_mix_r_buffer(ib, :) = p_res - active_space_env%as_mix_r_old active_space_env%as_mix_x_buffer(ib, :) = p_old - active_space_env%as_mix_x_old - delta_norm = NORM2(active_space_env%as_mix_r_buffer(ib, :)) + delta_norm = SQRT(DOT_PRODUCT(active_space_env%as_mix_r_buffer(ib, :), & + active_space_env%as_mix_r_buffer(ib, :))) can_update = res_norm > 1.E-14_dp .AND. delta_norm > 1.E-14_dp IF (can_update) THEN diff --git a/src/qs_active_space_types.F b/src/qs_active_space_types.F index c470db2ec7..8042e71158 100644 --- a/src/qs_active_space_types.F +++ b/src/qs_active_space_types.F @@ -237,9 +237,8 @@ CONTAINS DEALLOCATE (active_space_env%as_mix_x_buffer) END IF - IF (ASSOCIATED(active_space_env%pmat_inactive)) THEN + IF (ASSOCIATED(active_space_env%pmat_inactive)) & CALL dbcsr_deallocate_matrix_set(active_space_env%pmat_inactive) - END IF DEALLOCATE (active_space_env) END IF @@ -381,9 +380,8 @@ CONTAINS ! 1) Collect the amount of local data from each process nonzero_elements_local = 0 - IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) THEN + IF (MOD(i12 - 1, this%comm_exchange%num_pe) == this%comm_exchange%mepos) & nonzero_elements_local = eri%nzerow_local(i12l) - END IF CALL mp_group%allgather(nonzero_elements_local, nonzero_elements_global) ! 2) Prepare arrays for communication (calculate the offsets and the total number of elements) diff --git a/src/qs_cdft_methods.F b/src/qs_cdft_methods.F index 950b77b4f7..03f8f75cdd 100644 --- a/src/qs_cdft_methods.F +++ b/src/qs_cdft_methods.F @@ -181,9 +181,8 @@ CONTAINS becke_control => cdft_control%becke_control group => cdft_control%group cutoffs => becke_control%cutoffs - IF (cdft_control%atomic_charges) THEN + IF (cdft_control%atomic_charges) & charge => cdft_control%charge - END IF in_memory = .FALSE. IF (cdft_control%save_pot) THEN in_memory = becke_control%in_memory @@ -222,7 +221,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) + becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) END DO END DO @@ -244,9 +243,8 @@ CONTAINS ! A subsequent check (atom_in_group) ensures that the gradients of these dummy atoms are correct IF (cdft_control%save_pot .OR. & becke_control%cavity_confine .OR. & - becke_control%should_skip) THEN + becke_control%should_skip) & is_constraint(catom(i)) = .TRUE. - END IF END DO bo = group(1)%weight%pw_grid%bounds_local dvol = group(1)%weight%pw_grid%dvol @@ -335,7 +333,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(iatom) == 0.0_dp) THEN r = becke_control%vector_buffer%position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%distance_vecs(:, iatom) = dist_vec becke_control%vector_buffer%distances(iatom) = dist1 ELSE @@ -348,7 +346,7 @@ CONTAINS r(ip) = MODULO(r(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v - dist1 = NORM2(dist_vec) + dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN @@ -369,7 +367,7 @@ CONTAINS IF (becke_control%vector_buffer%distances(jatom) == 0.0_dp) THEN r1 = becke_control%vector_buffer%position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%distance_vecs(:, jatom) = dist_vec becke_control%vector_buffer%distances(jatom) = dist2 ELSE @@ -382,7 +380,7 @@ CONTAINS r1(ip) = MODULO(r1(ip), cell%hmat(ip, ip)) - cell%hmat(ip, ip)/2._dp END DO dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v - dist2 = NORM2(dist_vec) + dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF IF (in_memory) THEN IF (becke_control%vector_buffer%store_vectors) THEN @@ -564,9 +562,8 @@ CONTAINS END IF END IF NULLIFY (cutoffs) - IF (ALLOCATED(is_constraint)) THEN + IF (ALLOCATED(is_constraint)) & DEALLOCATE (is_constraint) - END IF DEALLOCATE (catom) DEALLOCATE (cell_functions) DEALLOCATE (skip_me) @@ -1189,9 +1186,8 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & CPABORT("Becke control has not been allocated.") - END IF group => cdft_control%group ! Initialize nvar = SIZE(cdft_control%target) @@ -1232,10 +1228,9 @@ CONTAINS IF (is_becke .AND. (cdft_control%external_control .AND. becke_control%cavity_confine)) THEN ! With external control, we can use cavity_mat as a mask to kahan sum eps_cavity = becke_control%eps_cavity - IF (igroup /= 1) THEN + IF (igroup /= 1) & CALL cp_abort(__LOCATION__, & "Multiple constraints not yet supported by parallel mixed calculations.") - END IF dE(igroup) = dE(igroup) + sign*accurate_dot_product(group(igroup)%weight%array, rho_r(i)%array, & becke_control%cavity_mat, eps_cavity)*dvol ELSE @@ -1259,10 +1254,9 @@ CONTAINS END IF IF (dft_control%qs_control%gapw) THEN ! GAPW: add core charges (rho_hard - rho_soft) - IF (cdft_control%fragment_density) THEN + IF (cdft_control%fragment_density) & CALL cp_abort(__LOCATION__, & "Fragment constraints not yet compatible with GAPW.") - END IF ALLOCATE (gapw_offset(nvar, dft_control%nspins)) gapw_offset = 0.0_dp CALL get_qs_env(qs_env, rho0_mpole=rho0_mpole) @@ -1628,21 +1622,18 @@ CONTAINS cdft_control => dft_control%qs_control%cdft_control is_becke = (cdft_control%type == outer_scf_becke_constraint) becke_control => cdft_control%becke_control - IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) THEN + IF (is_becke .AND. .NOT. ASSOCIATED(becke_control)) & CPABORT("Becke control has not been allocated.") - END IF group => cdft_control%group dvol = group(1)%weight%pw_grid%dvol ! Fragment densities are meaningful only for some calculation types - IF (.NOT. qs_env%single_point_run) THEN + IF (.NOT. qs_env%single_point_run) & CALL cp_abort(__LOCATION__, & "CDFT fragment constraints are only compatible with single "// & "point calculations (run_type ENERGY or ENERGY_FORCE).") - END IF - IF (dft_control%qs_control%gapw) THEN + IF (dft_control%qs_control%gapw) & CALL cp_abort(__LOCATION__, & "CDFT fragment constraint not compatible with GAPW.") - END IF needs_spin_density = .FALSE. multiplier = 1.0_dp nfrag_spins = 1 @@ -1700,11 +1691,10 @@ CONTAINS CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, nelectron_total=nelectron_total) nelectron_frag = pw_integrate_function(rho_frag(1)) - IF (NINT(nelectron_frag) /= nelectron_total) THEN + IF (NINT(nelectron_frag) /= nelectron_total) & CALL cp_abort(__LOCATION__, & "The number of electrons in the reference and interacting "// & "configurations does not match. Check your fragment cube files.") - END IF ! Update constraint target value i.e. perform integration w_i*rho_frag_{tot/spin}*dr cdft_control%target = 0.0_dp DO igroup = 1, SIZE(group) diff --git a/src/qs_cdft_opt_types.F b/src/qs_cdft_opt_types.F index 4a3ed616c6..92cb004adb 100644 --- a/src/qs_cdft_opt_types.F +++ b/src/qs_cdft_opt_types.F @@ -135,12 +135,10 @@ CONTAINS TYPE(cdft_opt_type), POINTER :: cdft_opt_control IF (ASSOCIATED(cdft_opt_control)) THEN - IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) THEN + IF (ASSOCIATED(cdft_opt_control%jacobian_vector)) & DEALLOCATE (cdft_opt_control%jacobian_vector) - END IF - IF (ALLOCATED(cdft_opt_control%jacobian_step)) THEN + IF (ALLOCATED(cdft_opt_control%jacobian_step)) & DEALLOCATE (cdft_opt_control%jacobian_step) - END IF DEALLOCATE (cdft_opt_control) END IF @@ -190,26 +188,22 @@ CONTAINS CALL section_vals_val_get(cdft_opt_section, "FACTOR_LS", & r_val=cdft_opt_control%factor_ls) IF (cdft_opt_control%factor_ls <= 0.0_dp .OR. & - cdft_opt_control%factor_ls >= 1.0_dp) THEN + cdft_opt_control%factor_ls >= 1.0_dp) & CALL cp_abort(__LOCATION__, & "Keyword FACTOR_LS must be between 0.0 and 1.0.") - END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", explicit=exists) IF (exists) THEN CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", & i_vals=tmplist) - IF (SIZE(tmplist) /= 2) THEN + IF (SIZE(tmplist) /= 2) & CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes exactly two input values.") - END IF - IF (ANY(tmplist < 0)) THEN + IF (ANY(tmplist < 0)) & CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes only positive values.") - END IF - IF (ALL(tmplist == 0)) THEN + IF (ALL(tmplist == 0)) & CALL cp_abort(__LOCATION__, & "Both values to keyword JACOBIAN_FREQ cannot be zero.") - END IF cdft_opt_control%jacobian_freq(:) = tmplist(1:2) END IF CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_RESTART", & @@ -281,10 +275,9 @@ CONTAINS IF (cdft_opt_control%jacobian_freq(2) > 0) THEN WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(2), " energy evaluation" - IF (cdft_opt_control%jacobian_freq(1) > 0) THEN + IF (cdft_opt_control%jacobian_freq(1) > 0) & WRITE (output_unit, '(T29,A,I4,A)') & - "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" - END IF + "or every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" ELSE WRITE (output_unit, '(T6,A,I4,A)') & "The Jacobian is restarted every ", cdft_opt_control%jacobian_freq(1), " CDFT SCF iteration" diff --git a/src/qs_cdft_scf_utils.F b/src/qs_cdft_scf_utils.F index c7b6bf59a1..f70237f2de 100644 --- a/src/qs_cdft_scf_utils.F +++ b/src/qs_cdft_scf_utils.F @@ -80,12 +80,11 @@ CONTAINS dft_control=dft_control) IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= 1 .AND. & - SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) THEN + SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step) /= SIZE(scf_env%outer_scf%variables, 1)) & CALL cp_abort(__LOCATION__, & cp_to_string(SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step))// & " values passed to keyword JACOBIAN_STEP, expected 1 or "// & cp_to_string(SIZE(scf_env%outer_scf%variables, 1))) - END IF ALLOCATE (dh(SIZE(scf_env%outer_scf%variables, 1))) IF (SIZE(dh) /= SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_step)) THEN @@ -230,9 +229,8 @@ CONTAINS use_md_history = .TRUE. ! Check that none of the history values are identical in which case we should try something different DO i = 1, nvar - IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) THEN + IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) & use_md_history = .FALSE. - END IF END DO IF (use_md_history) THEN ALLOCATE (jacobian(nvar, nvar)) @@ -240,9 +238,8 @@ CONTAINS jacobian(i, i) = (gradient_history(i, 2) - gradient_history(i, 1))/ & (variable_history(i, 2) - variable_history(i, 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -256,19 +253,17 @@ CONTAINS IF (ihistory >= 2 .AND. .NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ! Next, try history from current SCF procedure nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF must be greater than or equal "// & "to 3 for optimizers that build the Jacobian from SCF history.") - END IF ALLOCATE (jacobian(nvar, nvar)) DO i = 1, nvar jacobian(i, i) = (scf_env%outer_scf%gradient(i, ihistory) - scf_env%outer_scf%gradient(i, ihistory - 1))/ & (scf_env%outer_scf%variables(i, ihistory) - scf_env%outer_scf%variables(i, ihistory - 1)) END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) DEALLOCATE (jacobian) @@ -299,13 +294,11 @@ CONTAINS CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control%jacobian_vector)) nvar = SIZE(scf_env%outer_scf%variables, 1) - IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) THEN + IF (SIZE(scf_control%outer_scf%cdft_opt_control%jacobian_vector) /= nvar**2) & CALL cp_abort(__LOCATION__, & "Too many or too few values defined for restarting inverse Jacobian.") - END IF - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian iwork = 1 DO i = 1, nvar diff --git a/src/qs_cdft_types.F b/src/qs_cdft_types.F index 3841d78f60..74672844ab 100644 --- a/src/qs_cdft_types.F +++ b/src/qs_cdft_types.F @@ -315,43 +315,31 @@ CONTAINS TYPE(becke_constraint_type), INTENT(INOUT) :: becke_control IF (becke_control%vector_buffer%store_vectors) THEN - IF (ALLOCATED(becke_control%vector_buffer%distances)) THEN + IF (ALLOCATED(becke_control%vector_buffer%distances)) & DEALLOCATE (becke_control%vector_buffer%distances) - END IF - IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) THEN + IF (ALLOCATED(becke_control%vector_buffer%distance_vecs)) & DEALLOCATE (becke_control%vector_buffer%distance_vecs) - END IF - IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) THEN + IF (ALLOCATED(becke_control%vector_buffer%position_vecs)) & DEALLOCATE (becke_control%vector_buffer%position_vecs) - END IF - IF (ALLOCATED(becke_control%vector_buffer%R12)) THEN + IF (ALLOCATED(becke_control%vector_buffer%R12)) & DEALLOCATE (becke_control%vector_buffer%R12) - END IF - IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) THEN + IF (ALLOCATED(becke_control%vector_buffer%pair_dist_vecs)) & DEALLOCATE (becke_control%vector_buffer%pair_dist_vecs) - END IF END IF - IF (ASSOCIATED(becke_control%cutoffs)) THEN + IF (ASSOCIATED(becke_control%cutoffs)) & DEALLOCATE (becke_control%cutoffs) - END IF - IF (ASSOCIATED(becke_control%cutoffs_tmp)) THEN + IF (ASSOCIATED(becke_control%cutoffs_tmp)) & DEALLOCATE (becke_control%cutoffs_tmp) - END IF - IF (ASSOCIATED(becke_control%radii_tmp)) THEN + IF (ASSOCIATED(becke_control%radii_tmp)) & DEALLOCATE (becke_control%radii_tmp) - END IF - IF (ASSOCIATED(becke_control%radii)) THEN + IF (ASSOCIATED(becke_control%radii)) & DEALLOCATE (becke_control%radii) - END IF - IF (ASSOCIATED(becke_control%aij)) THEN + IF (ASSOCIATED(becke_control%aij)) & DEALLOCATE (becke_control%aij) - END IF - IF (ASSOCIATED(becke_control%cavity_mat)) THEN + IF (ASSOCIATED(becke_control%cavity_mat)) & DEALLOCATE (becke_control%cavity_mat) - END IF - IF (becke_control%cavity_confine) THEN + IF (becke_control%cavity_confine) & CALL release_hirshfeld_type(becke_control%cavity_env) - END IF END SUBROUTINE becke_control_release @@ -447,60 +435,44 @@ CONTAINS INTEGER :: i ! Constraint settings - IF (ASSOCIATED(cdft_control%atoms)) THEN + IF (ASSOCIATED(cdft_control%atoms)) & DEALLOCATE (cdft_control%atoms) - END IF - IF (ASSOCIATED(cdft_control%strength)) THEN + IF (ASSOCIATED(cdft_control%strength)) & DEALLOCATE (cdft_control%strength) - END IF - IF (ASSOCIATED(cdft_control%target)) THEN + IF (ASSOCIATED(cdft_control%target)) & DEALLOCATE (cdft_control%target) - END IF - IF (ASSOCIATED(cdft_control%value)) THEN + IF (ASSOCIATED(cdft_control%value)) & DEALLOCATE (cdft_control%value) - END IF - IF (ASSOCIATED(cdft_control%charges_fragment)) THEN + IF (ASSOCIATED(cdft_control%charges_fragment)) & DEALLOCATE (cdft_control%charges_fragment) - END IF - IF (ASSOCIATED(cdft_control%fragments)) THEN + IF (ASSOCIATED(cdft_control%fragments)) & DEALLOCATE (cdft_control%fragments) - END IF - IF (ASSOCIATED(cdft_control%is_constraint)) THEN + IF (ASSOCIATED(cdft_control%is_constraint)) & DEALLOCATE (cdft_control%is_constraint) - END IF - IF (ASSOCIATED(cdft_control%charge)) THEN + IF (ASSOCIATED(cdft_control%charge)) & DEALLOCATE (cdft_control%charge) - END IF ! Constraint atom groups IF (ASSOCIATED(cdft_control%group)) THEN DO i = 1, SIZE(cdft_control%group) - IF (ASSOCIATED(cdft_control%group(i)%atoms)) THEN + IF (ASSOCIATED(cdft_control%group(i)%atoms)) & DEALLOCATE (cdft_control%group(i)%atoms) - END IF - IF (ASSOCIATED(cdft_control%group(i)%coeff)) THEN + IF (ASSOCIATED(cdft_control%group(i)%coeff)) & DEALLOCATE (cdft_control%group(i)%coeff) - END IF - IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) THEN + IF (ALLOCATED(cdft_control%group(i)%d_sum_const_dR)) & DEALLOCATE (cdft_control%group(i)%d_sum_const_dR) - END IF IF (cdft_control%type == outer_scf_becke_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients)) & DEALLOCATE (cdft_control%group(i)%gradients) - END IF ELSE IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN - IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_x)) & DEALLOCATE (cdft_control%group(i)%gradients_x) - END IF - IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_y)) & DEALLOCATE (cdft_control%group(i)%gradients_y) - END IF - IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) THEN + IF (ASSOCIATED(cdft_control%group(i)%gradients_z)) & DEALLOCATE (cdft_control%group(i)%gradients_z) - END IF END IF - IF (ASSOCIATED(cdft_control%group(i)%integrated)) THEN + IF (ASSOCIATED(cdft_control%group(i)%integrated)) & DEALLOCATE (cdft_control%group(i)%integrated) - END IF END DO DEALLOCATE (cdft_control%group) END IF @@ -516,27 +488,21 @@ CONTAINS ! Release OUTER_SCF types CALL cdft_opt_type_release(cdft_control%ot_control%cdft_opt_control) CALL cdft_opt_type_release(cdft_control%constraint_control%cdft_opt_control) - IF (ASSOCIATED(cdft_control%constraint%variables)) THEN + IF (ASSOCIATED(cdft_control%constraint%variables)) & DEALLOCATE (cdft_control%constraint%variables) - END IF - IF (ASSOCIATED(cdft_control%constraint%count)) THEN + IF (ASSOCIATED(cdft_control%constraint%count)) & DEALLOCATE (cdft_control%constraint%count) - END IF - IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN + IF (ASSOCIATED(cdft_control%constraint%gradient)) & DEALLOCATE (cdft_control%constraint%gradient) - END IF - IF (ASSOCIATED(cdft_control%constraint%energy)) THEN + IF (ASSOCIATED(cdft_control%constraint%energy)) & DEALLOCATE (cdft_control%constraint%energy) - END IF - IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN + IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) & DEALLOCATE (cdft_control%constraint%inv_jacobian) - END IF ! Storage for mixed CDFT calculations IF (ALLOCATED(cdft_control%occupations)) THEN DO i = 1, SIZE(cdft_control%occupations) - IF (ASSOCIATED(cdft_control%occupations(i)%array)) THEN + IF (ASSOCIATED(cdft_control%occupations(i)%array)) & DEALLOCATE (cdft_control%occupations(i)%array) - END IF END DO DEALLOCATE (cdft_control%occupations) END IF @@ -577,9 +543,8 @@ CONTAINS SUBROUTINE hirshfeld_control_release(hirshfeld_control) TYPE(hirshfeld_constraint_type), INTENT(INOUT) :: hirshfeld_control - IF (ASSOCIATED(hirshfeld_control%radii)) THEN + IF (ASSOCIATED(hirshfeld_control%radii)) & DEALLOCATE (hirshfeld_control%radii) - END IF CALL release_hirshfeld_type(hirshfeld_control%hirshfeld_env) END SUBROUTINE hirshfeld_control_release diff --git a/src/qs_cdft_utils.F b/src/qs_cdft_utils.F index a5d0de5020..c82c9cddc3 100644 --- a/src/qs_cdft_utils.F +++ b/src/qs_cdft_utils.F @@ -163,11 +163,10 @@ CONTAINS IF (becke_control%adjust) THEN IF (.NOT. ASSOCIATED(becke_control%radii)) THEN CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%radii_tmp)) & CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF ALLOCATE (becke_control%radii(SIZE(atomic_kind_set))) becke_control%radii(:) = becke_control%radii_tmp(:) DEALLOCATE (becke_control%radii_tmp) @@ -181,11 +180,10 @@ CONTAINS CASE (becke_cutoff_global) becke_control%cutoffs(:) = becke_control%rglobal CASE (becke_cutoff_element) - IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(becke_control%cutoffs_tmp)) & CALL cp_abort(__LOCATION__, & "Length of keyword BECKE_CONSTRAINT\ELEMENT_CUTOFFS does not "// & "match number of atomic kinds in the input coordinate file.") - END IF DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=katom, atom_list=atom_list) DO iatom = 1, katom @@ -240,7 +238,7 @@ CONTAINS becke_control%vector_buffer%pair_dist_vecs(:, jatom, iatom) = -dist_vec(:) END IF END IF - becke_control%vector_buffer%R12(iatom, jatom) = NORM2(dist_vec) + becke_control%vector_buffer%R12(iatom, jatom) = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) becke_control%vector_buffer%R12(jatom, iatom) = becke_control%vector_buffer%R12(iatom, jatom) ! Set up heteronuclear cell partitioning using user defined radii IF (build) THEN @@ -331,9 +329,8 @@ CONTAINS CALL create_shape_function(cavity_env, qs_kind_set, atomic_kind_set, & radius=becke_control%rcavity, & radii_list=radii_list) - IF (ASSOCIATED(radii_list)) THEN + IF (ASSOCIATED(radii_list)) & DEALLOCATE (radii_list) - END IF END IF ! Form cavity by summing isolated Gaussian densities over constraint atoms NULLIFY (rs_cavity) @@ -428,10 +425,9 @@ CONTAINS middle_name="BECKE_CAVITY", & extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) - IF (para_env%is_source() .AND. unit_nr < 1) THEN + IF (para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") - END IF CALL get_qs_env(qs_env, subsys=subsys) CALL qs_subsys_get(subsys, particles=particles) CALL cp_pw_to_cube(becke_control%cavity, unit_nr, "CAVITY", particles=particles, stride=stride, mpi_io=mpi_io) @@ -439,9 +435,8 @@ CONTAINS DEALLOCATE (stride) END IF END IF - IF (ALLOCATED(is_constraint)) THEN + IF (ALLOCATED(is_constraint)) & DEALLOCATE (is_constraint) - END IF CALL timestop(handle) END SUBROUTINE becke_constraint_init @@ -502,10 +497,9 @@ CONTAINS CALL section_vals_val_get(becke_section, "IN_MEMORY", l_val=becke_control%in_memory) IF (cdft_control%becke_control%cavity_confine) THEN CALL section_vals_val_get(becke_section, "CAVITY_SHAPE", i_val=becke_control%cavity_shape) - IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) THEN + IF (becke_control%cavity_shape == radius_user .AND. .NOT. becke_control%adjust) & CALL cp_abort(__LOCATION__, & "Activate keyword ADJUST_SIZE to use cavity shape USER.") - END IF CALL section_vals_val_get(becke_section, "CAVITY_RADIUS", r_val=becke_control%rcavity) CALL section_vals_val_get(becke_section, "EPS_CAVITY", r_val=becke_control%eps_cavity) CALL section_vals_val_get(becke_section, "CAVITY_PRINT", l_val=becke_control%print_cavity) @@ -556,9 +550,8 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_section=k, i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) THEN + IF (SIZE(tmplist) < 1) & CPABORT("Each ATOM_GROUP must contain at least 1 atom.") - END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (cdft_control%group(k)%atoms(natoms)) @@ -625,9 +618,8 @@ CONTAINS CALL section_vals_val_get(group_section, "ATOMS", n_rep_val=n_rep) DO j = 1, n_rep CALL section_vals_val_get(group_section, "ATOMS", i_rep_val=j, i_vals=tmplist) - IF (SIZE(tmplist) < 1) THEN + IF (SIZE(tmplist) < 1) & CPABORT("DUMMY_ATOMS must contain at least 1 atom.") - END IF natoms = natoms + SIZE(tmplist) END DO ALLOCATE (dummylist(natoms)) @@ -643,18 +635,16 @@ CONTAINS ! Check for duplicates DO j = 1, natoms DO i = j + 1, natoms - IF (dummylist(i) == dummylist(j)) THEN + IF (dummylist(i) == dummylist(j)) & CPABORT("Duplicate atoms defined in section DUMMY_ATOMS.") - END IF END DO END DO ! Check that a dummy atom is not included in any ATOM_GROUP DO j = 1, SIZE(atomlist) DO i = 1, SIZE(dummylist) - IF (dummylist(i) == atomlist(j)) THEN + IF (dummylist(i) == atomlist(j)) & CALL cp_abort(__LOCATION__, & "Duplicate atoms defined in sections ATOM_GROUP and DUMMY_ATOMS.") - END IF END DO END DO END IF @@ -681,24 +671,22 @@ CONTAINS ALLOCATE (cdft_control%value(nvar)) ALLOCATE (cdft_control%target(nvar)) CALL section_vals_val_get(cdft_control_section, "STRENGTH", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) THEN + IF (SIZE(rtmplist) /= nvar) & CALL cp_abort(__LOCATION__, & "The length of keyword STRENGTH is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") - END IF DO j = 1, nvar cdft_control%strength(j) = rtmplist(j) END DO CALL section_vals_val_get(cdft_control_section, "TARGET", r_vals=rtmplist) - IF (SIZE(rtmplist) /= nvar) THEN + IF (SIZE(rtmplist) /= nvar) & CALL cp_abort(__LOCATION__, & "The length of keyword TARGET is incorrect. "// & "Expected "//TRIM(ADJUSTL(cp_to_string(nvar)))// & " value(s), got "// & TRIM(ADJUSTL(cp_to_string(SIZE(rtmplist))))//" value(s).") - END IF DO j = 1, nvar cdft_control%target(j) = rtmplist(j) END DO @@ -768,9 +756,8 @@ CONTAINS outer_scf_section => section_vals_get_subs_vals(cdft_control_section, "OUTER_SCF") CALL outer_scf_read_parameters(cdft_control%constraint_control, outer_scf_section) IF (cdft_control%constraint_control%have_scf) THEN - IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) THEN + IF (cdft_control%constraint_control%type /= outer_scf_cdft_constraint) & CPABORT("Unsupported CDFT constraint.") - END IF ! Constraint definitions CALL read_constraint_definitions(cdft_control, cdft_control_section) ! Constraint-specific initializations @@ -1027,11 +1014,10 @@ CONTAINS nkind = SIZE(qs_kind_set) ! Parse atomic radii for setting up Gaussian shape function IF (ASSOCIATED(hirshfeld_control%radii)) THEN - IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) THEN + IF (.NOT. SIZE(atomic_kind_set) == SIZE(hirshfeld_control%radii)) & CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF ALLOCATE (radii_list(SIZE(hirshfeld_control%radii))) DO ikind = 1, SIZE(hirshfeld_control%radii) @@ -1144,9 +1130,8 @@ CONTAINS CALL qs_scf_cdft_constraint_info(iw, cdft_control) ! Print weight function(s) to cube file(s) whenever weight is (re)built - IF (cdft_control%print_weight .AND. cdft_control%need_pot) THEN + IF (cdft_control%print_weight .AND. cdft_control%need_pot) & CALL cdft_print_weight_function(qs_env) - END IF ! Print atomic CDFT charges IF (iw > 0 .AND. cdft_control%atomic_charges) THEN @@ -1305,10 +1290,9 @@ CONTAINS extension=".cube", file_position="REWIND", & log_filename=.FALSE., mpi_io=mpi_io) ! Note PROGRAM_RUN_INFO section neeeds to be active! - IF (para_env%is_source() .AND. unit_nr < 1) THEN + IF (para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print CDFT weight function.") - END IF CALL cp_pw_to_cube(cdft_control%group(igroup)%weight, & unit_nr, & diff --git a/src/qs_charge_mixing.F b/src/qs_charge_mixing.F index 7682698cfc..d4981f4b0a 100644 --- a/src/qs_charge_mixing.F +++ b/src/qs_charge_mixing.F @@ -117,9 +117,8 @@ CONTAINS mixer_max_weight = tblite_mixer_max_weight_default IF (PRESENT(tblite_mixer_max_weight)) mixer_max_weight = tblite_mixer_max_weight IF (mixer_max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (mixer_max_weight < mixer_min_weight) THEN + IF (mixer_max_weight < mixer_min_weight) & CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") - END IF mixer_weight_factor = tblite_mixer_weight_factor_default IF (PRESENT(tblite_mixer_weight_factor)) mixer_weight_factor = tblite_mixer_weight_factor IF (mixer_weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") @@ -184,21 +183,21 @@ CONTAINS IF ((iter_count == 1) .OR. (iter_count + 1 <= mixing_store%nskip_mixing)) THEN ! skip mixing mixing_store%iter_method = "NoMix" - ELSE IF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN + ELSEIF (((iter_count + 1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) .OR. (nvec == 1)) THEN CALL mix_charges_only(mixing_store, charges, alpha, imin, ns, para_env) mixing_store%iter_method = "Mixing" - ELSE IF (mixing_method == gspace_mixing_nr) THEN + ELSEIF (mixing_method == gspace_mixing_nr) THEN CPABORT("Kerker method not available for Charge Mixing") - ELSE IF (mixing_method == pulay_mixing_nr) THEN + ELSEIF (mixing_method == pulay_mixing_nr) THEN CPABORT("Pulay method not available for Charge Mixing") - ELSE IF (mixing_method == broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr) THEN CALL broyden_mixing(mixing_store, charges, imin, nvec, ns, para_env) mixing_store%iter_method = "Broy." - ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN + ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN CPABORT("Modified Broyden mixing is only available for DFT density mixing") - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN CPABORT("Multisecant_mixing method not available for Charge Mixing") - ELSE IF (mixing_method == new_pulay_mixing_nr) THEN + ELSEIF (mixing_method == new_pulay_mixing_nr) THEN CPABORT("New Pulay method not available for Charge Mixing") END IF diff --git a/src/qs_chargemol.F b/src/qs_chargemol.F index e26a09e4fb..32f7c50516 100644 --- a/src/qs_chargemol.F +++ b/src/qs_chargemol.F @@ -604,7 +604,7 @@ CONTAINS DO imo = 1, mos(1)%homo IF (nspins == 1) THEN WRITE (iwfx, '(A15)') "Alpha and Beta" - ELSE IF (dft_control%uks) THEN + ELSEIF (dft_control%uks) THEN WRITE (iwfx, '(A6)') "Alpha" ELSE CALL cp_abort(__LOCATION__, "This wavefunction type is currently"// & diff --git a/src/qs_charges_types.F b/src/qs_charges_types.F index b72dd7d539..7771cd0745 100644 --- a/src/qs_charges_types.F +++ b/src/qs_charges_types.F @@ -73,13 +73,11 @@ CONTAINS REAL(KIND=dp), INTENT(in), OPTIONAL :: total_rho_core_rspace, total_rho_gspace qs_charges%total_rho_core_rspace = 0.0_dp - IF (PRESENT(total_rho_core_rspace)) THEN + IF (PRESENT(total_rho_core_rspace)) & qs_charges%total_rho_core_rspace = total_rho_core_rspace - END IF qs_charges%total_rho_gspace = 0.0_dp - IF (PRESENT(total_rho_gspace)) THEN + IF (PRESENT(total_rho_gspace)) & qs_charges%total_rho_gspace = total_rho_gspace - END IF qs_charges%total_rho_soft_gspace = 0.0_dp qs_charges%total_rho0_hard_lebedev = 0.0_dp qs_charges%total_rho_soft_gspace = 0.0_dp diff --git a/src/qs_cneo_methods.F b/src/qs_cneo_methods.F index 3485e11369..43081fa9b5 100644 --- a/src/qs_cneo_methods.F +++ b/src/qs_cneo_methods.F @@ -185,10 +185,9 @@ CONTAINS CALL get_gto_basis_set(nuc_soft_basis, npgf=npgf_s, gcc=gcc_s) ! There is such a limitation because we rely on atomic code to build S, T and U. ! Usually l=5 is more than enough, suppoting PB6H basis. - IF (maxl > lmat) THEN + IF (maxl > lmat) & CALL cp_abort(__LOCATION__, "Nuclear basis with angular momentum higher than "// & "atom_types::lmat is not supported yet.") - END IF set_index = 0 shell_index = 0 @@ -1075,7 +1074,7 @@ CONTAINS ! initial guess of f is taken from the result of last iteration CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) ! test if zero initial guess is better - IF (NORM2(r) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN + IF (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp .AND. DOT_PRODUCT(f, f) /= 0.0_dp) THEN CALL atom_solve_cneo(fmat, [0.0_dp, 0.0_dp, 0.0_dp], utrans, wfn, & ener, pmat, r_tmp, distance, nsgf, nne) IF (DOT_PRODUCT(r_tmp, r_tmp) < DOT_PRODUCT(r, r)) THEN @@ -1086,7 +1085,7 @@ CONTAINS max_iter = 20 iter = 0 ! using Newton's method to solve for f - DO WHILE (NORM2(r) > 1.e-12_dp) + DO WHILE (SQRT(DOT_PRODUCT(r, r)) > 1.e-12_dp) iter = iter + 1 ! construct numerical Jacobian with one-side finite difference DO i = 1, 3 @@ -1119,13 +1118,13 @@ CONTAINS CALL invert_matrix_3x3(jac, jac_inv, det, try_svd=.TRUE.) END IF df = -RESHAPE(MATMUL(jac_inv, RESHAPE(r, [3, 1])), [3]) - df_norm = NORM2(df) + df_norm = SQRT(DOT_PRODUCT(df, df)) f_tmp = f r_tmp = r - g0 = NORM2(r_tmp) + g0 = SQRT(DOT_PRODUCT(r_tmp, r_tmp)) f = f_tmp + df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = NORM2(r) + g1 = SQRT(DOT_PRODUCT(r, r)) step = 1.0_dp DO WHILE (g1 >= g0) ! line search @@ -1137,7 +1136,7 @@ CONTAINS step = step*MAX(-g0p/(2.0_dp*(g1 - g0 - g0p)), 0.1_dp) f = f_tmp + step*df CALL atom_solve_cneo(fmat, f, utrans, wfn, ener, pmat, r, distance, nsgf, nne) - g1 = NORM2(r) + g1 = SQRT(DOT_PRODUCT(r, r)) END DO IF (iter >= max_iter) THEN CALL cp_warn(__LOCATION__, "CNEO nuclear position constraint solver failed to "// & diff --git a/src/qs_cneo_types.F b/src/qs_cneo_types.F index f5661286f4..40dd2fb323 100644 --- a/src/qs_cneo_types.F +++ b/src/qs_cneo_types.F @@ -121,45 +121,32 @@ CONTAINS TYPE(rhoz_cneo_type), POINTER :: rhoz_cneo IF (ASSOCIATED(rhoz_cneo)) THEN - IF (ASSOCIATED(rhoz_cneo%pmat)) THEN + IF (ASSOCIATED(rhoz_cneo%pmat)) & DEALLOCATE (rhoz_cneo%pmat) - END IF - IF (ASSOCIATED(rhoz_cneo%core)) THEN + IF (ASSOCIATED(rhoz_cneo%core)) & DEALLOCATE (rhoz_cneo%core) - END IF - IF (ASSOCIATED(rhoz_cneo%vmat)) THEN + IF (ASSOCIATED(rhoz_cneo%vmat)) & DEALLOCATE (rhoz_cneo%vmat) - END IF - IF (ASSOCIATED(rhoz_cneo%fmat)) THEN + IF (ASSOCIATED(rhoz_cneo%fmat)) & DEALLOCATE (rhoz_cneo%fmat) - END IF - IF (ASSOCIATED(rhoz_cneo%wfn)) THEN + IF (ASSOCIATED(rhoz_cneo%wfn)) & DEALLOCATE (rhoz_cneo%wfn) - END IF - IF (ASSOCIATED(rhoz_cneo%cpc_h)) THEN + IF (ASSOCIATED(rhoz_cneo%cpc_h)) & DEALLOCATE (rhoz_cneo%cpc_h) - END IF - IF (ASSOCIATED(rhoz_cneo%cpc_s)) THEN + IF (ASSOCIATED(rhoz_cneo%cpc_s)) & DEALLOCATE (rhoz_cneo%cpc_s) - END IF - IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) THEN + IF (ASSOCIATED(rhoz_cneo%rho_rad_h)) & DEALLOCATE (rhoz_cneo%rho_rad_h) - END IF - IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) THEN + IF (ASSOCIATED(rhoz_cneo%rho_rad_s)) & DEALLOCATE (rhoz_cneo%rho_rad_s) - END IF - IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) THEN + IF (ASSOCIATED(rhoz_cneo%vrho_rad_h)) & DEALLOCATE (rhoz_cneo%vrho_rad_h) - END IF - IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) THEN + IF (ASSOCIATED(rhoz_cneo%vrho_rad_s)) & DEALLOCATE (rhoz_cneo%vrho_rad_s) - END IF - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) THEN + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_h)) & DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_h) - END IF - IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) THEN + IF (ASSOCIATED(rhoz_cneo%ga_Vlocal_gb_s)) & DEALLOCATE (rhoz_cneo%ga_Vlocal_gb_s) - END IF END IF END SUBROUTINE deallocate_rhoz_cneo @@ -194,9 +181,8 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential - IF (ASSOCIATED(potential)) THEN + IF (ASSOCIATED(potential)) & CALL deallocate_cneo_potential(potential) - END IF ALLOCATE (potential) @@ -211,51 +197,36 @@ CONTAINS TYPE(cneo_potential_type), POINTER :: potential IF (ASSOCIATED(potential)) THEN - IF (ASSOCIATED(potential%elec_conf)) THEN + IF (ASSOCIATED(potential%elec_conf)) & DEALLOCATE (potential%elec_conf) - END IF - IF (ASSOCIATED(potential%my_gcc_h)) THEN + IF (ASSOCIATED(potential%my_gcc_h)) & DEALLOCATE (potential%my_gcc_h) - END IF - IF (ASSOCIATED(potential%my_gcc_s)) THEN + IF (ASSOCIATED(potential%my_gcc_s)) & DEALLOCATE (potential%my_gcc_s) - END IF - IF (ASSOCIATED(potential%ovlp)) THEN + IF (ASSOCIATED(potential%ovlp)) & DEALLOCATE (potential%ovlp) - END IF - IF (ASSOCIATED(potential%kin)) THEN + IF (ASSOCIATED(potential%kin)) & DEALLOCATE (potential%kin) - END IF - IF (ASSOCIATED(potential%utrans)) THEN + IF (ASSOCIATED(potential%utrans)) & DEALLOCATE (potential%utrans) - END IF - IF (ASSOCIATED(potential%distance)) THEN + IF (ASSOCIATED(potential%distance)) & DEALLOCATE (potential%distance) - END IF - IF (ASSOCIATED(potential%harmonics)) THEN + IF (ASSOCIATED(potential%harmonics)) & CALL deallocate_harmonics_atom(potential%harmonics) - END IF - IF (ASSOCIATED(potential%Qlm_gg)) THEN + IF (ASSOCIATED(potential%Qlm_gg)) & DEALLOCATE (potential%Qlm_gg) - END IF - IF (ASSOCIATED(potential%gg)) THEN + IF (ASSOCIATED(potential%gg)) & DEALLOCATE (potential%gg) - END IF - IF (ASSOCIATED(potential%vgg)) THEN + IF (ASSOCIATED(potential%vgg)) & DEALLOCATE (potential%vgg) - END IF - IF (ASSOCIATED(potential%n2oindex)) THEN + IF (ASSOCIATED(potential%n2oindex)) & DEALLOCATE (potential%n2oindex) - END IF - IF (ASSOCIATED(potential%o2nindex)) THEN + IF (ASSOCIATED(potential%o2nindex)) & DEALLOCATE (potential%o2nindex) - END IF - IF (ASSOCIATED(potential%rad2l)) THEN + IF (ASSOCIATED(potential%rad2l)) & DEALLOCATE (potential%rad2l) - END IF - IF (ASSOCIATED(potential%oorad2l)) THEN + IF (ASSOCIATED(potential%oorad2l)) & DEALLOCATE (potential%oorad2l) - END IF DEALLOCATE (potential) END IF @@ -385,9 +356,8 @@ CONTAINS IF (PRESENT(z)) THEN potential%z = z potential%zeff = REAL(z, dp) - IF (ASSOCIATED(potential%elec_conf)) THEN + IF (ASSOCIATED(potential%elec_conf)) & CPABORT("elec_conf is already associated") - END IF ALLOCATE (potential%elec_conf(0:3)) potential%elec_conf(0:3) = ptable(z)%e_conv(0:3) CPASSERT(potential%mass == 0.0_dp) diff --git a/src/qs_collocate_density.F b/src/qs_collocate_density.F index c0df7d1eaf..57925e0e86 100644 --- a/src/qs_collocate_density.F +++ b/src/qs_collocate_density.F @@ -1245,10 +1245,9 @@ CONTAINS CALL transfer_rs2pw(rs_rho, rhoc_r) - IF (PRESENT(total_rho_metal)) THEN + IF (PRESENT(total_rho_metal)) & !minus sign: account for the fact that rho_metal has opposite sign total_rho_metal = pw_integrate_function(rhoc_r, isign=-1) - END IF CALL pw_transfer(rhoc_r, rho_metal) CALL auxbas_pw_pool%give_back_pw(rhoc_r) @@ -1570,7 +1569,7 @@ CONTAINS IF (PRESENT(soft_valid)) my_soft_valid = soft_valid IF (PRESENT(task_list_external)) THEN task_list => task_list_external - ELSE IF (my_soft_valid) THEN + ELSEIF (my_soft_valid) THEN CALL get_ks_env(ks_env, task_list_soft=task_list) ELSE CALL get_ks_env(ks_env, task_list=task_list) @@ -2359,48 +2358,44 @@ CONTAINS END SELECT IF (iatom <= jatom) THEN - IF (iatom == lambda) THEN + IF (iatom == lambda) & CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF - IF (jatom == lambda) THEN + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + IF (jatom == lambda) & CALL collocate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, scale, pab, na1 - 1, nb1 - 1, & - rsgrid=rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, scale, pab, na1 - 1, nb1 - 1, & + rsgrid=rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) ELSE rab_inv = -rab - IF (jatom == lambda) THEN + IF (jatom == lambda) & CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF - IF (iatom == lambda) THEN + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) + IF (iatom == lambda) & CALL collocate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & - rs_rho(igrid_level), & - ga_gb_function=dabqadb_func + 3, radius=radius, & - use_subpatch=use_subpatch, & - subpatch_pattern=tasks(itask)%subpatch_pattern) - END IF + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, scale, pab, nb1 - 1, na1 - 1, & + rs_rho(igrid_level), & + ga_gb_function=dabqadb_func + 3, radius=radius, & + use_subpatch=use_subpatch, & + subpatch_pattern=tasks(itask)%subpatch_pattern) END IF END DO loop_tasks diff --git a/src/qs_core_hamiltonian.F b/src/qs_core_hamiltonian.F index 2ab3d7e09c..ff5dfb464e 100644 --- a/src/qs_core_hamiltonian.F +++ b/src/qs_core_hamiltonian.F @@ -230,10 +230,9 @@ CONTAINS IF (dft_control%tddfpt2_control%enabled) THEN nders = 1 IF (dft_control%do_admm) THEN - IF (dft_control%admm_control%purification_method /= do_admm_purify_none) THEN + IF (dft_control%admm_control%purification_method /= do_admm_purify_none) & CALL cp_abort(__LOCATION__, & "Only purification method NONE is possible with TDDFT at the moment") - END IF END IF END IF @@ -337,10 +336,9 @@ CONTAINS nkind = SIZE(atomic_kind_set) CALL allocate_oce_set(oce, nkind) eps_fit = dft_control%qs_control%gapw_control%eps_fit - IF (ASSOCIATED(sap_oce)) THEN + IF (ASSOCIATED(sap_oce)) & CALL build_oce_matrices(oce%intac, calculate_forces, nder, qs_kind_set, particle_set, & sap_oce, eps_fit) - END IF END IF ! *** KG atomic potentials for nonadditive kinetic energy diff --git a/src/qs_core_matrices.F b/src/qs_core_matrices.F index b57e8fd83c..8ee4e78031 100644 --- a/src/qs_core_matrices.F +++ b/src/qs_core_matrices.F @@ -567,7 +567,7 @@ CONTAINS END IF IF (PRESENT(matrixkp_t)) THEN CALL build_atomic_relmat(matrixkp_t(1, ic)%matrix, atomic_kind_set, qs_kind_set) - ELSE IF (PRESENT(matrix_t)) THEN + ELSEIF (PRESENT(matrix_t)) THEN CALL build_atomic_relmat(matrix_t(1)%matrix, atomic_kind_set, qs_kind_set) END IF ELSE diff --git a/src/qs_dcdr_utils.F b/src/qs_dcdr_utils.F index 9c83bf24e0..9de800d1c3 100644 --- a/src/qs_dcdr_utils.F +++ b/src/qs_dcdr_utils.F @@ -778,9 +778,8 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(dcdr_section, "REFERENCE_POINT", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) THEN + IF (reference == use_mom_ref_user) & CPABORT("User-defined reference point should be given explicitly") - END IF END IF CALL get_reference_point(rpoint=dcdr_env%ref_point, qs_env=qs_env, & diff --git a/src/qs_dftb_parameters.F b/src/qs_dftb_parameters.F index 60d7083667..35c95324c7 100644 --- a/src/qs_dftb_parameters.F +++ b/src/qs_dftb_parameters.F @@ -204,11 +204,10 @@ CONTAINS CALL parser_release(parser) END BLOCK END IF - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "Failure in assigning KINDS <"//TRIM(iname)//"> and <"//TRIM(jname)// & "> to a DFTB interaction pair!") - END IF END DO END DO ! reading the files diff --git a/src/qs_dftb_utils.F b/src/qs_dftb_utils.F index 43440135a1..79a4972d93 100644 --- a/src/qs_dftb_utils.F +++ b/src/qs_dftb_utils.F @@ -62,9 +62,8 @@ CONTAINS TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter - IF (ASSOCIATED(dftb_parameter)) THEN + IF (ASSOCIATED(dftb_parameter)) & CALL deallocate_dftb_atom_param(dftb_parameter) - END IF ALLOCATE (dftb_parameter) diff --git a/src/qs_dispersion_cnum.F b/src/qs_dispersion_cnum.F index 2632a12933..9d5d96d71a 100644 --- a/src/qs_dispersion_cnum.F +++ b/src/qs_dispersion_cnum.F @@ -1261,9 +1261,9 @@ CONTAINS rcut = rcut + 0.1_dp IF (cnfun == 1) THEN CALL cnparam_d3(rcut, rcov, dispersion_env%k1, cnab, dcnab) - ELSE IF (cnfun == 2) THEN + ELSEIF (cnfun == 2) THEN CALL modcn_d3(rcut, rcov, cnab, dcnab) - ELSE IF (cnfun == 3) THEN + ELSEIF (cnfun == 3) THEN den = 0.0_dp CALL cn_d4per(rcut, rcov, den, cnab, dcnab) ELSE @@ -1367,9 +1367,9 @@ CONTAINS rcovab = dispersion_env%rcov(za) + dispersion_env%rcov(zb) IF (cnfun == 1) THEN CALL cnparam_d3(rcc, rcovab, dispersion_env%k1, cnab, dcnab) - ELSE IF (cnfun == 2) THEN + ELSEIF (cnfun == 2) THEN CALL modcn_d3(rcc, rcovab, cnab, dcnab) - ELSE IF (cnfun == 3) THEN + ELSEIF (cnfun == 3) THEN den = ABS(dispersion_env%eneg(za) - dispersion_env%eneg(zb)) CALL cn_d4per(rcc, rcovab, den, cnab, dcnab) ELSE diff --git a/src/qs_dispersion_d3.F b/src/qs_dispersion_d3.F index 0afac622bf..83f2a1ed5d 100644 --- a/src/qs_dispersion_d3.F +++ b/src/qs_dispersion_d3.F @@ -984,7 +984,7 @@ CONTAINS IF (rab >= ru) THEN fcc = 0._dp dfcc = 0._dp - ELSE IF (rab <= rl) THEN + ELSEIF (rab <= rl) THEN fcc = 1._dp dfcc = 0._dp ELSE diff --git a/src/qs_dispersion_nonloc.F b/src/qs_dispersion_nonloc.F index e4cce04a17..fa63eaf80f 100644 --- a/src/qs_dispersion_nonloc.F +++ b/src/qs_dispersion_nonloc.F @@ -583,7 +583,7 @@ CONTAINS COMPLEX(KIND=dp) :: uu COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: theta - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: u_vdw(:, :) INTEGER :: handle, ig, iq, l, m, nl_type, nqs, & q1_i, q2_i LOGICAL :: use_virial diff --git a/src/qs_dispersion_pairpot.F b/src/qs_dispersion_pairpot.F index 26d6bff01b..3f68b76445 100644 --- a/src/qs_dispersion_pairpot.F +++ b/src/qs_dispersion_pairpot.F @@ -188,12 +188,11 @@ CONTAINS disp%defined = .FALSE. END IF ! Check if the parameter is defined - IF (.NOT. disp%defined) THEN + IF (.NOT. disp%defined) & CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") - END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO CASE (vdw_pairpot_dftd3, vdw_pairpot_dftd3bj) @@ -275,12 +274,11 @@ CONTAINS ELSE disp%defined = .FALSE. END IF - IF (.NOT. disp%defined) THEN + IF (.NOT. disp%defined) & CALL cp_abort(__LOCATION__, & "Dispersion parameters for element ("//TRIM(symbol)//") are not defined! "// & "Please provide a valid set of parameters through the input section or "// & "through an external file! ") - END IF CALL set_qs_kind(qs_kind_set(ikind), dispersion=disp) END DO @@ -481,11 +479,11 @@ CONTAINS IF (dispersion_env%pp_type == vdw_pairpot_dftd2) THEN CALL calculate_dispersion_d2_pairpot(qs_env, dispersion_env, evdw, calculate_forces, atevdw) - ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & - dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN + ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & + dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN CALL calculate_dispersion_d3_pairpot(qs_env, dispersion_env, evdw, calculate_forces, & unit_nr, atevdw) - ELSE IF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN + ELSEIF (dispersion_env%pp_type == vdw_pairpot_dftd4) THEN IF (dispersion_env%lrc) THEN CPABORT("Long range correction with DFTD4 not implemented") END IF diff --git a/src/qs_efield_berry.F b/src/qs_efield_berry.F index bf69918821..48de8e24b0 100644 --- a/src/qs_efield_berry.F +++ b/src/qs_efield_berry.F @@ -263,7 +263,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = -fieldpol*strength hmat = cell%hmat(:, :)/twopi DO idir = 1, 3 @@ -296,9 +296,8 @@ CONTAINS END IF END IF IF (use_virial) THEN - IF (para_env%mepos == 0) THEN + IF (para_env%mepos == 0) & CALL virial_pair_force(virial%pv_virial, 1.0_dp, forcea, ria) - END IF END IF END DO qi = AIMAG(LOG(zi)) @@ -753,7 +752,7 @@ CONTAINS END IF fieldpol = dft_control%period_efield%polarisation - fieldpol = fieldpol/NORM2(fieldpol) + fieldpol = fieldpol/SQRT(DOT_PRODUCT(fieldpol, fieldpol)) fieldpol = fieldpol*strength omega = cell%deth diff --git a/src/qs_electric_field_gradient.F b/src/qs_electric_field_gradient.F index 31adb830c8..c706d01b8e 100644 --- a/src/qs_electric_field_gradient.F +++ b/src/qs_electric_field_gradient.F @@ -153,7 +153,7 @@ CONTAINS smoothing = .FALSE. ecut = 1.e10_dp ! not used, just to have vars defined sigma = 1._dp ! not used, just to have vars defined - ELSE IF (ecut == -1._dp .AND. sigma == -1._dp) THEN + ELSEIF (ecut == -1._dp .AND. sigma == -1._dp) THEN smoothing = .TRUE. CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL auxbas_pw_pool%create_pw(dvr2rs) diff --git a/src/qs_energy.F b/src/qs_energy.F index 2c83157a0d..9ef6f0d88a 100644 --- a/src/qs_energy.F +++ b/src/qs_energy.F @@ -167,9 +167,8 @@ CONTAINS END IF IF (dft_control%tddfpt2_control%do_smearing) THEN - IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) THEN + IF (.NOT. ASSOCIATED(dft_control%tddfpt2_control%smeared_occup)) & CPABORT("Smearing occupation not associated.") - END IF CALL deallocate_fermi_params(dft_control%tddfpt2_control%smeared_occup) END IF IF (dft_control%qs_control%lrigpw) THEN diff --git a/src/qs_energy_init.F b/src/qs_energy_init.F index 48655f12db..7e82c28f28 100644 --- a/src/qs_energy_init.F +++ b/src/qs_energy_init.F @@ -283,14 +283,12 @@ CONTAINS CALL set_kpoint_info(kpoints, sab_nl_nosym=sab_nl_nosym) END IF IF (dft_control%qs_control%cdft) THEN - IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) THEN + IF (.NOT. (dft_control%qs_control%cdft_control%external_control)) & dft_control%qs_control%cdft_control%need_pot = .TRUE. - END IF IF (ASSOCIATED(dft_control%qs_control%cdft_control%group)) THEN ! In case CDFT weight function was built beforehand (in mixed force_eval) - IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) THEN + IF (ASSOCIATED(dft_control%qs_control%cdft_control%group(1)%weight)) & dft_control%qs_control%cdft_control%need_pot = .FALSE. - END IF END IF END IF @@ -302,13 +300,13 @@ CONTAINS CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.FALSE.) CALL get_qs_env(qs_env=qs_env, dispersion_env=dispersion_env, energy=energy) CALL calculate_dispersion_pairpot(qs_env, dispersion_env, energy%dispersion, calc_forces) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.FALSE.) CALL qs_env_update_s_mstruct(qs_env) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.FALSE.) ELSE diff --git a/src/qs_energy_window.F b/src/qs_energy_window.F index 5e782d11cf..6c41baed36 100644 --- a/src/qs_energy_window.F +++ b/src/qs_energy_window.F @@ -88,7 +88,7 @@ CONTAINS INTEGER :: handle, i, lanzcos_max_iter, last, nao, & nelectron_total, newton_schulz_order, & next, nwindows, print_unit, unit_nr - INTEGER, DIMENSION(:), POINTER :: stride + INTEGER, DIMENSION(:), POINTER :: stride(:) LOGICAL :: mpi_io, print_cube, restrict_range REAL(KIND=dp) :: bin_width, density_ewindow_total, density_total, energy_range, fermi_level, & filter_eps, frob_norm, lanzcos_threshold, lower_bound, occupation, upper_bound diff --git a/src/qs_environment.F b/src/qs_environment.F index 08194e09b6..bf7ae4766d 100644 --- a/src/qs_environment.F +++ b/src/qs_environment.F @@ -417,17 +417,14 @@ CONTAINS do_tddfpt_unsupported_kpoints = tddfpt_kernel /= tddfpt_kernel_none IF (.NOT. do_tddfpt_unsupported_kpoints) THEN CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) THEN + IF (use_real_wfn) & CALL cp_abort(__LOCATION__, "K-point TDDFPT requires complex wavefunctions.") - END IF END IF CALL section_vals_val_get(tddfpt_section, "DO_BSE", l_val=do_bse) - IF (.NOT. do_bse) THEN + IF (.NOT. do_bse) & CALL section_vals_val_get(tddfpt_section, "DO_BSE_W_ONLY", l_val=do_bse) - END IF - IF (.NOT. do_bse) THEN + IF (.NOT. do_bse) & CALL section_vals_val_get(tddfpt_section, "DO_BSE_GW_ONLY", l_val=do_bse) - END IF END IF do_active_space = .FALSE. active_space_section => section_vals_get_subs_vals(qs_env%input, "DFT%ACTIVE_SPACE") @@ -474,11 +471,10 @@ CONTAINS l_val=do_wfc_low_scaling) CALL section_vals_val_get(qs_env%input, "DFT%XC%WF_CORRELATION%LOW_SCALING%DO_KPOINTS", & l_val=do_wfc_low_scaling_kpoints) - IF (.NOT. do_bse) THEN + IF (.NOT. do_bse) & CALL section_vals_val_get(qs_env%input, & "DFT%XC%WF_CORRELATION%RI_RPA%GW%BSE%_SECTION_PARAMETERS_", & l_val=do_bse) - END IF END IF CALL restrict_unsupported_atomic_kpoint_symmetry(kpoints, method_id, do_hfx, do_exx, do_gw, & do_tddfpt_unsupported_kpoints, & @@ -538,9 +534,8 @@ CONTAINS ! more kpoint stuff CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints, blacs_env=blacs_env) IF (do_kpoints) THEN - IF (dft_control%qs_control%do_ls_scf) THEN + IF (dft_control%qs_control%do_ls_scf) & CPABORT("DFT%KPOINTS are not implemented with QS/LS_SCF; use a real-space supercell instead.") - END IF CALL kpoint_env_initialize(kpoints, para_env, blacs_env, with_aux_fit=dft_control%do_admm) CALL kpoint_initialize_mos(kpoints, qs_env%mos) CALL get_qs_env(qs_env=qs_env, wf_history=wf_history) @@ -1194,7 +1189,7 @@ CONTAINS CALL ewald_pw_create(ewald_pw, ewald_env, cell, cell_ref, print_section=print_section) CALL set_qs_env(qs_env, ewald_env=ewald_env, ewald_pw=ewald_pw) END IF - ELSE IF (dft_control%qs_control%method_id == do_method_xtb) THEN + ELSEIF (dft_control%qs_control%method_id == do_method_xtb) THEN ! Read xTB parameter file xtb_control => dft_control%qs_control%xtb_control CALL get_qs_env(qs_env, nkind=nkind) @@ -1628,13 +1623,11 @@ CONTAINS IF (.NOT. dft_control%qs_control%do_ls_scf) THEN SELECT CASE (dft_control%qs_control%method_id) CASE (do_method_dftb) - IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN + IF (dft_control%qs_control%dftb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & scf_control%max_scf = dft_control%qs_control%dftb_control%tblite_mixer_iterations - END IF CASE (do_method_xtb) - IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) THEN + IF (dft_control%qs_control%xtb_control%tblite_scc_mixer == tblite_scc_mixer_tblite) & scf_control%max_scf = dft_control%qs_control%xtb_control%tblite_mixer_iterations - END IF END SELECT END IF @@ -1880,7 +1873,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN + ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d3bj) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd3bj dispersion_env%eps_cn = dftb_control%epscn @@ -1896,7 +1889,7 @@ CONTAINS dispersion_env%nd3_exclude_pair = 0 dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file CALL qs_dispersion_pairpot_init(atomic_kind_set, qs_kind_set, dispersion_env, para_env=para_env) - ELSE IF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN + ELSEIF (dftb_control%dispersion .AND. dftb_control%dispersion_type == dispersion_d2) THEN dispersion_env%type = xc_vdw_fun_pairpot dispersion_env%pp_type = vdw_pairpot_dftd2 dispersion_env%exp_pre = dftb_control%exp_pre @@ -2224,11 +2217,10 @@ CONTAINS n_mo(1) = n_mo(1) + scf_control%added_mos(1) IF (dft_control%nspins == 2) THEN - IF (n_mo(2) > n_mo(1)) THEN + IF (n_mo(2) > n_mo(1)) & CALL cp_warn(__LOCATION__, & "More beta than alpha MOs requested. "// & "The number of beta MOs will be reduced to the number alpha MOs.") - END IF n_mo(2) = MIN(n_mo(1), n_mo(2)) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2238,11 +2230,10 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) IF (do_kpoints .AND. dft_control%nspins == 2) THEN ! we need equal number of calculated states - IF (n_mo(2) /= n_mo(1)) THEN + IF (n_mo(2) /= n_mo(1)) & CALL cp_warn(__LOCATION__, & "Kpoints: Different number of MOs requested. "// & "The number of beta MOs will be set to the number alpha MOs.") - END IF n_mo(2) = n_mo(1) CPASSERT(n_mo(1) >= nelectron_spin(1)) CPASSERT(n_mo(2) >= nelectron_spin(2)) @@ -2489,7 +2480,7 @@ CONTAINS "- Orbital basis functions: ", maxlgto, & "- Local part of the GTH pseudopotential: ", maxlppl, & "- Non-local part of the GTH pseudopotential: ", maxlppnl - ELSE IF (maxlppl > -1) THEN + ELSEIF (maxlppl > -1) THEN WRITE (UNIT=output_unit, FMT="(/,T3,A,(T30,A,T75,I6))") & "Maximum angular momentum of the", & "- Orbital basis functions: ", maxlgto, & diff --git a/src/qs_environment_types.F b/src/qs_environment_types.F index ac95bc2f66..ac6c8fa2a6 100644 --- a/src/qs_environment_types.F +++ b/src/qs_environment_types.F @@ -163,8 +163,6 @@ MODULE qs_environment_types USE wannier_states_types, ONLY: wannier_centres_type USE xas_env_types, ONLY: xas_env_release,& xas_environment_type - USE xc_gauxc_cache, ONLY: cp_gauxc_cache_type,& - gauxc_cache_release #include "./base/base_uses.f90" IMPLICIT NONE @@ -324,7 +322,6 @@ MODULE qs_environment_types TYPE(mo_set_type), DIMENSION(:), POINTER :: mos_last_converged => NULL() ! tblite TYPE(tblite_type), POINTER :: tb_tblite => Null() - TYPE(cp_gauxc_cache_type), POINTER :: gauxc_cache => NULL() END TYPE qs_environment_type CONTAINS @@ -744,27 +741,20 @@ CONTAINS ! Resp charges IF (PRESENT(rhs)) rhs => qs_env%rhs - IF (PRESENT(local_rho_set)) THEN + IF (PRESENT(local_rho_set)) & local_rho_set => qs_env%local_rho_set - END IF - IF (PRESENT(rho_atom_set)) THEN + IF (PRESENT(rho_atom_set)) & CALL get_local_rho(qs_env%local_rho_set, rho_atom_set=rho_atom_set) - END IF - IF (PRESENT(rho0_atom_set)) THEN + IF (PRESENT(rho0_atom_set)) & CALL get_local_rho(qs_env%local_rho_set, rho0_atom_set=rho0_atom_set) - END IF - IF (PRESENT(rho0_mpole)) THEN + IF (PRESENT(rho0_mpole)) & CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_mpole) - END IF - IF (PRESENT(rhoz_set)) THEN + IF (PRESENT(rhoz_set)) & CALL get_local_rho(qs_env%local_rho_set, rhoz_set=rhoz_set) - END IF - IF (PRESENT(rhoz_cneo_set)) THEN + IF (PRESENT(rhoz_cneo_set)) & CALL get_local_rho(qs_env%local_rho_set, rhoz_cneo_set=rhoz_cneo_set) - END IF - IF (PRESENT(ecoul_1c)) THEN + IF (PRESENT(ecoul_1c)) & CALL get_hartree_local(qs_env%hartree_local, ecoul_1c=ecoul_1c) - END IF IF (PRESENT(rho0_s_rs)) THEN CALL get_local_rho(qs_env%local_rho_set, rho0_mpole=rho0_m) IF (ASSOCIATED(rho0_m)) THEN @@ -1011,7 +1001,6 @@ CONTAINS IF (.NOT. ASSOCIATED(qs_env%molecular_scf_guess_env)) ALLOCATE (qs_env%molecular_scf_guess_env) NULLIFY (qs_env%tb_tblite) - NULLIFY (qs_env%gauxc_cache) END SUBROUTINE init_qs_env @@ -1496,12 +1485,10 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) THEN + IF (ASSOCIATED(qs_env%gradient_history)) & DEALLOCATE (qs_env%gradient_history) - END IF - IF (ASSOCIATED(qs_env%variable_history)) THEN + IF (ASSOCIATED(qs_env%variable_history)) & DEALLOCATE (qs_env%variable_history) - END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) @@ -1693,11 +1680,6 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF - IF (ASSOCIATED(qs_env%gauxc_cache)) THEN - CALL gauxc_cache_release(qs_env%gauxc_cache) - DEALLOCATE (qs_env%gauxc_cache) - END IF - END SUBROUTINE qs_env_release ! ************************************************************************************************** @@ -1735,12 +1717,10 @@ CONTAINS DEALLOCATE (qs_env%outer_scf_history) qs_env%outer_scf_ihistory = 0 END IF - IF (ASSOCIATED(qs_env%gradient_history)) THEN + IF (ASSOCIATED(qs_env%gradient_history)) & DEALLOCATE (qs_env%gradient_history) - END IF - IF (ASSOCIATED(qs_env%variable_history)) THEN + IF (ASSOCIATED(qs_env%variable_history)) & DEALLOCATE (qs_env%variable_history) - END IF IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN CALL local_rho_set_release(qs_env%local_rho_set) @@ -1924,11 +1904,6 @@ CONTAINS CALL deallocate_tblite_type(qs_env%tb_tblite) END IF - IF (ASSOCIATED(qs_env%gauxc_cache)) THEN - CALL gauxc_cache_release(qs_env%gauxc_cache) - DEALLOCATE (qs_env%gauxc_cache) - END IF - END SUBROUTINE qs_env_part_release END MODULE qs_environment_types diff --git a/src/qs_external_potential.F b/src/qs_external_potential.F index e77b4b3655..ec813c6695 100644 --- a/src/qs_external_potential.F +++ b/src/qs_external_potential.F @@ -91,7 +91,7 @@ CONTAINS qs_env%sim_step, qs_env%sim_time, & scaling_factor) dft_control%eval_external_potential = .FALSE. - ELSE IF (dft_control%expot_control%read_from_cube) THEN + ELSEIF (dft_control%expot_control%read_from_cube) THEN scaling_factor = dft_control%expot_control%scaling_factor CALL cp_cube_to_pw(v_ee, 'pot.cube', scaling_factor) dft_control%eval_external_potential = .FALSE. diff --git a/src/qs_fb_env_types.F b/src/qs_fb_env_types.F index 0b0173c14b..3b580c1ac1 100644 --- a/src/qs_fb_env_types.F +++ b/src/qs_fb_env_types.F @@ -266,33 +266,24 @@ CONTAINS CPASSERT(ASSOCIATED(fb_env%obj)) CPASSERT(fb_env%obj%ref_count > 0) - IF (PRESENT(rcut)) THEN + IF (PRESENT(rcut)) & rcut => fb_env%obj%rcut - END IF - IF (PRESENT(filter_temperature)) THEN + IF (PRESENT(filter_temperature)) & filter_temperature = fb_env%obj%filter_temperature - END IF - IF (PRESENT(auto_cutoff_scale)) THEN + IF (PRESENT(auto_cutoff_scale)) & auto_cutoff_scale = fb_env%obj%auto_cutoff_scale - END IF - IF (PRESENT(eps_default)) THEN + IF (PRESENT(eps_default)) & eps_default = fb_env%obj%eps_default - END IF - IF (PRESENT(atomic_halos)) THEN + IF (PRESENT(atomic_halos)) & CALL fb_atomic_halo_list_associate(atomic_halos, fb_env%obj%atomic_halos) - END IF - IF (PRESENT(trial_fns)) THEN + IF (PRESENT(trial_fns)) & CALL fb_trial_fns_associate(trial_fns, fb_env%obj%trial_fns) - END IF - IF (PRESENT(collective_com)) THEN + IF (PRESENT(collective_com)) & collective_com = fb_env%obj%collective_com - END IF - IF (PRESENT(local_atoms)) THEN + IF (PRESENT(local_atoms)) & local_atoms => fb_env%obj%local_atoms - END IF - IF (PRESENT(nlocal_atoms)) THEN + IF (PRESENT(nlocal_atoms)) & nlocal_atoms = fb_env%obj%nlocal_atoms - END IF END SUBROUTINE fb_env_get ! ********************************************************************** @@ -338,38 +329,32 @@ CONTAINS END IF fb_env%obj%rcut => rcut END IF - IF (PRESENT(filter_temperature)) THEN + IF (PRESENT(filter_temperature)) & fb_env%obj%filter_temperature = filter_temperature - END IF - IF (PRESENT(auto_cutoff_scale)) THEN + IF (PRESENT(auto_cutoff_scale)) & fb_env%obj%auto_cutoff_scale = auto_cutoff_scale - END IF - IF (PRESENT(eps_default)) THEN + IF (PRESENT(eps_default)) & fb_env%obj%eps_default = eps_default - END IF IF (PRESENT(atomic_halos)) THEN CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos) CALL fb_atomic_halo_list_associate(fb_env%obj%atomic_halos, atomic_halos) END IF IF (PRESENT(trial_fns)) THEN - IF (fb_trial_fns_has_data(trial_fns)) THEN + IF (fb_trial_fns_has_data(trial_fns)) & CALL fb_trial_fns_retain(trial_fns) - END IF CALL fb_trial_fns_release(fb_env%obj%trial_fns) CALL fb_trial_fns_associate(fb_env%obj%trial_fns, trial_fns) END IF - IF (PRESENT(collective_com)) THEN + IF (PRESENT(collective_com)) & fb_env%obj%collective_com = collective_com - END IF IF (PRESENT(local_atoms)) THEN IF (ASSOCIATED(fb_env%obj%local_atoms)) THEN DEALLOCATE (fb_env%obj%local_atoms) END IF fb_env%obj%local_atoms => local_atoms END IF - IF (PRESENT(nlocal_atoms)) THEN + IF (PRESENT(nlocal_atoms)) & fb_env%obj%nlocal_atoms = nlocal_atoms - END IF END SUBROUTINE fb_env_set END MODULE qs_fb_env_types diff --git a/src/qs_fb_filter_matrix_methods.F b/src/qs_fb_filter_matrix_methods.F index 5b94b8fdc0..1be7bcdc2a 100644 --- a/src/qs_fb_filter_matrix_methods.F +++ b/src/qs_fb_filter_matrix_methods.F @@ -480,7 +480,7 @@ CONTAINS INTEGER :: handle, handle_mpi, iatom_global, iatom_in_halo, ind, ipair, ipe, itrial, & jatom_global, jatom_in_halo, jkind, natoms_global, natoms_in_halo, ncols_atmatrix, & - ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode + ncols_blk, nrows_atmatrix, nrows_blk, numprocs, pe, recv_encode, send_encode, stat INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs_recv, pairs_send INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data, ind_in_halo, & @@ -583,7 +583,9 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1)) + atomic_H_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -601,7 +603,9 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1)) + atomic_S_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -793,7 +797,7 @@ CONTAINS INTEGER :: handle, iatom_global, iatom_in_halo, itrial, jatom_global, jatom_in_halo, jkind, & natoms_global, natoms_in_halo, ncols_atmatrix, ncols_blk, ncols_blk_max, nrows_atmatrix, & - nrows_blk, nrows_blk_max + nrows_blk, nrows_blk_max, stat INTEGER, ALLOCATABLE, DIMENSION(:) :: atomic_H_blk_col_start, atomic_H_blk_row_start, & atomic_S_blk_col_start, atomic_S_blk_row_start, col_block_size_data INTEGER, DIMENSION(:), POINTER :: halo_atoms, ntfns, row_block_size_data @@ -837,7 +841,9 @@ CONTAINS ! construct atomic matrix for H for atomic_halo ALLOCATE (atomic_H_blk_row_start(natoms_in_halo + 1), & - atomic_H_blk_col_start(natoms_in_halo + 1)) + atomic_H_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & @@ -853,7 +859,9 @@ CONTAINS ! construct atomic matrix for S for atomic_halo ALLOCATE (atomic_S_blk_row_start(natoms_in_halo + 1), & - atomic_S_blk_col_start(natoms_in_halo + 1)) + atomic_S_blk_col_start(natoms_in_halo + 1), & + STAT=stat) + CPASSERT(stat == 0) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & @@ -898,6 +906,9 @@ CONTAINS nrows_blk = row_block_size_data(iatom_global) ncols_blk = ntfns(jkind) + ! ALLOCATE(mat_blk(nrows_blk,ncols_blk) STAT=stat) + ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) + ! do it column-wise one trial function at a time DO itrial = 1, ntfns(jkind) CALL dgemv("N", & diff --git a/src/qs_force.F b/src/qs_force.F index ab1f8d5ece..3bf365e4c1 100644 --- a/src/qs_force.F +++ b/src/qs_force.F @@ -227,9 +227,8 @@ CONTAINS CALL calc_c_mat_force(qs_env) IF (dft_control%do_admm) CALL rt_admm_force(qs_env) - IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) THEN + IF (dft_control%rtp_control%velocity_gauge .AND. dft_control%rtp_control%nl_gauge_transform) & CALL velocity_gauge_nl_force(qs_env, particle_set) - END IF END IF ! from an eventual Mulliken restraint IF (dft_control%qs_control%mulliken_restraint) THEN @@ -287,18 +286,18 @@ CONTAINS CALL build_se_core_matrix(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.TRUE.) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env, & calculate_forces=.TRUE.) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_matrices(qs_env=qs_env, calculate_forces=.TRUE.) ELSE CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) END IF - ELSE IF (perform_ec) THEN + ELSEIF (perform_ec) THEN ! Calculates core and grid based forces CALL energy_correction(qs_env, ec_init=.FALSE., calculate_forces=.TRUE.) ELSE @@ -306,12 +305,10 @@ CONTAINS CALL build_core_hamiltonian_matrix(qs_env=qs_env, calculate_forces=.TRUE.) ! The above line reset the core H, which should be re-updated in case a TD field is applied: IF (qs_env%run_rtp) THEN - IF (dft_control%apply_efield_field) THEN + IF (dft_control%apply_efield_field) & CALL efield_potential_lengh_gauge(qs_env) - END IF - IF (dft_control%rtp_control%velocity_gauge) THEN + IF (dft_control%rtp_control%velocity_gauge) & CALL velocity_gauge_ks_matrix(qs_env, subtract_nl_term=.FALSE.) - END IF END IF CALL calculate_ecore_self(qs_env) @@ -371,9 +368,9 @@ CONTAINS t3=dummy_real) END IF END IF - ELSE IF (perform_ec) THEN + ELSEIF (perform_ec) THEN ! energy correction forces postponed - ELSE IF (qs_env%harris_method) THEN + ELSEIF (qs_env%harris_method) THEN ! Harris method forces already done in harris_energy_correction ELSE ! Compute grid-based forces diff --git a/src/qs_fxc.F b/src/qs_fxc.F index 1380dc5c1d..6fe283637e 100644 --- a/src/qs_fxc.F +++ b/src/qs_fxc.F @@ -371,9 +371,8 @@ CONTAINS END DO ! Create fields for mGGA functionals. This implementation is not ready yet! IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) THEN + IF (.NOT. ASSOCIATED(tau1_r)) & CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") - END IF ALLOCATE (fxc_tau(spindim), gxc_tau(nspins)) DO ispin = 1, spindim CALL pw_pool%create_pw(fxc_tau(ispin)) diff --git a/src/qs_gapw_densities.F b/src/qs_gapw_densities.F index 2aaa407afc..567c7e99bb 100644 --- a/src/qs_gapw_densities.F +++ b/src/qs_gapw_densities.F @@ -158,11 +158,10 @@ CONTAINS END IF !Calculate rho0_h and rho0_s on the radial grids centered on the atomic position - IF (my_do_rho0) THEN + IF (my_do_rho0) & CALL calculate_rho0_atom(gapw_control, rho_atom_set, rhoz_cneo_set, rho0_atom_set, & rho0_mpole, atom_list, natom, ikind, my_kind_set(ikind), & rho0_h_tot) - END IF END DO !Do not mess with charges if using a non-default kind_set diff --git a/src/qs_gspace_mixing.F b/src/qs_gspace_mixing.F index e88926315d..eb64b2fbfa 100644 --- a/src/qs_gspace_mixing.F +++ b/src/qs_gspace_mixing.F @@ -164,25 +164,25 @@ CONTAINS CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSE IF (mixing_method == gspace_mixing_nr) THEN + ELSEIF (mixing_method == gspace_mixing_nr) THEN CALL cite_reference(Kerker1981) CALL gmix_potential_only(qs_env, mixing_store, rho) mixing_store%iter_method = "Kerker" - ELSE IF (mixing_method == pulay_mixing_nr) THEN + ELSEIF (mixing_method == pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Pulay" - ELSE IF (mixing_method == new_pulay_mixing_nr) THEN + ELSEIF (mixing_method == new_pulay_mixing_nr) THEN CALL pulay_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "NPulay" - ELSE IF (mixing_method == broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr) THEN CALL cite_reference(Broyden1965) CALL broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "Broy." - ELSE IF (mixing_method == modified_broyden_mixing_nr) THEN + ELSEIF (mixing_method == modified_broyden_mixing_nr) THEN CALL cite_reference(Johnson1988) CALL modified_broyden_mixing(qs_env, mixing_store, rho, para_env) mixing_store%iter_method = "MBroy" - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN CPASSERT(.NOT. gapw) CALL multisecant_mixing(mixing_store, rho, para_env) mixing_store%iter_method = "MSec." @@ -1446,7 +1446,7 @@ CONTAINS DO jb = 1, nb + 1 IF (jb < ib) THEN kb = jb - ELSE IF (jb > ib) THEN + ELSEIF (jb > ib) THEN kb = jb - 1 ELSE CYCLE @@ -1564,7 +1564,7 @@ CONTAINS AIMAG(pgn(ig))*AIMAG(pgn(ig)) END DO CALL para_env%sum(pgn_norm) - ELSE IF (use_zgemm_rev) THEN + ELSEIF (use_zgemm_rev) THEN CALL zgemv("N", nb, ng_global, cone, a_matrix(1, 1), & nb, gn_global(1), 1, czero, tmp_vec(1), 1) diff --git a/src/qs_initial_guess.F b/src/qs_initial_guess.F index 0df0b262a5..5c5acca6c7 100644 --- a/src/qs_initial_guess.F +++ b/src/qs_initial_guess.F @@ -330,9 +330,8 @@ CONTAINS IF (j /= 0) THEN filename = TRIM(file_name)//".bak-"//ADJUSTL(cp_to_string(j)) END IF - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & INQUIRE (FILE=filename, exist=exist) - END IF CALL para_env%bcast(exist) IF ((.NOT. exist) .AND. (i < not_read)) THEN not_read = i @@ -418,7 +417,7 @@ CONTAINS IF (has_unit_metric) THEN CALL make_basis_simple(mo_coeff, nmo) - ELSE IF (dft_control%smear) THEN + ELSEIF (dft_control%smear) THEN CALL make_basis_lowdin(vmatrix=mo_coeff, ncol=nmo, & matrix_s=s_sparse(1)%matrix) ELSE @@ -938,11 +937,11 @@ CONTAINS WRITE (ounit, *) 'wrong', i, SUM(buff**2) END IF END IF - length = NORM2(buff(:, 1)) + length = SQRT(DOT_PRODUCT(buff(:, 1), buff(:, 1))) buff(:, :) = buff(:, :)/length DO j = i + 1, nmo CALL cp_fm_get_submatrix(mo_coeff, buff2, 1, j, nao, 1) - length = NORM2(buff2(:, 1)) + length = SQRT(DOT_PRODUCT(buff2(:, 1), buff2(:, 1))) buff2(:, :) = buff2(:, :)/length IF (ABS(DOT_PRODUCT(buff(:, 1), buff2(:, 1)) - 1.0_dp) < 1E-10_dp) THEN IF (ounit > 0) THEN @@ -1290,10 +1289,10 @@ CONTAINS lmax=maxll, occupation=edftb) maxll = MIN(maxll, maxl) econf(0:maxl) = edftb(0:maxl) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL get_qs_kind(qs_kind_set(ikind), xtb_parameter=xtb_kind) CALL get_xtb_atom_param(xtb_kind, z=z, natorb=nsgf, nao=naox, lao=laox, occupation=occupation) - ELSE IF (has_pot) THEN + ELSEIF (has_pot) THEN CALL get_atomic_kind(atomic_kind_set(ikind), z=z) CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff) maxll = MIN(SIZE(elec_conf) - 1, maxl) @@ -1335,7 +1334,7 @@ CONTAINS END SELECT END DO END DO - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN DO iatom = 1, natom atom_a = atom_list(iatom) isgfa = first_sgf(atom_a) @@ -1352,7 +1351,7 @@ CONTAINS END DO END IF END DO - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN yy = REAL(dft_control%charge, KIND=dp)/REAL(nao, KIND=dp) DO iatom = 1, natom atom_a = atom_list(iatom) diff --git a/src/qs_integrate_potential_product.F b/src/qs_integrate_potential_product.F index e99302334e..decbe53525 100644 --- a/src/qs_integrate_potential_product.F +++ b/src/qs_integrate_potential_product.F @@ -417,58 +417,54 @@ CONTAINS END IF IF (iatom <= jatom) THEN - IF (iatom == lambda) THEN + IF (iatom == lambda) & CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) - END IF - IF (jatom == lambda) THEN + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) + IF (jatom == lambda) & CALL integrate_pgf_product( & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - ra, rab, rs_rho(igrid_level), & - hab, o1=na1 - 1, o2=nb1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) - END IF + la_max(iset), zeta(ipgf, iset), la_min(iset), & + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + ra, rab, rs_rho(igrid_level), & + hab, o1=na1 - 1, o2=nb1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) ELSE rab_inv = -rab - IF (iatom == lambda) THEN + IF (iatom == lambda) & CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hadb=hadb, pab=pab) - END IF - IF (jatom == lambda) THEN + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hadb=hadb, pab=pab) + IF (jatom == lambda) & CALL integrate_pgf_product( & - lb_max(jset), zetb(jpgf, jset), lb_min(jset), & - la_max(iset), zeta(ipgf, iset), la_min(iset), & - rb, rab_inv, rs_rho(igrid_level), & - hab, o1=nb1 - 1, o2=na1 - 1, & - radius=radius, & - calculate_forces=.TRUE., & - force_a=force_b, force_b=force_a, & - compute_tau=.FALSE., & - use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & - hdab=hdab, pab=pab) - END IF + lb_max(jset), zetb(jpgf, jset), lb_min(jset), & + la_max(iset), zeta(ipgf, iset), la_min(iset), & + rb, rab_inv, rs_rho(igrid_level), & + hab, o1=nb1 - 1, o2=na1 - 1, & + radius=radius, & + calculate_forces=.TRUE., & + force_a=force_b, force_b=force_a, & + compute_tau=.FALSE., & + use_subpatch=use_subpatch, subpatch_pattern=tasks(itask)%subpatch_pattern, & + hdab=hdab, pab=pab) END IF new_set_pair_coming = .FALSE. diff --git a/src/qs_kind_types.F b/src/qs_kind_types.F index 3367d1ec57..8928bc4553 100644 --- a/src/qs_kind_types.F +++ b/src/qs_kind_types.F @@ -1008,7 +1008,7 @@ CONTAINS IF (PRESENT(maxlppl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nexp_ppl=n) maxlppl = MAX(maxlppl, 2*(n - 1)) - ELSE IF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSEIF (PRESENT(maxlppl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nrloc=nrloc, ecp_semi_local=ecp_semi_local) n = MAXVAL(nrloc) - 2 maxlppl = MAX(maxlppl, 2*(n - 1)) @@ -1023,7 +1023,7 @@ CONTAINS IF (PRESENT(maxlppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, lprj_ppnl_max=imax) maxlppnl = MAX(maxlppnl, imax) - ELSE IF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSEIF (PRESENT(maxlppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, lmax=imax) maxlppnl = MAX(maxlppnl, imax) END IF @@ -1046,7 +1046,7 @@ CONTAINS IF (PRESENT(maxppnl) .AND. ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) - ELSE IF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN + ELSEIF (PRESENT(maxppnl) .AND. ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, nppnl=imax) maxppnl = MAX(maxppnl, imax) END IF @@ -1327,7 +1327,7 @@ CONTAINS IF (ASSOCIATED(qs_kind%gth_potential)) THEN CALL init_potential(qs_kind%gth_potential) - ELSE IF (ASSOCIATED(qs_kind%sgp_potential)) THEN + ELSEIF (ASSOCIATED(qs_kind%sgp_potential)) THEN CALL init_potential(qs_kind%sgp_potential) END IF @@ -1790,12 +1790,12 @@ CONTAINS basis_set_type(i) = "ORB" basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(1) - ELSE IF (SIZE(tmpstringlist) == 2) THEN + ELSEIF (SIZE(tmpstringlist) == 2) THEN ! default is GTO basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = "GTO" basis_set_name(i) = tmpstringlist(2) - ELSE IF (SIZE(tmpstringlist) == 3) THEN + ELSEIF (SIZE(tmpstringlist) == 3) THEN basis_set_type(i) = tmpstringlist(1) basis_set_form(i) = tmpstringlist(2) basis_set_name(i) = tmpstringlist(3) @@ -1876,7 +1876,7 @@ CONTAINS potential_type = potential_name END IF END IF - ELSE IF (SIZE(tmpstringlist) == 2) THEN + ELSEIF (SIZE(tmpstringlist) == 2) THEN potential_type = tmpstringlist(1) potential_name = tmpstringlist(2) ELSE @@ -1930,22 +1930,19 @@ CONTAINS CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RHO0_EXP_RADIUS", r_val=qs_kind%hard0_radius) END IF - IF (qs_kind%hard_radius < qs_kind%hard0_radius) THEN + IF (qs_kind%hard_radius < qs_kind%hard0_radius) & CPABORT("rc0 should be <= rc") - END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="MAX_RAD_LOCAL", r_val=qs_kind%max_rad_local) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="LEBEDEV_GRID", i_val=qs_kind%ngrid_ang) - IF (qs_kind%ngrid_ang <= 0) THEN + IF (qs_kind%ngrid_ang <= 0) & CPABORT("# point lebedev grid < 0") - END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="RADIAL_GRID", i_val=qs_kind%ngrid_rad) - IF (qs_kind%ngrid_rad <= 0) THEN + IF (qs_kind%ngrid_rad <= 0) & CPABORT("# point radial grid < 0") - END IF CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & keyword_name="GPW_TYPE", l_val=qs_kind%gpw_type_forced) CALL section_vals_val_get(kind_section, i_rep_section=k_rep, & @@ -2149,25 +2146,21 @@ CONTAINS keyword_name="ORBITALS", & i_vals=orbitals) norbitals = SIZE(orbitals) - IF (norbitals <= 0 .OR. norbitals > 2*l + 1) THEN + IF (norbitals <= 0 .OR. norbitals > 2*l + 1) & CALL cp_abort(__LOCATION__, "DFT+U| Invalid number of ORBITALS specified: "// & "1 to 2*L+1 integer numbers are expected") - END IF ALLOCATE (qs_kind%dft_plus_u%orbitals(norbitals)) qs_kind%dft_plus_u%orbitals(:) = orbitals(:) NULLIFY (orbitals) DO m = 1, norbitals - IF (qs_kind%dft_plus_u%orbitals(m) > l) THEN + IF (qs_kind%dft_plus_u%orbitals(m) > l) & CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m > l") - END IF - IF (qs_kind%dft_plus_u%orbitals(m) < -l) THEN + IF (qs_kind%dft_plus_u%orbitals(m) < -l) & CPABORT("DFT+U| Invalid orbital magnetic quantum number specified: m < -l") - END IF DO j = 1, norbitals IF (j /= m) THEN - IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) THEN + IF (qs_kind%dft_plus_u%orbitals(j) == qs_kind%dft_plus_u%orbitals(m)) & CPABORT("DFT+U| An orbital magnetic quantum number was specified twice") - END IF END IF END DO END DO @@ -2261,18 +2254,16 @@ CONTAINS qs_kind%se_parameter%zeff = qs_kind%se_parameter%zeff - zeff_correction check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF CASE (do_method_dftb) ! Allocate all_potential @@ -2296,18 +2287,16 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF CASE (do_method_xtb) ! Allocate all_potential @@ -2331,18 +2320,16 @@ CONTAINS END IF check = ((potential_name /= '') .OR. explicit_potential) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding POTENTIAL for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF check = ((k_rep > 0) .OR. explicit_basis) .AND. .NOT. silent - IF (check) THEN + IF (check) & CALL cp_warn(__LOCATION__, & "Information provided in the input file regarding BASIS for KIND <"// & TRIM(qs_kind%name)//"> will be ignored!") - END IF CASE (do_method_pw) ! PW DFT @@ -2658,9 +2645,8 @@ CONTAINS CALL atom_release_upf(upfpot) CALL atom_sgp_release(sgppot) CASE ("CNEO") - IF (zeff_correction /= 0.0_dp) THEN + IF (zeff_correction /= 0.0_dp) & CPABORT("CORE_CORRECTION is not compatible with CNEO") - END IF CALL allocate_cneo_potential(qs_kind%cneo_potential) CALL set_cneo_potential(qs_kind%cneo_potential, z=z) mass = 0.0_dp @@ -2787,17 +2773,14 @@ CONTAINS CALL get_qs_kind(qs_kind, name=name, gth_potential=gth_potential, basis_set=basis_set) npp = -1; nbs = -1 - IF (ASSOCIATED(gth_potential)) THEN + IF (ASSOCIATED(gth_potential)) & npp = parse_valence_electrons(gth_potential%aliases) - END IF - IF (ASSOCIATED(basis_set)) THEN + IF (ASSOCIATED(basis_set)) & nbs = parse_valence_electrons(basis_set%aliases) - END IF - IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) THEN + IF (npp >= 0 .AND. nbs >= 0 .AND. npp /= nbs) & CALL cp_abort(__LOCATION__, "Basis-set and pseudo-potential of atomic kind '"//TRIM(name)//"'"// & " were optimized for different valence electron numbers.") - END IF END SUBROUTINE check_potential_basis_compatibility @@ -4003,7 +3986,7 @@ CONTAINS IF (ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential, nlcc_present=nlcc_present) nlcc = nlcc .OR. nlcc_present - ELSE IF (ASSOCIATED(sgp_potential)) THEN + ELSEIF (ASSOCIATED(sgp_potential)) THEN CALL get_potential(potential=sgp_potential, has_nlcc=nlcc_present) nlcc = nlcc .OR. nlcc_present END IF diff --git a/src/qs_kinetic.F b/src/qs_kinetic.F index e9926351ad..b743911176 100644 --- a/src/qs_kinetic.F +++ b/src/qs_kinetic.F @@ -220,7 +220,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSE IF (PRESENT(matrixkp_t)) THEN + ELSEIF (PRESENT(matrixkp_t)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -279,7 +279,7 @@ CONTAINS ELSE IF (PRESENT(matrix_p)) THEN matp => matrix_p - ELSE IF (PRESENT(matrixkp_p)) THEN + ELSEIF (PRESENT(matrixkp_p)) THEN matp => matrixkp_p(1, 1)%matrix ELSE CPABORT("Missing density matrix") diff --git a/src/qs_kpp1_env_methods.F b/src/qs_kpp1_env_methods.F index 504224f6c8..2ff3fe8229 100644 --- a/src/qs_kpp1_env_methods.F +++ b/src/qs_kpp1_env_methods.F @@ -200,9 +200,8 @@ CONTAINS poisson_env=poisson_env) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) THEN + IF (gapw .OR. gapw_xc) & CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) - END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -455,7 +454,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=my_calc_forces, tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) diff --git a/src/qs_ks_apply_restraints.F b/src/qs_ks_apply_restraints.F index 79524ca9f1..d2d9c792c7 100644 --- a/src/qs_ks_apply_restraints.F +++ b/src/qs_ks_apply_restraints.F @@ -83,25 +83,22 @@ CONTAINS CALL auxbas_pw_pool%create_pw(cdft_control%group(igroup)%weight) ! Sanity check IF (cdft_control%group(igroup)%constraint_type /= cdft_charge_constraint & - .AND. dft_control%nspins == 1) THEN + .AND. dft_control%nspins == 1) & CALL cp_abort(__LOCATION__, & "Spin constraints require a spin polarized calculation.") - END IF END DO IF (cdft_control%atomic_charges) THEN - IF (.NOT. ASSOCIATED(cdft_control%charge)) THEN + IF (.NOT. ASSOCIATED(cdft_control%charge)) & ALLOCATE (cdft_control%charge(cdft_control%natoms)) - END IF DO iatom = 1, cdft_control%natoms CALL auxbas_pw_pool%create_pw(cdft_control%charge(iatom)) END DO END IF ! Another sanity check CALL get_qs_env(qs_env, natom=natom) - IF (natom < cdft_control%natoms) THEN + IF (natom < cdft_control%natoms) & CALL cp_abort(__LOCATION__, & "The number of constraint atoms exceeds the total number of atoms.") - END IF ELSE DO igroup = 1, SIZE(cdft_control%group) inv_vol = 1.0_dp/cdft_control%group(igroup)%weight%pw_grid%dvol diff --git a/src/qs_ks_atom.F b/src/qs_ks_atom.F index 891c94351b..fbf62a1fe3 100644 --- a/src/qs_ks_atom.F +++ b/src/qs_ks_atom.F @@ -649,14 +649,14 @@ CONTAINS 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (dista) THEN + ELSEIF (dista) THEN CALL DGEMM('N', 'T', nsp, ncontb, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_b(:, :, 1), SIZE(C_hh_b, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, ncontb, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & C_ss_b(:, :, 1), SIZE(C_ss_b, 1), 1.0_dp, coc, nsp) CALL DGEMM('N', 'N', nconta, ncontb, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & coc, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (distb) THEN + ELSEIF (distb) THEN CALL DGEMM('N', 'N', nconta, nsp, nsp, factor, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, nconta) CALL DGEMM('N', 'N', nconta, nsp, nsp, -factor, C_ss_a(:, :, 1), SIZE(C_ss_a, 1), & @@ -692,14 +692,14 @@ CONTAINS CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, coc, nsp, C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, C_int_h, nsp) CALL DGEMM('N', 'N', ncontb, nconta, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & C_int_h, nsp, 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (dista) THEN + ELSEIF (dista) THEN CALL DGEMM('N', 'N', ncontb, nsp, nsp, factor, C_hh_b(:, :, 1), SIZE(C_hh_b, 1), & int_hard, SIZE(int_hard, 1), 0.0_dp, coc, ncontb) CALL DGEMM('N', 'N', ncontb, nsp, nsp, -factor, C_ss_b(:, :, 1), SIZE(C_ss_b, 1), & int_soft, SIZE(int_soft, 1), 1.0_dp, coc, ncontb) CALL DGEMM('N', 'T', ncontb, nconta, nsp, 1.0_dp, coc, ncontb, & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, a_matrix, SIZE(a_matrix, 1)) - ELSE IF (distb) THEN + ELSEIF (distb) THEN CALL DGEMM('N', 'T', nsp, nconta, nsp, 1.0_dp, int_hard, SIZE(int_hard, 1), & C_hh_a(:, :, 1), SIZE(C_hh_a, 1), 0.0_dp, coc, nsp) CALL DGEMM('N', 'T', nsp, nconta, nsp, -1.0_dp, int_soft, SIZE(int_soft, 1), & diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index a2cf906d65..652655dae1 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -143,7 +143,6 @@ MODULE qs_ks_methods get_gauxc_section,& xc_section_uses_native_skala_grid USE smeagol_interface, ONLY: smeagol_shift_v_hartree - USE string_utilities, ONLY: uppercase USE surface_dipole, ONLY: calc_dipsurf_potential USE tblite_ks_matrix, ONLY: build_tblite_ks_matrix USE virial_types, ONLY: virial_type @@ -200,15 +199,14 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_build_kohn_sham_matrix' - CHARACTER(len=default_string_length) :: gauxc_model_name, name + CHARACTER(len=default_string_length) :: name INTEGER :: ace_rebuild_frequency, atom_a, handle, & iatom, ikind, img, ispin, natom, & nimages, nspins, output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, kind_of LOGICAL :: ace_active, do_adiabatic_rescaling, do_ddapc, do_hfx, do_kpoints, do_ppl, dokp, & - gapw, gapw_xc, gauxc_model_none, just_energy_xc, lrigpw, my_print, & - native_grid_diagnostics, native_grid_use_cuda, native_skala_restore_exc, rigpw, & - use_gauxc_matrix, use_virial + gapw, gapw_xc, just_energy_xc, lrigpw, my_print, native_grid_diagnostics, & + native_grid_use_cuda, native_skala_restore_exc, rigpw, use_gauxc_matrix, use_virial LOGICAL, SAVE :: native_grid_cpu_kpoints_warned = .FALSE. REAL(KIND=dp) :: ecore_ppl, edisp, ee_ener, ekin_mol, & mulliken_order_p, & @@ -577,7 +575,7 @@ CONTAINS CALL admm_mo_calc_rho_aux(qs_env) END IF END IF - ELSE IF (dft_control%do_admm_dm) THEN + ELSEIF (dft_control%do_admm_dm) THEN CALL admm_dm_calc_rho_aux(qs_env) END IF END IF @@ -924,19 +922,12 @@ CONTAINS NULLIFY (rho1) IF (dft_control%use_gauxc .AND. (gapw .OR. gapw_xc) .AND. & .NOT. xc_section_uses_native_skala_grid(xc_section)) THEN - gauxc_model_none = .FALSE. - gauxc_section => get_gauxc_section(xc_section) - IF (ASSOCIATED(gauxc_section)) THEN - CALL section_vals_val_get(gauxc_section, "MODEL", c_val=gauxc_model_name) - gauxc_model_name = ADJUSTL(gauxc_model_name) - CALL uppercase(gauxc_model_name) - gauxc_model_none = (TRIM(gauxc_model_name) == "" .OR. & - TRIM(gauxc_model_name) == "NONE") - END IF - IF (gauxc_model_none .AND. & - (gapw_xc .OR. gauxc_gapw_has_paw_pseudopotentials(qs_kind_set))) THEN - CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) - END IF + ! Molecular GauXC evaluates the XC term outside xc_derivatives. + ! The accurate-XCINT force correction would otherwise try to + ! evaluate the GAUXC section through CP2K's local functional path. + ! Native-grid SKALA can provide this correction through the + ! CP2K grid path and needs it for GAPW_XC force consistency. + CONTINUE ELSE CALL accint_weight_force(qs_env, rho_struct, rho1, 0, xc_section) END IF @@ -1093,7 +1084,7 @@ CONTAINS ELSE CALL admm_mo_merge_ks_matrix(qs_env) END IF - ELSE IF (dft_control%do_admm_dm) THEN + ELSEIF (dft_control%do_admm_dm) THEN CALL admm_dm_merge_ks_matrix(qs_env) END IF @@ -1171,9 +1162,8 @@ CONTAINS IF (native_skala_restore_exc) energy%total = native_skala_total_scf - IF (abnormal_value(energy%total)) THEN + IF (abnormal_value(energy%total)) & CPABORT("KS energy is an abnormal value (NaN/Inf).") - END IF ! Print detailed energy IF (my_print) THEN @@ -1449,9 +1439,8 @@ CONTAINS END IF ! kinetic energy - IF (ASSOCIATED(matrixkp_t)) THEN + IF (ASSOCIATED(matrixkp_t)) & CALL calculate_ptrace(matrixkp_t, rho_ao_kp, energy%kinetic, dft_control%nspins) - END IF CALL timestop(handle) END SUBROUTINE evaluate_core_matrix_traces @@ -1484,12 +1473,12 @@ CONTAINS calculate_forces=calculate_forces, & just_energy=just_energy) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_ks_matrix(qs_env, & calculate_forces=calculate_forces, & just_energy=just_energy) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, & calculate_forces=calculate_forces, & diff --git a/src/qs_ks_types.F b/src/qs_ks_types.F index 0f6c029414..73e953562b 100644 --- a/src/qs_ks_types.F +++ b/src/qs_ks_types.F @@ -621,9 +621,8 @@ CONTAINS IF (PRESENT(potential_changed)) ks_env%potential_changed = potential_changed IF (PRESENT(forces_up_to_date)) ks_env%forces_up_to_date = forces_up_to_date IF (PRESENT(complex_ks)) ks_env%complex_ks = complex_ks - IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) THEN + IF (ks_env%s_mstruct_changed .OR. ks_env%potential_changed .OR. ks_env%rho_changed) & ks_env%forces_up_to_date = .FALSE. - END IF IF (PRESENT(exc_accint)) ks_env%exc_accint = exc_accint IF (PRESENT(v_hartree_rspace)) ks_env%v_hartree_rspace => v_hartree_rspace @@ -764,12 +763,10 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - END IF - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) - END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -778,15 +775,12 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%distribution_2d)) THEN + IF (ASSOCIATED(ks_env%distribution_2d)) & CALL distribution_2d_release(ks_env%distribution_2d) - END IF - IF (ASSOCIATED(ks_env%task_list)) THEN + IF (ASSOCIATED(ks_env%task_list)) & CALL deallocate_task_list(ks_env%task_list) - END IF - IF (ASSOCIATED(ks_env%task_list_soft)) THEN + IF (ASSOCIATED(ks_env%task_list_soft)) & CALL deallocate_task_list(ks_env%task_list_soft) - END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() @@ -875,12 +869,10 @@ CONTAINS CALL kpoint_transitional_release(ks_env%kinetic) CALL kpoint_transitional_release(ks_env%matrix_s_RI_aux) - IF (ASSOCIATED(ks_env%matrix_p_mp2)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) - END IF - IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) THEN + IF (ASSOCIATED(ks_env%matrix_p_mp2_admm)) & CALL dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2_admm) - END IF IF (ASSOCIATED(ks_env%rho)) THEN CALL qs_rho_release(ks_env%rho) DEALLOCATE (ks_env%rho) @@ -889,12 +881,10 @@ CONTAINS CALL qs_rho_release(ks_env%rho_xc) DEALLOCATE (ks_env%rho_xc) END IF - IF (ASSOCIATED(ks_env%task_list)) THEN + IF (ASSOCIATED(ks_env%task_list)) & CALL deallocate_task_list(ks_env%task_list) - END IF - IF (ASSOCIATED(ks_env%task_list_soft)) THEN + IF (ASSOCIATED(ks_env%task_list_soft)) & CALL deallocate_task_list(ks_env%task_list_soft) - END IF IF (ASSOCIATED(ks_env%xcint_weights)) THEN CALL ks_env%xcint_weights%release() diff --git a/src/qs_ks_utils.F b/src/qs_ks_utils.F index aa83ab16a1..98755af9bf 100644 --- a/src/qs_ks_utils.F +++ b/src/qs_ks_utils.F @@ -789,9 +789,8 @@ CONTAINS IF (dft_control%sic_method_id == sic_none) RETURN IF (dft_control%sic_method_id == sic_eo) RETURN - IF (dft_control%qs_control%gapw) THEN + IF (dft_control%qs_control%gapw) & CPABORT("sic and GAPW not yet compatible") - END IF ! OK, right now we like two spins to do sic, could be relaxed for AD CPASSERT(dft_control%nspins == 2) @@ -1132,22 +1131,18 @@ CONTAINS "Integral of the (density * v_xc): ", energy%exc END IF - IF (energy%e_hartree /= 0.0_dp) THEN + IF (energy%e_hartree /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Coulomb (electron-electron) energy: ", energy%e_hartree - END IF - IF (energy%dispersion /= 0.0_dp) THEN + "Coulomb (electron-electron) energy: ", energy%e_hartree + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Dispersion energy: ", energy%dispersion - END IF - IF (energy%efield /= 0.0_dp) THEN + "Dispersion energy: ", energy%dispersion + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "Electric field interaction energy: ", energy%efield - END IF - IF (energy%gcp /= 0.0_dp) THEN + "Electric field interaction energy: ", energy%efield + IF (energy%gcp /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T61,F20.10)") & - "gCP energy: ", energy%gcp - END IF + "gCP energy: ", energy%gcp IF (dft_control%qs_control%gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T61,F20.10))") & "GAPW| Exc from hard and soft atomic rho1: ", energy%exc1 + energy%exc1_aux_fit, & @@ -1535,7 +1530,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1639,7 +1634,7 @@ CONTAINS IF (lri_env%ppl_ri) THEN CALL v_int_ppl_update(qs_env, lri_v_int, calculate_forces) END IF - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind, para_env=para_env) DO ikind = 1, nkind @@ -1677,7 +1672,7 @@ CONTAINS IF (calculate_forces) THEN CALL calculate_lri_forces(lri_env, lri_density, qs_env, rho_ao_kp, atomic_kind_set) END IF - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN CALL get_qs_env(qs_env, matrix_s=smat) DO ispin = 1, nspins CALL calculate_ri_ks_matrix(lri_env, lri_v_int, ks_matrix(ispin, 1)%matrix, & diff --git a/src/qs_kubo_transport.F b/src/qs_kubo_transport.F index 68825aecb2..8ec3525d01 100644 --- a/src/qs_kubo_transport.F +++ b/src/qs_kubo_transport.F @@ -193,7 +193,7 @@ CONTAINS END IF IF (ALL(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "CP2K canonical MOs" - ELSE IF (ANY(reused_mos)) THEN + ELSEIF (ANY(reused_mos)) THEN WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "mixed canonical/internal" ELSE WRITE (output_unit, '(T3,A,T38,A)') "Eigensystem source:", "internal diagonalization" @@ -708,7 +708,7 @@ CONTAINS x = (eig - mu)/kT IF (x > 80.0_dp) THEN occ = 0.0_dp - ELSE IF (x < -80.0_dp) THEN + ELSEIF (x < -80.0_dp) THEN occ = maxocc ELSE occ = maxocc/(1.0_dp + EXP(x)) diff --git a/src/qs_linres_atom_current.F b/src/qs_linres_atom_current.F index a258a30e77..43eee3ff8c 100644 --- a/src/qs_linres_atom_current.F +++ b/src/qs_linres_atom_current.F @@ -266,11 +266,16 @@ CONTAINS NULLIFY (basis_1c_set, jp_RARnu, jp2_RARnu) ALLOCATE (a_block(nspins), b_block(nspins), c_block(nspins), d_block(nspins), & - jp_RARnu(nspins), jp2_RARnu(nspins)) + jp_RARnu(nspins), jp2_RARnu(nspins), & + STAT=istat) + CPASSERT(istat == 0) ALLOCATE (a_matrix(max_nsgf, max_nsgf), b_matrix(max_nsgf, max_nsgf), & - c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf)) - ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC)) + c_matrix(max_nsgf, max_nsgf), d_matrix(max_nsgf, max_nsgf), & + STAT=istat) + CPASSERT(istat == 0) + ALLOCATE (proj_work1(len_PC1), proj_work2(len_CPC), STAT=istat) + CPASSERT(istat == 0) !$OMP SINGLE !$ ALLOCATE (alloc_lock(natom)) @@ -597,9 +602,8 @@ CONTAINS END IF CALL para_env%sum(tmp_coeff) - IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) THEN + IF (ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef)) & nbr_dbl = nbr_dbl + 8.0_dp*REAL(SIZE(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef), dp) - END IF END DO ! ispin END DO ! iat diff --git a/src/qs_linres_current.F b/src/qs_linres_current.F index a0f155514c..400cc30712 100644 --- a/src/qs_linres_current.F +++ b/src/qs_linres_current.F @@ -1024,9 +1024,8 @@ CONTAINS IF (do_igaim) CALL dbcsr_get_block_p(matrix=deltajp_d(1)%matrix, row=brow, col=bcol, & block=jp_block_d, found=den_found) - IF (.NOT. ASSOCIATED(jp_block_a)) THEN + IF (.NOT. ASSOCIATED(jp_block_a)) & CPABORT("p_block not associated in deltap") - END IF iatom_old = iatom jatom_old = jatom diff --git a/src/qs_linres_current_utils.F b/src/qs_linres_current_utils.F index 49c842e78f..b31ce717f5 100644 --- a/src/qs_linres_current_utils.F +++ b/src/qs_linres_current_utils.F @@ -794,9 +794,8 @@ CONTAINS current_env%do_selected_states = n_rep > 0 ! ! for the moment selected states doesnt work with the preconditioner FULL_ALL - IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) THEN + IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) & CPABORT("Selected states doesnt work with the preconditioner FULL_ALL") - END IF ! ! NULLIFY (current_env%selected_states_on_atom_list) @@ -1161,7 +1160,7 @@ CONTAINS REPEAT(' ', 20 - LEN_TRIM(current_env%orb_center_name))//TRIM(current_env%orb_center_name) IF (current_env%orb_center == current_orb_center_common) THEN WRITE (output_unit, "(T2,A,T50,3F10.6)") "CURRENT| Common center", common_center(1:3) - ELSE IF (current_env%orb_center == current_orb_center_box) THEN + ELSEIF (current_env%orb_center == current_orb_center_box) THEN WRITE (output_unit, "(T2,A,T60,3I5)") "CURRENT| Nbr boxes in each direction", nbox(1:3) END IF ! diff --git a/src/qs_linres_epr_nablavks.F b/src/qs_linres_epr_nablavks.F index 6761fb1794..9a571ba003 100644 --- a/src/qs_linres_epr_nablavks.F +++ b/src/qs_linres_epr_nablavks.F @@ -631,7 +631,7 @@ CONTAINS rap(1) = MODULO(rap(1), cell%hmat(1, 1)) - cell%hmat(1, 1)/2._dp rap(2) = MODULO(rap(2), cell%hmat(2, 2)) - cell%hmat(2, 2)/2._dp rap(3) = MODULO(rap(3), cell%hmat(3, 3)) - cell%hmat(3, 3)/2._dp - sqrt_rap = NORM2(rap) + sqrt_rap = SQRT(DOT_PRODUCT(rap, rap)) exp_rap = EXP(-alpha*sqrt_rap**2) sqrt_rap = MAX(sqrt_rap, 1.e-10_dp) ! d_x diff --git a/src/qs_linres_issc_utils.F b/src/qs_linres_issc_utils.F index 44ed32e9f2..c02149d74f 100644 --- a/src/qs_linres_issc_utils.F +++ b/src/qs_linres_issc_utils.F @@ -200,8 +200,11 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) + !CALL cp_fm_to_fm(p_psi0(ispin,ijdir)%matrix, psi1(ispin)) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! + !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(efg_psi0(ispin, ijdir), h1_psi0(ispin)) END DO @@ -220,6 +223,18 @@ CONTAINS chk = chk + fro END DO ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_efg',& + ! idir=ijdir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -266,6 +281,18 @@ CONTAINS chk = chk + fro END DO ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_pso',& + ! idir=idir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -287,8 +314,11 @@ CONTAINS !Initial guess for psi1 DO ispin = 1, nspins CALL cp_fm_set_all(psi1(ispin), 0.0_dp) + !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)) END DO ! + !DO scf cycle to optimize psi1 DO ispin = 1, nspins CALL cp_fm_to_fm(fc_psi0(ispin), h1_psi0(ispin)) END DO @@ -307,6 +337,18 @@ CONTAINS chk = chk + fro END DO ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_pso',& + ! idir=idir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" @@ -352,6 +394,20 @@ CONTAINS fro = cp_fm_frobenius_norm(psi1(ispin)) chk = chk + fro END DO + ! + ! print response functions + !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN + ! ncubes = SIZE(list_cubes,1) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") + ! DO ispin = 1,nspins + ! CALL qs_print_cubes(qs_env,psi1(ispin),ncubes,list_cubes,& + ! centers_set(ispin)%array,print_key,'psi1_pso',& + ! idir=idir,ispin=ispin) + ! ENDDO ! ispin + !ENDIF ! print response functions + ! + ! IF (output_unit > 0) THEN WRITE (output_unit, "(T10,A)") "Write the resulting psi1 in restart file... not implemented yet" END IF @@ -544,6 +600,27 @@ CONTAINS ! !>>>>> for debugging we compute here the polarizability and NOT the DSO term! IF (do_dso .AND. iatom == natom .AND. jatom == natom) THEN + ! + ! build the integral for the jatom + !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(4)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(5)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(6)%matrix,0.0_dp) + !CALL build_dso_matrix(qs_env,matrix_dso,r_i,r_j) + !DO ixyz = 1,6 + ! CALL cp_sm_fm_multiply(matrix_dso(ixyz)%matrix,mo_coeff,& + ! & fc_psi0(ispin),ncol=nmo,& ! fc_psi0 a buffer + ! & alpha=1.0_dp,beta=0.0_dp) + ! CALL cp_fm_trace(fc_psi0(ispin),mo_coeff,buf) + ! issc_dso = 2.0_dp * maxocc * facdso * buf + ! issc(ixyz,jxyz,iatom,jatom,4) = issc_dso + !ENDDO + !CALL dbcsr_set(matrix_dso(1)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(2)%matrix,0.0_dp) + !CALL dbcsr_set(matrix_dso(3)%matrix,0.0_dp) + !CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1) DO ixyz = 1, 3 CALL cp_dbcsr_sm_fm_multiply(matrix_dso(ixyz)%matrix, mo_coeff, & fc_psi0(ispin), ncol=nmo,& ! fc_psi0 a buffer @@ -702,9 +779,9 @@ CONTAINS CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_env_init' - INTEGER :: handle, iatom, idir, ini, ir, ispin, m, & - n, n_rep, nao, natom, nspins, & - output_unit + INTEGER :: handle, iatom, idir, ini, ir, ispin, & + istat, m, n, n_rep, nao, natom, & + nspins, output_unit INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf, last_sgf INTEGER, DIMENSION(:), POINTER :: list, row_blk_sizes LOGICAL :: gapw @@ -764,10 +841,9 @@ CONTAINS natom = SIZE(particle_set, 1) ! ! check that the psi0 are localized and you have all the centers - IF (.NOT. linres_control%localized_psi0) THEN + IF (.NOT. linres_control%localized_psi0) & CALL cp_warn(__LOCATION__, 'To get indirect spin-spin coupling parameters within '// & 'PBC you need to localize zero order orbitals') - END IF ! ! ! read terms need to be calculated @@ -800,7 +876,8 @@ CONTAINS END DO ! IF (.NOT. ASSOCIATED(issc_env%issc_on_atom_list)) THEN - ALLOCATE (issc_env%issc_on_atom_list(natom)) + ALLOCATE (issc_env%issc_on_atom_list(natom), STAT=istat) + CPASSERT(istat == 0) DO iatom = 1, natom issc_env%issc_on_atom_list(iatom) = iatom END DO @@ -810,15 +887,20 @@ CONTAINS ! ! Initialize the issc tensor ALLOCATE (issc_env%issc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & - issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4)) + issc_env%issc_loc(3, 3, issc_env%issc_natms, issc_env%issc_natms, 4), & + STAT=istat) + CPASSERT(istat == 0) issc_env%issc(:, :, :, :, :) = 0.0_dp issc_env%issc_loc(:, :, :, :, :) = 0.0_dp ! ! allocation ALLOCATE (issc_env%efg_psi0(nspins, 6), issc_env%pso_psi0(nspins, 3), issc_env%fc_psi0(nspins), & issc_env%psi1_efg(nspins, 6), issc_env%psi1_pso(nspins, 3), issc_env%psi1_fc(nspins), & - issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3)) + issc_env%dso_psi0(nspins, 3), issc_env%psi1_dso(nspins, 3), & + STAT=istat) + CPASSERT(istat == 0) DO ispin = 1, nspins + !mo_coeff => current_env%psi0_order(ispin)%matrix CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff) CALL cp_fm_get_info(mo_coeff, ncol_global=m, nrow_global=nao) diff --git a/src/qs_linres_kernel.F b/src/qs_linres_kernel.F index a8d15ea670..c9ac0c1255 100644 --- a/src/qs_linres_kernel.F +++ b/src/qs_linres_kernel.F @@ -142,9 +142,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Linear response not available with SE methods") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("Linear response not available with DFTB") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL apply_op_2_xtb(qs_env, p_env) ELSE CALL apply_op_2_dft(qs_env, p_env) @@ -278,9 +278,8 @@ CONTAINS CALL auxbas_pw_pool%create_pw(v_hartree_gspace) CALL auxbas_pw_pool%create_pw(v_hartree_rspace) - IF (gapw .OR. gapw_xc) THEN + IF (gapw .OR. gapw_xc) & CALL prepare_gapw_den(qs_env, p_env%local_rho_set, do_rho0=(.NOT. gapw_xc)) - END IF ! *** calculate the hartree potential on the total density *** CALL auxbas_pw_pool%create_pw(rho1_tot_gspace) @@ -445,9 +444,8 @@ CONTAINS END IF IF (lrigpw) THEN - IF (ASSOCIATED(v_xc_tau)) THEN + IF (ASSOCIATED(v_xc_tau)) & CPABORT("metaGGA-functionals not supported with LRI!") - END IF lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds CALL get_qs_env(qs_env, nkind=nkind) @@ -508,7 +506,7 @@ CONTAINS psmat(1:ns, 1:1) => rho_ao(1:ns) CALL update_ks_atom(qs_env, ksmat, psmat, forces=.FALSE., tddft=.TRUE., & rho_atom_external=p_env%local_rho_set%rho_atom_set) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN ns = SIZE(p_env%kpp1) ksmat(1:ns, 1:1) => p_env%kpp1(1:ns) ns = SIZE(rho_ao) diff --git a/src/qs_linres_methods.F b/src/qs_linres_methods.F index ad5d4d0c72..f730cfc2cf 100644 --- a/src/qs_linres_methods.F +++ b/src/qs_linres_methods.F @@ -642,7 +642,7 @@ CONTAINS CALL qs_rho_update_rho(rho, qs_env=qs_env) ! that could be called before IF (dft_control%qs_control%gapw) THEN CALL prepare_gapw_den(qs_env) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL prepare_gapw_den(qs_env, do_rho0=.FALSE.) END IF diff --git a/src/qs_linres_module.F b/src/qs_linres_module.F index ff4d100b67..4da28f2d80 100644 --- a/src/qs_linres_module.F +++ b/src/qs_linres_module.F @@ -202,9 +202,8 @@ CONTAINS vcd_env%apt_total_nvpt(:, :, vcd_env%dcdr_env%lambda) = & vcd_env%apt_el_nvpt(:, :, vcd_env%dcdr_env%lambda) + vcd_env%apt_nuc_nvpt(:, :, vcd_env%dcdr_env%lambda) - IF (vcd_env%do_mfp) THEN + IF (vcd_env%do_mfp) & vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda) = vcd_env%aat_atom_mfp(:, :, vcd_env%dcdr_env%lambda)*4._dp - END IF END DO !lambda diff --git a/src/qs_linres_op.F b/src/qs_linres_op.F index ed9e9fe2b8..ad52669b40 100644 --- a/src/qs_linres_op.F +++ b/src/qs_linres_op.F @@ -1276,7 +1276,7 @@ CONTAINS IF ((b == a + 1 .OR. b == a - 2) .AND. (c == b + 1 .OR. c == b - 2)) THEN factor = 1.0_dp - ELSE IF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN + ELSEIF ((b == a - 1 .OR. b == a + 2) .AND. (c == b - 1 .OR. c == b + 2)) THEN factor = -1.0_dp END IF @@ -1298,9 +1298,9 @@ CONTAINS l(1:3) = 0 IF (ii == 0) THEN l(iii) = 1 - ELSE IF (iii == 0) THEN + ELSEIF (iii == 0) THEN l(ii) = 1 - ELSE IF (ii == iii) THEN + ELSEIF (ii == iii) THEN l(ii) = 2 i = coset(l(1), l(2), l(3)) - 1 ELSE @@ -1324,10 +1324,10 @@ CONTAINS IF (i1 == 1) THEN i2 = 2 i3 = 3 - ELSE IF (i1 == 2) THEN + ELSEIF (i1 == 2) THEN i2 = 3 i3 = 1 - ELSE IF (i1 == 3) THEN + ELSEIF (i1 == 3) THEN i2 = 1 i3 = 2 ELSE @@ -1347,9 +1347,9 @@ CONTAINS IF ((i1 + i2) == 3) THEN i3 = 3 - ELSE IF ((i1 + i2) == 4) THEN + ELSEIF ((i1 + i2) == 4) THEN i3 = 2 - ELSE IF ((i1 + i2) == 5) THEN + ELSEIF ((i1 + i2) == 5) THEN i3 = 1 ELSE END IF diff --git a/src/qs_loc_main.F b/src/qs_loc_main.F index f929aacda9..356f10d813 100644 --- a/src/qs_loc_main.F +++ b/src/qs_loc_main.F @@ -401,7 +401,7 @@ CONTAINS CALL cp_fm_release(tmp_fm) CALL cp_fm_release(tmp_fm_1) CALL cp_fm_struct_release(tmp_fm_struct) - ELSE IF (my_guess_wan) THEN + ELSEIF (my_guess_wan) THEN nguess = localized_wfn_control%nguess(myspin) ALLOCATE (tmp_mat(nao, nguess)) CALL cp_fm_get_submatrix(moloc_coeff(myspin), tmp_mat, 1, 1, nao, nguess) diff --git a/src/qs_loc_states.F b/src/qs_loc_states.F index 8163a283a2..0c9d90a473 100644 --- a/src/qs_loc_states.F +++ b/src/qs_loc_states.F @@ -133,21 +133,16 @@ CONTAINS IF (qs_loc_env%do_localize) THEN ! Do the Real localization.. - IF (output_unit > 0 .AND. do_homo) THEN + IF (output_unit > 0 .AND. do_homo) WRITE (output_unit, "(/,T2,A,I3)") & + "LOCALIZATION| Computing localization properties "// & + "for OCCUPIED ORBITALS. Spin:", ispin + IF (output_unit > 0 .AND. do_mixed) WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & + "LOCALIZATION| Computing localization properties for OCCUPIED, ", & + "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin + IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) & WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for OCCUPIED ORBITALS. Spin:", ispin - END IF - IF (output_unit > 0 .AND. do_mixed) THEN - WRITE (output_unit, "(/,T2,A,/,T16,A,I3)") & - "LOCALIZATION| Computing localization properties for OCCUPIED, ", & - "PARTIALLY OCCUPIED and UNOCCUPIED ORBITALS. Spin:", ispin - END IF - IF (output_unit > 0 .AND. (.NOT. do_homo) .AND. (.NOT. do_mixed)) THEN - WRITE (output_unit, "(/,T2,A,I3)") & - "LOCALIZATION| Computing localization properties "// & - "for UNOCCUPIED ORBITALS. Spin:", ispin - END IF + "LOCALIZATION| Computing localization properties "// & + "for UNOCCUPIED ORBITALS. Spin:", ispin scenter => qs_loc_env%localized_wfn_control%centers_set(ispin)%array diff --git a/src/qs_loc_types.F b/src/qs_loc_types.F index 4da4fc2c07..e22f26abb8 100644 --- a/src/qs_loc_types.F +++ b/src/qs_loc_types.F @@ -196,9 +196,8 @@ CONTAINS INTEGER :: i, ii, j IF (ASSOCIATED(qs_loc_env%cell)) CALL cell_release(qs_loc_env%cell) - IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN + IF (ASSOCIATED(qs_loc_env%local_molecules)) & CALL distribution_1d_release(qs_loc_env%local_molecules) - END IF IF (ASSOCIATED(qs_loc_env%localized_wfn_control)) THEN CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control) END IF @@ -337,9 +336,8 @@ CONTAINS IF (PRESENT(cell)) cell => qs_loc_env%cell IF (PRESENT(moloc_coeff)) moloc_coeff => qs_loc_env%moloc_coeff IF (PRESENT(local_molecules)) local_molecules => qs_loc_env%local_molecules - IF (PRESENT(localized_wfn_control)) THEN + IF (PRESENT(localized_wfn_control)) & localized_wfn_control => qs_loc_env%localized_wfn_control - END IF IF (PRESENT(op_sm_set)) op_sm_set => qs_loc_env%op_sm_set IF (PRESENT(op_fm_set)) op_fm_set => qs_loc_env%op_fm_set IF (PRESENT(para_env)) para_env => qs_loc_env%para_env @@ -394,9 +392,8 @@ CONTAINS IF (PRESENT(local_molecules)) THEN CALL distribution_1d_retain(local_molecules) - IF (ASSOCIATED(qs_loc_env%local_molecules)) THEN + IF (ASSOCIATED(qs_loc_env%local_molecules)) & CALL distribution_1d_release(qs_loc_env%local_molecules) - END IF qs_loc_env%local_molecules => local_molecules END IF diff --git a/src/qs_loc_utils.F b/src/qs_loc_utils.F index 3a8cd53d04..988b9b6212 100644 --- a/src/qs_loc_utils.F +++ b/src/qs_loc_utils.F @@ -340,11 +340,10 @@ CONTAINS IF (localized_wfn_control%do_homo) THEN occ_imo = occupations(imo) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) THEN + IF (localized_wfn_control%localization_method /= do_loc_none) & CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") - END IF END IF END IF ! Take the imo vector from the full set and copy in the imoloc vector of the subset @@ -358,11 +357,10 @@ CONTAINS my_occ = occupations(lb) occ_imo = occupations(ub) IF (ABS(occ_imo - my_occ) > localized_wfn_control%eps_occ) THEN - IF (localized_wfn_control%localization_method /= do_loc_none) THEN + IF (localized_wfn_control%localization_method /= do_loc_none) & CALL cp_abort(__LOCATION__, & "States with different occupations "// & "cannot be rotated together") - END IF END IF nmosub = localized_wfn_control%nloc_states(ispin) @@ -416,7 +414,7 @@ CONTAINS END DO END DO - ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN natoms = SIZE(qs_loc_env%particle_set, 1) ALLOCATE (qs_loc_env%op_fm_set(natoms, 1)) CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=natoms) @@ -441,7 +439,7 @@ CONTAINS CALL get_berry_operator(qs_loc_env, qs_env) - ELSE IF (localized_wfn_control%operator_type == op_loc_pipek) THEN + ELSEIF (localized_wfn_control%operator_type == op_loc_pipek) THEN !! here we don't have to do anything !! CALL get_pipek_mezey_operator ( qs_loc_env, qs_env ) @@ -759,7 +757,7 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSE IF (my_do_mixed) THEN + ELSEIF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -874,13 +872,12 @@ CONTAINS IF (PRESENT(do_mixed)) my_do_mixed = do_mixed IF (do_homo) THEN fname_key = "LOCHOMO_RESTART_FILE_NAME" - ELSE IF (my_do_mixed) THEN + ELSEIF (my_do_mixed) THEN fname_key = "LOCMIXD_RESTART_FILE_NAME" ELSE fname_key = "LOCLUMO_RESTART_FILE_NAME" - IF (.NOT. PRESENT(evals)) THEN + IF (.NOT. PRESENT(evals)) & CPABORT("Missing argument to localize unoccupied states.") - END IF END IF file_exists = .FALSE. @@ -892,7 +889,7 @@ CONTAINS print_key => section_vals_get_subs_vals(section2, "LOC_RESTART") IF (do_homo) THEN my_middle = "LOC_HOMO" - ELSE IF (my_do_mixed) THEN + ELSEIF (my_do_mixed) THEN my_middle = "LOC_MIXED" ELSE my_middle = "LOC_LUMO" @@ -917,10 +914,8 @@ CONTAINS READ (rst_unit) qs_loc_env%localized_wfn_control%nloc_states END IF ELSE - IF (output_unit > 0) THEN - WRITE (output_unit, "(/,T10,A)") & - "Restart file not available filename=<"//TRIM(filename)//'>' - END IF + IF (output_unit > 0) WRITE (output_unit, "(/,T10,A)") & + "Restart file not available filename=<"//TRIM(filename)//'>' END IF CALL para_env%bcast(file_exists) @@ -961,16 +956,14 @@ CONTAINS eig_read = 0.0_dp READ (rst_unit) eig_read(1:nmo_read) END IF - IF (nmo_read < nmo) THEN + IF (nmo_read < nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. ") - END IF - IF (nmo_read > nmo) THEN + IF (nmo_read > nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") - END IF nmo = MIN(nmo, nmo_read) IF (do_homo .OR. do_mixed) THEN @@ -1193,6 +1186,7 @@ CONTAINS maxocc=maxocc) ! Get eigenstates (only needed if not already calculated before) IF ((.NOT. my_do_mo_cubes) & + ! .OR. section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO")==0)& .AND. my_do_homo .AND. ASSOCIATED(qs_env%scf_env) & .AND. qs_env%scf_env%method == ot_method_nr .AND. (.NOT. dft_control%restricted)) THEN CALL make_mo_eig(mos, nspin, ks_rmpv, scf_control, mo_derivs) @@ -1213,12 +1207,11 @@ CONTAINS localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = ilast_intocc IF (nmoloc(ispin) /= n_mo(ispin)) THEN - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - ilast_intocc, " occupied orbitals are localized,", " with energies from ", & - mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." - END IF + "LOCALIZATION| Spin ", ispin, " The first ", & + ilast_intocc, " occupied orbitals are localized,", " with energies from ", & + mo_eigenvalues(1), " to ", mo_eigenvalues(ilast_intocc), " [a.u.]." END IF ELSE IF (localized_wfn_control%set_of_states == energy_loc_range .AND. my_do_homo) THEN ilow = 0 @@ -1250,12 +1243,11 @@ CONTAINS nmoloc(ispin) = n_mo(ispin) - homo localized_wfn_control%lu_bound_states(1, ispin) = homo + 1 localized_wfn_control%lu_bound_states(2, ispin) = n_mo(ispin) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,F12.6,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & - mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." - END IF + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " virtual orbitals are localized,", " with energies from ", & + mo_eigenvalues(homo + 1), " to ", mo_eigenvalues(n_mo(ispin)), " [a.u.]." ELSE IF (localized_wfn_control%set_of_states == state_loc_mixed) THEN nextra = localized_wfn_control%nextra nocc = homo @@ -1270,15 +1262,14 @@ CONTAINS nmoloc(ispin) = nocc + nextra localized_wfn_control%lu_bound_states(1, ispin) = 1 localized_wfn_control%lu_bound_states(2, ispin) = nmoloc(ispin) - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/,T2,A,I4,A,I6,A,/,T15,A,I6,/,T15,A,I6,/,T15,A,I6,/,T15,A,F12.6,A)") & - "LOCALIZATION| Spin ", ispin, " The first ", & - nmoloc(ispin), " orbitals are localized.", & - "Number of fully occupied MOs: ", nocc, & - "Number of partially occupied MOs: ", npocc, & - "Number of extra degrees of freedom: ", nextra, & - "Excess charge: ", my_tot_zeff_corr, " electrons" - END IF + "LOCALIZATION| Spin ", ispin, " The first ", & + nmoloc(ispin), " orbitals are localized.", & + "Number of fully occupied MOs: ", nocc, & + "Number of partially occupied MOs: ", npocc, & + "Number of extra degrees of freedom: ", nextra, & + "Excess charge: ", my_tot_zeff_corr, " electrons" ELSE nmoloc(ispin) = MIN(localized_wfn_control%nloc_states(1), n_mo(ispin)) IF (output_unit > 0 .AND. my_do_homo) WRITE (output_unit, "(/,T2,A,I4,A,I6,A)") "LOCALIZATION| Spin ", ispin, & diff --git a/src/qs_local_rho_types.F b/src/qs_local_rho_types.F index 97b456cf64..2efbf1089a 100644 --- a/src/qs_local_rho_types.F +++ b/src/qs_local_rho_types.F @@ -156,9 +156,12 @@ CONTAINS nkind = SIZE(rhoz_set) DO ikind = 1, nkind - IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) DEALLOCATE (rhoz_set(ikind)%r_coef) - IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) DEALLOCATE (rhoz_set(ikind)%dr_coef) - IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) DEALLOCATE (rhoz_set(ikind)%vr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%r_coef)) & + DEALLOCATE (rhoz_set(ikind)%r_coef) + IF (ASSOCIATED(rhoz_set(ikind)%dr_coef)) & + DEALLOCATE (rhoz_set(ikind)%dr_coef) + IF (ASSOCIATED(rhoz_set(ikind)%vr_coef)) & + DEALLOCATE (rhoz_set(ikind)%vr_coef) END DO DEALLOCATE (rhoz_set) diff --git a/src/qs_localization_methods.F b/src/qs_localization_methods.F index 6cc9eebe2f..97b0e6c4b8 100644 --- a/src/qs_localization_methods.F +++ b/src/qs_localization_methods.F @@ -162,6 +162,7 @@ CONTAINS END DO END DO CALL C%matrix_struct%para_env%sum(f2) + !write(*,*) 'qs_localize: f_2=',f2 !------------------------------------------------------------------- ! compute the derivative of f_2 ! f_2(x)=(x^2+eps)^1/2 @@ -178,6 +179,7 @@ CONTAINS !------------------------------------------------------------------- ! gnorm = cp_fm_frobenius_norm(G) + !write(*,*) 'qs_localize: norm(G)=',gnorm ! ! rescale for steepest descent CALL cp_fm_scale(-alpha, G) @@ -189,6 +191,7 @@ CONTAINS expfactor = 1.0_dp CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, G) tnorm = cp_fm_frobenius_norm(G) + !write(*,*) 'Taylor expansion i=',1,' norm(X^i)/i!=',tnorm IF (tnorm > 1.0E-10_dp) THEN ! other orders CALL cp_fm_to_fm(G, Gp1) @@ -200,6 +203,7 @@ CONTAINS expfactor = expfactor/REAL(i, KIND=dp) CALL cp_fm_scale_and_add(1.0_dp, U, expfactor, Gp1) tnorm = cp_fm_frobenius_norm(Gp1) + !write(*,*) 'Taylor expansion i=',i,' norm(X^i)/i!=',tnorm*expfactor IF (tnorm*expfactor < 1.0E-10_dp) EXIT END DO END IF @@ -215,6 +219,7 @@ CONTAINS ! ! Are we done? sweeps = istep + !IF(gnorm<=grad_thresh.AND.ABS((f2-f2old)/f2)<=f2_thresh.AND.istep>1) THEN IF (ABS((f2 - f2old)/f2) <= eps .AND. istep > 1) THEN converged = .TRUE. EXIT @@ -226,6 +231,23 @@ CONTAINS ! ! Print the final result IF (output_unit > 0) WRITE (output_unit, '(A,E16.10)') ' sparseness function f2 = ', f2 + ! + ! sparsity + !DO i=1,size(thresh,1) + ! gnorm = 0.0_dp + ! DO o=1,ncol_local + ! DO p=1,nrow_local + ! IF(ABS(C%local_data(p,o))>thresh(i)) THEN + ! gnorm = gnorm + 1.0_dp + ! ENDIF + ! ENDDO + ! ENDDO + ! CALL C%matrix_struct%para_env%sum(gnorm) + ! IF(output_unit>0) THEN + ! WRITE(output_unit,*) 'qs_localize: ratio2=',gnorm / ( REAL(k,KIND=dp)*REAL(n,KIND=dp) ),thresh(i) + ! ENDIF + !ENDDO + ! ! deallocate CALL cp_fm_struct_release(fm_struct_k_k) CALL cp_fm_release(CTmp) @@ -667,7 +689,7 @@ CONTAINS IF (do_cinit_random) THEN icinit = 1 do_U_guess_mo = .FALSE. - ELSE IF (do_cinit_mo) THEN + ELSEIF (do_cinit_mo) THEN icinit = 2 do_U_guess_mo = .TRUE. END IF @@ -1139,7 +1161,7 @@ CONTAINS IF ((ABS(ds) < 1.0E-10_dp) .AND. (lsl == 1)) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha - ELSE IF (ABS(ds) > 10.0_dp) THEN + ELSEIF (ABS(ds) > 10.0_dp) THEN new_direction = .TRUE. ds_min = 0.5_dp/alpha ELSE @@ -1327,7 +1349,7 @@ CONTAINS IF (ABS(b12) > 1.e-10_dp) THEN ratio = -a12/b12 theta = 0.25_dp*ATAN(ratio) - ELSE IF (ABS(b12) < 1.e-10_dp) THEN + ELSEIF (ABS(b12) < 1.e-10_dp) THEN b12 = 0.0_dp theta = 0.0_dp ELSE @@ -1975,6 +1997,14 @@ CONTAINS IF (new_direction) THEN ! energy converged up to machine precision ? line_searches = line_searches + 1 + ! DO i=1,line_search_count + ! write(15,*) pos(i),energy(i) + ! ENDDO + ! write(15,*) "" + ! CALL m_flush(15) + !write(16,*) evals(:) + !write(17,*) matrix_A%local_data(:,:) + !write(18,*) matrix_G%local_data(:,:) IF (output_unit > 0) THEN WRITE (output_unit, '(T5,I10,T18,I10,T31,2F20.6,F10.3)') line_searches, Iterations, Omega, tol, ds_min CALL m_flush(output_unit) @@ -2483,9 +2513,9 @@ CONTAINS COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: c_array_me, c_array_partner COMPLEX(KIND=dp), POINTER :: mii(:), mij(:), mjj(:) INTEGER :: i, idim, ii, ik, il1, il2, il_recv, il_recv_partner, ilow1, ilow2, ip, ip_has_i, & - ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istate, iu1, iu2, iup1, iup2, j, & - jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, ns_recv_from, & - ns_recv_partner + ip_partner, ip_recv_from, ip_recv_partner, ipair, iperm, istat, istate, iu1, iu2, iup1, & + iup2, j, jj, jstate, k, kk, lsweep, n1, n2, npair, nperm, ns_me, ns_partner, & + ns_recv_from, ns_recv_partner INTEGER, ALLOCATABLE, DIMENSION(:) :: rcount, rdispl INTEGER, ALLOCATABLE, DIMENSION(:, :) :: list_pair LOGICAL :: should_stop @@ -2502,8 +2532,8 @@ CONTAINS ALLOCATE (mii(dim2), mij(dim2), mjj(dim2)) - ALLOCATE (rcount(para_env%num_pe)) - ALLOCATE (rdispl(para_env%num_pe)) + ALLOCATE (rcount(para_env%num_pe), STAT=istat) + ALLOCATE (rdispl(para_env%num_pe), STAT=istat) tolerance = 1.0e10_dp sweeps = 0 @@ -2675,6 +2705,7 @@ CONTAINS IF (ilow1 < ilow2) THEN ! no longer compiles in official sdgb: + !CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1, k), nstate, rmat_loc(1 + n1, 1), n1 + n2, 0.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, rmat_loc(1 + n1:, 1:n1), & n2, 0.0_dp, gmat(:, :), nstate) @@ -2684,6 +2715,7 @@ CONTAINS CALL dgemm("N", "N", nstate, n1, n2, 1.0_dp, rotmat(1:, k:), nstate, & rmat_loc(1:, n2 + 1:), n1 + n2, 0.0_dp, gmat(:, :), nstate) ! no longer compiles in official sdgb: + !CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1, 1), nstate, rmat_loc(n2 + 1, n2 + 1), n1 + n2, 1.0_dp, gmat, nstate) ! probably inefficient: CALL dgemm("N", "N", nstate, n1, n1, 1.0_dp, rotmat(1:, 1:), nstate, rmat_loc(n2 + 1:, n2 + 1:), & n1, 1.0_dp, gmat(:, :), nstate) @@ -2961,7 +2993,7 @@ CONTAINS list_pair(JJ, II) = i END DO IF (MOD(para_env%num_pe, 2) == 1) list_pair(2, npair) = -1 - ELSE IF (MOD(iperm, 2) == 0) THEN + ELSEIF (MOD(iperm, 2) == 0) THEN !..a type shift jj = list_pair(1, npair) DO I = npair, 3, -1 diff --git a/src/qs_mixing_utils.F b/src/qs_mixing_utils.F index b61e5251e4..d5869da8f0 100644 --- a/src/qs_mixing_utils.F +++ b/src/qs_mixing_utils.F @@ -188,7 +188,7 @@ CONTAINS CPASSERT(.NOT. mixing_store%gmix_p) IF (dft_control%qs_control%dftb) THEN max_shell = max_dftb_scc_vars - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN max_shell = max_xtb_scc_vars ELSE CPABORT('UNKNOWN METHOD') @@ -219,7 +219,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%pulay_matrix)) DEALLOCATE (mixing_store%pulay_matrix) ALLOCATE (mixing_store%pulay_matrix(nbuffer, nbuffer, nspins)) mixing_store%pulay_matrix = 0.0_dp - ELSE IF (mixing_method == broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr) THEN IF (ASSOCIATED(mixing_store%abroy)) DEALLOCATE (mixing_store%abroy) ALLOCATE (mixing_store%abroy(nbuffer, nbuffer)) mixing_store%abroy = 0.0_dp @@ -232,7 +232,7 @@ CONTAINS IF (ASSOCIATED(mixing_store%ubroy)) DEALLOCATE (mixing_store%ubroy) ALLOCATE (mixing_store%ubroy(na, max_shell, nbuffer)) mixing_store%ubroy = 0.0_dp - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN CPABORT("multisecant_mixing not available") END IF ELSE @@ -588,7 +588,7 @@ CONTAINS END IF IF (mixing_method == gspace_mixing_nr) THEN - ELSE IF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN + ELSEIF (mixing_method == pulay_mixing_nr .OR. mixing_method == new_pulay_mixing_nr) THEN IF (mixing_store%gmix_p .AND. PRESENT(rho_atom)) THEN DO ispin = 1, nspin DO iat = 1, natom @@ -613,7 +613,7 @@ CONTAINS END DO END DO END IF - ELSE IF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN + ELSEIF (mixing_method == broyden_mixing_nr .OR. mixing_method == modified_broyden_mixing_nr) THEN DO ispin = 1, nspin IF (.NOT. ASSOCIATED(mixing_store%rhoin_old(ispin)%cc)) THEN ALLOCATE (mixing_store%rhoin_old(ispin)%cc(ng)) @@ -685,7 +685,7 @@ CONTAINS END DO IF (rho_g(1)%pw_grid%have_g0) mixing_store%p_metric(1) = bconst END IF - ELSE IF (mixing_method == multisecant_mixing_nr) THEN + ELSEIF (mixing_method == multisecant_mixing_nr) THEN IF (.NOT. ASSOCIATED(mixing_store%ig_global_index)) THEN ALLOCATE (mixing_store%ig_global_index(ng)) END IF diff --git a/src/qs_mo_io.F b/src/qs_mo_io.F index 55c77ef141..4504787e02 100644 --- a/src/qs_mo_io.F +++ b/src/qs_mo_io.F @@ -346,7 +346,7 @@ CONTAINS DO iset = 1, nset nshell_max = MAX(nshell_max, nshell(iset)) END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_max = MAX(nset_max, 1) nshell_max = MAX(nshell_max, lmax + 1) @@ -383,7 +383,7 @@ CONTAINS nso_info(ishell, iset, iatom) = nso(lshell) END DO END DO - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset_info(iatom) = 1 nshell_info(1, iatom) = lmax + 1 @@ -754,9 +754,8 @@ CONTAINS IF (nao_read /= nao) THEN WRITE (cp_logger_get_default_unit_nr(logger), *) & " READ RESTART : WARNING : DIFFERENT # AOs ", nao, nao_read - IF (PRESENT(rt_mos)) THEN + IF (PRESENT(rt_mos)) & CPABORT("To change basis is not possible. ") - END IF END IF READ (rst_unit) nset_info @@ -811,16 +810,14 @@ CONTAINS occ_read = 0.0_dp nmo = MIN(nmo, nmo_read) - IF (nmo_read < nmo) THEN + IF (nmo_read < nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is smaller than the number of "// & "the allocated MOs. The MO set will be padded with zeros!") - END IF - IF (nmo_read > nmo) THEN + IF (nmo_read > nmo) & CALL cp_warn(__LOCATION__, & "The number of MOs on the restart unit is greater than the number of "// & "the allocated MOs. The read MO set will be truncated!") - END IF READ (rst_unit) eig_read(1:nmo_read), occ_read(1:nmo_read) mos(ispin)%eigenvalues(1:nmo) = eig_read(1:nmo) @@ -881,7 +878,7 @@ CONTAINS nshell=nshell, & l=l) minbas = .FALSE. - ELSE IF (ASSOCIATED(dftb_parameter)) THEN + ELSEIF (ASSOCIATED(dftb_parameter)) THEN CALL get_dftb_atom_param(dftb_parameter, lmax=lmax) nset = 1 minbas = .TRUE. @@ -1329,16 +1326,14 @@ CONTAINS name = TRIM(energy_str)//", OCCUPATION NUMBERS, AND "// & TRIM(orbital_str)//" "//TRIM(vector_str) - IF (.NOT. my_final) THEN + IF (.NOT. my_final) & WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step - END IF ELSE IF (print_occup .OR. print_eigvals) THEN name = TRIM(energy_str)//" AND OCCUPATION NUMBERS" - IF (.NOT. my_final) THEN + IF (.NOT. my_final) & WRITE (UNIT=name, FMT="(A,1X,I0)") TRIM(name)//step_string, scf_step - END IF END IF ! print_eigvecs ! Print headline diff --git a/src/qs_mo_occupation.F b/src/qs_mo_occupation.F index dcd2c88e4f..38d815e707 100644 --- a/src/qs_mo_occupation.F +++ b/src/qs_mo_occupation.F @@ -155,11 +155,10 @@ CONTAINS CPWARN_IF(is_large, TRIM(method_label)//" smearing includes the first MO") is_large = ABS(all_occ(all_nmo)) > smear%eps_fermi_dirac - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF IF (.NOT. do_gce) THEN ! check that the total electron count is accurate is_large = (ABS(all_nelec - accurate_sum(all_occ(:))) > smear%eps_fermi_dirac*all_nelec) @@ -343,15 +342,13 @@ CONTAINS multiplicity_old = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (mo_array(1)%nelectron >= mo_array(1)%nmo) THEN + IF (mo_array(1)%nelectron >= mo_array(1)%nmo) & CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") - END IF - IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) THEN + IF ((mo_array(2)%nelectron >= mo_array(2)%nmo) .AND. (mo_array(2)%nelectron /= mo_array(1)%nelectron)) & CALL cp_warn(__LOCATION__, "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") - END IF eigval_a => mo_array(1)%eigenvalues eigval_b => mo_array(2)%eigenvalues @@ -370,22 +367,20 @@ CONTAINS lumo_b = lumo_b + 1 END IF IF (lumo_a > mo_array(1)%nmo) THEN - IF (i /= nelec) THEN + IF (i /= nelec) & CALL cp_warn(__LOCATION__, & "All alpha MOs are occupied. Add more alpha MOs to "// & "allow for a higher multiplicity") - END IF IF (i < nelec) THEN lumo_a = lumo_a - 1 lumo_b = lumo_b + 1 END IF END IF IF (lumo_b > mo_array(2)%nmo) THEN - IF (lumo_b < lumo_a) THEN + IF (lumo_b < lumo_a) & CALL cp_warn(__LOCATION__, & "All beta MOs are occupied. Add more beta MOs to "// & "allow for a lower multiplicity") - END IF IF (i < nelec) THEN lumo_a = lumo_a + 1 lumo_b = lumo_b - 1 @@ -411,12 +406,11 @@ CONTAINS mo_array(2)%nelectron = mo_array(2)%homo multiplicity_new = mo_array(1)%nelectron - mo_array(2)%nelectron + 1 - IF (multiplicity_new /= multiplicity_old) THEN + IF (multiplicity_new /= multiplicity_old) & CALL cp_warn(__LOCATION__, & "Multiplicity changed from "// & TRIM(ADJUSTL(cp_to_string(multiplicity_old)))//" to "// & TRIM(ADJUSTL(cp_to_string(multiplicity_new)))) - END IF IF (PRESENT(probe)) THEN CALL set_mo_occupation_1(mo_array(1), smear=smear, probe=probe) @@ -502,9 +496,8 @@ CONTAINS mo_set%occupation_numbers(1:nomo) = mo_set%maxocc IF (xas_estate > 0) mo_set%occupation_numbers(xas_estate) = occ_estate el_count = SUM(mo_set%occupation_numbers(1:nomo)) - IF (el_count > xas_nelectron) THEN + IF (el_count > xas_nelectron) & mo_set%occupation_numbers(nomo) = mo_set%occupation_numbers(nomo) - (el_count - xas_nelectron) - END IF el_count = SUM(mo_set%occupation_numbers(1:nomo)) is_large = ABS(el_count - xas_nelectron) > xas_nelectron*EPSILON(el_count) CPASSERT(.NOT. is_large) @@ -593,13 +586,13 @@ CONTAINS END DO nomo = nomo - irmo IF (mo_set%occupation_numbers(nomo) == 0.0_dp) nomo = nomo - 1 - ELSE IF (delectron < 0.0_dp) THEN + ELSEIF (delectron < 0.0_dp) THEN mo_set%occupation_numbers(nomo) = -delectron ELSE mo_set%occupation_numbers(nomo) = 0.0_dp nomo = nomo - 1 END IF - ELSE IF (total_zeff_corr > 0.0_dp) THEN + ELSEIF (total_zeff_corr > 0.0_dp) THEN ! add electron density to the mos delectron = total_zeff_corr - REAL(mo_set%maxocc, KIND=dp) IF (delectron > 0.0_dp) THEN @@ -662,9 +655,8 @@ CONTAINS END DO is_large = ABS(MAXVAL(mo_set%occupation_numbers) - mo_set%maxocc) > probe(1)%eps_hp ! this is not a real problem, but the temperature might be a bit large - IF (is_large) THEN + IF (is_large) & CPWARN("Hair-probes occupancy distribution includes the first MO") - END IF ! Find the highest (fractional) occupied MO which will be now the HOMO DO imo = nmo, mo_set%lfomo, -1 @@ -674,17 +666,15 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > probe(1)%eps_hp - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & "Hair-probes occupancy distribution includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > probe(1)%eps_hp*nelec) - IF (is_large) THEN + IF (is_large) & CPWARN("Total number of electrons is not accurate") - END IF END IF @@ -760,11 +750,10 @@ CONTAINS END IF END DO is_large = ABS(MINVAL(mo_set%occupation_numbers)) > smear%eps_fermi_dirac - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & "Fermi-Dirac smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -817,11 +806,10 @@ CONTAINS END IF END DO is_large = ABS(mo_set%occupation_numbers(nmo)) > smear%eps_fermi_dirac - IF (is_large) THEN + IF (is_large) & CALL cp_warn(__LOCATION__, & TRIM(method_label)//" smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! Check that the total electron count is accurate is_large = (ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) @@ -838,11 +826,10 @@ CONTAINS END IF e2 = mo_set%eigenvalues(mo_set%homo) + 0.5_dp*smear%window_size - IF (e2 >= mo_set%eigenvalues(nmo)) THEN + IF (e2 >= mo_set%eigenvalues(nmo)) & CALL cp_warn(__LOCATION__, & "Energy window for smearing includes the last MO => "// & "Add more MOs for proper smearing.") - END IF ! Find the lowest fractional occupied MO (LFOMO) DO imo = i_first, nomo diff --git a/src/qs_mom_methods.F b/src/qs_mom_methods.F index 9d5921eaab..29544e3795 100644 --- a/src/qs_mom_methods.F +++ b/src/qs_mom_methods.F @@ -89,9 +89,8 @@ CONTAINS ! Ensure that all orbital indices are positive integers. ! A special value '0' means 'disabled keyword', ! it must appear once to be interpreted in such a way - IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) THEN + IF (tmp_iarr(1) < 0 .OR. (tmp_iarr(1) == 0 .AND. norbs > 1)) & CPABORT("MOM: all molecular orbital indices must be positive integer numbers") - END IF DEALLOCATE (tmp_iarr) END IF @@ -266,10 +265,9 @@ CONTAINS (mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccA) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_deoccB) .AND. & mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occA) .AND. & - mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) THEN + mom_is_unique_orbital_indices(scf_control%diagonalization%mom_occB))) & CALL cp_abort(__LOCATION__, & "Duplicate orbital indices were found in the MOM section") - END IF ! ignore beta orbitals for spin-unpolarized calculations IF (nspins == 1 .AND. (scf_control%diagonalization%mom_deoccB(1) /= 0 & @@ -310,18 +308,16 @@ CONTAINS END DO ! proceed alpha orbitals - IF (nspins >= 1) THEN + IF (nspins >= 1) & CALL mom_reoccupy_orbitals(mos(1), & scf_control%diagonalization%mom_deoccA, & scf_control%diagonalization%mom_occA, 'alpha') - END IF ! proceed beta orbitals (if any) - IF (nspins >= 2) THEN + IF (nspins >= 2) & CALL mom_reoccupy_orbitals(mos(2), & scf_control%diagonalization%mom_deoccB, & scf_control%diagonalization%mom_occB, 'beta') - END IF ! recompute the density matrix if the molecular orbitals are here; ! otherwise do nothing to prevent zeroing out the density matrix @@ -396,10 +392,9 @@ CONTAINS CALL timeset(routineN, handle) - IF (.NOT. scf_control%diagonalization%mom_didguess) THEN + IF (.NOT. scf_control%diagonalization%mom_didguess) & CALL cp_abort(__LOCATION__, & "The current implementation of the maximum overlap method is incompatible with the initial SCF guess") - END IF ! number of spins == dft_control%nspins nspins = SIZE(matrix_ks) diff --git a/src/qs_moments.F b/src/qs_moments.F index c434f3ca8b..6a8ac14ccf 100644 --- a/src/qs_moments.F +++ b/src/qs_moments.F @@ -3361,9 +3361,8 @@ CONTAINS kpnts => section_vals_get_subs_vals(qs_env%input, "DFT%PRINT%MOMENTS%KPOINTS") CALL section_vals_get(kpset, explicit=explicit_kpset) CALL section_vals_get(kpnts, explicit=explicit_kpnts) - IF (explicit_kpset .AND. explicit_kpnts) then + IF (explicit_kpset .AND. explicit_kpnts) & CPABORT("Both KPOINT_SET and KPOINTS present in MOMENTS section") - end if IF (explicit_kpset) THEN CALL get_qs_env(qs_env, cell=cell) @@ -4012,9 +4011,8 @@ CONTAINS IF (ABS(energy_diff) <= eps_degenerate) CYCLE CALL cp_fm_get_element(moment_re, m, n, creal) CALL cp_fm_get_element(moment_im, m, n, cimag) - IF (para_env%is_source()) then + IF (para_env%is_source()) & dipole(ispin, ikp, i_dir, n, m) = CMPLX(creal, cimag, KIND=dp)/energy_diff - end if END DO END DO END DO diff --git a/src/qs_neighbor_list_types.F b/src/qs_neighbor_list_types.F index f85df43651..c77afac074 100644 --- a/src/qs_neighbor_list_types.F +++ b/src/qs_neighbor_list_types.F @@ -358,9 +358,8 @@ CONTAINS TYPE(neighbor_list_set_p_type), DIMENSION(:), & POINTER :: nl - IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) THEN + IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) & CPABORT("Parallel iterator calls must include 'mepos'") - END IF IF (PRESENT(mepos)) THEN me = mepos @@ -462,10 +461,10 @@ CONTAINS IF (iterator%inode >= iterator%nnode) THEN ! end of loop istat = 1 - ELSE IF (iterator%inode == 0) THEN + ELSEIF (iterator%inode == 0) THEN iterator%inode = 1 iterator%neighbor_node => first_node(iterator%neighbor_list) - ELSE IF (iterator%inode > 0) THEN + ELSEIF (iterator%inode > 0) THEN ! we can be sure that there is another node in this list iterator%inode = iterator%inode + 1 iterator%neighbor_node => iterator%neighbor_node%next_neighbor_node diff --git a/src/qs_neighbor_lists.F b/src/qs_neighbor_lists.F index b67e328c93..4c8e38cf4f 100644 --- a/src/qs_neighbor_lists.F +++ b/src/qs_neighbor_lists.F @@ -112,10 +112,6 @@ MODULE qs_neighbor_lists END TYPE local_atoms_type ! ************************************************************************************************** - TYPE local_lists - INTEGER, DIMENSION(:), POINTER :: list => NULL() - END TYPE local_lists - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_neighbor_lists' ! private counter, used to version qs neighbor lists @@ -434,7 +430,7 @@ CONTAINS IF (dokp) THEN ! no MIC for kpoints mic = .FALSE. - ELSE IF (nddo) THEN + ELSEIF (nddo) THEN ! enforce MIC for interaction lists in SE mic = .TRUE. END IF @@ -667,9 +663,8 @@ CONTAINS CALL pair_radius_setup(orb_present, orb_present, orb_radius, orb_radius, pair_radius_lb) DO jkind = 1, nkind DO ikind = 1, nkind - IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) THEN + IF (pair_radius(ikind, jkind) + cutoff_screen_factor*roperator <= pair_radius_lb(ikind, jkind)) & pair_radius(ikind, jkind) = pair_radius_lb(ikind, jkind) - roperator - END IF END DO END DO ELSE @@ -952,7 +947,7 @@ CONTAINS qs_env%lri_env%soo_list => soo_list CALL write_neighbor_lists(soo_list, particle_set, cell, para_env, neighbor_list_section, & "/SOO_LIST", "soo_list", "ORBITAL ORBITAL (RI)") - ELSE IF (rigpw) THEN + ELSEIF (rigpw) THEN ALLOCATE (ri_present(nkind), ri_radius(nkind)) ri_present = .FALSE. ri_radius = 0.0_dp @@ -1086,28 +1081,31 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'build_neighbor_lists' - INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, iatom_subcell, icell, ikind, & - inode, j, jatom, jatom_local, jcell, jkind, k, kcell, maxat, mol_a, mol_b, natom, nentry, & - nkind, nnode, otype - INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb + TYPE local_lists + INTEGER, DIMENSION(:), POINTER :: list + END TYPE local_lists + + INTEGER :: atom_a, atom_b, handle, i, iab, iatom, iatom_local, & + iatom_subcell, icell, ikind, j, jatom, jatom_local, jcell, jkind, k, & + kcell, maxat, mol_a, mol_b, nkind, otype, natom, inode, nnode, nentry INTEGER, DIMENSION(3) :: cell_b, ncell, nsubcell, periodic INTEGER, DIMENSION(:), POINTER :: index_list - LOGICAL :: include_ab, my_mic, my_molecular, & - my_sort_atomb, my_symmetric + LOGICAL :: include_ab, my_mic, & + my_molecular, my_symmetric, my_sort_atomb LOGICAL, ALLOCATABLE, DIMENSION(:) :: pres_a, pres_b - REAL(dp) :: deth, rab2, rab2_max, rab_max, rabm, & - subcell_scale - REAL(dp), DIMENSION(3) :: pd, r, ra, rab, rab_pbc, rb, sab_max, & - sab_max_guard, sb, sb_max, sb_min, & - sb_pbc - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: r_pbc + REAL(dp) :: rab2, rab2_max, rab_max, rabm, deth, subcell_scale + REAL(dp), DIMENSION(3) :: r, rab, ra, rb, sab_max, sb, & + sb_pbc, sb_min, sb_max, rab_pbc, pd, sab_max_guard + INTEGER, ALLOCATABLE, DIMENSION(:) :: nlista, nlistb TYPE(local_lists), DIMENSION(:), POINTER :: lista, listb + TYPE(neighbor_list_p_type), & + ALLOCATABLE, DIMENSION(:) :: kind_a + TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set + TYPE(subcell_type), DIMENSION(:, :, :), & + POINTER :: subcell + REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: r_pbc TYPE(neighbor_list_iterator_p_type), & DIMENSION(:), POINTER :: nl_iterator - TYPE(neighbor_list_p_type), ALLOCATABLE, & - DIMENSION(:) :: kind_a - TYPE(neighbor_list_set_type), POINTER :: neighbor_list_set - TYPE(subcell_type), DIMENSION(:, :, :), POINTER :: subcell CALL timeset(routineN//"_"//TRIM(nlname), handle) diff --git a/src/qs_nonscf_utils.F b/src/qs_nonscf_utils.F index 79bf5fd5e2..bc73ecfbd9 100644 --- a/src/qs_nonscf_utils.F +++ b/src/qs_nonscf_utils.F @@ -82,22 +82,19 @@ CONTAINS "Self energy of the core charge distribution: ", energy%core_self, & "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", energy%exc - IF (energy%dispersion /= 0.0_dp) THEN + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - END IF - IF (energy%gcp /= 0.0_dp) THEN + "Dispersion energy: ", energy%dispersion + IF (energy%gcp /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - END IF - IF (energy%efield /= 0.0_dp) THEN + "gCP energy: ", energy%gcp + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT("NONSCF not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPASSERT(energy%dftb3 == 0.0_dp) energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & @@ -106,11 +103,10 @@ CONTAINS "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Dispersion energy: ", energy%dispersion - IF (energy%efield /= 0.0_dp) THEN + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF - ELSE IF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + ELSEIF (dft_control%qs_control%xtb) THEN energy%total = energy%total + energy%band + energy%qmmm_el WRITE (UNIT=iounit, FMT="(/,T2,A,T40,A,F10.2,T61,F20.10)") & "Diagonalization", "Time:", tdiag, energy%total @@ -121,14 +117,12 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF - IF (energy%efield /= 0.0_dp) THEN + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=iounit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield ELSE CPABORT("NONSCF not available") END IF diff --git a/src/qs_ot.F b/src/qs_ot.F index 598749bc9c..2b13565c51 100644 --- a/src/qs_ot.F +++ b/src/qs_ot.F @@ -295,9 +295,8 @@ CONTAINS ! ! compute the P^(-1/2) DO i = 1, k - IF (eig(i) <= 0.0_dp) THEN + IF (eig(i) <= 0.0_dp) & CPABORT("P not positive definite") - END IF IF (eig(i) < 1.0E-8_dp) THEN fun(i) = 0.0_dp ELSE diff --git a/src/qs_ot_types.F b/src/qs_ot_types.F index d301039af0..d184e998fd 100644 --- a/src/qs_ot_types.F +++ b/src/qs_ot_types.F @@ -269,31 +269,25 @@ CONTAINS CALL dbcsr_set(qs_ot_env%matrix_gx, 0.0_dp) - IF (qs_ot_env%use_dx) THEN + IF (qs_ot_env%use_dx) & CALL dbcsr_set(qs_ot_env%matrix_dx, 0.0_dp) - END IF - IF (qs_ot_env%use_gx_old) THEN + IF (qs_ot_env%use_gx_old) & CALL dbcsr_set(qs_ot_env%matrix_gx_old, 0.0_dp) - END IF IF (qs_ot_env%settings%do_rotation) THEN CALL dbcsr_set(qs_ot_env%rot_mat_gx, 0.0_dp) - IF (qs_ot_env%use_dx) THEN + IF (qs_ot_env%use_dx) & CALL dbcsr_set(qs_ot_env%rot_mat_dx, 0.0_dp) - END IF - IF (qs_ot_env%use_gx_old) THEN + IF (qs_ot_env%use_gx_old) & CALL dbcsr_set(qs_ot_env%rot_mat_gx_old, 0.0_dp) - END IF END IF IF (qs_ot_env%settings%do_ener) THEN qs_ot_env%ener_gx(:) = 0.0_dp - IF (qs_ot_env%use_dx) THEN + IF (qs_ot_env%use_dx) & qs_ot_env%ener_dx(:) = 0.0_dp - END IF - IF (qs_ot_env%use_gx_old) THEN + IF (qs_ot_env%use_gx_old) & qs_ot_env%ener_gx_old(:) = 0.0_dp - END IF END IF END SUBROUTINE qs_ot_init diff --git a/src/qs_outer_scf.F b/src/qs_outer_scf.F index 55d7d7b239..1b4a93e52d 100644 --- a/src/qs_outer_scf.F +++ b/src/qs_outer_scf.F @@ -318,11 +318,10 @@ CONTAINS END IF IF (scf_control%outer_scf%cdft_opt_control%broyden_update) THEN ! Perform a Broyden update of the inverse Jacobian J^(-1) - IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) THEN + IF (SIZE(scf_env%outer_scf%gradient, 2) < 3) & CALL cp_abort(__LOCATION__, & "Keyword EXTRAPOLATION_ORDER in section OUTER_SCF "// & "must be greater than or equal to 3 for Broyden optimizers.") - END IF nvar = SIZE(scf_env%outer_scf%gradient, 1) ALLOCATE (f(nvar, 1), x(nvar, 1)) DO i = 1, nvar @@ -573,37 +572,31 @@ CONTAINS cdft_control%constraint%deallocate_jacobian = scf_env%outer_scf%deallocate_jacobian IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN nvariables = SIZE(scf_env%outer_scf%inv_jacobian, 1) - IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(cdft_control%constraint%inv_jacobian)) & ALLOCATE (cdft_control%constraint%inv_jacobian(nvariables, nvariables)) - END IF cdft_control%constraint%inv_jacobian = scf_env%outer_scf%inv_jacobian END IF ! Now switch - IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN + IF (ASSOCIATED(scf_env%outer_scf%energy)) & DEALLOCATE (scf_env%outer_scf%energy) - END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN + IF (ASSOCIATED(scf_env%outer_scf%variables)) & DEALLOCATE (scf_env%outer_scf%variables) - END IF ALLOCATE (scf_env%outer_scf%variables(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN + IF (ASSOCIATED(scf_env%outer_scf%gradient)) & DEALLOCATE (scf_env%outer_scf%gradient) - END IF ALLOCATE (scf_env%outer_scf%gradient(1, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = 0.0_dp - IF (ASSOCIATED(scf_env%outer_scf%count)) THEN + IF (ASSOCIATED(scf_env%outer_scf%count)) & DEALLOCATE (scf_env%outer_scf%count) - END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = 0 ! OT SCF does not need Jacobian scf_env%outer_scf%deallocate_jacobian = .TRUE. - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & DEALLOCATE (scf_env%outer_scf%inv_jacobian) - END IF CASE (ot2cdft) ! OT -> constraint scf_control%outer_scf%have_scf = cdft_control%constraint_control%have_scf @@ -617,32 +610,27 @@ CONTAINS CALL cdft_opt_type_copy(scf_control%outer_scf%cdft_opt_control, & cdft_control%constraint_control%cdft_opt_control) nvariables = SIZE(cdft_control%constraint%variables, 1) - IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN + IF (ASSOCIATED(scf_env%outer_scf%energy)) & DEALLOCATE (scf_env%outer_scf%energy) - END IF ALLOCATE (scf_env%outer_scf%energy(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%energy = cdft_control%constraint%energy - IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN + IF (ASSOCIATED(scf_env%outer_scf%variables)) & DEALLOCATE (scf_env%outer_scf%variables) - END IF ALLOCATE (scf_env%outer_scf%variables(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%variables = cdft_control%constraint%variables - IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN + IF (ASSOCIATED(scf_env%outer_scf%gradient)) & DEALLOCATE (scf_env%outer_scf%gradient) - END IF ALLOCATE (scf_env%outer_scf%gradient(nvariables, scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%gradient = cdft_control%constraint%gradient - IF (ASSOCIATED(scf_env%outer_scf%count)) THEN + IF (ASSOCIATED(scf_env%outer_scf%count)) & DEALLOCATE (scf_env%outer_scf%count) - END IF ALLOCATE (scf_env%outer_scf%count(scf_control%outer_scf%max_scf + 1)) scf_env%outer_scf%count = cdft_control%constraint%count scf_env%outer_scf%iter_count = cdft_control%constraint%iter_count scf_env%outer_scf%deallocate_jacobian = cdft_control%constraint%deallocate_jacobian IF (ASSOCIATED(cdft_control%constraint%inv_jacobian)) THEN - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & DEALLOCATE (scf_env%outer_scf%inv_jacobian) - END IF ALLOCATE (scf_env%outer_scf%inv_jacobian(nvariables, nvariables)) scf_env%outer_scf%inv_jacobian = cdft_control%constraint%inv_jacobian END IF diff --git a/src/qs_overlap.F b/src/qs_overlap.F index 6007a9739d..857850a5bf 100644 --- a/src/qs_overlap.F +++ b/src/qs_overlap.F @@ -235,7 +235,7 @@ CONTAINS dokp = .FALSE. use_cell_mapping = .FALSE. nimg = dft_control%nimages - ELSE IF (PRESENT(matrixkp_s)) THEN + ELSEIF (PRESENT(matrixkp_s)) THEN dokp = .TRUE. IF (PRESENT(ext_kpoints)) THEN IF (ASSOCIATED(ext_kpoints)) THEN @@ -868,7 +868,7 @@ CONTAINS IF (PRESENT(matrix_p)) THEN dokp = .FALSE. use_cell_mapping = .FALSE. - ELSE IF (PRESENT(matrixkp_p)) THEN + ELSEIF (PRESENT(matrixkp_p)) THEN dokp = .TRUE. CALL get_ks_env(ks_env=ks_env, kpoints=kpoints) CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) diff --git a/src/qs_p_env_methods.F b/src/qs_p_env_methods.F index 7fde38663a..b7e2b9a78c 100644 --- a/src/qs_p_env_methods.F +++ b/src/qs_p_env_methods.F @@ -224,9 +224,8 @@ CONTAINS END DO p_env%orthogonal_orbitals = .FALSE. - IF (PRESENT(orthogonal_orbitals)) THEN + IF (PRESENT(orthogonal_orbitals)) & p_env%orthogonal_orbitals = orthogonal_orbitals - END IF CALL fm_pools_create_fm_vect(ao_mo_fm_pools, elements=p_env%S_psi0, & name="p_env%S_psi0") @@ -266,7 +265,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, p_env%local_rho_set%rho0_mpole) CALL hartree_local_create(p_env%hartree_local) CALL init_coulomb_local(p_env%hartree_local, natom) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) diff --git a/src/qs_pdos.F b/src/qs_pdos.F index 3f569ade73..5a16f5b080 100644 --- a/src/qs_pdos.F +++ b/src/qs_pdos.F @@ -579,9 +579,8 @@ CONTAINS eval_ref => mos_ref(ispin_ref)%eigenvalues occ_ref => mos_ref(ispin_ref)%occupation_numbers DO imo_ref = 1, nmo_ref - IF (occ_ref(imo_ref) > 1.0e-10_dp) THEN + IF (occ_ref(imo_ref) > 1.0e-10_dp) & hoco_ref(ispin_ref) = MAX(hoco_ref(ispin_ref), eval_ref(imo_ref)) - END IF IF (ABS(occ_ref(imo_ref) - REAL(NINT(occ_ref(imo_ref)), KIND=dp)) > & 1.0e-8_dp) fractional_occupation = .TRUE. END DO @@ -619,12 +618,10 @@ CONTAINS !Adjust energy range for r_ldos DO ildos = 1, n_r_ldos - IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) THEN + IF (eigenvalues(1) > r_ldos_p(ildos)%ldos%eval_range(1)) & r_ldos_p(ildos)%ldos%eval_range(1) = eigenvalues(1) - END IF - IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) THEN + IF (eigenvalues(nmo + nvirt) < r_ldos_p(ildos)%ldos%eval_range(2)) & r_ldos_p(ildos)%ldos%eval_range(2) = eigenvalues(nmo + nvirt) - END IF END DO IF (output_unit > 0) WRITE (UNIT=output_unit, FMT='(/,(T15,A))') & diff --git a/src/qs_resp.F b/src/qs_resp.F index 13843d37cc..971dd1768c 100644 --- a/src/qs_resp.F +++ b/src/qs_resp.F @@ -396,10 +396,9 @@ CONTAINS r_val=resp_env%rheavies_strength) END IF CALL section_vals_val_get(resp_section, "STRIDE", i_vals=my_stride) - IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) THEN + IF (SIZE(my_stride) /= 1 .AND. SIZE(my_stride) /= 3) & CALL cp_abort(__LOCATION__, "STRIDE keyword can accept only 1 (the same for X,Y,Z) "// & "or 3 values. Correct your input file.") - END IF IF (SIZE(my_stride) == 1) THEN DO i = 1, 3 resp_env%stride(i) = my_stride(1) @@ -727,9 +726,8 @@ CONTAINS DO j = i + 1, num_atom atom_a = atom_list(i) atom_b = atom_list(j) - IF (atom_a == atom_b) THEN + IF (atom_a == atom_b) & CPABORT("There are atoms doubled in atom list for RESP.") - END IF END DO END DO diff --git a/src/qs_rho0_ggrid.F b/src/qs_rho0_ggrid.F index d3fa12931d..a6a8c57793 100644 --- a/src/qs_rho0_ggrid.F +++ b/src/qs_rho0_ggrid.F @@ -440,10 +440,9 @@ CONTAINS ! END IF !END IF - IF (PRESENT(local_rho_set)) THEN + IF (PRESENT(local_rho_set)) & CALL get_local_rho(local_rho_set, rho0_mpole=rho0_mpole, rho_atom_set=rho_atom_set, & rhoz_cneo_set=rhoz_cneo_set) - END IF ! Q from rho0_mpole of local_rho_set ! for TDDFT forces we need mixed potential / integral space ! potential stored on local_rho_set_2nd diff --git a/src/qs_rho_methods.F b/src/qs_rho_methods.F index f54d7afcd9..7cb0436876 100644 --- a/src/qs_rho_methods.F +++ b/src/qs_rho_methods.F @@ -140,9 +140,8 @@ CONTAINS do_kpoints=do_kpoints, & pw_env=pw_env, & dft_control=dft_control) - IF (PRESENT(pw_env_external)) THEN + IF (PRESENT(pw_env_external)) & pw_env => pw_env_external - END IF nimg = dft_control%nimages @@ -183,9 +182,8 @@ CONTAINS ! rho_ao IF (my_rebuild_ao .OR. (.NOT. ASSOCIATED(rho_ao_kp))) THEN - IF (ASSOCIATED(rho_ao_kp)) THEN + IF (ASSOCIATED(rho_ao_kp)) & CALL dbcsr_deallocate_matrix_set(rho_ao_kp) - END IF ! Create a new density matrix set CALL dbcsr_allocate_matrix_set(rho_ao_kp, nspins, nimg) CALL qs_rho_set(rho, rho_ao_kp=rho_ao_kp) @@ -408,12 +406,12 @@ CONTAINS CALL calculate_harris_density(qs_env, harris_env%rhoin, rho_struct) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSE IF (dft_control%qs_control%semi_empirical .OR. & - dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%semi_empirical .OR. & + dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE.) - ELSE IF (dft_control%qs_control%lrigpw) THEN + ELSEIF (dft_control%qs_control%lrigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) @@ -429,7 +427,7 @@ CONTAINS CALL set_qs_env(qs_env, lri_density=lri_density) CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) - ELSE IF (dft_control%qs_control%rigpw) THEN + ELSEIF (dft_control%qs_control%rigpw) THEN CPASSERT(.NOT. dft_control%use_kinetic_energy_density) CPASSERT(.NOT. dft_control%drho_by_collocation) CALL get_qs_env(qs_env, lri_env=lri_env) diff --git a/src/qs_scf.F b/src/qs_scf.F index 8c9eaf8760..30865f773b 100644 --- a/src/qs_scf.F +++ b/src/qs_scf.F @@ -278,9 +278,8 @@ CONTAINS scf_control%outer_scf%cdft_opt_control%ijacobian(2) = scf_control%outer_scf%cdft_opt_control%ijacobian(2) + 1 IF (scf_control%outer_scf%cdft_opt_control%ijacobian(2) >= & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) .AND. & - scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) THEN + scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) & scf_env%outer_scf%deallocate_jacobian = .TRUE. - END IF END IF END IF ! *** add the converged wavefunction to the wavefunction history @@ -318,9 +317,8 @@ CONTAINS ! *** cleanup CALL scf_env_cleanup(scf_env) - IF (dft_control%qs_control%cdft) THEN + IF (dft_control%qs_control%cdft) & CALL cdft_control_cleanup(dft_control%qs_control%cdft_control) - END IF IF (PRESENT(has_converged)) THEN has_converged = converged @@ -476,11 +474,10 @@ CONTAINS CALL get_results(results, description=description, & values=res_val_3, n_entries=i_tmp) CPASSERT(i_tmp == 3) - IF (ALL(res_val_3(:) <= 0.0)) THEN + IF (ALL(res_val_3(:) <= 0.0)) & CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)// & ") which is not correctly stored.") - END IF CALL external_comm%set_handle(NINT(res_val_3(1))) END IF ext_master_id = NINT(res_val_3(2)) @@ -581,7 +578,7 @@ CONTAINS IF (tblite_native_mixer) THEN scf_env%iter_param = dft_control%qs_control%xtb_control%tblite_mixer_damping scf_env%iter_method = "TBLite/Diag" - ELSE IF (internal_tblite_mixer) THEN + ELSEIF (internal_tblite_mixer) THEN scf_env%iter_method = "TBLite/Diag" IF (dft_control%qs_control%dftb) THEN scf_env%iter_param = dft_control%qs_control%dftb_control%tblite_mixer_damping @@ -644,9 +641,8 @@ CONTAINS END IF IF (.NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) THEN + scf_section, "PRINT%ITERATION_INFO/TIME_CUMUL"), cp_p_file)) & t1 = m_walltime() - END IF ! mixing methods have the new density matrix in p_mix_new IF (scf_env%mixing_method > 0) THEN @@ -695,10 +691,9 @@ CONTAINS converged = inner_loop_converged .AND. outer_loop_converged total_scf_steps = total_steps - IF (dft_control%qs_control%cdft) THEN + IF (dft_control%qs_control%cdft) & dft_control%qs_control%cdft_control%total_steps = & - dft_control%qs_control%cdft_control%total_steps + total_steps - END IF + dft_control%qs_control%cdft_control%total_steps + total_steps IF (.NOT. converged) THEN IF (scf_control%ignore_convergence_failure .OR. should_stop) THEN @@ -720,10 +715,8 @@ CONTAINS ! if needed copy mo_coeff dbcsr->fm for later use in post_scf!fm->dbcsr DO ispin = 1, SIZE(mos) !fm -> dbcsr IF (mos(ispin)%use_mo_coeff_b) THEN !fm->dbcsr - IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) THEN - !fm->dbcsr - CPABORT("mo_coeff_b is not allocated") - END IF !fm->dbcsr + IF (.NOT. ASSOCIATED(mos(ispin)%mo_coeff_b)) & !fm->dbcsr + CPABORT("mo_coeff_b is not allocated") !fm->dbcsr CALL copy_dbcsr_to_fm(mos(ispin)%mo_coeff_b, & !fm->dbcsr mos(ispin)%mo_coeff) !fm -> dbcsr END IF !fm->dbcsr @@ -928,11 +921,10 @@ CONTAINS IF (dft_control%restricted) THEN scf_env%qs_ot_env(1)%restricted = .TRUE. ! requires rotation - IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) THEN + IF (.NOT. scf_env%qs_ot_env(1)%settings%do_rotation) & CALL cp_abort(__LOCATION__, & "Restricted calculation with OT requires orbital rotation. Please "// & "activate the OT%ROTATION keyword!") - END IF ELSE scf_env%qs_ot_env(:)%restricted = .FALSE. END IF @@ -942,9 +934,8 @@ CONTAINS do_rotation = scf_env%qs_ot_env(1)%settings%do_rotation ! only full all needs rotation is_full_all = scf_env%qs_ot_env(1)%settings%preconditioner_type == ot_precond_full_all - IF (do_rotation .AND. is_full_all) THEN + IF (do_rotation .AND. is_full_all) & CPABORT('PRECONDITIONER FULL_ALL is not compatible with ROTATION.') - END IF ! might need the KS matrix to init properly CALL qs_ks_update_qs_env(qs_env, just_energy=.FALSE., & @@ -952,11 +943,10 @@ CONTAINS ! if an old preconditioner is still around (i.e. outer SCF is active), ! remove it if this could be worthwhile - IF (.NOT. reuse_precond) THEN + IF (.NOT. reuse_precond) & CALL restart_preconditioner(qs_env, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & dft_control%nspins) - END IF ! ! preconditioning still needs to be done correctly with has_unit_metric @@ -968,14 +958,13 @@ CONTAINS orthogonality_metric => matrix_s(1)%matrix END IF - IF (.NOT. reuse_precond) THEN + IF (.NOT. reuse_precond) & CALL prepare_preconditioner(qs_env, mos, matrix_ks, matrix_s, scf_env%ot_preconditioner, & scf_env%qs_ot_env(1)%settings%preconditioner_type, & scf_env%qs_ot_env(1)%settings%precond_solver_type, & scf_env%qs_ot_env(1)%settings%energy_gap, dft_control%nspins, & has_unit_metric=has_unit_metric, & chol_type=scf_env%qs_ot_env(1)%settings%cholesky_type) - END IF IF (reuse_precond) reuse_precond = .FALSE. CALL ot_scf_init(mo_array=mos, matrix_s=orthogonality_metric, & @@ -1214,9 +1203,8 @@ CONTAINS ! usually this means that the electronic structure has already converged to the correct state ! but the constraint optimizer keeps jumping over the optimal solution IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count == 1 & - .AND. cdft_control%total_steps /= 1) THEN + .AND. cdft_control%total_steps /= 1) & cdft_control%nreused = cdft_control%nreused - 1 - END IF ! SCF converged in less than precond_freq steps IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count <= cdft_control%precond_freq .AND. & cdft_control%total_steps /= 1 .AND. cdft_control%nreused < cdft_control%max_reuse) THEN @@ -1368,22 +1356,17 @@ CONTAINS SUBROUTINE cdft_control_cleanup(cdft_control) TYPE(cdft_control_type), POINTER :: cdft_control - IF (ASSOCIATED(cdft_control%constraint%variables)) THEN + IF (ASSOCIATED(cdft_control%constraint%variables)) & DEALLOCATE (cdft_control%constraint%variables) - END IF - IF (ASSOCIATED(cdft_control%constraint%count)) THEN + IF (ASSOCIATED(cdft_control%constraint%count)) & DEALLOCATE (cdft_control%constraint%count) - END IF - IF (ASSOCIATED(cdft_control%constraint%gradient)) THEN + IF (ASSOCIATED(cdft_control%constraint%gradient)) & DEALLOCATE (cdft_control%constraint%gradient) - END IF - IF (ASSOCIATED(cdft_control%constraint%energy)) THEN + IF (ASSOCIATED(cdft_control%constraint%energy)) & DEALLOCATE (cdft_control%constraint%energy) - END IF IF (ASSOCIATED(cdft_control%constraint%inv_jacobian) .AND. & - cdft_control%constraint%deallocate_jacobian) THEN + cdft_control%constraint%deallocate_jacobian) & DEALLOCATE (cdft_control%constraint%inv_jacobian) - END IF END SUBROUTINE cdft_control_cleanup @@ -1455,11 +1438,10 @@ CONTAINS IF (explicit_jacobian) THEN ! Build Jacobian with finite differences cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) THEN + IF (.NOT. ASSOCIATED(cdft_control)) & CALL cp_abort(__LOCATION__, & "Optimizers that need the explicit Jacobian can"// & " only be used together with a valid CDFT constraint.") - END IF ! Redirect output from Jacobian calculation to a new file by creating a temporary logger project_name = logger%iter_info%project_name CALL create_tmp_logger(para_env, project_name, "-JacobianInfo.out", output_unit, tmp_logger) @@ -1555,9 +1537,8 @@ CONTAINS jacobian(i, j) = jacobian(i, j)/dh(j) END DO END DO - IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (.NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & ALLOCATE (scf_env%outer_scf%inv_jacobian(nvar, nvar)) - END IF inv_jacobian => scf_env%outer_scf%inv_jacobian CALL invert_matrix(jacobian, inv_jacobian, inv_error) scf_control%outer_scf%cdft_opt_control%broyden_update = .FALSE. @@ -1648,25 +1629,22 @@ CONTAINS do_linesearch = .FALSE. CASE (broyden_type_1_ls, broyden_type_1_explicit_ls, broyden_type_2_ls, broyden_type_2_explicit_ls) cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) THEN + IF (.NOT. ASSOCIATED(cdft_control)) & CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") - END IF - IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) & do_linesearch = .TRUE. - END IF END SELECT END SELECT IF (do_linesearch) THEN BLOCK TYPE(mo_set_type), DIMENSION(:), ALLOCATABLE :: mos_ls, mos_stashed cdft_control => dft_control%qs_control%cdft_control - IF (.NOT. ASSOCIATED(cdft_control)) THEN + IF (.NOT. ASSOCIATED(cdft_control)) & CALL cp_abort(__LOCATION__, & "Optimizers that perform a line search can"// & " only be used together with a valid CDFT constraint") - END IF CPASSERT(ASSOCIATED(scf_env%outer_scf%inv_jacobian)) CPASSERT(ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) alpha = scf_control%outer_scf%cdft_opt_control%newton_step_save @@ -1800,9 +1778,8 @@ CONTAINS IF (i == max_linesearch) continue_ls_exit = .TRUE. ! Exit if constraint target is satisfied to requested tolerance IF (SQRT(MAXVAL(scf_env%outer_scf%gradient(:, scf_env%outer_scf%iter_count + 1)**2)) < & - scf_control%outer_scf%eps_scf) THEN + scf_control%outer_scf%eps_scf) & continue_ls_exit = .TRUE. - END IF ! Exit if line search jumped over the optimal step length IF (sign_changed) continue_ls_exit = .TRUE. END IF @@ -1858,10 +1835,9 @@ CONTAINS "Line search did not converge. CDFT SCF proceeds with fixed step size.") scf_control%outer_scf%cdft_opt_control%newton_step = scf_control%outer_scf%cdft_opt_control%newton_step_save END IF - IF (reached_maxls) THEN + IF (reached_maxls) & CALL cp_warn(__LOCATION__, & "Line search did not converge. CDFT SCF proceeds with lasted iterated step size.") - END IF CALL cp_rm_default_logger() CALL cp_logger_release(tmp_logger) ! Release temporary storage diff --git a/src/qs_scf_csr_write.F b/src/qs_scf_csr_write.F index 557ff151d3..c92135f798 100644 --- a/src/qs_scf_csr_write.F +++ b/src/qs_scf_csr_write.F @@ -594,9 +594,8 @@ CONTAINS nomirror = 0 DO ic = 1, ncell cell = i2c(:, ic) - IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) THEN + IF (cell_to_index(-cell(1), -cell(2), -cell(3)) == 0) & nomirror = nomirror + 1 - END IF END DO ! create the mirror imgs diff --git a/src/qs_scf_diagonalization.F b/src/qs_scf_diagonalization.F index fc7973f9c5..0c0619c93f 100644 --- a/src/qs_scf_diagonalization.F +++ b/src/qs_scf_diagonalization.F @@ -223,7 +223,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1124,9 +1124,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(subspace_env%mixing_store) - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(subspace_env%mixing_method, rho, subspace_env%mixing_store, para_env) @@ -1378,7 +1378,7 @@ CONTAINS ELSE scf_env%iter_method = "P_Mix/Diag." END IF - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha IF (use_jacobi) THEN scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Jacobi" @@ -1476,7 +1476,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/OTdiag." - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/OTdiag." END IF @@ -1695,7 +1695,7 @@ CONTAINS IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF @@ -1917,11 +1917,10 @@ CONTAINS CALL lanczos_refinement(scf_env%krylov_space, ks, c0, c1, mo_eigenvalues, & nao, eps_iter, ispin, check_moconv_only=my_check_moconv_only) t2 = m_walltime() - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, '(T8,I3,T16,I5,T24,I6,T33,E12.4,2x,E12.4,T60,F8.3)') & - ispin, iter, scf_env%krylov_space%nmo_conv, & - scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 - END IF + ispin, iter, scf_env%krylov_space%nmo_conv, & + scf_env%krylov_space%max_res_norm, scf_env%krylov_space%min_res_norm, t2 - t1 CYCLE ELSE @@ -2039,9 +2038,8 @@ CONTAINS output_unit = cp_print_key_unit_nr(logger, scf_section, "PRINT%DAVIDSON", & extension=".scfLog") - IF (output_unit > 0) THEN + IF (output_unit > 0) & WRITE (output_unit, "(/T15,A)") '<<<<<<<<< DAVIDSON ITERATIONS <<<<<<<<<<' - END IF IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha diff --git a/src/qs_scf_initialization.F b/src/qs_scf_initialization.F index fd63e14991..71bed6abc6 100644 --- a/src/qs_scf_initialization.F +++ b/src/qs_scf_initialization.F @@ -349,15 +349,13 @@ CONTAINS NULLIFY (outer_scf_history, gradient_history, variable_history) CALL get_qs_env(qs_env=qs_env, do_kpoints=do_kpoints) ! Test kpoints - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("CDFT calculation not possible with kpoints") - END IF ! Check that OUTER_SCF section in DFT&SCF is active ! This section must always be active to facilitate ! switching of the CDFT and SCF control parameters in outer_loop_switch - IF (.NOT. scf_control%outer_scf%have_scf) THEN + IF (.NOT. scf_control%outer_scf%have_scf) & CPABORT("Section SCF&OUTER_SCF must be active for CDFT calculations.") - END IF ! Initialize CDFT and outer_loop variables (constraint settings active in scf_control) IF (dft_control%qs_control%cdft_control%constraint_control%have_scf) THEN nhistory = dft_control%qs_control%cdft_control%constraint_control%max_scf + 1 @@ -662,12 +660,10 @@ CONTAINS ! possible for OT gamma point calculations qs_env%requires_mo_derivs = .FALSE. END IF - IF (dft_control%do_xas_calculation) THEN + IF (dft_control%do_xas_calculation) & CPABORT("No XAS implemented with kpoints") - END IF - IF (qs_env%do_rixs) THEN + IF (qs_env%do_rixs) & CPABORT("RIXS not implemented with kpoints") - END IF DO ik = 1, SIZE(kpoints%kp_env) CALL mpools_get(kpoints%mpools, ao_mo_fm_pools=ao_mo_fm_pools) mos_k => kpoints%kp_env(ik)%kpoint_env%mos @@ -798,14 +794,12 @@ CONTAINS IF (scf_control%use_diag) THEN ! sanity check whether combinations are allowed - IF (dft_control%restricted) THEN + IF (dft_control%restricted) & CPABORT("OT only for restricted (ROKS)") - END IF SELECT CASE (scf_control%diagonalization%method) CASE (diag_ot, diag_block_krylov, diag_block_davidson) - IF (.NOT. not_se_or_tb) THEN + IF (.NOT. not_se_or_tb) & CPABORT("TB and SE not possible with OT diagonalization") - END IF END SELECT SELECT CASE (scf_control%diagonalization%method) ! Diagonalization: additional check whether we are in an orthonormal basis @@ -826,39 +820,32 @@ CONTAINS END IF ! OT Diagonalization: not possible with ROKS CASE (diag_ot) - IF (dft_control%roks) THEN + IF (dft_control%roks) & CPABORT("ROKS with OT diagonalization not possible") - END IF - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("OT diagonalization not possible with kpoint calculations") - END IF scf_env%method = ot_diag_method_nr need_coeff_b = .TRUE. ! Block Krylov diagonlization: not possible with ROKS, ! allocation of additional matrices is needed CASE (diag_block_krylov) - IF (dft_control%roks) THEN + IF (dft_control%roks) & CPABORT("ROKS with block PF diagonalization not possible") - END IF - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("Block Krylov diagonalization not possible with kpoint calculations") - END IF scf_env%method = block_krylov_diag_method_nr scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%krylov_space)) THEN + IF (.NOT. ASSOCIATED(scf_env%krylov_space)) & CALL krylov_space_create(scf_env%krylov_space, scf_section) - END IF CALL krylov_space_allocate(scf_env%krylov_space, scf_control, mos) ! Block davidson diagonlization: allocation of additional matrices is needed CASE (diag_block_davidson) - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("Block Davidson diagonalization not possible with kpoint calculations") - END IF scf_env%method = block_davidson_diag_method_nr - IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) THEN + IF (.NOT. ASSOCIATED(scf_env%block_davidson_env)) & CALL block_davidson_env_create(scf_env%block_davidson_env, dft_control%nspins, & scf_section) - END IF DO ispin = 1, dft_control%nspins CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff, nao=nao, nmo=nmo) CALL block_davidson_allocate(scf_env%block_davidson_env(ispin), mo_coeff, nao, nmo) @@ -881,29 +868,24 @@ CONTAINS ! Check if subspace diagonlization is requested: allocation of additional matrices is needed IF (scf_control%do_diag_sub) THEN scf_env%needs_ortho = .TRUE. - IF (.NOT. ASSOCIATED(scf_env%subspace_env)) THEN + IF (.NOT. ASSOCIATED(scf_env%subspace_env)) & CALL diag_subspace_env_create(scf_env%subspace_env, scf_section, & dft_control%qs_control%cutoff) - END IF CALL diag_subspace_allocate(scf_env%subspace_env, qs_env, mos) - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("No subspace diagonlization with kpoint calculation") - END IF END IF ! OT: check if OT is used instead of diagonalization. Not possible with added MOS at the moment - ELSE IF (scf_control%use_ot) THEN + ELSEIF (scf_control%use_ot) THEN scf_env%method = ot_method_nr need_coeff_b = .TRUE. - IF (SUM(ABS(scf_control%added_mos)) > 0) THEN + IF (SUM(ABS(scf_control%added_mos)) > 0) & CPABORT("OT with ADDED_MOS/=0 not implemented") - END IF - IF (dft_control%restricted .AND. dft_control%nspins /= 2) THEN + IF (dft_control%restricted .AND. dft_control%nspins /= 2) & CPABORT("nspin must be 2 for restricted (ROKS)") - END IF - IF (do_kpoints) THEN + IF (do_kpoints) & CPABORT("OT not possible with kpoint calculations") - END IF - ELSE IF (scf_env%method /= smeagol_method_nr) THEN + ELSEIF (scf_env%method /= smeagol_method_nr) THEN CPABORT("OT or DIAGONALIZATION have to be set") END IF DO ispin = 1, dft_control%nspins @@ -1307,9 +1289,9 @@ CONTAINS CALL get_qs_env(qs_env=qs_env, rho_atom_set=rho_atom) CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & para_env, rho_atom=rho_atom) - ELSE IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%dftb .OR. dft_control%qs_control%xtb) THEN CALL charge_mixing_init(scf_env%mixing_store) - ELSE IF (dft_control%qs_control%semi_empirical) THEN + ELSEIF (dft_control%qs_control%semi_empirical) THEN CPABORT('SE Code not possible') ELSE CALL mixing_init(scf_env%mixing_method, rho, scf_env%mixing_store, & diff --git a/src/qs_scf_loop_utils.F b/src/qs_scf_loop_utils.F index 148d1bc942..9732a0c488 100644 --- a/src/qs_scf_loop_utils.F +++ b/src/qs_scf_loop_utils.F @@ -172,13 +172,13 @@ CONTAINS "SCF%DIAGONALIZATION if "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE ") - ELSE IF (dft_control%roks) THEN + ELSEIF (dft_control%roks) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & "SURFACE_DIPOLE_CORRECTION TRUE "// & "is not implemented with ROKS") - ELSE IF (scf_control%diagonalization%mom) THEN + ELSEIF (scf_control%diagonalization%mom) THEN CALL cp_abort(__LOCATION__, & "Combination of "// & "CORE_CORRECTION /= 0.0 and "// & @@ -342,9 +342,8 @@ CONTAINS scf_control%eps_diis = 0.0_dp END IF - IF (dft_control%roks) THEN + IF (dft_control%roks) & CPABORT("KP code: ROKS method not available: ") - END IF SELECT CASE (scf_env%method) CASE DEFAULT @@ -371,7 +370,7 @@ CONTAINS ELSE IF (scf_env%mixing_method == 1) THEN scf_env%iter_param = scf_env%p_mix_alpha scf_env%iter_method = "P_Mix/Diag." - ELSE IF (scf_env%mixing_method > 1) THEN + ELSEIF (scf_env%mixing_method > 1) THEN scf_env%iter_param = scf_env%mixing_store%alpha scf_env%iter_method = TRIM(scf_env%mixing_store%iter_method)//"/Diag." END IF diff --git a/src/qs_scf_methods.F b/src/qs_scf_methods.F index cbb13c407d..bfba4f2e90 100644 --- a/src/qs_scf_methods.F +++ b/src/qs_scf_methods.F @@ -197,16 +197,14 @@ CONTAINS CASE (cholesky_reduce) CALL cp_fm_cholesky_reduce(matrix_ks_fm, ortho) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF CASE (cholesky_restore) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -215,17 +213,15 @@ CONTAINS CALL cp_fm_cholesky_restore(work, nao, ortho, matrix_ks_fm, & "SOLVE", pos="LEFT", transa="T") - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_cholesky_restore(work, nmo, ortho, mo_coeff, "SOLVE") - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF CASE (cholesky_inverse) CALL cp_fm_uplo_to_full(matrix_ks_fm, work) @@ -235,19 +231,17 @@ CONTAINS CALL cp_fm_triangular_multiply(ortho, matrix_ks_fm, side="L", transpose_tr=.TRUE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nao, alpha=1.0_dp) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.TRUE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL cp_fm_triangular_multiply(ortho, work, side="L", transpose_tr=.FALSE., & invert_tr=.FALSE., uplo_tr="U", n_rows=nao, n_cols=nmo, alpha=1.0_dp) CALL cp_fm_to_fm(work, mo_coeff, nmo, 1, 1) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF END SELECT @@ -432,10 +426,9 @@ CONTAINS CALL cp_fm_symm("L", "U", nao, nao_red, 1.0_dp, matrix_ks_fm, ortho_red, 0.0_dp, work_red) CALL parallel_gemm("T", "N", nao_red, nao_red, nao, 1.0_dp, ortho_red, work_red, 0.0_dp, matrix_ks_fm_red) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm_red, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm_red) - END IF CALL cp_fm_create(work_red2, matrix_ks_fm_red%matrix_struct) ALLOCATE (eigenvalues(nao_red)) @@ -447,18 +440,16 @@ CONTAINS ELSE CALL cp_fm_symm("L", "U", nao, nao, 1.0_dp, matrix_ks_fm, ortho, 0.0_dp, work) CALL parallel_gemm("T", "N", nao, nao, nao, 1.0_dp, ortho, work, 0.0_dp, matrix_ks_fm) - IF (do_level_shift) THEN + IF (do_level_shift) & CALL shift_unocc_mos(matrix_ks_fm=matrix_ks_fm, mo_coeff=mo_coeff, homo=homo, & level_shift=level_shift, is_triangular=.FALSE., matrix_u_fm=matrix_u_fm) - END IF CALL choose_eigv_solver(matrix_ks_fm, work, mo_eigenvalues) CALL parallel_gemm("N", "N", nao, nmo, nao, 1.0_dp, ortho, work, 0.0_dp, & mo_coeff) END IF - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF END IF @@ -528,9 +519,8 @@ CONTAINS END IF - IF (do_level_shift) THEN + IF (do_level_shift) & CALL correct_mo_eigenvalues(mo_eigenvalues, homo, nmo, level_shift) - END IF CALL timestop(handle) diff --git a/src/qs_scf_output.F b/src/qs_scf_output.F index 60afbc842b..203abdc458 100644 --- a/src/qs_scf_output.F +++ b/src/qs_scf_output.F @@ -252,13 +252,11 @@ CONTAINS occup_stats_occ_threshold = 1e-6_dp IF (SIZE(tmpstringlist) > 0) THEN ! the lone_keyword_c_vals doesn't work as advertised, handle it manually print_occup_stats = .TRUE. - IF (LEN_TRIM(tmpstringlist(1)) > 0) THEN + IF (LEN_TRIM(tmpstringlist(1)) > 0) & READ (tmpstringlist(1), *) print_occup_stats - END IF END IF - IF (SIZE(tmpstringlist) > 1) THEN + IF (SIZE(tmpstringlist) > 1) & READ (tmpstringlist(2), *) occup_stats_occ_threshold - END IF logger => cp_get_default_logger() print_mo_info = (cp_print_key_should_output(logger%iter_info, dft_section, "PRINT%MO") /= 0) @@ -703,25 +701,22 @@ CONTAINS "Two-electron integral energy [eV]: ", energy%hartree*evolt, & "Electronic energy [eV]: ", & (energy%core + 0.5_dp*energy%hartree)*evolt - IF (energy%dispersion /= 0.0_dp) THEN + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy [eV]: ", energy%dispersion*evolt - END IF - ELSE IF (dft_control%qs_control%dftb) THEN + "Dispersion energy [eV]: ", energy%dispersion*evolt + ELSEIF (dft_control%qs_control%dftb) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "Dispersion energy: ", energy%dispersion - IF (energy%dftb3 /= 0.0_dp) THEN + IF (energy%dftb3 /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "DFTB3 3rd order energy: ", energy%dftb3 - END IF - IF (energy%efield /= 0.0_dp) THEN + "DFTB3 3rd order energy: ", energy%dftb3 + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF - ELSE IF (dft_control%qs_control%xtb) THEN + "Electric field interaction energy: ", energy%efield + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & @@ -738,31 +733,28 @@ CONTAINS "SRB Correction energy: ", energy%srb, & "Charge equilibration energy: ", energy%eeq, & "Dispersion energy: ", energy%dispersion - ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN + ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 1) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "Core Hamiltonian energy: ", energy%core, & "Repulsive potential energy: ", energy%repulsive, & "Electronic energy: ", energy%hartree, & "DFTB3 3rd order energy: ", energy%dftb3, & "Dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%xb_interaction) THEN + IF (dft_control%qs_control%xtb_control%xb_interaction) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - END IF - ELSE IF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN + "Correction for halogen bonding: ", energy%xtb_xb_inter + ELSEIF (dft_control%qs_control%xtb_control%gfn_type == 2) THEN CPABORT("gfn_typ 2 NYA") ELSE CPABORT("invalid gfn_typ") END IF END IF - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF - IF (energy%efield /= 0.0_dp) THEN + "Correction for nonbonded interactions: ", energy%xtb_nonbonded + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield ELSE IF (dft_control%do_admm) THEN exc_energy = energy%exc + energy%exc_aux_fit @@ -800,27 +792,22 @@ CONTAINS "Hartree energy: ", energy%hartree, & "Exchange-correlation energy: ", exc_energy END IF - IF (energy%e_hartree /= 0.0_dp) THEN + IF (energy%e_hartree /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,/,T3,A,T56,F25.14)") & - "Coulomb Electron-Electron Interaction Energy ", & - "- Already included in the total Hartree term ", energy%e_hartree - END IF - IF (energy%ex /= 0.0_dp) THEN + "Coulomb Electron-Electron Interaction Energy ", & + "- Already included in the total Hartree term ", energy%e_hartree + IF (energy%ex /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Hartree-Fock Exchange energy: ", energy%ex - END IF - IF (energy%dispersion /= 0.0_dp) THEN + "Hartree-Fock Exchange energy: ", energy%ex + IF (energy%dispersion /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Dispersion energy: ", energy%dispersion - END IF - IF (energy%gcp /= 0.0_dp) THEN + "Dispersion energy: ", energy%dispersion + IF (energy%gcp /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "gCP energy: ", energy%gcp - END IF - IF (energy%efield /= 0.0_dp) THEN + "gCP energy: ", energy%gcp + IF (energy%efield /= 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T3,A,T56,F25.14)") & - "Electric field interaction energy: ", energy%efield - END IF + "Electric field interaction energy: ", energy%efield IF (gapw) THEN WRITE (UNIT=output_unit, FMT="(/,(T3,A,T56,F25.14))") & "GAPW| Exc from hard and soft atomic rho1: ", exc1_energy, & @@ -1213,10 +1200,9 @@ CONTAINS WRITE (output_unit, '(A,L7)') & " Precompute gradients : ", cdft_control%becke_control%in_memory WRITE (output_unit, '(A)') " " - IF (cdft_control%becke_control%adjust) THEN + IF (cdft_control%becke_control%adjust) & WRITE (output_unit, '(A)') & - " Using atomic radii to generate a heteronuclear charge partitioning" - END IF + " Using atomic radii to generate a heteronuclear charge partitioning" WRITE (output_unit, '(A)') " " IF (.NOT. cdft_control%becke_control%cavity_confine) THEN WRITE (output_unit, '(A)') & diff --git a/src/qs_scf_post_gpw.F b/src/qs_scf_post_gpw.F index a4fe7a7a25..16cd43613c 100644 --- a/src/qs_scf_post_gpw.F +++ b/src/qs_scf_post_gpw.F @@ -903,9 +903,9 @@ CONTAINS IF (p_loc_homo) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSE IF (dft_control%restricted & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & - .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN + ELSEIF (dft_control%restricted & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_none) & + .AND. (section_get_ival(localize_section, "METHOD") /= do_loc_jacobi)) THEN CPABORT("ROKS works only with LOCALIZE METHOD NONE or JACOBI") ELSE ALLOCATE (occupied_orbs(dft_control%nspins)) @@ -1053,7 +1053,7 @@ CONTAINS IF (p_loc_mixed) THEN IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") - ELSE IF (dft_control%restricted) THEN + ELSEIF (dft_control%restricted) THEN IF (output_unit > 0) WRITE (output_unit, *) & " Unclear how we define MOs / localization in the restricted case... skipping" ELSE @@ -2277,7 +2277,7 @@ CONTAINS CALL section_vals_val_get(dft_section, "PRINT%DOS%NLUMO", i_val=nlumo_dos) IF (nlumo_dos == -1) THEN nlumo_required = -1 - ELSE IF (nlumo_required /= -1) THEN + ELSEIF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_dos) END IF END IF @@ -2285,7 +2285,7 @@ CONTAINS IF (defer_molden) THEN IF (nlumo_molden == -1) THEN nlumo_required = -1 - ELSE IF (nlumo_required /= -1) THEN + ELSEIF (nlumo_required /= -1) THEN nlumo_required = MAX(nlumo_required, nlumo_molden) END IF END IF @@ -3539,11 +3539,10 @@ CONTAINS IF (do_radius) THEN radius_type = radius_user CALL section_vals_val_get(input_section, "ATOMIC_RADII", r_vals=radii) - IF (.NOT. SIZE(radii) == nkind) THEN + IF (.NOT. SIZE(radii) == nkind) & CALL cp_abort(__LOCATION__, & "Length of keyword HIRSHFELD\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") - END IF ELSE radius_type = radius_covalent END IF diff --git a/src/qs_scf_post_scf.F b/src/qs_scf_post_scf.F index 57ef526d5b..5287b69456 100644 --- a/src/qs_scf_post_scf.F +++ b/src/qs_scf_post_scf.F @@ -55,15 +55,15 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CALL scf_post_calculation_se(qs_env) - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CALL wfn_localization_tb(qs_env, "DFTB") CALL scf_post_calculation_tb(qs_env, "DFTB", .FALSE.) - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL wfn_localization_tb(qs_env, "xTB") CALL scf_post_calculation_tb(qs_env, "xTB", .FALSE.) - ELSE IF (dft_control%qs_control%ofgpw) THEN + ELSEIF (dft_control%qs_control%ofgpw) THEN CPWARN("No properties from PRINT section available for OFGPW methods") - ELSE IF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN + ELSEIF (dft_control%qs_control%lri_optbas .AND. dft_control%qs_control%gpw) THEN CALL optimize_lri_basis(qs_env) ELSE IF (PRESENT(wf_type)) THEN diff --git a/src/qs_scf_wfn_mix.F b/src/qs_scf_wfn_mix.F index 5fa98ca6f2..0830d2bd0a 100644 --- a/src/qs_scf_wfn_mix.F +++ b/src/qs_scf_wfn_mix.F @@ -193,11 +193,10 @@ CONTAINS ELSE IF (orig_type == wfn_mix_orig_external) THEN CALL section_vals_val_get(update_section, "ORIG_EXT_FILE_NAME", i_rep_section=i_rep, & c_val=read_file_name) - IF (read_file_name == "EMPTY") THEN + IF (read_file_name == "EMPTY") & CALL cp_abort(__LOCATION__, & "If ORIG_TYPE is set to EXTERNAL, a file name should be set in ORIG_EXT_FILE_NAME "// & "so that it can be used as the orginal MO.") - END IF ALLOCATE (mos_orig_ext(SIZE(mos))) DO ispin = 1, SIZE(mos) @@ -206,10 +205,9 @@ CONTAINS IF (para_env%is_source()) THEN INQUIRE (FILE=TRIM(read_file_name), exist=is_file) - IF (.NOT. is_file) THEN + IF (.NOT. is_file) & CALL cp_abort(__LOCATION__, & "Reference file not found! Name of the file CP2K looked for: "//TRIM(read_file_name)) - END IF CALL open_file(file_name=read_file_name, & file_action="READ", & @@ -263,12 +261,10 @@ CONTAINS IF (my_for_rtp) THEN DO ispin = 1, SIZE(mos_new) CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) THEN + IF (mos_new(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) - END IF - IF (mos(1)%use_mo_coeff_b) THEN + IF (mos(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) - END IF END DO ELSE IF (scf_env%method == special_diag_method_nr) THEN @@ -287,13 +283,11 @@ CONTAINS DO ispin = 1, SIZE(mos_new) IF (overwrite_mos) THEN CALL cp_fm_to_fm(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff) - IF (mos_new(1)%use_mo_coeff_b) THEN + IF (mos_new(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos_new(ispin)%mo_coeff_b) - END IF END IF - IF (mos(1)%use_mo_coeff_b) THEN + IF (mos(1)%use_mo_coeff_b) & CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_coeff, mos(ispin)%mo_coeff_b) - END IF END DO CALL write_mo_set_to_restart(mos_new, particle_set, dft_section=dft_section, & qs_kind_set=qs_kind_set) diff --git a/src/qs_subsys_types.F b/src/qs_subsys_types.F index 3fb4c80a20..0787f1db4f 100644 --- a/src/qs_subsys_types.F +++ b/src/qs_subsys_types.F @@ -77,15 +77,12 @@ CONTAINS CALL cp_subsys_release(subsys%cp_subsys) CALL cell_release(subsys%cell_ref) - IF (ASSOCIATED(subsys%qs_kind_set)) THEN + IF (ASSOCIATED(subsys%qs_kind_set)) & CALL deallocate_qs_kind_set(subsys%qs_kind_set) - END IF - IF (ASSOCIATED(subsys%energy)) THEN + IF (ASSOCIATED(subsys%energy)) & CALL deallocate_qs_energy(subsys%energy) - END IF - IF (ASSOCIATED(subsys%force)) THEN + IF (ASSOCIATED(subsys%force)) & CALL deallocate_qs_force(subsys%force) - END IF END SUBROUTINE qs_subsys_release diff --git a/src/qs_tddfpt2_densities.F b/src/qs_tddfpt2_densities.F index 63ce4065f6..c9c283e13b 100644 --- a/src/qs_tddfpt2_densities.F +++ b/src/qs_tddfpt2_densities.F @@ -100,9 +100,8 @@ CONTAINS END DO ! take into account that all MOs are doubly occupied in spin-restricted case - IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) THEN + IF (nspins == 1 .AND. (.NOT. is_rks_triplets)) & CALL dbcsr_scale(rho_ij_ao(1)%matrix, 2.0_dp) - END IF CALL get_qs_env(qs_env, dft_control=dft_control) @@ -113,7 +112,7 @@ CONTAINS task_list_external=sub_env%task_list_orb_soft, & para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, local_rho_set=sub_env%local_rho_set, pw_env_sub=sub_env%pw_env) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL qs_rho_update_rho(rho_orb_struct, qs_env, & rho_xc_external=rho_xc_struct, & local_rho_set=sub_env%local_rho_set, & diff --git a/src/qs_tddfpt2_eigensolver.F b/src/qs_tddfpt2_eigensolver.F index 12900d5dbb..dcfa59166d 100644 --- a/src/qs_tddfpt2_eigensolver.F +++ b/src/qs_tddfpt2_eigensolver.F @@ -779,9 +779,8 @@ CONTAINS ! eref = e_virt - e_occ - lambda = e_virt - e_occ - (eref_scale*lambda + (1-eref_scale)*lambda); ! eref_new = e_virt - e_occ - eref_scale*lambda = eref + (1 - eref_scale)*lambda - IF (ABS(eref) < threshold) THEN + IF (ABS(eref) < threshold) & eref = eref + (1.0_dp - eref_scale)*lambda - END IF weights_ldata(irow_local, icol_local) = weights_ldata(irow_local, icol_local)/eref END DO @@ -931,9 +930,8 @@ CONTAINS conv = MAXVAL(ABS(evals_last(1:nstates) - evals(1:nstates))) nvects_exist = nvects_exist + nvects_new - IF (nvects_exist + nvects_new > max_krylov_vects) THEN + IF (nvects_exist + nvects_new > max_krylov_vects) & nvects_new = max_krylov_vects - nvects_exist - END IF IF (iter >= tddfpt_control%niters) nvects_new = 0 IF (conv > tddfpt_control%conv .AND. nvects_new > 0) THEN @@ -984,9 +982,8 @@ CONTAINS IF (iter_unit > 0) THEN nstates_conv = 0 DO istate = 1, nstates - IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) THEN + IF (ABS(evals_last(istate) - evals(istate)) <= tddfpt_control%conv) & nstates_conv = nstates_conv + 1 - END IF END DO WRITE (iter_unit, '(T7,I8,T24,F7.1,T40,ES11.4,T66,I8)') iter, t2 - t1, conv, nstates_conv diff --git a/src/qs_tddfpt2_fhxc.F b/src/qs_tddfpt2_fhxc.F index a8b9dfbad0..6c4ba207e8 100644 --- a/src/qs_tddfpt2_fhxc.F +++ b/src/qs_tddfpt2_fhxc.F @@ -201,8 +201,8 @@ CONTAINS para_env_external=sub_env%para_env, & tddfpt_lri_env=kernel_env%lri_env, & tddfpt_lri_density=kernel_env%lri_density) - ELSE IF (dft_control%qs_control%lrigpw .OR. & - dft_control%qs_control%rigpw) THEN + ELSEIF (dft_control%qs_control%lrigpw .OR. & + dft_control%qs_control%rigpw) THEN CALL qs_rho_update_tddfpt(work_matrices%rho_orb_struct_sub, qs_env, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb, & @@ -216,7 +216,7 @@ CONTAINS para_env_external=sub_env%para_env) CALL prepare_gapw_den(qs_env, work_matrices%local_rho_set, & do_rho0=(.NOT. is_rks_triplets), pw_env_sub=sub_env%pw_env) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL qs_rho_update_rho(work_matrices%rho_orb_struct_sub, qs_env, & rho_xc_external=work_matrices%rho_xc_struct_sub, & local_rho_set=work_matrices%local_rho_set, & @@ -447,7 +447,7 @@ CONTAINS qs_env=qs_env, calculate_forces=.FALSE., gapw=gapw, & pw_env_external=sub_env%pw_env, & task_list_external=sub_env%task_list_orb_soft) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN IF (.NOT. is_rks_triplets) THEN CALL integrate_v_rspace(v_rspace=work_matrices%A_ia_rspace_sub(ispin), & hmat=work_matrices%A_ia_munu_sub(ispin), & diff --git a/src/qs_tddfpt2_fhxc_forces.F b/src/qs_tddfpt2_fhxc_forces.F index 2bc0d14fc9..535be9af2e 100644 --- a/src/qs_tddfpt2_fhxc_forces.F +++ b/src/qs_tddfpt2_fhxc_forces.F @@ -612,7 +612,7 @@ CONTAINS CALL qs_fgxc_analytic(rho, rhox, xc_section, weights, auxbas_pw_pool, & fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) END IF - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, & weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf) @@ -633,7 +633,7 @@ CONTAINS IF (gapw .OR. gapw_xc) THEN IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, ex_env%local_rho_set%rho_atom_set, & local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, & @@ -820,7 +820,7 @@ CONTAINS END IF IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd derivatives of EXC not available") - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, & is_rks_triplets, weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau) @@ -909,7 +909,7 @@ CONTAINS IF (do_analytic .AND. .NOT. do_numeric) THEN CPABORT("Analytic 3rd EXC derivatives not available") - ELSE IF (do_numeric) THEN + ELSEIF (do_numeric) THEN IF (do_analytic) THEN CALL gfxc_atom_diff(qs_env, rho_atom_set, & rho_atom_set_f, rho_atom_set_g, & diff --git a/src/qs_tddfpt2_forces.F b/src/qs_tddfpt2_forces.F index af37574cee..35fc7b95f1 100644 --- a/src/qs_tddfpt2_forces.F +++ b/src/qs_tddfpt2_forces.F @@ -907,7 +907,7 @@ CONTAINS CALL rho0_s_grid_create(pw_env, local_rho_set%rho0_mpole) CALL hartree_local_create(hartree_local) CALL init_coulomb_local(hartree_local, natom) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) diff --git a/src/qs_tddfpt2_fprint.F b/src/qs_tddfpt2_fprint.F index 4eb8f2ab0e..8f89d0a44a 100644 --- a/src/qs_tddfpt2_fprint.F +++ b/src/qs_tddfpt2_fprint.F @@ -225,9 +225,9 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("Not available") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL response_force_xtb(qs_env, p_env, ex_env%matrix_hz, ex_env, debug=debug_forces) ELSE CALL response_force(qs_env=qs_env, vh_rspace=ex_env%vh_rspace, & @@ -330,9 +330,9 @@ CONTAINS CALL get_qs_env(qs_env, para_env=para_env) IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT| SE not available") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT| DFTB not available") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN CALL build_xtb_matrices(qs_env=qs_env, calculate_forces=.TRUE.) CALL build_xtb_ks_matrix(qs_env, calculate_forces=.TRUE., just_energy=.FALSE.) ELSE diff --git a/src/qs_tddfpt2_methods.F b/src/qs_tddfpt2_methods.F index 0d5e1af192..9ca62a9333 100644 --- a/src/qs_tddfpt2_methods.F +++ b/src/qs_tddfpt2_methods.F @@ -285,15 +285,12 @@ CONTAINS CALL kernel_info(log_unit, dft_control, tddfpt_control, xc_section) IF (do_kpoints) THEN - IF (calc_forces) THEN + IF (calc_forces) & CPABORT("TDDFPT forces are not implemented for k-points") - END IF - IF (do_rixs) THEN + IF (do_rixs) & CPABORT("RIXS/TDDFPT is not implemented for k-points") - END IF - IF (do_soc) THEN + IF (do_soc) & CPABORT("TDDFPT-SOC is not implemented for k-points") - END IF CALL tddfpt_kpoint_independent_particle(qs_env, logger, tddfpt_control) CALL cp_print_key_finished_output(log_unit, & logger, & @@ -344,9 +341,8 @@ CONTAINS ! multiplicity of molecular system IF (nspins > 1) THEN mult = ABS(SIZE(gs_mos(1)%evals_occ) - SIZE(gs_mos(2)%evals_occ)) + 1 - IF (mult > 2) THEN + IF (mult > 2) & CALL cp_warn(__LOCATION__, "There is a convergence issue for multiplicity >= 3") - END IF ELSE IF (tddfpt_control%rks_triplets) THEN mult = 3 @@ -515,7 +511,7 @@ CONTAINS state_change = .FALSE. IF (ex_env%state > 0) THEN my_state = ex_env%state - ELSE IF (ex_env%state < 0) THEN + ELSEIF (ex_env%state < 0) THEN ! state following ALLOCATE (my_mos(nspins)) DO ispin = 1, nspins @@ -638,9 +634,8 @@ CONTAINS END DO DEALLOCATE (gs_mos) - IF (ASSOCIATED(matrix_ks_oep)) THEN + IF (ASSOCIATED(matrix_ks_oep)) & CALL dbcsr_deallocate_matrix_set(matrix_ks_oep) - END IF CALL timestop(handle) @@ -686,27 +681,21 @@ CONTAINS CALL get_qs_env(qs_env, dft_control=dft_control, input=input, kpoints=kpoints) IF (dft_control%nimages > 1) THEN - IF (tddfpt_control%kernel /= tddfpt_kernel_none) THEN + IF (tddfpt_control%kernel /= tddfpt_kernel_none) & CPABORT("TDDFPT with k-points currently supports only KERNEL NONE") - END IF CALL get_kpoint_info(kpoints, use_real_wfn=use_real_wfn) - IF (use_real_wfn) THEN + IF (use_real_wfn) & CPABORT("K-point TDDFPT requires complex wavefunctions") - END IF - IF (tddfpt_control%spinflip /= no_sf_tddfpt) THEN + IF (tddfpt_control%spinflip /= no_sf_tddfpt) & CPABORT("Spin-flip TDDFPT is not implemented for k-points") - END IF - IF (tddfpt_control%do_smearing) THEN + IF (tddfpt_control%do_smearing) & CPABORT("Smeared-occupation TDDFPT is not implemented for k-points") - END IF - IF (tddfpt_control%oe_corr /= oe_none) THEN + IF (tddfpt_control%oe_corr /= oe_none) & CPABORT("Orbital-energy-corrected TDDFPT is not implemented for k-points") - END IF IF (tddfpt_control%dipole_form /= 0 .AND. & tddfpt_control%dipole_form /= tddfpt_dipole_velocity .AND. & - tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) THEN + tddfpt_control%dipole_form /= tddfpt_dipole_scf_moment) & CPABORT("K-point TDDFPT supports only velocity-form or SCF_MOMENT transition dipoles") - END IF END IF IF (tddfpt_control%nstates <= 0) THEN @@ -721,9 +710,8 @@ CONTAINS IF (dft_control%nimages > 1) THEN IF (tddfpt_control%do_exciton_descriptors .OR. & - tddfpt_control%do_directional_exciton_descriptors) THEN + tddfpt_control%do_directional_exciton_descriptors) & CPABORT("Exciton descriptors are not implemented for k-point TDDFPT") - END IF print_sub => section_vals_get_subs_vals(tddfpt_print_section, "NTO_ANALYSIS") CALL section_vals_get(print_sub, explicit=explicit) IF (explicit) CPABORT("NTO analysis is not implemented for k-point TDDFPT") @@ -1086,15 +1074,13 @@ CONTAINS ntrans_kpoint = 0 DO ispin = 1, nspins nvirt_spin(ispin) = nmo_spin(ispin) - homo_spin(ispin) - IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) THEN + IF (homo_spin(ispin) <= 0 .OR. nvirt_spin(ispin) <= 0) & CPABORT("At least one occupied and one unoccupied MO are required for k-point TDDFPT") - END IF ntrans_kpoint = ntrans_kpoint + homo_spin(ispin)*nvirt_spin(ispin) END DO ntrans_total = nkp*ntrans_kpoint - IF (ntrans_total <= 0) THEN + IF (ntrans_total <= 0) & CPABORT("No independent-particle k-point transitions available") - END IF ALLOCATE (transition_energy(ntrans_total), transition_dipole_re(ntrans_total, nderivs), & transition_dipole_im(ntrans_total, nderivs), oscillator_strength(ntrans_total), & @@ -1157,9 +1143,8 @@ CONTAINS IF (my_kpgrp) THEN CALL get_mo_set(mos_kp(1, ispin), eigenvalues=eigenvalues) CPASSERT(ASSOCIATED(eigenvalues)) - IF (para_env_kp%is_source()) THEN + IF (para_env_kp%is_source()) & eigenvalues_kp(1:nmo_spin(ispin)) = eigenvalues(1:nmo_spin(ispin)) - END IF IF (.NOT. use_scf_moment_dipoles) THEN CALL get_mo_set(mos_kp(1, ispin), mo_coeff=mo_coeff_re) CALL get_mo_set(mos_kp(2, ispin), mo_coeff=mo_coeff_im) @@ -1221,9 +1206,8 @@ CONTAINS trans_index = (ikp - 1)*ntrans_kpoint + spin_offset + & (iocc - 1)*nvirt_spin(ispin) + ivirt - homo_spin(ispin) gap = eigenvalues_kp(ivirt) - eigenvalues_kp(iocc) - IF (gap <= 0.0_dp) THEN + IF (gap <= 0.0_dp) & CPABORT("K-point TDDFPT requires positive occupied-virtual energy gaps") - END IF IF (use_scf_moment_dipoles) THEN oscillator_factor = SQRT(spin_factor*wkp(ikp)) dipole_re = REAL(kpoint_dipole(ispin, ikp, ideriv, iocc, ivirt), KIND=dp) @@ -1261,9 +1245,8 @@ CONTAINS END DO END DO - IF (ANY(transition_energy <= 0.0_dp)) THEN + IF (ANY(transition_energy <= 0.0_dp)) & CPABORT("K-point TDDFPT KERNEL NONE requires positive occupied-virtual energy gaps") - END IF CALL sort(transition_energy, ntrans_total, inds) nstates = MIN(tddfpt_control%nstates, ntrans_total) @@ -1988,7 +1971,7 @@ CONTAINS DO ispin = 1, nspins CPASSERT(.NOT. ASSOCIATED(gs_mos(ispin)%evals_occ_matrix)) END DO - ELSE IF (ewcut) THEN + ELSEIF (ewcut) THEN ! Filter orbitals wrt energy window DO ispin = 1, nspins DO i = 1, gs_mos(ispin)%nmo_occ diff --git a/src/qs_tddfpt2_properties.F b/src/qs_tddfpt2_properties.F index 3f32e85a70..0ea5e1abef 100644 --- a/src/qs_tddfpt2_properties.F +++ b/src/qs_tddfpt2_properties.F @@ -835,9 +835,8 @@ CONTAINS END DO DO iproc = 1, para_env%num_pe - IF (iproc - 1 /= para_env%mepos) THEN + IF (iproc - 1 /= para_env%mepos) & CALL recv_handlers(iproc)%wait() - END IF END DO ! compute total number of non-negligible excitations @@ -937,9 +936,8 @@ CONTAINS END IF ! deallocate temporary arrays - IF (para_env%is_source()) THEN + IF (para_env%is_source()) & DEALLOCATE (weights_recv, weights_neg_abs_recv, inds_recv, inds) - END IF END DO DEALLOCATE (weights_local, inds_local) @@ -1527,7 +1525,7 @@ CONTAINS cell, dft_control, particle_set, pw_env) IF (iset == 1) THEN WRITE (filename, '(a4,I3.3,I2.2,a11)') "NTO_STATE", istate, i, "_Hole_State" - ELSE IF (iset == 2) THEN + ELSEIF (iset == 2) THEN WRITE (filename, '(a4,I3.3,I2.2,a15)') "NTO_STATE", istate, i, "_Particle_State" END IF mpi_io = .TRUE. @@ -1536,7 +1534,7 @@ CONTAINS log_filename=.FALSE., ignore_should_output=.TRUE., mpi_io=mpi_io) IF (iset == 1) THEN WRITE (title, *) "Natural Transition Orbital Hole State", i - ELSE IF (iset == 2) THEN + ELSEIF (iset == 2) THEN WRITE (title, *) "Natural Transition Orbital Particle State", i END IF CALL cp_pw_to_cube(wf_r, unit_nr, title, particles=particles, stride=stride, mpi_io=mpi_io) diff --git a/src/qs_tddfpt2_restart.F b/src/qs_tddfpt2_restart.F index 4c2e0a02f5..8ed2934237 100644 --- a/src/qs_tddfpt2_restart.F +++ b/src/qs_tddfpt2_restart.F @@ -294,9 +294,8 @@ CONTAINS END DO END DO - IF (para_env_global%is_source()) THEN + IF (para_env_global%is_source()) & CALL close_file(unit_number=iunit) - END IF CALL timestop(handle) @@ -635,13 +634,11 @@ CONTAINS sum_sign_array(icol_global) = sum_sign_array(icol_global) + sign_int IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) THEN + IF (minrow_pos_array(icol_global) > irow_global) & minrow_pos_array(icol_global) = irow_global - END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) THEN + IF (minrow_neg_array(icol_global) > irow_global) & minrow_neg_array(icol_global) = irow_global - END IF END IF END DO diff --git a/src/qs_tddfpt2_stda_types.F b/src/qs_tddfpt2_stda_types.F index c175409e56..333da363e7 100644 --- a/src/qs_tddfpt2_stda_types.F +++ b/src/qs_tddfpt2_stda_types.F @@ -277,9 +277,8 @@ CONTAINS TYPE(stda_kind_type), POINTER :: kind_param - IF (ASSOCIATED(kind_param)) THEN + IF (ASSOCIATED(kind_param)) & CALL deallocate_stda_kind_param(kind_param) - END IF ALLOCATE (kind_param) diff --git a/src/qs_tddfpt2_stda_utils.F b/src/qs_tddfpt2_stda_utils.F index c98d3e93ef..68840bfd85 100644 --- a/src/qs_tddfpt2_stda_utils.F +++ b/src/qs_tddfpt2_stda_utils.F @@ -252,7 +252,7 @@ CONTAINS IF (dr < 1.e-6) THEN ! on site terms gblock(:, :) = gblock(:, :) + eta - ELSE IF (dr > rcut) THEN + ELSEIF (dr > rcut) THEN ! do nothing ELSE IF (dr < rcut - rsmooth) THEN @@ -408,11 +408,10 @@ CONTAINS CALL cp_fm_struct_release(fmstruct=fmstruct) CALL copy_dbcsr_to_fm(sm_s, fm_s_half) CALL cp_fm_power(fm_s_half, fm_work1, 0.5_dp, scf_control%eps_eigval, ndep) - IF (ndep /= 0) THEN + IF (ndep /= 0) & CALL cp_warn(__LOCATION__, & "Overlap matrix exhibits linear dependencies. At least some "// & "eigenvalues have been quenched.") - END IF CALL copy_fm_to_dbcsr(fm_s_half, sm_h) CALL cp_fm_release(fm_s_half) CALL cp_fm_release(fm_work1) diff --git a/src/qs_tddfpt2_subgroups.F b/src/qs_tddfpt2_subgroups.F index 6097231eb9..009f80a27c 100644 --- a/src/qs_tddfpt2_subgroups.F +++ b/src/qs_tddfpt2_subgroups.F @@ -302,9 +302,8 @@ CONTAINS NULLIFY (sub_env%task_list_orb_soft, sub_env%task_list_aux_fit_soft) IF (sub_env%is_mgrid) THEN - IF (tddfpt_control%mgrid_is_explicit) THEN + IF (tddfpt_control%mgrid_is_explicit) & CALL init_tddfpt_mgrid(qs_control, tddfpt_control, mgrid_saved) - END IF IF (ASSOCIATED(weights)) THEN CPABORT('Redefining MGRID and integration weights not compatible') @@ -345,9 +344,8 @@ CONTAINS END IF END IF - IF (tddfpt_control%mgrid_is_explicit) THEN + IF (tddfpt_control%mgrid_is_explicit) & CALL restore_qs_mgrid(qs_control, mgrid_saved) - END IF ELSE CALL pw_env_retain(pw_env_global) sub_env%pw_env => pw_env_global @@ -382,7 +380,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, sub_env%local_rho_set%rho0_mpole) CALL hartree_local_create(sub_env%hartree_local) CALL init_coulomb_local(sub_env%hartree_local, natom) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -450,21 +448,17 @@ CONTAINS CALL timeset(routineN, handle) IF (sub_env%is_mgrid) THEN - IF (ASSOCIATED(sub_env%task_list_aux_fit)) THEN + IF (ASSOCIATED(sub_env%task_list_aux_fit)) & CALL deallocate_task_list(sub_env%task_list_aux_fit) - END IF - IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) THEN + IF (ASSOCIATED(sub_env%task_list_aux_fit_soft)) & CALL deallocate_task_list(sub_env%task_list_aux_fit_soft) - END IF - IF (ASSOCIATED(sub_env%task_list_orb)) THEN + IF (ASSOCIATED(sub_env%task_list_orb)) & CALL deallocate_task_list(sub_env%task_list_orb) - END IF - IF (ASSOCIATED(sub_env%task_list_orb_soft)) THEN + IF (ASSOCIATED(sub_env%task_list_orb_soft)) & CALL deallocate_task_list(sub_env%task_list_orb_soft) - END IF CALL release_neighbor_list_sets(sub_env%sab_aux_fit) CALL release_neighbor_list_sets(sub_env%sab_orb) @@ -474,9 +468,8 @@ CONTAINS DEALLOCATE (sub_env%dbcsr_dist) END IF - IF (ASSOCIATED(sub_env%dist_2d)) THEN + IF (ASSOCIATED(sub_env%dist_2d)) & CALL distribution_2d_release(sub_env%dist_2d) - END IF END IF ! GAPW @@ -519,9 +512,8 @@ CONTAINS CALL cp_blacs_env_release(sub_env%blacs_env) CALL mp_para_env_release(sub_env%para_env) - IF (ALLOCATED(sub_env%group_distribution)) THEN + IF (ALLOCATED(sub_env%group_distribution)) & DEALLOCATE (sub_env%group_distribution) - END IF sub_env%is_split = .FALSE. @@ -586,9 +578,8 @@ CONTAINS END DO ! igrid == 0 if qs_control%cutoff is larger than the largest manually provided cutoff value; ! use the largest actual value - IF (igrid <= 0) THEN + IF (igrid <= 0) & qs_control%cutoff = qs_control%e_cutoff(1) - END IF ELSE qs_control%e_cutoff(1) = qs_control%cutoff DO igrid = 2, ngrids @@ -616,9 +607,8 @@ CONTAINS CALL timeset(routineN, handle) - IF (ASSOCIATED(qs_control%e_cutoff)) THEN + IF (ASSOCIATED(qs_control%e_cutoff)) & DEALLOCATE (qs_control%e_cutoff) - END IF qs_control%commensurate_mgrids = mgrid_saved%commensurate_mgrids qs_control%realspace_mgrids = mgrid_saved%realspace_mgrids diff --git a/src/qs_tddfpt2_types.F b/src/qs_tddfpt2_types.F index 19ea44ddac..0a9790800e 100644 --- a/src/qs_tddfpt2_types.F +++ b/src/qs_tddfpt2_types.F @@ -465,7 +465,7 @@ CONTAINS CALL rho0_s_grid_create(sub_env%pw_env, work_matrices%local_rho_set%rho0_mpole) CALL hartree_local_create(work_matrices%hartree_local) CALL init_coulomb_local(work_matrices%hartree_local, natom) - ELSE IF (dft_control%qs_control%gapw_xc) THEN + ELSEIF (dft_control%qs_control%gapw_xc) THEN CALL get_qs_env(qs_env, & atomic_kind_set=atomic_kind_set, & qs_kind_set=qs_kind_set) @@ -939,9 +939,8 @@ CONTAINS CALL cp_fm_release(work_matrices%slambda) DEALLOCATE (work_matrices%slambda) END IF - IF (ASSOCIATED(work_matrices%S_eigenvalues)) THEN + IF (ASSOCIATED(work_matrices%S_eigenvalues)) & DEALLOCATE (work_matrices%S_eigenvalues) - END IF ! Ewald IF (ASSOCIATED(work_matrices%ewald_env)) THEN CALL ewald_env_release(work_matrices%ewald_env) diff --git a/src/qs_tddfpt2_utils.F b/src/qs_tddfpt2_utils.F index 814d6db052..4a98dbc280 100644 --- a/src/qs_tddfpt2_utils.F +++ b/src/qs_tddfpt2_utils.F @@ -297,14 +297,12 @@ CONTAINS CALL section_vals_val_get(print_section, "NAMD_PRINT%PRINT_PHASES", l_val=print_phases) nmo_virt = nao - nmo_occ - IF (nlumo >= 0) THEN + IF (nlumo >= 0) & nmo_virt = MIN(nmo_virt, nlumo) - END IF - IF (nmo_virt <= 0) THEN + IF (nmo_virt <= 0) & CALL cp_abort(__LOCATION__, & 'At least one unoccupied molecular orbital is required to calculate excited states.') - END IF do_eigen = .FALSE. ! diagonalise the Kohn-Sham matrix one more time if the number of available unoccupied states are too small @@ -428,13 +426,11 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) THEN + IF (minrow_pos_array(icol_global) > irow_global) & minrow_pos_array(icol_global) = irow_global - END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) THEN + IF (minrow_neg_array(icol_global) > irow_global) & minrow_neg_array(icol_global) = irow_global - END IF END IF END DO END DO @@ -512,13 +508,11 @@ CONTAINS irow_global = row_indices(irow_local) IF (sign_int > 0) THEN - IF (minrow_pos_array(icol_global) > irow_global) THEN + IF (minrow_pos_array(icol_global) > irow_global) & minrow_pos_array(icol_global) = irow_global - END IF ELSE IF (sign_int < 0) THEN - IF (minrow_neg_array(icol_global) > irow_global) THEN + IF (minrow_neg_array(icol_global) > irow_global) & minrow_neg_array(icol_global) = irow_global - END IF END IF END DO END DO @@ -576,25 +570,20 @@ CONTAINS CALL timeset(routineN, handle) - IF (ALLOCATED(gs_mos%phases_occ)) THEN + IF (ALLOCATED(gs_mos%phases_occ)) & DEALLOCATE (gs_mos%phases_occ) - END IF - IF (ALLOCATED(gs_mos%evals_virt)) THEN + IF (ALLOCATED(gs_mos%evals_virt)) & DEALLOCATE (gs_mos%evals_virt) - END IF - IF (ALLOCATED(gs_mos%evals_occ)) THEN + IF (ALLOCATED(gs_mos%evals_occ)) & DEALLOCATE (gs_mos%evals_occ) - END IF - IF (ALLOCATED(gs_mos%phases_virt)) THEN + IF (ALLOCATED(gs_mos%phases_virt)) & DEALLOCATE (gs_mos%phases_virt) - END IF - IF (ALLOCATED(gs_mos%index_active)) THEN + IF (ALLOCATED(gs_mos%index_active)) & DEALLOCATE (gs_mos%index_active) - END IF IF (ASSOCIATED(gs_mos%evals_occ_matrix)) THEN CALL cp_fm_release(gs_mos%evals_occ_matrix) @@ -697,9 +686,9 @@ CONTAINS IF (dft_control%qs_control%semi_empirical) THEN CPABORT("TDDFPT with SE not possible") - ELSE IF (dft_control%qs_control%dftb) THEN + ELSEIF (dft_control%qs_control%dftb) THEN CPABORT("TDDFPT with DFTB not possible") - ELSE IF (dft_control%qs_control%xtb) THEN + ELSEIF (dft_control%qs_control%xtb) THEN IF (dft_control%qs_control%xtb_control%do_tblite) THEN CALL build_tblite_ks_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., & ext_ks_matrix=matrix_ks_oep) @@ -1143,10 +1132,9 @@ CONTAINS DO istate = 1, nstates IF (ASSOCIATED(evects(1, istate)%matrix_struct)) THEN ! Initial guess vector read from restart file - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(T7,I8,T28,A19,T60,F14.5)') & - istate, "*** restarted ***", evals(istate)*evolt - END IF + istate, "*** restarted ***", evals(istate)*evolt ELSE ! New initial guess vector ! @@ -1178,10 +1166,9 @@ CONTAINS ! Assign initial guess for excitation energy evals(istate) = e_virt_minus_occ(istate) - IF (log_unit > 0) THEN + IF (log_unit > 0) & WRITE (log_unit, '(T7,I8,T24,I8,T37,A5,T45,I8,T54,A5,T60,F14.5)') & - istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt - END IF + istate, imo_occ, spin_label1, nmo(spin2) + imo_virt, spin_label2, e_virt_minus_occ(istate)*evolt DO jspin = 1, SIZE(evects, 1) ! .NOT. ASSOCIATED(evects(jspin, istate)%matrix_struct)) diff --git a/src/qs_tensors.F b/src/qs_tensors.F index 01298654b6..ca92892f16 100644 --- a/src/qs_tensors.F +++ b/src/qs_tensors.F @@ -713,7 +713,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -722,7 +722,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1030,7 +1030,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1039,7 +1039,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1262,7 +1262,7 @@ CONTAINS IF (do_kpoints_prv) THEN prefac = 0.5_dp - ELSE IF (nl_3c%sym == symmetric_jk) THEN + ELSEIF (nl_3c%sym == symmetric_jk) THEN IF (jatom == katom) THEN prefac = 0.5_dp ELSE @@ -1548,7 +1548,7 @@ CONTAINS END DO END DO - ELSE IF (nl_3c%sym == symmetric_jk) THEN + ELSEIF (nl_3c%sym == symmetric_jk) THEN !Add the transpose of t3c_der_j to t3c_der_k to get the fully populated tensor CALL dbt_create(t3c_der_k(1, 1, 1), t3c_tmp) DO i_xyz = 1, 3 @@ -1567,7 +1567,7 @@ CONTAINS END DO CALL dbt_destroy(t3c_tmp) - ELSE IF (nl_3c%sym == symmetric_none) THEN + ELSEIF (nl_3c%sym == symmetric_none) THEN DO i_xyz = 1, 3 DO kcell = 1, ncell_RI DO jcell = 1, nimg @@ -1701,7 +1701,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -1710,7 +1710,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2238,7 +2238,7 @@ CONTAINS .OR. op_ij == do_potential_mix_cl_trunc) THEN dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_ij == do_potential_coulomb) THEN + ELSEIF (op_ij == do_potential_coulomb) THEN dr_ij = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2247,7 +2247,7 @@ CONTAINS .OR. op_jk == do_potential_mix_cl_trunc) THEN dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSE IF (op_jk == do_potential_coulomb) THEN + ELSEIF (op_jk == do_potential_coulomb) THEN dr_jk = 1000000.0_dp dr_ik = 1000000.0_dp END IF @@ -2454,7 +2454,7 @@ CONTAINS ELSE prefac = 1.0_dp END IF - ELSE IF (nl_3c%sym == symmetric_ij) THEN + ELSEIF (nl_3c%sym == symmetric_ij) THEN IF (iatom == jatom) THEN ! factor 0.5 due to double-counting of diagonal blocks ! (we desymmetrize by adding transpose) @@ -2689,13 +2689,13 @@ CONTAINS END DO CALL dbt_destroy(t_3c_tmp) END IF - ELSE IF (nl_3c%sym == symmetric_ij) THEN + ELSEIF (nl_3c%sym == symmetric_ij) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps/2) END DO END DO - ELSE IF (nl_3c%sym == symmetric_none) THEN + ELSEIF (nl_3c%sym == symmetric_none) THEN DO kcell = 1, nimg DO jcell = 1, nimg CALL dbt_filter(t3c(jcell, kcell), filter_eps) diff --git a/src/qs_update_s_mstruct.F b/src/qs_update_s_mstruct.F index bee9f33d9e..dd9017adf9 100644 --- a/src/qs_update_s_mstruct.F +++ b/src/qs_update_s_mstruct.F @@ -227,9 +227,8 @@ CONTAINS IF (ASSOCIATED(qs_env%kg_env%subset)) THEN DO isub = 1, qs_env%kg_env%nsubsets - IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) THEN + IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) & CALL deallocate_task_list(qs_env%kg_env%subset(isub)%task_list) - END IF END DO ELSE ALLOCATE (qs_env%kg_env%subset(qs_env%kg_env%nsubsets)) diff --git a/src/qs_vcd_utils.F b/src/qs_vcd_utils.F index 75b0ff3b6c..379326e61d 100644 --- a/src/qs_vcd_utils.F +++ b/src/qs_vcd_utils.F @@ -153,9 +153,8 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "MAGNETIC_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) THEN + IF (reference == use_mom_ref_user) & CPABORT("User-defined reference point should be given explicitly") - END IF END IF CALL get_reference_point(rpoint=vcd_env%magnetic_origin, qs_env=qs_env, & @@ -168,9 +167,8 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(vcd_section, "SPATIAL_ORIGIN_REFERENCE", r_vals=ref_point) ELSE - IF (reference == use_mom_ref_user) THEN + IF (reference == use_mom_ref_user) & CPABORT("User-defined reference point should be given explicitly") - END IF END IF CALL get_reference_point(rpoint=vcd_env%spatial_origin, qs_env=qs_env, & @@ -826,10 +824,9 @@ CONTAINS + apt_total_nvpt(2, 2, l) & + apt_total_nvpt(3, 3, l))/3._dp DO i = 1, 3 - IF (vcd_env%output_unit > 0) THEN + IF (vcd_env%output_unit > 0) & WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", apt_total_nvpt(i, :, l) - END IF + "NVP | ", apt_total_nvpt(i, :, l) END DO END DO @@ -839,10 +836,9 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'NVP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) THEN + IF (vcd_env%output_unit > 0) & WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) - END IF + "NVP | ", vcd_env%aat_atom_nvpt(i, :, l) END DO END DO @@ -853,10 +849,9 @@ CONTAINS IF (vcd_env%output_unit > 0) WRITE (vcd_env%output_unit, "(A,I3)") & 'MFP | Atom', l DO i = 1, 3 - IF (vcd_env%output_unit > 0) THEN + IF (vcd_env%output_unit > 0) & WRITE (vcd_env%output_unit, "(A,F15.6,F15.6,F15.6)") & - "MFP | ", vcd_env%aat_atom_mfp(i, :, l) - END IF + "MFP | ", vcd_env%aat_atom_mfp(i, :, l) END DO END DO END IF diff --git a/src/qs_vxc.F b/src/qs_vxc.F index a3410e78ac..924ff307d4 100644 --- a/src/qs_vxc.F +++ b/src/qs_vxc.F @@ -206,13 +206,11 @@ CONTAINS ! test if the real space density is available CPASSERT(ASSOCIATED(rho_struct)) - IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) THEN + IF (dft_control%nspins /= 1 .AND. dft_control%nspins /= 2) & CPABORT("nspins must be 1 or 2") - END IF mspin = SIZE(rho_struct_r) - IF (dft_control%nspins == 2 .AND. mspin == 1) THEN + IF (dft_control%nspins == 2 .AND. mspin == 1) & CPABORT("Spin count mismatch") - END IF ! there are some options related to SIC here. ! Normal DFT computes E(rho_alpha,rho_beta) (or its variant E(2*rho_alpha) for non-LSD) @@ -244,9 +242,8 @@ CONTAINS sic_scaling_b_zero = .FALSE. END IF - IF (PRESENT(pw_env_external)) THEN + IF (PRESENT(pw_env_external)) & pw_env => pw_env_external - END IF CALL pw_env_get(pw_env, xc_pw_pool=xc_pw_pool, auxbas_pw_pool=auxbas_pw_pool) uf_grid = .NOT. pw_grid_compare(auxbas_pw_pool%pw_grid, xc_pw_pool%pw_grid) @@ -762,7 +759,7 @@ CONTAINS NULLIFY (rho_r, rho_g, tau_r, tau_g) IF (rho_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, rho_struct_g, rho_r, rho_g) - ELSE IF (ASSOCIATED(rho_struct_r)) THEN + ELSEIF (ASSOCIATED(rho_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, rho_struct_r, rho_r, rho_g) ELSE CPABORT("Fine Grid in qs_xc_density requires rho_r or rho_g") @@ -770,7 +767,7 @@ CONTAINS IF (tau_r_valid) THEN IF (tau_g_valid) THEN CALL create_density_on_pool(xc_pw_pool, tau_struct_g, tau_r, tau_g) - ELSE IF (ASSOCIATED(tau_struct_r)) THEN + ELSEIF (ASSOCIATED(tau_struct_r)) THEN CALL create_density_on_pool_from_r(auxbas_pw_pool, xc_pw_pool, tau_struct_r, tau_r, tau_g) ELSE CPABORT("Fine Grid in qs_xc_density requires tau_r or tau_g") diff --git a/src/qs_vxc_atom.F b/src/qs_vxc_atom.F index 34110e06a9..77ca466195 100644 --- a/src/qs_vxc_atom.F +++ b/src/qs_vxc_atom.F @@ -15,8 +15,6 @@ MODULE qs_vxc_atom USE basis_set_types, ONLY: get_gto_basis_set,& gto_basis_set_type USE cp_control_types, ONLY: dft_control_type - USE external_potential_types, ONLY: gth_potential_type,& - sgp_potential_type USE input_constants, ONLY: xc_none USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type,& @@ -122,16 +120,14 @@ CONTAINS INTEGER :: bo(2), gapw_density_partition, handle, & iat, iatom, idir, ikind, ir, jdir, & - myfun, na, natom, nr, nspins, num_pe, & - zatom + myfun, na, natom, nr, nspins, num_pe INTEGER, DIMENSION(2, 3) :: bounds INTEGER, DIMENSION(:), POINTER :: atom_list LOGICAL :: accint, donlcc, evaluate_hard, evaluate_soft, gradient_f, lsd, & my_calculate_forces, nlcc, paw_atom, skala_atom_grid, tau_f, use_virial REAL(dp) :: agr, alpha, density_cut, exc_h, exc_s, & gradient_cut, & - my_adiabatic_rescale_factor, tau_cut, & - zeff + my_adiabatic_rescale_factor, tau_cut REAL(dp), DIMENSION(1, 1, 1) :: tau_d REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d REAL(dp), DIMENSION(3) :: skala_atom_force_h, skala_atom_force_s @@ -144,7 +140,6 @@ CONTAINS TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(dft_control_type), POINTER :: dft_control TYPE(grid_atom_type), POINTER :: grid_atom - TYPE(gth_potential_type), POINTER :: gth_potential TYPE(gto_basis_set_type), POINTER :: basis_1c TYPE(harmonics_atom_type), POINTER :: harmonics TYPE(mp_para_env_type), POINTER :: para_env @@ -156,7 +151,6 @@ CONTAINS TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set TYPE(rho_atom_type), POINTER :: rho_atom TYPE(section_vals_type), POINTER :: input, my_xc_section, xc_fun_section - TYPE(sgp_potential_type), POINTER :: sgp_potential TYPE(tau_basis_cache_type) :: tau_basis_cache TYPE(virial_type), POINTER :: virial TYPE(xc_derivative_set_type) :: deriv_set @@ -171,7 +165,6 @@ CONTAINS NULLIFY (my_kind_set) NULLIFY (atomic_kind_set) NULLIFY (grid_atom) - NULLIFY (gth_potential) NULLIFY (force) NULLIFY (harmonics) NULLIFY (input) @@ -180,7 +173,6 @@ CONTAINS NULLIFY (rho_atom) NULLIFY (my_rho_atom_set) NULLIFY (rho_nlcc) - NULLIFY (sgp_potential) NULLIFY (virial) my_calculate_forces = .FALSE. IF (PRESENT(calculate_forces)) my_calculate_forces = calculate_forces @@ -258,17 +250,11 @@ CONTAINS DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom) - NULLIFY (gth_potential, sgp_potential) CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, & - gth_potential=gth_potential, harmonics=harmonics, & - grid_atom=grid_atom, sgp_potential=sgp_potential, & - zatom=zatom, zeff=zeff) + harmonics=harmonics, grid_atom=grid_atom) CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C") IF (.NOT. paw_atom) CYCLE - IF (skala_atom_grid .AND. & - (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. & - ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE nr = grid_atom%nr na = grid_atom%ng_sphere @@ -996,7 +982,7 @@ CONTAINS lsd = .TRUE. scale_rho = .TRUE. END IF - ELSE IF (PRESENT(do_triplet)) THEN + ELSEIF (PRESENT(do_triplet)) THEN IF (nspins == 1 .AND. do_triplet) lsd = .TRUE. END IF diff --git a/src/qs_wannier90.F b/src/qs_wannier90.F index ad9bb42de0..b2c7989282 100644 --- a/src/qs_wannier90.F +++ b/src/qs_wannier90.F @@ -57,9 +57,8 @@ MODULE qs_wannier90 kpoint_initialize_mo_set,& kpoint_initialize_mos,& rskp_transform - USE kpoint_mo_symmetry_methods, ONLY: kpoint_same_periodic,& - kpoint_transform_scf_mo USE kpoint_types, ONLY: get_kpoint_info,& + kind_rotmat_type,& kpoint_create,& kpoint_env_type,& kpoint_release,& @@ -1169,12 +1168,12 @@ CONTAINS num_candidates = 0 ! Little-group operations can reach the same target k-point; keep the first valid eigenspace. DO isym_try = 1, kpsym%nwred - IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & + IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE num_candidates = num_candidates + 1 - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, & - candidate_reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, & + candidate_reason) IF (.NOT. ok) THEN reason = candidate_reason CYCLE @@ -1192,9 +1191,9 @@ CONTAINS END IF IF (.NOT. ok) THEN IF (source_window) THEN - CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, & - dst_real_full, dst_imag_full, qs_kpoint, & - ikred, isym_try, para_env, ok, candidate_reason) + CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, & + dst_real_full, dst_imag_full, qs_kpoint, & + ikred, isym_try, para_env, ok, candidate_reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, & dst_real, dst_imag, matrix_s, & @@ -1233,15 +1232,15 @@ CONTAINS WRITE (reason, "(A,I0,A,ES9.2,A,I0,A,A32)") & "atom/AO W90 guarded: best/", num_candidates, "=", best_residual, & " k=", ik, " ", TRIM(best_reason) - ELSE IF (.NOT. ok .AND. num_candidates == 0) THEN + ELSEIF (.NOT. ok .AND. num_candidates == 0) THEN reason = "no matching SCF symmetry operation candidate" END IF ELSE reason = "SCF k-point symmetry operation is not available" END IF ELSE - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) END IF IF (ok .AND. sym_index(ik) <= 0) THEN ! Even a direct k-point copy must be a closed H(k),S(k) subspace. This catches @@ -1252,9 +1251,9 @@ CONTAINS ok, reason, aligned_blocks, aligned_max_size, & aligned_min_svalue, candidate_residual) IF (.NOT. ok .AND. source_window) THEN - CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, dst_real_full, & - dst_imag_full, qs_kpoint, ikred, sym_index(ik), & - para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, dst_real_full, & + dst_imag_full, qs_kpoint, ikred, sym_index(ik), & + para_env, ok, reason) IF (ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, dst_real, & dst_imag, matrix_s, matrix_ks, & @@ -1263,7 +1262,7 @@ CONTAINS reason, source_window_min_svalue, & candidate_residual) END IF - ELSE IF (.NOT. ok) THEN + ELSEIF (.NOT. ok) THEN CALL ritz_reconstruct_wannier90_window(dst_real, dst_imag, dst_real, dst_imag, & matrix_s, matrix_ks, kpoint%xkp(1:3, ik), & cell_to_index, sab_nl, ispin, & @@ -1724,8 +1723,8 @@ CONTAINS best_residual = 0.0_dp best_svalue = 0.0_dp IF (sym_index(ik) <= 0) THEN - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & - ikred, sym_index(ik), para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, & + ikred, sym_index(ik), para_env, ok, reason) IF (ok) THEN CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, matrix_s, & kpoint%xkp(1:3, ik), cell_to_index, sab_nl, & @@ -1753,14 +1752,14 @@ CONTAINS END IF END IF END IF - ELSE IF (ASSOCIATED(qs_kpoint%kp_sym)) THEN + ELSEIF (ASSOCIATED(qs_kpoint%kp_sym)) THEN kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym IF (ASSOCIATED(kpsym)) THEN DO isym_try = 1, kpsym%nwred - IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), & + IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), & kpsym%xkp(1:3, isym_try))) CYCLE - CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, & - qs_kpoint, ikred, isym_try, para_env, ok, reason) + CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, & + qs_kpoint, ikred, isym_try, para_env, ok, reason) IF (.NOT. ok) CYCLE CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, & matrix_s, kpoint%xkp(1:3, ik), cell_to_index, & @@ -2616,7 +2615,7 @@ CONTAINS ik_match = 0 DO ik = 1, SIZE(xkp_mesh, 2) - IF (kpoint_same_periodic(xkp_mesh(1:3, ik), xkp_search)) THEN + IF (same_periodic_kpoint(xkp_mesh(1:3, ik), xkp_search)) THEN ik_match = ik RETURN END IF @@ -2624,6 +2623,209 @@ CONTAINS END FUNCTION find_matching_kpoint +! ************************************************************************************************** +!> \brief Compare two fractional k-points modulo reciprocal lattice vectors. +!> \param xkp_a first k-point +!> \param xkp_b second k-point +!> \return true if the k-points are equivalent +! ************************************************************************************************** + LOGICAL FUNCTION same_periodic_kpoint(xkp_a, xkp_b) RESULT(same) + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b + + REAL(KIND=dp), DIMENSION(3) :: diff + + diff(1:3) = xkp_a(1:3) - xkp_b(1:3) + diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp) + same = SUM(ABS(diff(1:3))) < 1.0e-8_dp + + END FUNCTION same_periodic_kpoint + +! ************************************************************************************************** +!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point. +!> \param src_real real part of source MO coefficients +!> \param src_imag imaginary part of source MO coefficients +!> \param dst_real real part of transformed MO coefficients +!> \param dst_imag imaginary part of transformed MO coefficients +!> \param qs_kpoint SCF k-point object containing symmetry operations +!> \param ikred representative k-point index +!> \param isym symmetry operation index; 0 direct copy, -1 time reversal +!> \param para_env global parallel environment +!> \param success true if the transformation was performed +!> \param reason diagnostic message +! ************************************************************************************************** + SUBROUTINE transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, & + isym, para_env, success, reason) + TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: ikred, isym + TYPE(mp_para_env_type), POINTER :: para_env + LOGICAL, INTENT(OUT) :: success + CHARACTER(LEN=*), INTENT(OUT) :: reason + + INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, & + nmo, rot_slot, source_atom, source_dim, target_atom, target_dim + INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start + LOGICAL :: reverse_phase, time_reversal + REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, & + phase_imag, phase_real, sinkl + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r + REAL(KIND=dp), DIMENSION(3) :: xkp_phase + REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat + TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot + TYPE(kpoint_sym_type), POINTER :: kpsym + + success = .FALSE. + reason = "" + IF (isym == 0) THEN + CALL cp_fm_copy_general(src_real, dst_real, para_env) + CALL cp_fm_copy_general(src_imag, dst_imag, para_env) + success = .TRUE. + RETURN + END IF + + CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo) + ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo)) + CALL cp_fm_get_submatrix(src_real, src_r) + CALL cp_fm_get_submatrix(src_imag, src_i) + dst_r(:, :) = 0.0_dp + dst_i(:, :) = 0.0_dp + + IF (isym == -1) THEN + dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo) + dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo) + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i) + success = .TRUE. + RETURN + END IF + + IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN + reason = "SCF symmetry operation data are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym + IF (.NOT. ASSOCIATED(kpsym)) THEN + reason = "SCF k-point symmetry operation is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (isym > kpsym%nwred) THEN + reason = "SCF k-point symmetry operation index is out of range" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN + reason = "SCF atom mappings or basis rotation matrices are not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + + rot_slot = find_wannier90_rotation_slot(qs_kpoint, kpsym%rotp(isym)) + IF (rot_slot == 0) THEN + reason = "could not match the SCF symmetry operation to a basis rotation" + DEALLOCATE (src_r, src_i, dst_r, dst_i) + RETURN + END IF + kind_rot => qs_kpoint%kind_rotmat(rot_slot, :) + natom = SIZE(qs_kpoint%atype) + ALLOCATE (ao_start(natom), ao_size(natom)) + irow = 1 + DO iatom = 1, natom + ikind = qs_kpoint%atype(iatom) + IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN + reason = "a required basis rotation matrix is not available" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + ao_start(iatom) = irow + ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2) + irow = irow + ao_size(iatom) + END DO + IF (irow - 1 /= nao) THEN + reason = "atom-resolved AO dimensions do not match the MO coefficient matrix" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + + time_reversal = kpsym%rotp(isym) < 0 + reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0) + IF (ASSOCIATED(kpsym%phase_mode)) THEN + IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2 + END IF + xkp_phase(1:3) = kpsym%xkp(1:3, isym) + DO iatom = 1, natom + source_atom = iatom + target_atom = kpsym%f0(iatom, isym) + ikind = qs_kpoint%atype(source_atom) + rotmat => kind_rot(ikind)%rmat + source_dim = ao_size(source_atom) + target_dim = ao_size(target_atom) + IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN + reason = "basis rotation dimensions do not match the atom/AO symmetry transform" + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + RETURN + END IF + arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + & + REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + & + REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3) + IF (ASSOCIATED(kpsym%kgphase)) THEN + arg = arg + kpsym%kgphase(source_atom, isym) + END IF + IF (reverse_phase) arg = -arg + coskl = COS(twopi*arg) + sinkl = SIN(twopi*arg) + DO imo = 1, nmo + DO irow_work = 1, source_dim + irow_source = ao_start(source_atom) + irow_work - 1 + coeff_real = src_r(irow_source, imo) + coeff_imag = src_i(irow_source, imo) + IF (time_reversal) coeff_imag = -coeff_imag + phase_real = coskl*coeff_real - sinkl*coeff_imag + phase_imag = sinkl*coeff_real + coskl*coeff_imag + DO iao = 1, target_dim + irow_target = ao_start(target_atom) + iao - 1 + dst_r(irow_target, imo) = dst_r(irow_target, imo) + & + rotmat(iao, irow_work)*phase_real + dst_i(irow_target, imo) = dst_i(irow_target, imo) + & + rotmat(iao, irow_work)*phase_imag + END DO + END DO + END DO + END DO + + CALL cp_fm_set_submatrix(dst_real, dst_r) + CALL cp_fm_set_submatrix(dst_imag, dst_i) + DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size) + success = .TRUE. + + END SUBROUTINE transform_wannier90_scf_mo + +! ************************************************************************************************** +!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation. +!> \param qs_kpoint SCF k-point object +!> \param rotp signed operation identifier +!> \return rotation slot, or zero when no slot matches +! ************************************************************************************************** + INTEGER FUNCTION find_wannier90_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot) + TYPE(kpoint_type), POINTER :: qs_kpoint + INTEGER, INTENT(IN) :: rotp + + INTEGER :: irot, rot_abs + + rot_slot = 0 + rot_abs = ABS(rotp) + IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN + DO irot = 1, SIZE(qs_kpoint%ibrot) + IF (rot_abs == qs_kpoint%ibrot(irot)) THEN + rot_slot = irot + RETURN + END IF + END DO + + END FUNCTION find_wannier90_rotation_slot + ! ************************************************************************************************** !> \brief Infer a tensor-product Wannier90 mesh from explicit fractional k-point coordinates. !> \param kpt_latt explicit k-point coordinates in reciprocal-lattice units diff --git a/src/qs_wf_history_methods.F b/src/qs_wf_history_methods.F index e70607cffd..af061e3cea 100644 --- a/src/qs_wf_history_methods.F +++ b/src/qs_wf_history_methods.F @@ -761,9 +761,8 @@ CONTAINS END IF END SELECT - IF (PRESENT(extrapolation_method_nr)) THEN + IF (PRESENT(extrapolation_method_nr)) & extrapolation_method_nr = actual_extrapolation_method_nr - END IF my_orthogonal_wf = .FALSE. SELECT CASE (actual_extrapolation_method_nr) @@ -2306,9 +2305,8 @@ CONTAINS wfi_linear_ps_method_nr, wfi_ps_method_nr, & wfi_aspc_nr, wfi_gext_proj_nr, wfi_gext_proj_qtr_nr) IF (qs_env%wf_history%snapshot_count >= 2) THEN - IF (debug_this_module .AND. io_unit > 0) THEN + IF (debug_this_module .AND. io_unit > 0) & WRITE (io_unit, FMT="(T2,A)") "QS| Purging WFN history" - END IF CALL wfi_create(wf_history, interpolation_method_nr= & dft_control%qs_control%wf_interpolation_method_nr, & extrapolation_order=dft_control%qs_control%wf_extrapolation_order, & diff --git a/src/replica_methods.F b/src/replica_methods.F index b8a1de1b67..0fd4b3b08c 100644 --- a/src/replica_methods.F +++ b/src/replica_methods.F @@ -295,9 +295,8 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) THEN + IF (.NOT. ASSOCIATED(rep_env)) & CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) - END IF NULLIFY (qs_env, dft_control, subsys) CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() diff --git a/src/replica_types.F b/src/replica_types.F index 41f96a58b2..646349fcae 100644 --- a/src/replica_types.F +++ b/src/replica_types.F @@ -206,9 +206,8 @@ CONTAINS TYPE(replica_env_type), POINTER :: rep_env rep_env => rep_envs_get_rep_env(rep_env_id, ierr=stat) - IF (.NOT. ASSOCIATED(rep_env)) THEN + IF (.NOT. ASSOCIATED(rep_env)) & CPABORT("could not find rep_env with id_nr"//cp_to_string(rep_env_id)) - END IF CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env) logger => cp_get_default_logger() CALL cp_rm_iter_level(iteration_info=logger%iter_info, & diff --git a/src/response_solver.F b/src/response_solver.F index 8409bc3eaa..9985ca3402 100644 --- a/src/response_solver.F +++ b/src/response_solver.F @@ -1244,7 +1244,7 @@ CONTAINS CALL pw_zero(vhxc_rspace) IF (gapw) THEN CALL pw_transfer(v_hartree_rspace_gs, vhxc_rspace) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL pw_transfer(vh_rspace, vhxc_rspace) END IF CALL integrate_v_rspace(v_rspace=vhxc_rspace, & @@ -1795,7 +1795,7 @@ CONTAINS CALL pw_zero(v_xc(ispin)) IF (gapw) THEN ! Hartree potential of response density CALL pw_axpy(v_hartree_rspace_t, v_xc(ispin)) - ELSE IF (gapw_xc) THEN + ELSEIF (gapw_xc) THEN CALL pw_axpy(zv_hartree_rspace, v_xc(ispin)) END IF CALL integrate_v_rspace(qs_env=qs_env, & diff --git a/src/restraint.F b/src/restraint.F index 53c602452a..4b2d6d7738 100644 --- a/src/restraint.F +++ b/src/restraint.F @@ -442,9 +442,9 @@ CONTAINS r0_13(:) = particle_set(index_a)%r - particle_set(index_c)%r r0_23(:) = particle_set(index_b)%r - particle_set(index_c)%r - rab = NORM2(r0_12) - rac = NORM2(r0_13) - rbc = NORM2(r0_23) + rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) + rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) + rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) tab = rab - g3x3_list(ng3x3)%dab tac = rac - g3x3_list(ng3x3)%dac tbc = rbc - g3x3_list(ng3x3)%dbc @@ -508,12 +508,12 @@ CONTAINS r0_24(:) = particle_set(index_b)%r - particle_set(index_d)%r r0_34(:) = particle_set(index_c)%r - particle_set(index_d)%r - rab = NORM2(r0_12) - rac = NORM2(r0_13) - rad = NORM2(r0_14) - rbc = NORM2(r0_23) - rbd = NORM2(r0_24) - rcd = NORM2(r0_34) + rab = SQRT(DOT_PRODUCT(r0_12, r0_12)) + rac = SQRT(DOT_PRODUCT(r0_13, r0_13)) + rad = SQRT(DOT_PRODUCT(r0_14, r0_14)) + rbc = SQRT(DOT_PRODUCT(r0_23, r0_23)) + rbd = SQRT(DOT_PRODUCT(r0_24, r0_24)) + rcd = SQRT(DOT_PRODUCT(r0_34, r0_34)) tab = rab - g4x6_list(ng4x6)%dab tac = rac - g4x6_list(ng4x6)%dac diff --git a/src/rpa_grad.F b/src/rpa_grad.F index 2ea5e679e9..a24334cf14 100644 --- a/src/rpa_grad.F +++ b/src/rpa_grad.F @@ -1054,9 +1054,8 @@ CONTAINS mem_per_block = REAL(number_of_elements_per_blk, KIND=dp)*8.0_dp number_of_parallel_channels = MAX(1, MIN(MAXVAL(grid) - 1, FLOOR(mem_real/mem_per_block))) CALL para_env%min(number_of_parallel_channels) - IF (mp2_env%ri_grad%max_parallel_comm > 0) THEN + IF (mp2_env%ri_grad%max_parallel_comm > 0) & number_of_parallel_channels = MIN(number_of_parallel_channels, mp2_env%ri_grad%max_parallel_comm) - END IF IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,T75,I6)') 'GRAD_INFO| Number of parallel communication channels:', number_of_parallel_channels @@ -1672,13 +1671,11 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) THEN + IF (ALLOCATED(index2send(pcol_send)%array)) & size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) - END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN + IF (ALLOCATED(index2recv(pcol_recv)%array)) & size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) - END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -1832,13 +1829,11 @@ CONTAINS pcol_send = MODULO(my_pcol + proc_shift, num_pe_col) pcol_recv = MODULO(my_pcol - proc_shift, num_pe_col) - IF (ALLOCATED(index2send(pcol_send)%array)) THEN + IF (ALLOCATED(index2send(pcol_send)%array)) & size_send_buffer = MAX(size_send_buffer, SIZE(index2send(pcol_send)%array)) - END IF - IF (ALLOCATED(index2recv(pcol_recv)%array)) THEN + IF (ALLOCATED(index2recv(pcol_recv)%array)) & size_recv_buffer = MAX(size_recv_buffer, SIZE(index2recv(pcol_recv)%array)) - END IF END DO ALLOCATE (buffer_send(nrow_local, size_send_buffer), buffer_recv(nrow_local, size_recv_buffer)) @@ -2278,18 +2273,14 @@ CONTAINS DO ispin = 1, nspins DO pcol = 0, SIZE(sos_mp2_work_occ(ispin)%index2send, 1) - 1 - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - END IF - IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_occ(ispin)%index2send(pcol)%array)) & DEALLOCATE (sos_mp2_work_occ(ispin)%index2send(pcol)%array) - END IF - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) - END IF - IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) THEN + IF (ALLOCATED(sos_mp2_work_virt(ispin)%index2recv(pcol)%array)) & DEALLOCATE (sos_mp2_work_virt(ispin)%index2recv(pcol)%array) - END IF END DO DEALLOCATE (sos_mp2_work_occ(ispin)%index2send, & sos_mp2_work_occ(ispin)%index2recv, & @@ -2318,8 +2309,7 @@ CONTAINS mp2_env%ri_grad%P_ij(ispin)%array(:, :) = 0.5_dp*(mp2_env%ri_grad%P_ij(ispin)%array + & TRANSPOSE(mp2_env%ri_grad%P_ij(ispin)%array)) - ! The first index of P_ab has to be distributed within the subgroups, - ! so sum it up first and add the required elements later + ! The first index of P_ab has to be distributed within the subgroups, so sum it up first and add the required elements later CALL para_env%sum(sos_mp2_work_virt(ispin)%P) itmp = get_limit(virtual(ispin), para_env_sub%num_pe, para_env_sub%mepos) diff --git a/src/rpa_gw_kpoints_util.F b/src/rpa_gw_kpoints_util.F index 00699efc4f..460a46aaa6 100644 --- a/src/rpa_gw_kpoints_util.F +++ b/src/rpa_gw_kpoints_util.F @@ -1315,9 +1315,8 @@ CONTAINS ELSE IF (kpoint_weights_W_method == kp_weights_W_tailored .OR. & kpoint_weights_W_method == kp_weights_W_auto) THEN - IF (kpoint_weights_W_method == kp_weights_W_tailored) THEN + IF (kpoint_weights_W_method == kp_weights_W_tailored) & exp_kpoints = qs_env%mp2_env%ri_rpa_im_time%exp_tailored_weights - END IF IF (kpoint_weights_W_method == kp_weights_W_auto) THEN IF (SUM(periodic) == 2) exp_kpoints = -1.0_dp diff --git a/src/rpa_im_time.F b/src/rpa_im_time.F index 8081575ae5..5c1054cbb8 100644 --- a/src/rpa_im_time.F +++ b/src/rpa_im_time.F @@ -477,9 +477,8 @@ CONTAINS first_cycle_im_time = .FALSE. - IF (jquad == 1 .AND. flops_2 == 0) THEN + IF (jquad == 1 .AND. flops_2 == 0) & has_mat_P_blocks(i_cell_T, i_mem, j_mem, i_cell_R_1, i_cell_R_2) = .FALSE. - END IF END DO END DO diff --git a/src/rpa_main.F b/src/rpa_main.F index c005965d59..294525cce1 100644 --- a/src/rpa_main.F +++ b/src/rpa_main.F @@ -330,20 +330,18 @@ CONTAINS input_num_integ_groups = mp2_env%ri_rpa%rpa_num_integ_groups IF (my_do_gw .AND. do_minimax_quad) THEN IF (num_integ_points > 34) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 30.") - END IF num_integ_points = 30 END IF ELSE IF (do_minimax_quad .AND. num_integ_points > 20) THEN - IF (unit_nr > 0) THEN + IF (unit_nr > 0) & CALL cp_warn(__LOCATION__, & "The required number of quadrature point exceeds the maximum possible in the "// & "Minimax quadrature scheme. The number of quadrature point has been reset to 20.") - END IF num_integ_points = 20 END IF END IF @@ -975,9 +973,8 @@ CONTAINS CALL cp_fm_struct_release(fm_struct) - IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) THEN + IF (.NOT. (my_blacs_ext .OR. (para_env_RPA%num_pe == para_env%num_pe .AND. PRESENT(qs_env)))) & CALL cp_blacs_env_release(blacs_env_Q) - END IF END IF ! release blacs_env @@ -1336,10 +1333,9 @@ CONTAINS IF (calc_forces .AND. .NOT. do_im_time) CALL rpa_grad_create(rpa_grad, fm_mat_Q(1), & fm_mat_S, homo, virtual, mp2_env, Eigenval(:, 1, :), & unit_nr, do_ri_sos_laplace_mp2) - IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) THEN + IF (.NOT. do_im_time .AND. .NOT. do_ri_sos_laplace_mp2) & CALL exchange_work%create(qs_env, para_env_sub, mat_munu, dimen_RI_red, & fm_mat_S, fm_mat_Q(1), fm_mat_Q_gemm(1), homo, virtual) - END IF Erpa = 0.0_dp IF (mp2_env%ri_rpa%exchange_correction /= rpa_exchange_none) e_exchange = 0.0_dp first_cycle = .TRUE. diff --git a/src/rt_propagation_forces.F b/src/rt_propagation_forces.F index 5d8ffc1854..bb9d1ac65c 100644 --- a/src/rt_propagation_forces.F +++ b/src/rt_propagation_forces.F @@ -122,18 +122,16 @@ CONTAINS IF (rtp%linear_scaling) THEN CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_new(re)%matrix, zero, tmp, & filter_eps=rtp%filter_eps) - IF (rtp%propagate_complex_ks) THEN + IF (rtp%propagate_complex_ks) & CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) - END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_new(im)%matrix, one, tmp, & filter_eps=rtp%filter_eps) CALL compute_forces(force, tmp, S_der, rho_new(im)%matrix, C_mat, kind_of, atom_of_kind) ELSE CALL dbcsr_multiply("N", "N", one, SinvH(ispin)%matrix, rho_ao(ispin)%matrix, zero, tmp) - IF (rtp%propagate_complex_ks) THEN + IF (rtp%propagate_complex_ks) & CALL dbcsr_multiply("N", "N", one, SinvH_imag(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) - END IF CALL dbcsr_multiply("N", "N", one, SinvB(ispin)%matrix, rho_ao_im(ispin)%matrix, one, tmp) CALL compute_forces(force, tmp, S_der, rho_ao_im(ispin)%matrix, C_mat, kind_of, atom_of_kind) END IF diff --git a/src/rt_propagation_types.F b/src/rt_propagation_types.F index 416906664d..ec1e3f4823 100644 --- a/src/rt_propagation_types.F +++ b/src/rt_propagation_types.F @@ -476,15 +476,12 @@ CONTAINS CALL dbcsr_deallocate_matrix_set(rtp%H_last_iter) CALL dbcsr_deallocate_matrix_set(rtp%propagator_matrix) IF (ASSOCIATED(rtp%rho)) THEN - IF (ASSOCIATED(rtp%rho%old)) THEN + IF (ASSOCIATED(rtp%rho%old)) & CALL dbcsr_deallocate_matrix_set(rtp%rho%old) - END IF - IF (ASSOCIATED(rtp%rho%next)) THEN + IF (ASSOCIATED(rtp%rho%next)) & CALL dbcsr_deallocate_matrix_set(rtp%rho%next) - END IF - IF (ASSOCIATED(rtp%rho%new)) THEN + IF (ASSOCIATED(rtp%rho%new)) & CALL dbcsr_deallocate_matrix_set(rtp%rho%new) - END IF DEALLOCATE (rtp%rho) END IF @@ -493,27 +490,20 @@ CONTAINS CALL dbcsr_deallocate_matrix(rtp%S_inv) CALL dbcsr_deallocate_matrix(rtp%S_half) CALL dbcsr_deallocate_matrix(rtp%S_minus_half) - IF (ASSOCIATED(rtp%B_mat)) THEN + IF (ASSOCIATED(rtp%B_mat)) & CALL dbcsr_deallocate_matrix(rtp%B_mat) - END IF - IF (ASSOCIATED(rtp%C_mat)) THEN + IF (ASSOCIATED(rtp%C_mat)) & CALL dbcsr_deallocate_matrix_set(rtp%C_mat) - END IF - IF (ASSOCIATED(rtp%S_der)) THEN + IF (ASSOCIATED(rtp%S_der)) & CALL dbcsr_deallocate_matrix_set(rtp%S_der) - END IF - IF (ASSOCIATED(rtp%SinvH)) THEN + IF (ASSOCIATED(rtp%SinvH)) & CALL dbcsr_deallocate_matrix_set(rtp%SinvH) - END IF - IF (ASSOCIATED(rtp%SinvH_imag)) THEN + IF (ASSOCIATED(rtp%SinvH_imag)) & CALL dbcsr_deallocate_matrix_set(rtp%SinvH_imag) - END IF - IF (ASSOCIATED(rtp%SinvB)) THEN + IF (ASSOCIATED(rtp%SinvB)) & CALL dbcsr_deallocate_matrix_set(rtp%SinvB) - END IF - IF (ASSOCIATED(rtp%history)) THEN + IF (ASSOCIATED(rtp%history)) & CALL rtp_history_release(rtp) - END IF DEALLOCATE (rtp%orders) END SUBROUTINE rt_prop_release @@ -525,18 +515,14 @@ CONTAINS TYPE(rt_prop_type), INTENT(inout) :: rtp IF (ASSOCIATED(rtp%mos)) THEN - IF (ASSOCIATED(rtp%mos%old)) THEN + IF (ASSOCIATED(rtp%mos%old)) & CALL cp_fm_release(rtp%mos%old) - END IF - IF (ASSOCIATED(rtp%mos%new)) THEN + IF (ASSOCIATED(rtp%mos%new)) & CALL cp_fm_release(rtp%mos%new) - END IF - IF (ASSOCIATED(rtp%mos%next)) THEN + IF (ASSOCIATED(rtp%mos%next)) & CALL cp_fm_release(rtp%mos%next) - END IF - IF (ASSOCIATED(rtp%mos%admm)) THEN + IF (ASSOCIATED(rtp%mos%admm)) & CALL cp_fm_release(rtp%mos%admm) - END IF CALL cp_fm_struct_release(rtp%ao_ao_fmstruct) DEALLOCATE (rtp%mos) END IF @@ -607,9 +593,8 @@ CONTAINS IF (ASSOCIATED(rtp%history%s_history)) THEN DO i = 1, SIZE(rtp%history%s_history) - IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) THEN + IF (ASSOCIATED(rtp%history%s_history(i)%matrix)) & CALL dbcsr_deallocate_matrix(rtp%history%s_history(i)%matrix) - END IF END DO DEALLOCATE (rtp%history%s_history) END IF diff --git a/src/rt_propagation_velocity_gauge.F b/src/rt_propagation_velocity_gauge.F index 9ad2819d5c..ee205d1999 100644 --- a/src/rt_propagation_velocity_gauge.F +++ b/src/rt_propagation_velocity_gauge.F @@ -1090,58 +1090,48 @@ CONTAINS na = SIZE(acint_cos, 1) np = SIZE(acint_cos, 2) nb = SIZE(bcint_cos, 1) - ! Re(dV_ab/dRA) = + - ! + + - ! Im(dV_ab/dRA) = - - ! - + + ! Re(dV_ab/dRA) = + + + + ! Im(dV_ab/dRA) = - - + katom = alist_cos_ac%clist(kac)%catom DO idir = 1, 3 IF (iatom <= jatom) THEN ! For fa: - IF (found_real) THEN + IF (found_real) & fa(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & + MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (+MATMUL(acint_sin(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_cos(1:nb, 1:np, 1))) & - MATMUL(acint_cos(1:na, 1:np, 1 + idir), TRANSPOSE(bchint_sin(1:nb, 1:np, 1))))) - END IF ! For fb: - IF (found_real) THEN + IF (found_real) & fb(idir) = SUM(matrix_p_real(1:na, 1:nb)* & (+MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:na, 1:nb)* & (-MATMUL(achint_cos(1:na, 1:np, 1), TRANSPOSE(bcint_sin(1:nb, 1:np, 1 + idir))) & + MATMUL(achint_sin(1:na, 1:np, 1), TRANSPOSE(bcint_cos(1:nb, 1:np, 1 + idir))))) - END IF ELSE ! For fa: - IF (found_real) THEN + IF (found_real) & fa(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & + MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fa(idir) = fa(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (+MATMUL(bchint_sin(1:nb, 1:np, 1), TRANSPOSE(acint_cos(1:na, 1:np, 1 + idir))) & - MATMUL(bchint_cos(1:nb, 1:np, 1), TRANSPOSE(acint_sin(1:na, 1:np, 1 + idir))))) - END IF ! For fb - IF (found_real) THEN + IF (found_real) & fb(idir) = SUM(matrix_p_real(1:nb, 1:na)* & (+MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))))) - END IF - IF (found_imag) THEN + IF (found_imag) & fb(idir) = fb(idir) - sign_imag*SUM(matrix_p_imag(1:nb, 1:na)* & (-MATMUL(bcint_cos(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_sin(1:na, 1:np, 1))) & + MATMUL(bcint_sin(1:nb, 1:np, 1 + idir), TRANSPOSE(achint_cos(1:na, 1:np, 1))))) - END IF END IF force_thread(idir, iatom) = force_thread(idir, iatom) + f0*fa(idir) force_thread(idir, katom) = force_thread(idir, katom) - f0*fa(idir) diff --git a/src/scf_control_types.F b/src/scf_control_types.F index 623af5359f..527bb5e81f 100644 --- a/src/scf_control_types.F +++ b/src/scf_control_types.F @@ -302,9 +302,8 @@ CONTAINS END IF DEALLOCATE (scf_control%smear) - IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) THEN + IF (ASSOCIATED(scf_control%outer_scf%cdft_opt_control)) & CALL cdft_opt_type_release(scf_control%outer_scf%cdft_opt_control) - END IF IF (ASSOCIATED(scf_control%gce)) THEN DEALLOCATE (scf_control%gce) @@ -354,7 +353,7 @@ CONTAINS IF (scf_control%use_diag .AND. scf_control%use_ot) THEN ! don't allow both options to be true CPABORT("Don't activate OT and Diagonaliztion together") - ELSE IF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN + ELSEIF (.NOT. (scf_control%use_diag .OR. scf_control%use_ot)) THEN ! set default to diagonalization scf_control%use_diag = .TRUE. END IF @@ -700,10 +699,9 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T25,A,T71,ES10.2)") & "Smearing width (sigma) [a.u.]:", scf_control%smear%smearing_width, & "Accuracy threshold:", scf_control%smear%eps_fermi_dirac - IF (scf_control%smear%fixed_mag_mom > 0.0_dp) THEN + IF (scf_control%smear%fixed_mag_mom > 0.0_dp) & WRITE (UNIT=output_unit, FMT="(T25,A,T61,F20.1)") & - "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom - END IF + "Fixed magnetic moment set to:", scf_control%smear%fixed_mag_mom CASE (smear_energy_window) WRITE (UNIT=output_unit, FMT="(T25,A,T71,F10.6)") & "Smear window [a.u.]: ", scf_control%smear%window_size diff --git a/src/scine_utils.F b/src/scine_utils.F index 8bd0ee64ca..208d4b2f0b 100644 --- a/src/scine_utils.F +++ b/src/scine_utils.F @@ -117,15 +117,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSE IF (nc == j + 4) THEN + ELSEIF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 3) THEN + ELSEIF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 2) THEN + ELSEIF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 1) THEN + ELSEIF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j) THEN + ELSEIF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -134,15 +134,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSE IF (nc == j + 4) THEN + ELSEIF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 3) THEN + ELSEIF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 2) THEN + ELSEIF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 1) THEN + ELSEIF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j) THEN + ELSEIF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO @@ -151,15 +151,15 @@ CONTAINS DO j = 1, nc, 5 IF (nc > j + 4) THEN WRITE (iounit, "(T12,5(F20.12,','))") hessian(nc, j:j + 4) - ELSE IF (nc == j + 4) THEN + ELSEIF (nc == j + 4) THEN WRITE (iounit, "(T12,4(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 3) THEN + ELSEIF (nc == j + 3) THEN WRITE (iounit, "(T12,3(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 2) THEN + ELSEIF (nc == j + 2) THEN WRITE (iounit, "(T12,2(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j + 1) THEN + ELSEIF (nc == j + 1) THEN WRITE (iounit, "(T12,1(F20.12,','),F20.12,' ]')") hessian(nc, j:nc) - ELSE IF (nc == j) THEN + ELSEIF (nc == j) THEN WRITE (iounit, "(T12,F20.12,' ]')") hessian(nc, j:nc) END IF END DO diff --git a/src/se_core_matrix.F b/src/se_core_matrix.F index 10bda9bd4e..2c53f7ca31 100644 --- a/src/se_core_matrix.F +++ b/src/se_core_matrix.F @@ -281,6 +281,24 @@ CONTAINS ! two-centre one-electron term NULLIFY (s_block) +! CALL dbcsr_get_block_p(matrix_s(1)%matrix,& +! irow,icol,s_block,found) +! CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) +! +! if( irow == iatom )then +! R= -rij +! call makeS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,S) +! else +! R= rij +! call makeS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,S) +! endif +! +! do i=1,4 +! do j=1,4 +! s_block(i,j)=S(ix(i),ix(j)) +! enddo +! enddo + CALL dbcsr_get_block_p(matrix_s(1)%matrix, & irow, icol, s_block, found) CPASSERT(ASSOCIATED(s_block)) @@ -301,11 +319,28 @@ CONTAINS atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) +! if( irow == iatom )then +! R= -rij +! call makedS(R,nra,nrb,ZSa,ZSb,ZPa,ZPb,dS) +! else +! R= rij +! call makedS(R,nrb,nra,ZSb,ZSa,ZPb,ZPa,dS) +! endif + CALL dbcsr_get_block_p(matrix_p(1)%matrix, irow, icol, pabmat, found) CPASSERT(ASSOCIATED(pabmat)) DO icor = 1, 3 force_ab(icor) = 0._dp +! CALL dbcsr_get_block_p(matrix_s(icor+1)%matrix,irow,icol,dsmat,found) +! CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,failure) +! +! do i=1,4 +! do j=1,4 +! dsmat(i,j)=dS(ix(i),ix(j),icor) +! enddo +! enddo + CALL dbcsr_get_block_p(matrix_s(icor + 1)%matrix, irow, icol, dsmat, found) CPASSERT(ASSOCIATED(dsmat)) dsmat = 2._dp*kh*dsmat*pabmat @@ -593,7 +628,7 @@ CONTAINS S(:, :) = 0.0_dp v(:) = R(:) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) IF (rr < 1.0e-20_dp) THEN @@ -971,7 +1006,7 @@ CONTAINS dS(:, :, :) = 0.0_dp v(:) = R(:) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) IF (rr < 1.0e-20_dp) THEN diff --git a/src/semi_empirical_int_ana.F b/src/semi_empirical_int_ana.F index 3698bf1625..d9e33d563a 100644 --- a/src/semi_empirical_int_ana.F +++ b/src/semi_empirical_int_ana.F @@ -548,7 +548,7 @@ CONTAINS (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2)*(-2.0_dp*apdg*(rij - dbi - daj)) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2)*(-2.0_dp*apdg*(rij - dbi - dbj)) END IF - ELSE IF (itype == do_method_pchg) THEN + ELSEIF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp dscale = 0.0_dp @@ -571,15 +571,15 @@ CONTAINS IF (l_denuc) dscale = dscale*(2._dp*xab*EXP(-aab*rija*rija)) - & scale*2._dp*xab*EXP(-aab*rija*rija)*(2.0_dp*aab*rija)*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) & - scale*2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6))*aab*(1.0_dp + 6.0_dp*0.0003_dp*rija**5)*drija & - scale*9.28_dp*EXP(-5.98_dp*rija)*5.98_dp*drija IF (l_enuc) scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O IF (l_denuc) dscale = & dscale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) & @@ -1578,7 +1578,8 @@ CONTAINS ! Evaluate additional taper function for dumped integrals IF (se_int_control%integral_screening == do_se_IS_kdso_d) THEN se_int_screen%ft = taper_eval(se_taper%taper_add, rij) - IF (lgrad) se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) + IF (lgrad) & + se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) END IF ! Integral Values for sp shells only diff --git a/src/semi_empirical_int_debug.F b/src/semi_empirical_int_debug.F index 466d99a3c7..2a77ae1016 100644 --- a/src/semi_empirical_int_debug.F +++ b/src/semi_empirical_int_debug.F @@ -71,7 +71,7 @@ SUBROUTINE check_rotmat_der(sepi, sepj, rjiv, ij_matrix, do_invert) IF (i == 1) matrix => matrix_p IF (i == 2) matrix => matrix_m r0 = rjiv + (-1.0_dp)**(i - 1)*x - r = NORM2(r0) + r = SQRT(DOT_PRODUCT(r0, r0)) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=do_invert) END DO ! SP @@ -218,7 +218,7 @@ SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, in x(imap(j)) = dx DO i = 1, 2 r0 = rijv + (-1.0_dp)**(i - 1)*x - r = NORM2(r0) + r = SQRT(DOT_PRODUCT(r0, r0)) CALL rotmat_create(matrix) CALL rotmat(sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=invert) diff --git a/src/semi_empirical_int_gks.F b/src/semi_empirical_int_gks.F index b6da8aa20d..f285735404 100644 --- a/src/semi_empirical_int_gks.F +++ b/src/semi_empirical_int_gks.F @@ -270,7 +270,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -373,7 +373,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) w0 = a2*rr @@ -590,7 +590,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) r1 = 1.0_dp/rr r2 = r1*r1 @@ -807,7 +807,7 @@ CONTAINS v(1) = RAB(1) v(2) = RAB(2) v(3) = RAB(3) - rr = NORM2(v) + rr = SQRT(DOT_PRODUCT(v, v)) a2 = 0.5_dp*(1.0_dp/ACOULA + 1.0_dp/ACOULB) diff --git a/src/semi_empirical_int_num.F b/src/semi_empirical_int_num.F index a5cbd768c6..a541863a75 100644 --- a/src/semi_empirical_int_num.F +++ b/src/semi_empirical_int_num.F @@ -619,7 +619,7 @@ CONTAINS (zaf*pai + zbf*pbj)*EXP(-apdg*(rij - dai - dbj)**2) + & (zaf*pbi + zbf*paj)*EXP(-apdg*(rij - dbi - daj)**2) + & (zaf*pbi + zbf*pbj)*EXP(-apdg*(rij - dbi - dbj)**2) - ELSE IF (itype == do_method_pchg) THEN + ELSEIF (itype == do_method_pchg) THEN qcorr = 0.0_dp scale = 0.0_dp ELSE @@ -635,11 +635,11 @@ CONTAINS (sepj%z == 1 .AND. (sepi%z == 6 .OR. sepi%z == 7 .OR. sepi%z == 8))) THEN ! Special Case O-H or N-H or C-H scale = scale*(2._dp*xab*EXP(-aab*rija*rija)) - ELSE IF (sepi%z == 6 .AND. sepj%z == 6) THEN + ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN ! Special Case C-C scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) + 9.28_dp*EXP(-5.98_dp*rija)) - ELSE IF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & - (sepj%z == 8 .AND. sepi%z == 14)) THEN + ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. & + (sepj%z == 8 .AND. sepi%z == 14)) THEN ! Special Case Si-O scale = scale*(2._dp*xab*EXP(-aab*(rija + 0.0003_dp*rija**6)) - 0.0007_dp*EXP(-(rija - 2.9_dp)**2)) ELSE diff --git a/src/semi_empirical_par_utils.F b/src/semi_empirical_par_utils.F index ec1302790b..4ca22c5713 100644 --- a/src/semi_empirical_par_utils.F +++ b/src/semi_empirical_par_utils.F @@ -261,16 +261,16 @@ CONTAINS ELSE IF (l == 0) THEN n = nqs(sep%z) - ELSE IF (l == 1) THEN + ELSEIF (l == 1) THEN ! Special case for Hydrogen.. If requested allow p-orbitals on it.. IF ((sep%z == 1) .AND. sep%p_orbitals_on_h) THEN n = 1 ELSE n = nqp(sep%z) END IF - ELSE IF (l == 2) THEN + ELSEIF (l == 2) THEN n = nqd(sep%z) - ELSE IF (l == 3) THEN + ELSEIF (l == 3) THEN n = nqf(sep%z) ELSE CPABORT("Invalid l quantum number !") @@ -535,27 +535,24 @@ CONTAINS z1 = sep%sto_exponents(0) z2 = sep%sto_exponents(1) z3 = sep%sto_exponents(2) - IF (z1 <= 0.0_dp) THEN + IF (z1 <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Trying to use s-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of s orbitals! ") - END IF amn = 0.0_dp nsp = nqs(sep%z) IF (sep%natorb >= 4) THEN - IF (z2 <= 0.0_dp) THEN + IF (z2 <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Trying to use p-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of p orbitals! ") - END IF amn(2) = amn_l_low(z1, z2, nsp, nsp, 1) amn(3) = amn_l_low(z2, z2, nsp, nsp, 2) IF (sep%dorb) THEN - IF (z3 <= 0.0_dp) THEN + IF (z3 <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Trying to use d-orbitals, but the STO exponents is set to 0. "// & "Please check if your parameterization supports the usage of d orbitals! ") - END IF nd = nqd(sep%z) amn(4) = amn_l_low(z1, z3, nsp, nd, 2) amn(5) = amn_l_low(z2, z3, nsp, nd, 1) diff --git a/src/semi_empirical_store_int_types.F b/src/semi_empirical_store_int_types.F index f878234b19..f00537c0de 100644 --- a/src/semi_empirical_store_int_types.F +++ b/src/semi_empirical_store_int_types.F @@ -97,9 +97,8 @@ CONTAINS END IF ! Disk Storage disabled for semi-empirical methods - IF (store_int_env%memory_parameter%do_disk_storage) THEN + IF (store_int_env%memory_parameter%do_disk_storage) & CPABORT("Disk storage for SEMIEMPIRICAL methods disabled! ") - END IF ! Allocate containers/caches for integral storage if requested IF (.NOT. store_int_env%memory_parameter%do_all_on_the_fly .AND. store_int_env%compress) THEN diff --git a/src/semi_empirical_types.F b/src/semi_empirical_types.F index 9157e5f5db..806e85c01c 100644 --- a/src/semi_empirical_types.F +++ b/src/semi_empirical_types.F @@ -833,7 +833,7 @@ CONTAINS ADJUSTR("ACOUL"), "- "//" Slater parameter: ", sep%acoul WRITE (UNIT=output_unit, FMT="(T16,A11,T30,A,T69,I12)") & ADJUSTR("NR"), "- "//" Slater parameter: ", sep%nr - ELSE IF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN + ELSEIF ((typ == do_method_am1 .OR. typ == do_method_rm1) .AND. sep%z == 5) THEN ! Standard case DO i = 1, SIZE(sep%bfn1, 1) i_string = cp_to_string(i) diff --git a/src/semi_empirical_utils.F b/src/semi_empirical_utils.F index 4cc9b5e0a9..5c9911931f 100644 --- a/src/semi_empirical_utils.F +++ b/src/semi_empirical_utils.F @@ -305,11 +305,10 @@ CONTAINS END IF ! Check if the element has been defined.. - IF (.NOT. sep%defined) THEN + IF (.NOT. sep%defined) & CALL cp_abort(__LOCATION__, & "Semiempirical type ("//TRIM(sep%name)//") cannot be defined for "// & "the requested parameterization.") - END IF ! Fill 1 center - 2 electron integrals CALL setup_1c_2el_int(sep) diff --git a/src/shg_int/construct_shg.F b/src/shg_int/construct_shg.F index 9de93b969d..b63da9c9c1 100644 --- a/src/shg_int/construct_shg.F +++ b/src/shg_int/construct_shg.F @@ -377,8 +377,7 @@ CONTAINS IF (ma - 1 >= 0) THEN Wamm(0:lamb, 1) = Waux_mat(1:lamb + 1, ipam - 1, ipb) IF (mb > 0) Wamm(0:lamb, 2) = Waux_mat(1:lamb + 1, ipam - 1, imb) - ! order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 - IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) + IF (ma - 1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb + 1, imam + 1, ipb) !order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 IF (ma - 1 > 0 .AND. mb > 0) Wamm(0:lamb, 4) = Waux_mat(1:lamb + 1, imam + 1, imb) END IF !*** Wamp: la-1, ma+1 diff --git a/src/sirius_interface.F b/src/sirius_interface.F index 9b94f8290b..c278a27ee1 100644 --- a/src/sirius_interface.F +++ b/src/sirius_interface.F @@ -327,7 +327,7 @@ CONTAINS symbol=element_symbol, & mass=REAL(mass/massunit, KIND=C_DOUBLE)) - ELSE IF (ASSOCIATED(gth_potential)) THEN + ELSEIF (ASSOCIATED(gth_potential)) THEN ! NULLIFY (atom_grid) CALL allocate_grid_atom(atom_grid) diff --git a/src/skala_gpw_features.F b/src/skala_gpw_features.F index f791c73354..14a0b088a5 100644 --- a/src/skala_gpw_features.F +++ b/src/skala_gpw_features.F @@ -225,9 +225,8 @@ CONTAINS my_requires_grad = .FALSE. IF (PRESENT(requires_grad)) my_requires_grad = requires_grad my_requires_coordinate_grad = .FALSE. - IF (PRESENT(requires_coordinate_grad)) THEN + IF (PRESENT(requires_coordinate_grad)) & my_requires_coordinate_grad = requires_coordinate_grad - END IF my_requires_stress_grad = .FALSE. IF (PRESENT(requires_stress_grad)) my_requires_stress_grad = requires_stress_grad my_use_atom_chunks = .FALSE. @@ -596,9 +595,8 @@ CONTAINS END IF max_local_features = nflat_local - IF (my_atom_partition == skala_gpw_atom_partition_smooth) THEN + IF (my_atom_partition == skala_gpw_atom_partition_smooth) & max_local_features = nflat_local*natom - END IF ALLOCATE (local_owner(max_local_features), & local_source_points(max_local_features), & local_static(nstatic_per_point*max_local_features), & @@ -781,9 +779,8 @@ CONTAINS atom_position(owner) = atom_position(owner) + 1 source_global = global_source_points(ipt) cached_layout%feature_source_points(row) = source_global - IF (cached_layout%global_to_feature(source_global) == 0) THEN + IF (cached_layout%global_to_feature(source_global) == 0) & cached_layout%global_to_feature(source_global) = row - END IF static_base = nstatic_per_point*(ipt - 1) cached_layout%grid_coords(:, row) = global_static(static_base + 1:static_base + 3) cached_layout%grid_weights(row) = global_static(static_base + 4) @@ -1461,18 +1458,14 @@ CONTAINS IF (ALLOCATED(cache%chunk_feature_displs)) DEALLOCATE (cache%chunk_feature_displs) IF (ALLOCATED(cache%chunk_grad_counts)) DEALLOCATE (cache%chunk_grad_counts) IF (ALLOCATED(cache%chunk_grad_displs)) DEALLOCATE (cache%chunk_grad_displs) - IF (ALLOCATED(cache%route_grad_return_recv_counts)) THEN + IF (ALLOCATED(cache%route_grad_return_recv_counts)) & DEALLOCATE (cache%route_grad_return_recv_counts) - END IF - IF (ALLOCATED(cache%route_grad_return_recv_displs)) THEN + IF (ALLOCATED(cache%route_grad_return_recv_displs)) & DEALLOCATE (cache%route_grad_return_recv_displs) - END IF - IF (ALLOCATED(cache%route_grad_return_send_counts)) THEN + IF (ALLOCATED(cache%route_grad_return_send_counts)) & DEALLOCATE (cache%route_grad_return_send_counts) - END IF - IF (ALLOCATED(cache%route_grad_return_send_displs)) THEN + IF (ALLOCATED(cache%route_grad_return_send_displs)) & DEALLOCATE (cache%route_grad_return_send_displs) - END IF IF (ALLOCATED(cache%route_local_dest)) DEALLOCATE (cache%route_local_dest) IF (ALLOCATED(cache%chunk_return_positions)) DEALLOCATE (cache%chunk_return_positions) IF (ALLOCATED(cache%route_point_recv_counts)) DEALLOCATE (cache%route_point_recv_counts) @@ -1495,20 +1488,17 @@ CONTAINS IF (ALLOCATED(cache%local_feature_offsets)) DEALLOCATE (cache%local_feature_offsets) IF (ALLOCATED(cache%local_feature_points)) DEALLOCATE (cache%local_feature_points) IF (ALLOCATED(cache%local_feature_rows)) DEALLOCATE (cache%local_feature_rows) - IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) THEN + IF (ALLOCATED(cache%atomic_grid_size_bound_shape)) & DEALLOCATE (cache%atomic_grid_size_bound_shape) - END IF - IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) THEN + IF (ALLOCATED(cache%chunk_atomic_grid_size_bound_shape)) & DEALLOCATE (cache%chunk_atomic_grid_size_bound_shape) - END IF IF (ALLOCATED(cache%atomic_grid_weights)) DEALLOCATE (cache%atomic_grid_weights) IF (ALLOCATED(cache%chunk_atomic_grid_weights)) DEALLOCATE (cache%chunk_atomic_grid_weights) IF (ALLOCATED(cache%chunk_grid_weights)) DEALLOCATE (cache%chunk_grid_weights) IF (ALLOCATED(cache%grid_weights)) DEALLOCATE (cache%grid_weights) IF (ALLOCATED(cache%atom_coords)) DEALLOCATE (cache%atom_coords) - IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) THEN + IF (ALLOCATED(cache%chunk_coarse_0_atomic_coords)) & DEALLOCATE (cache%chunk_coarse_0_atomic_coords) - END IF IF (ALLOCATED(cache%coarse_0_atomic_coords)) DEALLOCATE (cache%coarse_0_atomic_coords) IF (ALLOCATED(cache%chunk_grid_coords)) DEALLOCATE (cache%chunk_grid_coords) IF (ALLOCATED(cache%grid_coords)) DEALLOCATE (cache%grid_coords) @@ -1602,30 +1592,22 @@ CONTAINS IF (ALLOCATED(features%chunk_grad_counts)) DEALLOCATE (features%chunk_grad_counts) IF (ALLOCATED(features%chunk_grad_displs)) DEALLOCATE (features%chunk_grad_displs) IF (ALLOCATED(features%chunk_return_positions)) DEALLOCATE (features%chunk_return_positions) - IF (ALLOCATED(features%route_grad_return_recv_counts)) THEN + IF (ALLOCATED(features%route_grad_return_recv_counts)) & DEALLOCATE (features%route_grad_return_recv_counts) - END IF - IF (ALLOCATED(features%route_grad_return_recv_displs)) THEN + IF (ALLOCATED(features%route_grad_return_recv_displs)) & DEALLOCATE (features%route_grad_return_recv_displs) - END IF - IF (ALLOCATED(features%route_grad_return_send_counts)) THEN + IF (ALLOCATED(features%route_grad_return_send_counts)) & DEALLOCATE (features%route_grad_return_send_counts) - END IF - IF (ALLOCATED(features%route_grad_return_send_displs)) THEN + IF (ALLOCATED(features%route_grad_return_send_displs)) & DEALLOCATE (features%route_grad_return_send_displs) - END IF - IF (ALLOCATED(features%route_point_recv_counts)) THEN + IF (ALLOCATED(features%route_point_recv_counts)) & DEALLOCATE (features%route_point_recv_counts) - END IF - IF (ALLOCATED(features%route_point_recv_displs)) THEN + IF (ALLOCATED(features%route_point_recv_displs)) & DEALLOCATE (features%route_point_recv_displs) - END IF - IF (ALLOCATED(features%route_point_send_counts)) THEN + IF (ALLOCATED(features%route_point_send_counts)) & DEALLOCATE (features%route_point_send_counts) - END IF - IF (ALLOCATED(features%route_point_send_displs)) THEN + IF (ALLOCATED(features%route_point_send_displs)) & DEALLOCATE (features%route_point_send_displs) - END IF IF (ALLOCATED(features%route_send_local_rows)) DEALLOCATE (features%route_send_local_rows) IF (ALLOCATED(features%feature_index)) DEALLOCATE (features%feature_index) IF (ALLOCATED(features%local_feature_counts)) DEALLOCATE (features%local_feature_counts) @@ -1636,9 +1618,8 @@ CONTAINS IF (ALLOCATED(features%atomic_grid_weights)) DEALLOCATE (features%atomic_grid_weights) IF (ALLOCATED(features%atomic_grid_sizes)) DEALLOCATE (features%atomic_grid_sizes) IF (ALLOCATED(features%coarse_0_atomic_coords)) DEALLOCATE (features%coarse_0_atomic_coords) - IF (ALLOCATED(features%atomic_grid_size_bound_shape)) THEN + IF (ALLOCATED(features%atomic_grid_size_bound_shape)) & DEALLOCATE (features%atomic_grid_size_bound_shape) - END IF features%chunk_feature_count = 0 features%nflat = 0 features%nflat_local = 0 diff --git a/src/skala_gpw_functional.F b/src/skala_gpw_functional.F index ab0d553178..ea71c9ead5 100644 --- a/src/skala_gpw_functional.F +++ b/src/skala_gpw_functional.F @@ -109,7 +109,7 @@ CONTAINS END FUNCTION xc_section_uses_native_skala_grid ! ************************************************************************************************** -!> \brief Return true if the GAUXC subsection requests a model evaluation. +!> \brief Return true if the GAUXC subsection requests a Skala-style model. !> \param xc_section ... !> \return ... ! ************************************************************************************************** @@ -117,20 +117,16 @@ CONTAINS TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section LOGICAL :: uses_gauxc_model - CHARACTER(len=default_path_length) :: model_key, model_name, xc_key, xc_name + CHARACTER(len=default_path_length) :: model_key, model_name TYPE(section_vals_type), POINTER :: gauxc_section uses_gauxc_model = .FALSE. gauxc_section => get_gauxc_section(xc_section) IF (ASSOCIATED(gauxc_section)) THEN CALL section_vals_val_get(gauxc_section, "MODEL", c_val=model_name) - CALL section_vals_val_get(gauxc_section, "FUNCTIONAL", c_val=xc_name) model_key = ADJUSTL(model_name) - xc_key = ADJUSTL(xc_name) CALL uppercase(model_key) - CALL uppercase(xc_key) - uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & - TRIM(model_key) /= TRIM(xc_key)) + uses_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") END IF END FUNCTION xc_section_uses_gauxc_model @@ -1514,9 +1510,8 @@ CONTAINS CPASSERT(SUM(features%route_point_send_counts) == nroute_points) nroute_grad_per_point = ngrad_per_point - IF (features%uses_collapsed_rks_dynamic) THEN + IF (features%uses_collapsed_rks_dynamic) & nroute_grad_per_point = ncollapsed_grad_per_point - END IF ALLOCATE (send_grad_buffer(MAX(1, nroute_grad_per_point*features%chunk_feature_count)), & recv_grad_buffer(MAX(1, nroute_grad_per_point*nroute_points)), & route_grad_return_send_counts(SIZE(features%route_point_recv_counts)), & diff --git a/src/smeagol_control_types.F b/src/smeagol_control_types.F index 7e63f52054..37cbe5c18a 100644 --- a/src/smeagol_control_types.F +++ b/src/smeagol_control_types.F @@ -58,7 +58,7 @@ MODULE smeagol_control_types REAL(kind=dp) :: to_smeagol_energy_units = 2.0_dp !> number of cell images along i and j cell vectors - INTEGER, DIMENSION(2) :: n_cell_images = [1, 1] + INTEGER, DIMENSION(2) :: n_cell_images = (/1, 1/) !> what lead (bulk transport calculation) INTEGER :: lead_label = smeagol_bulklead_leftright diff --git a/src/smeagol_emtoptions.F b/src/smeagol_emtoptions.F index adb1cc9417..fc1ea616e3 100644 --- a/src/smeagol_emtoptions.F +++ b/src/smeagol_emtoptions.F @@ -179,8 +179,7 @@ MODULE smeagol_emtoptions smeagolglobal_emSTT = torqueflag smeagolglobal_emSTTLin = torquelin - ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, - ! therefore 'EM.TimeReversal' is also enabled. + ! In case of the original SIESTA+SMEAGOL, 'TimeReversal' keyword is enabled by default, therefore 'EM.TimeReversal' is also enabled. ! In case of this CP2K+SMEAGOL interface, the default value of 'timereversal' variable is .FALSE. IF (smeagol_control%aux%timereversal) THEN CALL cp_warn(__LOCATION__, & @@ -329,8 +328,7 @@ MODULE smeagol_emtoptions ! current-induced forces ! The value of 'smeagol_control%emforces' is set in qs_energies(). - ! Calculation of forces is enabled automatically for certain run_types - ! (energy_force, geo_opt, md) and disabled otherwise. + ! Calculation of forces is enabled automatically for certain run_types (energy_force, geo_opt, md) and disabled otherwise. IF (smeagol_control%aux%curr_dist) THEN smeagol_control%emforces = .TRUE. END IF @@ -340,9 +338,8 @@ MODULE smeagol_emtoptions IF (.NOT. smeagol_control%aux%isexplicit_GetRhoSingleLead) smeagol_control%aux%GetRhoSingleLead = GetRhoSingleLeadDefault IF (smeagol_control%aux%MinChannelIndex < 1) smeagol_control%aux%MinChannelIndex = 1 - IF (smeagol_control%aux%MaxChannelIndex < 1) THEN + IF (smeagol_control%aux%MaxChannelIndex < 1) & smeagol_control%aux%MaxChannelIndex = smeagol_control%aux%MinChannelIndex + 4 - END IF IF (smeagolglobal_emSTT .AND. smeagolglobal_emSTTLin .AND. smeagol_control%aux%GetRhoSingleLead /= -3) THEN CALL cp_warn(__LOCATION__, & diff --git a/src/smeagol_interface.F b/src/smeagol_interface.F index eccf01abec..556e5b4e67 100644 --- a/src/smeagol_interface.F +++ b/src/smeagol_interface.F @@ -731,13 +731,11 @@ CONTAINS ! first invocation of the subroutine : initialise md_iter_level and md_first_step variables smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "MD") - IF (smeagol_control%aux%md_iter_level <= 0) THEN + IF (smeagol_control%aux%md_iter_level <= 0) & smeagol_control%aux%md_iter_level = cp_get_iter_level_by_name(logger%iter_info, "GEO_OPT") - END IF - IF (smeagol_control%aux%md_iter_level <= 0) THEN + IF (smeagol_control%aux%md_iter_level <= 0) & smeagol_control%aux%md_iter_level = 0 - END IF ! index of the first GEO_OPT / MD step IF (smeagol_control%aux%md_iter_level > 0) THEN diff --git a/src/smeagol_matrix_utils.F b/src/smeagol_matrix_utils.F index 1bf43236fc..ad3ea6d6d8 100644 --- a/src/smeagol_matrix_utils.F +++ b/src/smeagol_matrix_utils.F @@ -72,8 +72,7 @@ MODULE smeagol_matrix_utils INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_send = 2 INTEGER, PARAMETER, PRIVATE :: nelements_dbcsr_dim2 = nelements_dbcsr_send - ! 128 MiB (to limit memory usage for matrix redistribution) - INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 + INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_bytes = 134217728 ! 128 MiB (to limit memory usage for matrix redistribution) INTEGER(kind=int_8), PARAMETER, PRIVATE :: max_mpi_packet_size_dp = max_mpi_packet_size_bytes/INT(dp_size, kind=int_8) ! a portable way to determine the upper bound for tag value is to call @@ -221,8 +220,7 @@ CONTAINS ! via subroutine arguments, an extra MPI_Allreduce operation is needed each time we call ! replicate_neighbour_list() / get_nnodes_local(). max_ijk_cell_image(3) = -1 - ! bulk-transport calculation expects exactly 3 cell images along transport direction - IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 + IF (.NOT. do_merge) max_ijk_cell_image(3) = 1 ! bulk-transport calculation expects exactly 3 cell images along transport direction ! replicate pair-wise neighbour list. Identical non-zero matrix blocks from cell image along transport direction ! are grouped together if do_merge == .TRUE. @@ -504,10 +502,8 @@ CONTAINS END IF END IF - ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements - ! (should be OK due to SMEAGOL limitation) - ! in principle, it is possible to overcome this limit by using derived datatypes - ! (which will require additional wrapper functions, indeed). + ! point-to-point recv/send can be replaced with alltoallv, if data to distribute per rank is < 2^31 elements (should be OK due to SMEAGOL limitation) + ! in principle, it is possible to overcome this limit by using derived datatypes (which will require additional wrapper functions, indeed). ! ! pre-post non-blocking receive operations IF (n_nonzero_elements_siesta > 0) THEN @@ -689,13 +685,10 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) DEALLOCATE (offset_per_proc, n_packed_elements_per_proc) - ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, - ! local row index, and column index (in this order). - ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, - ! source MPI rank, and column index. + ! non-zero matrix elements in 'recv_buffer' array are grouped by their source MPI rank, local row index, and column index (in this order). + ! Reorder the matrix elements ('reorder_recv_buffer') so they are grouped by their local row index, source MPI rank, and column index. ! (column indices are in the ascending order within each (row index, source MPI rank) block). - ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : - ! local row index, column index + ! The array 'packed_index' allows mapping matrix element between these intermediate order and SIESTA order : local row index, column index IF (n_nonzero_elements_siesta > 0) THEN ALLOCATE (reorder_recv_buffer(n_nonzero_elements_siesta)) ALLOCATE (next_nonzero_element_offset(siesta_struct%nrows)) @@ -1030,8 +1023,7 @@ CONTAINS IF (ALLOCATED(send_buffer)) DEALLOCATE (send_buffer) - ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root - iproc = siesta_struct%gather_root + iproc = siesta_struct%gather_root ! if do_distribute == .FALSE., collect matrix elements from MPI process with rank gather_root IF (n_nonzero_elements_dbcsr > 0) THEN DO inode_proc = 1, nnodes_proc n_image_ind = siesta_struct%n_dbcsr_cell_images_to_merge(inode_proc) @@ -1874,9 +1866,8 @@ CONTAINS ! there is no need to send data to the same MPI process IF (iproc /= mepos) THEN nrequests = nrequests + INT(nelements_per_proc(iproc)/max_nelements_per_packet) - IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) THEN + IF (MOD(nelements_per_proc(iproc), max_nelements_per_packet) > 0) & nrequests = nrequests + 1 - END IF END IF END DO END FUNCTION get_number_of_mpi_sendrecv_requests diff --git a/src/start/cp2k.F b/src/start/cp2k.F index 15857c3c7d..8d26c43ea1 100644 --- a/src/start/cp2k.F +++ b/src/start/cp2k.F @@ -167,9 +167,8 @@ PROGRAM cp2k INTEGER :: veclib_max_threads, ierr CALL get_environment_variable("VECLIB_MAXIMUM_THREADS", env_var, status=ierr) veclib_max_threads = 0 - IF (ierr == 0) THEN + IF (ierr == 0) & READ (env_var, *) veclib_max_threads - END IF IF (ierr == 1 .OR. (ierr == 0 .AND. veclib_max_threads > 1)) THEN CALL cp_warn(__LOCATION__, & "macOS' Accelerate framework has its own threading enabled which may interfere"// & @@ -237,9 +236,8 @@ PROGRAM cp2k DO inp_var_idx = 1, SIZE(initial_variables, 2) ! check whether the variable was already set, in this case, overwrite - IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) THEN + IF (TRIM(initial_variables(1, inp_var_idx)) == arg_att(:var_set_sep - 1)) & EXIT - END IF END DO IF (inp_var_idx > SIZE(initial_variables, 2)) THEN diff --git a/src/start/cp2k_runs.F b/src/start/cp2k_runs.F index c1d18cf537..7287947c5d 100644 --- a/src/start/cp2k_runs.F +++ b/src/start/cp2k_runs.F @@ -314,9 +314,8 @@ CONTAINS method_name_id /= do_nnp .AND. & method_name_id /= do_embed .AND. & method_name_id /= do_fist .AND. & - method_name_id /= do_ipi) THEN + method_name_id /= do_ipi) & CPABORT("Energy/Force run not available for all methods ") - END IF sublogger => cp_get_default_logger() CALL cp_add_iter_level(sublogger%iter_info, "JUST_ENERGY", & @@ -325,9 +324,8 @@ CONTAINS ! loop over molecules to generate a molecular guess ! this procedure is initiated here to avoid passing globenv deep down ! the subroutine stack - IF (do_mol_loop(force_env=force_env)) THEN + IF (do_mol_loop(force_env=force_env)) & CALL loop_over_molecules(globenv, force_env) - END IF SELECT CASE (globenv%run_type_id) CASE (energy_run) @@ -349,9 +347,8 @@ CONTAINS CASE (do_tamc) CALL qs_tamc(force_env, globenv) CASE (real_time_propagation) - IF (method_name_id /= do_qs) THEN + IF (method_name_id /= do_qs) & CPABORT("Real time propagation needs METHOD QS. ") - END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .TRUE. SELECT CASE (dft_control%rtp_control%rtp_method) @@ -363,9 +360,8 @@ CONTAINS CALL rt_prop_setup(force_env) END SELECT CASE (ehrenfest) - IF (method_name_id /= do_qs) THEN + IF (method_name_id /= do_qs) & CPABORT("Ehrenfest dynamics needs METHOD QS ") - END IF CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions = .FALSE. CALL qs_mol_dyn(force_env, globenv) @@ -373,9 +369,8 @@ CONTAINS CALL do_bsse_calculation(force_env, globenv) CASE (linear_response_run) IF (method_name_id /= do_qs .AND. & - method_name_id /= do_qmmm) THEN + method_name_id /= do_qmmm) & CPABORT("Property calculations by Linear Response only within the QS or QMMM program ") - END IF ! The Ground State is needed, it can be read from Restart CALL force_env_calc_energy_force(force_env, calc_force=.FALSE., linres=.TRUE.) CALL linres_calculation(force_env) @@ -805,9 +800,8 @@ CONTAINS ! change to the new working directory CALL m_chdir(TRIM(farming_env%Job(i)%cwd), ierr) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CPABORT("Failed to change dir to: "//TRIM(farming_env%Job(i)%cwd)) - END IF ! generate a fresh call to cp2k_run IF (new_rank == 0) THEN diff --git a/src/start/cp2k_shell.F b/src/start/cp2k_shell.F index 6dd3ad5438..d1071bc108 100644 --- a/src/start/cp2k_shell.F +++ b/src/start/cp2k_shell.F @@ -541,13 +541,13 @@ CONTAINS TYPE(cp2k_shell_type) :: shell CHARACTER(LEN=*), INTENT(IN) :: arg1 - INTEGER :: ierr, n_atom + INTEGER :: ierr, iostat, n_atom IF (.NOT. parse_env_id(arg1, shell)) RETURN CALL get_natom(shell%env_id, n_atom, ierr) IF (.NOT. my_assert(ierr == 0, 'get_natom failed', shell)) RETURN IF (shell%iw > 0) THEN - WRITE (shell%iw, '(i10)') n_atom + WRITE (shell%iw, '(i10)', iostat=iostat) n_atom CALL m_flush(shell%iw) END IF END SUBROUTINE get_natom_command diff --git a/src/start/libcp2k.F b/src/start/libcp2k.F index 4ac0f6b73b..85f39e3c5a 100755 --- a/src/start/libcp2k.F +++ b/src/start/libcp2k.F @@ -515,9 +515,8 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=nmo) END BLOCK try @@ -556,15 +555,13 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF CALL get_mo_set(active_space_env%mos_active(1), nmo=norb) - IF (buf_len < norb*norb) THEN + IF (buf_len < norb*norb) & EXIT try - END IF DO i = 0, norb - 1 DO j = 0, norb - 1 @@ -605,9 +602,8 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF nze_count = INT(active_space_env%eri%eri(1)%csr_mat%nze_total, KIND(nze_count)) END BLOCK try @@ -650,14 +646,12 @@ CONTAINS try: BLOCK CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env) - IF (.NOT. ASSOCIATED(active_space_env)) THEN + IF (.NOT. ASSOCIATED(active_space_env)) & EXIT try - END IF ASSOCIATE (nze => active_space_env%eri%eri(1)%csr_mat%nze_total) - IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) THEN + IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) & EXIT try - END IF CALL active_space_env%eri%eri_foreach(1, active_space_env%active_orbitals, eri2array(buf_coords, buf_values)) diff --git a/src/stm_images.F b/src/stm_images.F index a0f6411fcc..d4e1ecb285 100644 --- a/src/stm_images.F +++ b/src/stm_images.F @@ -309,9 +309,8 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) THEN + IF ((output_unit > 0) .AND. evals(ispin)%array(1) > efermi + stm_biases(ibias)) & WRITE (output_unit, '(T4,A)') "Warning: EFermi+bias below lowest computed occupied MO" - END IF ELSE nmo = SIZE(evals(ispin)%array) DO imo = 1, nmo @@ -321,9 +320,8 @@ CONTAINS nstates(ispin) = nstates(ispin) + 1 END IF END DO - IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) THEN + IF ((output_unit > 0) .AND. evals(ispin)%array(nmo) < efermi + stm_biases(ibias)) & WRITE (output_unit, '(T4,A)') "Warning: E-Fermi+bias above highest computed unoccupied MO" - END IF END IF istates = istates + nstates(ispin) END DO diff --git a/src/subsys/colvar_types.F b/src/subsys/colvar_types.F index 1e390bc3ec..b7c28982d7 100644 --- a/src/subsys/colvar_types.F +++ b/src/subsys/colvar_types.F @@ -501,7 +501,7 @@ CONTAINS SUBROUTINE colvar_setup(colvar) TYPE(colvar_type), INTENT(INOUT) :: colvar - INTEGER :: i, idum, iend, ii, istart, j, np + INTEGER :: i, idum, iend, ii, istart, j, np, stat INTEGER, DIMENSION(:), POINTER :: list SELECT CASE (colvar%type_id) @@ -660,12 +660,11 @@ CONTAINS IF (colvar%plane_plane_angle_param%plane1%type_of_def == plane_def_atoms) np = np + 3 IF (colvar%plane_plane_angle_param%plane2%type_of_def == plane_def_atoms) np = np + 3 ! if np is equal to zero this means that this is not a COLLECTIVE variable.. - IF (np == 0) THEN + IF (np == 0) & CALL cp_abort(__LOCATION__, & "PLANE_PLANE_ANGLE Colvar defined using two normal vectors! This is "// & "not a COLLECTIVE VARIABLE! One of the two planes must be defined "// & "using atomic positions.") - END IF ! Number of real atoms involved in the colvar colvar%n_atom_s = 0 @@ -851,8 +850,8 @@ CONTAINS i = colvar%xyz_outerdiag_param%i_atoms(2) list(2) = i CASE (u_colvar_id) - np = 1 - ALLOCATE (list(np)) + np = 1; ALLOCATE (list(np), stat=stat) + CPASSERT(stat == 0) colvar%n_atom_s = np; list(1) = 1 CASE (Wc_colvar_id) np = 3 @@ -1035,9 +1034,8 @@ CONTAINS idum = idum + 1 i = i_oxygens(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) THEN + IF (ANY(i_hydrogens == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS and HYDROGENS list") - END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1048,12 +1046,10 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens) THEN + IF (i <= n_oxygens) & CPABORT("atoms doubled in OXYGENS list") - END IF - IF (i > n_oxygens) THEN + IF (i > n_oxygens) & CPABORT("atoms doubled in HYDROGENS list") - END IF END IF END DO END DO @@ -1117,20 +1113,17 @@ CONTAINS idum = idum + 1 i = i_oxygens_water(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) THEN + IF (ANY(i_hydrogens == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and HYDROGENS list") - END IF - IF (ANY(i_oxygens_acid == i)) THEN + IF (ANY(i_oxygens_acid == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS_WATER and OXYGENS_ACID list") - END IF END DO DO ii = 1, n_oxygens_acid idum = idum + 1 i = i_oxygens_acid(ii) list(idum) = i - IF (ANY(i_hydrogens == i)) THEN + IF (ANY(i_hydrogens == i)) & CPABORT("COLVAR: atoms doubled in OXYGENS_ACID and HYDROGENS list") - END IF END DO DO ii = 1, n_hydrogens idum = idum + 1 @@ -1141,15 +1134,12 @@ CONTAINS DO i = 1, np DO ii = i + 1, np IF (list(i) == list(ii)) THEN - IF (i <= n_oxygens_water) THEN + IF (i <= n_oxygens_water) & CPABORT("atoms doubled in OXYGENS_WATER list") - END IF - IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) THEN + IF (i > n_oxygens_water .AND. i <= n_oxygens_water + n_oxygens_acid) & CPABORT("atoms doubled in OXYGENS_ACID list") - END IF - IF (i > n_oxygens_water + n_oxygens_acid) THEN + IF (i > n_oxygens_water + n_oxygens_acid) & CPABORT("atoms doubled in HYDROGENS list") - END IF END IF END DO END DO @@ -1364,7 +1354,7 @@ CONTAINS TYPE(colvar_type), INTENT(IN) :: colvar_in INTEGER, INTENT(IN), OPTIONAL :: i_atom_offset - INTEGER :: i, my_offset, ndim, ndim2 + INTEGER :: i, my_offset, ndim, ndim2, stat my_offset = 0 IF (PRESENT(i_atom_offset)) my_offset = i_atom_offset @@ -1417,7 +1407,7 @@ CONTAINS ndim = SIZE(colvar_in%coord_param%c_kinds_to_b) ALLOCATE (colvar_out%coord_param%c_kinds_to_b(ndim)) colvar_out%coord_param%c_kinds_to_b = colvar_in%coord_param%c_kinds_to_b - ELSE IF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN + ELSEIF (ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN ! INDEX ndim = SIZE(colvar_in%coord_param%i_at_to_b) ALLOCATE (colvar_out%coord_param%i_at_to_b(ndim)) @@ -1625,11 +1615,11 @@ CONTAINS colvar_out%reaction_path_param%align_frames = colvar_in%reaction_path_param%align_frames colvar_out%reaction_path_param%subset = colvar_in%reaction_path_param%subset ndim = SIZE(colvar_in%reaction_path_param%i_rmsd) - ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim)) + ALLOCATE (colvar_out%reaction_path_param%i_rmsd(ndim), stat=stat) colvar_out%reaction_path_param%i_rmsd = colvar_in%reaction_path_param%i_rmsd ndim = SIZE(colvar_in%reaction_path_param%r_ref, 1) ndim2 = SIZE(colvar_in%reaction_path_param%r_ref, 2) - ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2)) + ALLOCATE (colvar_out%reaction_path_param%r_ref(ndim, ndim2), stat=stat) colvar_out%reaction_path_param%r_ref = colvar_in%reaction_path_param%r_ref ELSE ndim = SIZE(colvar_in%reaction_path_param%colvar_p) @@ -1852,9 +1842,8 @@ CONTAINS IF (ASSOCIATED(colvar_p)) THEN DO i = 1, SIZE(colvar_p) - IF (ASSOCIATED(colvar_p(i)%colvar)) THEN + IF (ASSOCIATED(colvar_p(i)%colvar)) & CALL colvar_release(colvar_p(i)%colvar) - END IF END DO DEALLOCATE (colvar_p) END IF diff --git a/src/subsys/external_potential_types.F b/src/subsys/external_potential_types.F index 26bc3d047f..dbdf0c557a 100644 --- a/src/subsys/external_potential_types.F +++ b/src/subsys/external_potential_types.F @@ -587,13 +587,11 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) name = potential%name - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & alpha_core_charge = potential%alpha_core_charge - END IF IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & core_charge_radius = potential%core_charge_radius - END IF IF (PRESENT(z)) z = potential%z IF (PRESENT(zeff)) zeff = potential%zeff IF (PRESENT(zeff_correction)) zeff_correction = potential%zeff_correction @@ -765,15 +763,13 @@ CONTAINS IF (PRESENT(name)) name = potential%name IF (PRESENT(aliases)) aliases = potential%aliases - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & alpha_core_charge = potential%alpha_core_charge - END IF IF (PRESENT(alpha_ppl)) alpha_ppl = potential%alpha_ppl IF (PRESENT(ccore_charge)) ccore_charge = potential%ccore_charge IF (PRESENT(cerf_ppl)) cerf_ppl = potential%cerf_ppl - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & core_charge_radius = potential%core_charge_radius - END IF IF (PRESENT(ppl_radius)) ppl_radius = potential%ppl_radius IF (PRESENT(ppnl_radius)) ppnl_radius = potential%ppnl_radius IF (PRESENT(soc_present)) soc_present = potential%soc @@ -1375,10 +1371,9 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1416,10 +1411,9 @@ CONTAINS IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r ELSE @@ -1563,10 +1557,9 @@ CONTAINS ! Read ngau and npol IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) ngau, npol CALL remove_word(line_att) @@ -1586,10 +1579,9 @@ CONTAINS DO igau = 1, ngau IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error reading the Potential from input file!") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) alpha(igau), (cval(igau, ipol), ipol=1, npol) ELSE @@ -1783,10 +1775,9 @@ CONTAINS CALL reallocate(elec_conf, 0, l) IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) elec_conf(l) CALL remove_word(line_att) @@ -1827,10 +1818,9 @@ CONTAINS ! distribution and calculate the corresponding coefficient IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2167,10 +2157,9 @@ CONTAINS DO l = 0, lppnl IF (read_from_input) THEN is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) r CALL remove_word(line_att) @@ -2215,15 +2204,13 @@ CONTAINS END IF ELSE IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) THEN + IF (LEN_TRIM(line_att) /= 0) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) hprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2271,15 +2258,13 @@ CONTAINS ! Read non-local parameters for spin-orbit coupling DO i = 1, nprj_ppnl IF (read_from_input) THEN - IF (LEN_TRIM(line_att) /= 0) THEN + IF (LEN_TRIM(line_att) /= 0) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF is_ok = cp_sll_val_next(list, val) - IF (.NOT. is_ok) THEN + IF (.NOT. is_ok) & CALL cp_abort(__LOCATION__, & "Error while reading GTH potential from input file") - END IF CALL val_get(val, c_val=line_att) READ (line_att, *) kprj_ppnl(i, i, l) CALL remove_word(line_att) @@ -2458,13 +2443,11 @@ CONTAINS INTEGER, DIMENSION(:), OPTIONAL, POINTER :: elec_conf IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & potential%alpha_core_charge = alpha_core_charge - END IF IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & potential%core_charge_radius = core_charge_radius - END IF IF (PRESENT(z)) potential%z = z IF (PRESENT(zeff)) potential%zeff = zeff IF (PRESENT(zeff_correction)) potential%zeff_correction = zeff_correction @@ -2590,15 +2573,13 @@ CONTAINS POINTER :: hprj_ppnl, kprj_ppnl IF (PRESENT(name)) potential%name = name - IF (PRESENT(alpha_core_charge)) THEN + IF (PRESENT(alpha_core_charge)) & potential%alpha_core_charge = alpha_core_charge - END IF IF (PRESENT(alpha_ppl)) potential%alpha_ppl = alpha_ppl IF (PRESENT(ccore_charge)) potential%ccore_charge = ccore_charge IF (PRESENT(cerf_ppl)) potential%cerf_ppl = cerf_ppl - IF (PRESENT(core_charge_radius)) THEN + IF (PRESENT(core_charge_radius)) & potential%core_charge_radius = core_charge_radius - END IF IF (PRESENT(ppl_radius)) potential%ppl_radius = ppl_radius IF (PRESENT(ppnl_radius)) potential%ppnl_radius = ppnl_radius IF (PRESENT(lppnl)) potential%lppnl = lppnl diff --git a/src/subsys/molecule_kind_types.F b/src/subsys/molecule_kind_types.F index 9943a66164..232123e92e 100644 --- a/src/subsys/molecule_kind_types.F +++ b/src/subsys/molecule_kind_types.F @@ -365,9 +365,8 @@ CONTAINS END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set)) THEN DO i = 1, SIZE(molecule_kind_set(imolecule_kind)%bend_kind_set) - IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) THEN + IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs)) & DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set(i)%legendre%coeffs) - END IF END DO DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set) END IF @@ -935,30 +934,24 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T9,A,I6,/,T9,A,(T30,5I10))") & "Number of molecules: ", nmolecule, "Molecule list:", & (molecule_kind%molecule_list(imolecule), imolecule=1, nmolecule) - IF (molecule_kind%nbond > 0) THEN + IF (molecule_kind%nbond > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bonds: ", molecule_kind%nbond - END IF - IF (molecule_kind%nbend > 0) THEN + "Number of bonds: ", molecule_kind%nbond + IF (molecule_kind%nbend > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of bends: ", molecule_kind%nbend - END IF - IF (molecule_kind%nub > 0) THEN + "Number of bends: ", molecule_kind%nbend + IF (molecule_kind%nub > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of Urey-Bradley:", molecule_kind%nub - END IF - IF (molecule_kind%ntorsion > 0) THEN + "Number of Urey-Bradley:", molecule_kind%nub + IF (molecule_kind%ntorsion > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of torsions: ", molecule_kind%ntorsion - END IF - IF (molecule_kind%nimpr > 0) THEN + "Number of torsions: ", molecule_kind%ntorsion + IF (molecule_kind%nimpr > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of improper: ", molecule_kind%nimpr - END IF - IF (molecule_kind%nopbend > 0) THEN + "Number of improper: ", molecule_kind%nimpr + IF (molecule_kind%nopbend > 0) & WRITE (UNIT=output_unit, FMT="(1X,A30,I6)") & - "Number of out opbends: ", molecule_kind%nopbend - END IF + "Number of out opbends: ", molecule_kind%nopbend END IF END IF END SUBROUTINE write_molecule_kind diff --git a/src/subsys/molecule_types.F b/src/subsys/molecule_types.F index 41d097f00c..f300b5d188 100644 --- a/src/subsys/molecule_types.F +++ b/src/subsys/molecule_types.F @@ -212,13 +212,11 @@ CONTAINS DEALLOCATE (gci%colv_list) END IF - IF (ASSOCIATED(gci%g3x3_list)) THEN + IF (ASSOCIATED(gci%g3x3_list)) & DEALLOCATE (gci%g3x3_list) - END IF - IF (ASSOCIATED(gci%g4x6_list)) THEN + IF (ASSOCIATED(gci%g4x6_list)) & DEALLOCATE (gci%g4x6_list) - END IF ! Local information IF (ASSOCIATED(gci%lcolv)) THEN @@ -229,17 +227,14 @@ CONTAINS DEALLOCATE (gci%lcolv) END IF - IF (ASSOCIATED(gci%lg3x3)) THEN + IF (ASSOCIATED(gci%lg3x3)) & DEALLOCATE (gci%lg3x3) - END IF - IF (ASSOCIATED(gci%lg4x6)) THEN + IF (ASSOCIATED(gci%lg4x6)) & DEALLOCATE (gci%lg4x6) - END IF - IF (ASSOCIATED(gci%fixd_list)) THEN + IF (ASSOCIATED(gci%fixd_list)) & DEALLOCATE (gci%fixd_list) - END IF DEALLOCATE (gci) END IF diff --git a/src/surface_dipole.F b/src/surface_dipole.F index ef35421cad..a4271394e8 100644 --- a/src/surface_dipole.F +++ b/src/surface_dipole.F @@ -166,7 +166,7 @@ CONTAINS rhoavsurf(i) = accurate_sum(wf_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), i)) END DO - ELSE IF (idir_surfdip == 2) THEN + ELSEIF (idir_surfdip == 2) THEN isurf = 3 jsurf = 1 @@ -258,7 +258,7 @@ CONTAINS IF (idir_surfdip == 3) THEN vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) = & vdip_r%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), irho) + vdip - ELSE IF (idir_surfdip == 2) THEN + ELSEIF (idir_surfdip == 2) THEN IF (irho >= bo(1, 2) .AND. irho <= bo(2, 2)) THEN vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) = & vdip_r%array(bo(1, 1):bo(2, 1), irho, bo(1, 3):bo(2, 3)) + vdip diff --git a/src/swarm/glbopt_history.F b/src/swarm/glbopt_history.F index a217a22a75..81cc126cca 100644 --- a/src/swarm/glbopt_history.F +++ b/src/swarm/glbopt_history.F @@ -213,9 +213,8 @@ CONTAINS ALLOCATE (history%entries(k)%p) history%entries(k)%p = fingerprint - IF (PRESENT(id)) THEN + IF (PRESENT(id)) & history%entries(k)%id = id - END IF history%length = history%length + 1 IF (debug) THEN @@ -223,9 +222,8 @@ CONTAINS DO k = 1, history%length !WRITE(*,*) "history: ", k, "Epot",history%entries(k)%p%Epot IF (k > 1) THEN - IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) THEN + IF (history%entries(k - 1)%p%Epot > history%entries(k)%p%Epot) & CPABORT("history_add: history in wrong order") - END IF END IF END DO END IF @@ -376,9 +374,8 @@ CONTAINS INTEGER :: i DO i = 1, history%length - IF (ASSOCIATED(history%entries(i)%p)) THEN + IF (ASSOCIATED(history%entries(i)%p)) & DEALLOCATE (history%entries(i)%p) - END IF END DO DEALLOCATE (history%entries) diff --git a/src/swarm/glbopt_mincrawl.F b/src/swarm/glbopt_mincrawl.F index bbb9eb7133..ce6938ec53 100644 --- a/src/swarm/glbopt_mincrawl.F +++ b/src/swarm/glbopt_mincrawl.F @@ -182,9 +182,8 @@ CONTAINS RETURN END IF - IF (TRIM(status) == "ok") THEN + IF (TRIM(status) == "ok") & CALL mincrawl_register_minima(this, report) - END IF IF (.FALSE.) CALL print_tempdist(best_minima) diff --git a/src/swarm/glbopt_minhop.F b/src/swarm/glbopt_minhop.F index 53c4202532..9bde51b2d7 100644 --- a/src/swarm/glbopt_minhop.F +++ b/src/swarm/glbopt_minhop.F @@ -217,9 +217,8 @@ CONTAINS ! new locally lowest IF (this%iw > 0) WRITE (this%iw, '(A)') " MINHOP| New locally lowest" this%worker_state(wid)%Epot_hop = report_Epot - IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) THEN + IF (.NOT. ALLOCATED(this%worker_state(wid)%pos_hop)) & ALLOCATE (this%worker_state(wid)%pos_hop(SIZE(report_positions))) - END IF this%worker_state(wid)%pos_hop(:) = report_positions this%worker_state(wid)%fp_hop = report_fp END IF diff --git a/src/swarm/glbopt_worker.F b/src/swarm/glbopt_worker.F index bcb2f8134a..78e14d9927 100644 --- a/src/swarm/glbopt_worker.F +++ b/src/swarm/glbopt_worker.F @@ -232,9 +232,8 @@ CONTAINS END DO CALL unpack_subsys_particles(worker%subsys, r=positions) - IF (n_fragments > 0 .AND. worker%iw > 0) THEN + IF (n_fragments > 0 .AND. worker%iw > 0) & WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Ran fix_fragmentation times:", n_fragments - END IF ! setup geometry optimization IF (worker%iw > 0) WRITE (worker%iw, '(A,13X,I10)') " GLBOPT| Starting local optimisation at trajectory frame ", iframe @@ -293,10 +292,10 @@ CONTAINS DO WHILE (stack_size > 0) i = stack(stack_size); stack_size = stack_size - 1 !pop DO j = 1, n_particles - IF (NORM2(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected + IF (norm(diff(positions, i, j)) < 1.25*bondlength) THEN ! they are close = they are connected IF (.NOT. marked(j)) THEN marked(j) = .TRUE. - stack(stack_size + 1) = j; stack_size = stack_size + 1 !push + stack(stack_size + 1) = j; stack_size = stack_size + 1; !push END IF END IF END DO @@ -315,7 +314,7 @@ CONTAINS IF (marked(i)) CYCLE DO j = 1, n_particles IF (.NOT. marked(j)) CYCLE - d = NORM2(diff(positions, i, j)) + d = norm(diff(positions, i, j)) IF (d < min_dist) THEN min_dist = d cluster_edge = i @@ -325,7 +324,7 @@ CONTAINS END DO dr = diff(positions, cluster_edge, fragment_edge) - s = 1.0 - bondlength/NORM2(dr) + s = 1.0 - bondlength/norm(dr) DO i = 1, n_particles IF (marked(i)) CYCLE positions(3*i - 2:3*i) = positions(3*i - 2:3*i) - s*dr @@ -349,6 +348,19 @@ CONTAINS dr = positions(3*i - 2:3*i) - positions(3*j - 2:3*j) END FUNCTION diff +! ************************************************************************************************** +!> \brief Helper routine for fix_fragmentation, calculates vector norm +!> \param vec ... +!> \return ... +!> \author Ole Schuett +! ************************************************************************************************** + PURE FUNCTION norm(vec) RESULT(res) + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec + REAL(KIND=dp) :: res + + res = SQRT(DOT_PRODUCT(vec, vec)) + END FUNCTION norm + ! ************************************************************************************************** !> \brief Finalizes worker for global optimization !> \param worker ... diff --git a/src/swarm/swarm_master.F b/src/swarm/swarm_master.F index bd627a6d5d..703686c352 100644 --- a/src/swarm/swarm_master.F +++ b/src/swarm/swarm_master.F @@ -261,9 +261,8 @@ CONTAINS IF (.NOT. master%should_stop) THEN CALL external_control(master%should_stop, "SWARM", master%globenv) - IF (master%should_stop .AND. master%iw > 0) THEN + IF (master%should_stop .AND. master%iw > 0) & WRITE (master%iw, *) " SWARM| Received stop from external_control. Quitting." - END IF END IF !IF(unit > 0) & diff --git a/src/swarm/swarm_message.F b/src/swarm/swarm_message.F index 79bc07e666..96418c033a 100644 --- a/src/swarm/swarm_message.F +++ b/src/swarm/swarm_message.F @@ -866,9 +866,8 @@ CONTAINS TYPE(message_entry_type), POINTER :: new_entry - IF (swarm_message_haskey(msg, key)) THEN + IF (swarm_message_haskey(msg, key)) & CPABORT("swarm_message_add_${label}$: key already exists: "//TRIM(key)) - END IF ALLOCATE (new_entry) new_entry%key = key @@ -921,9 +920,8 @@ CONTAINS curr_entry => msg%root DO WHILE (ASSOCIATED(curr_entry)) IF (TRIM(curr_entry%key) == TRIM(key)) THEN - IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) THEN + IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) & CPABORT("swarm_message_get_${label}$: value not associated key: "//TRIM(key)) - END IF #:if label.startswith("1d_") ALLOCATE (value(SIZE(curr_entry%value_${label}$))) #:endif diff --git a/src/swarm/swarm_mpi.F b/src/swarm/swarm_mpi.F index db985c32f6..f1f4842ffe 100644 --- a/src/swarm/swarm_mpi.F +++ b/src/swarm/swarm_mpi.F @@ -133,9 +133,8 @@ CONTAINS !WRITE (*,*) "this is worker ", worker_id, swarm_mpi%worker%mepos, swarm_mpi%worker%num_pe ! collect world-ranks of each worker groups rank-0 node - IF (swarm_mpi%worker%mepos == 0) THEN + IF (swarm_mpi%worker%mepos == 0) & swarm_mpi%wid2group(worker_id) = swarm_mpi%world%mepos - END IF END IF @@ -163,16 +162,14 @@ CONTAINS logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr swarm_mpi%master_output_path = output_unit2path(output_unit) - IF (output_unit /= default_output_unit) THEN + IF (output_unit /= default_output_unit) & CLOSE (output_unit) - END IF END IF CALL swarm_mpi%world%bcast(swarm_mpi%master_output_path) - IF (ASSOCIATED(swarm_mpi%master)) THEN + IF (ASSOCIATED(swarm_mpi%master)) & CALL error_add_new_logger(swarm_mpi%master, swarm_mpi%master_output_path) - END IF END SUBROUTINE logger_init_master ! ************************************************************************************************** @@ -186,9 +183,8 @@ CONTAINS CHARACTER(LEN=default_path_length) :: output_path output_path = "__STD_OUT__" - IF (output_unit /= default_output_unit) THEN + IF (output_unit /= default_output_unit) & INQUIRE (unit=output_unit, name=output_path) - END IF END FUNCTION output_unit2path ! ************************************************************************************************** @@ -249,10 +245,9 @@ CONTAINS IF (para_env%is_source()) THEN ! open output_unit according to output_path output_unit = default_output_unit - IF (output_path /= "__STD_OUT__") THEN + IF (output_path /= "__STD_OUT__") & CALL open_file(file_name=output_path, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", unit_number=output_unit) - END IF END IF old_logger => cp_get_default_logger() @@ -299,9 +294,8 @@ CONTAINS NULLIFY (logger, old_logger) logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr - IF (output_unit > 0 .AND. output_unit /= default_output_unit) THEN + IF (output_unit > 0 .AND. output_unit /= default_output_unit) & CALL close_file(output_unit) - END IF CALL cp_rm_default_logger() !pops the top-most logger old_logger => cp_get_default_logger() diff --git a/src/swarm/swarm_worker.F b/src/swarm/swarm_worker.F index 13c8f698e8..2b51172354 100644 --- a/src/swarm/swarm_worker.F +++ b/src/swarm/swarm_worker.F @@ -123,9 +123,8 @@ CONTAINS END SELECT END IF - IF (.NOT. swarm_message_haskey(report, "status")) THEN + IF (.NOT. swarm_message_haskey(report, "status")) & CALL swarm_message_add(report, "status", "ok") - END IF END SUBROUTINE swarm_worker_execute diff --git a/src/task_list_methods.F b/src/task_list_methods.F index 5b467db21c..f7983f47a6 100644 --- a/src/task_list_methods.F +++ b/src/task_list_methods.F @@ -1682,7 +1682,8 @@ CONTAINS DO i = 1, desc%group_size ! At the moment we can only offload replicated tasks - IF (load_imbalance(i) > 0) load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) + IF (load_imbalance(i) > 0) & + load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) END DO ! simplest algorithm I can think of of is that the processor with the most @@ -1934,9 +1935,8 @@ CONTAINS DO igrid_level = 1, SIZE(rs_descs) IF (rs_descs(igrid_level)%rs_desc%distributed) THEN - IF (.NOT. skip_load_balance_distributed) THEN + IF (.NOT. skip_load_balance_distributed) & CALL load_balance_distributed(tasks, ntasks, rs_descs, igrid_level, natoms) - END IF CALL get_current_loads(loads(:, igrid_level), rs_descs, igrid_level, ntasks, & tasks, use_reordered_ranks=.FALSE.) @@ -1958,6 +1958,10 @@ CONTAINS END IF END DO + !IF (desc%my_pos==0) THEN + ! WRITE(*,*) "Total replicated load is ",replicated_load + !END IF + ! Now we adjust the rank ordering based on the current loads ! we leave the first distributed level and all the replicated levels in the default order IF (reorder_rs_grid_ranks) THEN @@ -2018,6 +2022,21 @@ CONTAINS ! Now we use the replicated tasks to balance out the rest of the load CALL load_balance_replicated(rs_descs, ntasks, tasks) + !total_loads = 0 + !DO igrid_level=1,SIZE(rs_descs) + ! CALL get_current_loads(loads(:,igrid_level), rs_descs, igrid_level, ntasks, & + ! tasks, use_reordered_ranks=.TRUE.) + ! total_loads = total_loads + loads(:, igrid_level) + !END DO + + !IF (desc%my_pos==0) THEN + ! WRITE(*,*) "" + ! WRITE(*,*) "At the end of the load balancing procedure" + ! WRITE(*,*) "Maximum load:",MAXVAL(total_loads) + ! WRITE(*,*) "Average load:",SUM(total_loads)/SIZE(total_loads) + ! WRITE(*,*) "Minimum load:",MINVAL(total_loads) + !ENDIF + ! given a list of tasks, this will do the needed reshuffle so that all tasks will be local CALL create_local_tasks(rs_descs, ntasks, tasks, ntasks_recv, tasks_recv) @@ -2027,6 +2046,13 @@ CONTAINS ! CALL get_atom_pair(atom_pair_send, tasks, ntasks=ntasks, send=.TRUE., symmetric=symmetric, rs_descs=rs_descs) + ! natom_send=SIZE(atom_pair_send) + ! CALL desc%group%sum(natom_send) + ! IF (desc%my_pos==0) THEN + ! WRITE(*,*) "" + ! WRITE(*,*) "Total number of atomic blocks to be send:",natom_send + ! ENDIF + CALL get_atom_pair(atom_pair_recv, tasks_recv, ntasks=ntasks_recv, send=.FALSE., symmetric=symmetric, rs_descs=rs_descs) ! cleanup, at this point we don't need the original tasks anymore @@ -2833,24 +2859,18 @@ CONTAINS tasks(itask)%subpatch_pattern = 0 ! encode the domain size for this task ! if the bit is set, we need to add the border in that direction - IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) THEN + IF (ix == lb_coord(1) .AND. .NOT. dir_periodic(1)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 0) - END IF - IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) THEN + IF (ix == ub_coord(1) .AND. .NOT. dir_periodic(1)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 1) - END IF - IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) THEN + IF (iy == lb_coord(2) .AND. .NOT. dir_periodic(2)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 2) - END IF - IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) THEN + IF (iy == ub_coord(2) .AND. .NOT. dir_periodic(2)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 3) - END IF - IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) THEN + IF (iz == lb_coord(3) .AND. .NOT. dir_periodic(3)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 4) - END IF - IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) THEN + IF (iz == ub_coord(3) .AND. .NOT. dir_periodic(3)) & tasks(itask)%subpatch_pattern = IBSET(tasks(itask)%subpatch_pattern, 5) - END IF itask = itask + 1 END DO END DO diff --git a/src/tblite_interface.F b/src/tblite_interface.F index fe2be3e8d6..c15de30544 100644 --- a/src/tblite_interface.F +++ b/src/tblite_interface.F @@ -180,9 +180,8 @@ CONTAINS nspin = SIZE(matrix_p, 1) nimg = SIZE(matrix_p, 2) IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN - IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) THEN + IF (SIZE(tb%rho_ao_kp_ref, 1) /= nspin .OR. SIZE(tb%rho_ao_kp_ref, 2) /= nimg) & CALL dbcsr_deallocate_matrix_set(tb%rho_ao_kp_ref) - END IF END IF IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN CALL dbcsr_allocate_matrix_set(tb%rho_ao_kp_ref, nspin, nimg) @@ -338,9 +337,8 @@ CONTAINS info = tb%calc%variable_info() IF (info%charge > shell_resolved) CPABORT("tblite: no support for orbital resolved charge") IF (info%dipole > atom_resolved) CPABORT("tblite: no support for shell resolved dipole moment") - IF (info%quadrupole > atom_resolved) THEN + IF (info%quadrupole > atom_resolved) & CPABORT("tblite: no support shell resolved quadrupole moment") - END IF CALL new_wavefunction(tb%wfn, tb%mol%nat, tb%calc%bas%nsh, tb%calc%bas%nao, nSpin, 0.0_dp) CALL get_occupation(tb%mol, tb%calc%bas, tb%calc%h0, tb%wfn%nocc, tb%wfn%n0at, tb%wfn%n0sh) @@ -465,9 +463,8 @@ CONTAINS IF (omega0 <= 0.0_dp) CPABORT("tblite SCC mixer OMEGA0 must be positive") IF (min_weight <= 0.0_dp) CPABORT("tblite SCC mixer MIN_WEIGHT must be positive") IF (max_weight <= 0.0_dp) CPABORT("tblite SCC mixer MAX_WEIGHT must be positive") - IF (max_weight < min_weight) THEN + IF (max_weight < min_weight) & CPABORT("tblite SCC mixer MAX_WEIGHT must not be smaller than MIN_WEIGHT") - END IF IF (weight_factor <= 0.0_dp) CPABORT("tblite SCC mixer WEIGHT_FACTOR must be positive") SELECT CASE (solver) CASE (tblite_solver_gvd, tblite_solver_gvr) @@ -1473,9 +1470,8 @@ CONTAINS END IF !compute multipole moments for gfn2 - IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) THEN + IF (dft_control%qs_control%xtb_control%tblite_method == gfn2xtb) & CALL tb_get_multipole(qs_env, tb) - END IF ! output overlap information NULLIFY (logger) @@ -1586,7 +1582,7 @@ CONTAINS CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_GRADIENT", debug_value, STATUS=debug_status) IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_gradient CALL GET_ENVIRONMENT_VARIABLE("CP2K_TBLITE_DEBUG_SKIP_SCF_DISPERSION_POTENTIAL", debug_value, STATUS=debug_status) - IF (debug_status == 0) READ (debug_value, *) skip_scf_dispersion_potential + IF (debug_status == 0) READ (debug_value, *, IOSTAT=debug_status) skip_scf_dispersion_potential #endif IF (dft_control%qs_control%do_ls_scf .OR. scf_control%use_ot) THEN use_native_mixer = .FALSE. @@ -1634,10 +1630,9 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSE IF (calculate_forces .AND. nspin > 1) THEN - IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) THEN + ELSEIF (calculate_forces .AND. nspin > 1) THEN + IF (.NOT. ASSOCIATED(tb%rho_ao_kp_ref)) & CPABORT("Missing converged tblite density for UKS/LSD forces") - END IF matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -1928,7 +1923,7 @@ CONTAINS ! LS_SCF and OT optimize the electronic variables directly. Use the ! current shell/multipole response from that density without an ! extra SCC variable mixing step. - ELSE IF (nspin > 1) THEN + ELSEIF (nspin > 1) THEN n_mix_cols = nspin*max_shell IF (do_dipole) n_mix_cols = n_mix_cols + nspin*dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + nspin*quad_n @@ -1992,7 +1987,7 @@ CONTAINS skip_charge_mixing = use_no_mixer IF (skip_charge_mixing) THEN ! - ELSE IF (do_combined_mixing) THEN + ELSEIF (do_combined_mixing) THEN n_mix_cols = max_shell IF (do_dipole) n_mix_cols = n_mix_cols + dip_n IF (do_quadrupole) n_mix_cols = n_mix_cols + quad_n @@ -2123,12 +2118,10 @@ CONTAINS CALL tb%calc%coulomb%get_energy(tb%mol, tb%cache, tb%wfn, tb%e_es) END IF IF (ALLOCATED(tb%calc%dispersion)) THEN - IF (.NOT. skip_scf_dispersion_potential) THEN + IF (.NOT. skip_scf_dispersion_potential) & CALL tb%calc%dispersion%get_potential(tb%mol, tb%dcache, tb%wfn, tb%pot) - END IF - IF (.NOT. skip_scf_dispersion_energy) THEN + IF (.NOT. skip_scf_dispersion_energy) & CALL tb%calc%dispersion%get_energy(tb%mol, tb%dcache, tb%wfn, tb%e_scd) - END IF END IF IF (ALLOCATED(tb%calc%interactions)) THEN CALL tb%calc%interactions%get_potential(tb%mol, tb%icache, tb%wfn, tb%pot) @@ -3491,9 +3484,8 @@ CONTAINS kpoint_coordinate = REAL(2*ikp_axis - nkp_grid(i) - 1, KIND=dp)/ & REAL(2*nkp_grid(i), KIND=dp) + kp_shift(i) END IF - IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) THEN + IF (ABS(kpoint_coordinate - ANINT(kpoint_coordinate)) < 1.0e-12_dp) & mesh_has_gamma(i) = .TRUE. - END IF END DO END DO has_multipole_response = ASSOCIATED(tb%dipbra) .OR. ASSOCIATED(tb%quadbra) @@ -3501,7 +3493,7 @@ CONTAINS NULLIFY (matrix_p) IF (use_rho) THEN CALL qs_rho_get(rho, rho_ao_kp=matrix_p) - ELSE IF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN + ELSEIF (ASSOCIATED(tb%rho_ao_kp_ref)) THEN matrix_p => tb%rho_ao_kp_ref ELSE matrix_p => scf_env%p_mix_new @@ -3941,9 +3933,8 @@ CONTAINS post_processing_output_file = "" IF (LEN_TRIM(ref%grad_file) > 0) grad_file = ref%grad_file IF (LEN_TRIM(ref%json_file) > 0) json_file = ref%json_file - IF (LEN_TRIM(ref%post_processing_output_file) > 0) THEN + IF (LEN_TRIM(ref%post_processing_output_file) > 0) & post_processing_output_file = ref%post_processing_output_file - END IF WRITE (charge_str, "(I0)") dft_control%charge spin = MAX(0, dft_control%multiplicity - 1) @@ -4035,9 +4026,8 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_min_weight_default, & ", while CP2K uses MIN_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_min_weight, "." - IF (ref%stop_on_error) THEN + IF (ref%stop_on_error) & CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MIN_WEIGHT") - END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_max_weight - & tblite_mixer_max_weight_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4046,9 +4036,8 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,ES12.4,A,ES12.4,A)") & "The native reference run uses tblite's library default ", tblite_mixer_max_weight_default, & ", while CP2K uses MAX_WEIGHT ", dft_control%qs_control%xtb_control%tblite_mixer_max_weight, "." - IF (ref%stop_on_error) THEN + IF (ref%stop_on_error) & CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/MAX_WEIGHT") - END IF END IF IF (ABS(dft_control%qs_control%xtb_control%tblite_mixer_weight_factor - & tblite_mixer_weight_factor_default) > 10.0_dp*EPSILON(1.0_dp)) THEN @@ -4058,22 +4047,19 @@ CONTAINS "The native reference run uses tblite's library default ", tblite_mixer_weight_factor_default, & ", while CP2K uses WEIGHT_FACTOR ", & dft_control%qs_control%xtb_control%tblite_mixer_weight_factor, "." - IF (ref%stop_on_error) THEN + IF (ref%stop_on_error) & CPABORT("tblite reference CLI cannot reproduce TBLITE_MIXER/WEIGHT_FACTOR") - END IF END IF etemp = 300.0_dp - IF (ASSOCIATED(scf_control)) THEN - IF (ASSOCIATED(scf_control%smear)) THEN - IF (scf_control%smear%do_smear) THEN - etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") - IF (scf_control%smear%method /= smear_fermi_dirac) THEN - WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & - "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & - TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." - WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & - "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." - END IF + IF (ASSOCIATED(scf_control) .AND. ASSOCIATED(scf_control%smear)) THEN + IF (scf_control%smear%do_smear) THEN + etemp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature, "K") + IF (scf_control%smear%method /= smear_fermi_dirac) THEN + WRITE (UNIT=iounit, FMT="(/,T2,A,A,A)") & + "WARNING: tblite reference CLI cannot reproduce CP2K smearing method ", & + TRIM(tb_reference_smear_method_name(scf_control%smear%method)), "." + WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") & + "The native reference run uses Fermi-Dirac electronic temperature ", etemp, " K instead." END IF END IF END IF @@ -4086,15 +4072,13 @@ CONTAINS etemp_guess_str = " --etemp-guess "//TRIM(ADJUSTL(etemp_guess_val_str)) END IF param_str = "" - IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) THEN + IF (LEN_TRIM(dft_control%qs_control%xtb_control%tblite_param_file) > 0) & param_str = " --param "//TRIM(tb_shell_quote(dft_control%qs_control%xtb_control%tblite_param_file)) - END IF spinpol_str = "" IF (dft_control%lsd) spinpol_str = " --spin-polarized" post_processing_str = "" - IF (LEN_TRIM(ref%post_processing) > 0) THEN + IF (LEN_TRIM(ref%post_processing) > 0) & post_processing_str = " --post-processing "//TRIM(tb_shell_quote(ref%post_processing)) - END IF post_processing_output_str = "" IF (LEN_TRIM(post_processing_output_file) > 0) THEN WRITE (UNIT=iounit, FMT="(/,T2,A)") & @@ -4105,9 +4089,8 @@ CONTAINS TRIM(tb_shell_quote(post_processing_output_file)) END IF restart_str = " --no-restart" - IF (LEN_TRIM(ref%restart_file) > 0) THEN + IF (LEN_TRIM(ref%restart_file) > 0) & restart_str = " --restart "//TRIM(tb_shell_quote(ref%restart_file)) - END IF CALL tb_write_reference_gen(qs_env, TRIM(gen_file)) @@ -4155,22 +4138,17 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,A)") "Guess: ", TRIM(guess) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Solver: ", TRIM(solver) WRITE (UNIT=iounit, FMT="(T2,A,L1)") "Spin-pol.: ", dft_control%lsd - IF (ref%efield_active) THEN + IF (ref%efield_active) & WRITE (UNIT=iounit, FMT="(T2,A,3ES16.8,A)") "Efield: ", ref%efield, " V/Angstrom" - END IF - IF (ref%solvation_active) THEN + IF (ref%solvation_active) & WRITE (UNIT=iounit, FMT="(T2,A,A,1X,A)") "Solvation: ", TRIM(solvation_model_name), & - TRIM(ref%solvation_solvent) - END IF - IF (LEN_TRIM(ref%post_processing) > 0) THEN + TRIM(ref%solvation_solvent) + IF (LEN_TRIM(ref%post_processing) > 0) & WRITE (UNIT=iounit, FMT="(T2,A,A)") "Post proc.: ", TRIM(ref%post_processing) - END IF - IF (LEN_TRIM(post_processing_output_file) > 0) THEN + IF (LEN_TRIM(post_processing_output_file) > 0) & WRITE (UNIT=iounit, FMT="(T2,A,A)") "PP output: ", TRIM(post_processing_output_file) - END IF - IF (ref%electronic_temperature_guess > 0.0_dp) THEN + IF (ref%electronic_temperature_guess > 0.0_dp) & WRITE (UNIT=iounit, FMT="(T2,A,F12.3,A)") "Guess etemp:", etemp_guess, " K" - END IF WRITE (UNIT=iounit, FMT="(T2,A,A)") "Grad file: ", TRIM(grad_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "JSON file: ", TRIM(json_file) WRITE (UNIT=iounit, FMT="(T2,A,A)") "Log file: ", TRIM(log_file) @@ -4373,9 +4351,8 @@ CONTAINS grad_str = "" IF (ref%guess_cli%grad) grad_str = " --grad" json_str = "" - IF (LEN_TRIM(ref%guess_cli%json_file) > 0) THEN + IF (LEN_TRIM(ref%guess_cli%json_file) > 0) & json_str = " --json "//TRIM(tb_shell_quote(ref%guess_cli%json_file)) - END IF log_file = TRIM(file_base)//".guess.log" command = TRIM(tb_shell_quote(ref%program_name))// & " guess --charge "//TRIM(ADJUSTL(charge_str))// & @@ -4390,44 +4367,38 @@ CONTAINS " "//TRIM(tb_shell_quote(guess_input))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "guess", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) THEN + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%guess_cli%json_file) > 0) & CALL tb_delete_file(ref%guess_cli%json_file) - END IF END IF IF (ref%param_cli%enabled) THEN method_str = "" - IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) THEN + IF (ref%param_cli%method_explicit .OR. LEN_TRIM(ref%param_cli%input_file) == 0) & method_str = " --method "// & TRIM(tb_reference_method_name(MERGE(ref%param_cli%method, & dft_control%qs_control%xtb_control%tblite_method, & ref%param_cli%method_explicit))) - END IF output_str = "" - IF (LEN_TRIM(ref%param_cli%output_file) > 0) THEN + IF (LEN_TRIM(ref%param_cli%output_file) > 0) & output_str = " --output "//TRIM(tb_shell_quote(ref%param_cli%output_file)) - END IF log_file = TRIM(file_base)//".param.log" command = TRIM(tb_shell_quote(ref%program_name))//" param"// & TRIM(method_str)// & TRIM(output_str) - IF (LEN_TRIM(ref%param_cli%input_file) > 0) THEN + IF (LEN_TRIM(ref%param_cli%input_file) > 0) & command = TRIM(command)//" "//TRIM(tb_shell_quote(ref%param_cli%input_file)) - END IF command = TRIM(command)//" > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "param", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) THEN + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%param_cli%output_file) > 0) & CALL tb_delete_file(ref%param_cli%output_file) - END IF END IF IF (ref%fit_cli%enabled) THEN dry_run_str = "" IF (ref%fit_cli%dry_run) dry_run_str = " --dry-run" copy_str = "" - IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN + IF (LEN_TRIM(ref%fit_cli%copy_file) > 0) & copy_str = " --copy "//TRIM(tb_shell_quote(ref%fit_cli%copy_file)) - END IF log_file = TRIM(file_base)//".fit.log" command = TRIM(tb_shell_quote(ref%program_name))//" fit"// & TRIM(dry_run_str)// & @@ -4436,9 +4407,8 @@ CONTAINS " "//TRIM(tb_shell_quote(ref%fit_cli%input_file))// & " > "//TRIM(tb_shell_quote(log_file))//" 2>&1" CALL tb_reference_cli_execute(ref, "fit", command, log_file, iounit) - IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) THEN + IF (.NOT. ref%keep_files .AND. LEN_TRIM(ref%fit_cli%copy_file) > 0) & CALL tb_delete_file(ref%fit_cli%copy_file) - END IF END IF IF (ref%tagdiff_cli%enabled) THEN @@ -4770,9 +4740,8 @@ CONTAINS CALL tb_delete_file(grad_file) CALL tb_delete_file(json_file) CALL tb_delete_file(log_file) - IF (LEN_TRIM(post_processing_output_file) > 0) THEN + IF (LEN_TRIM(post_processing_output_file) > 0) & CALL tb_delete_file(post_processing_output_file) - END IF END SUBROUTINE tb_reference_cleanup diff --git a/src/tblite_scc_mixer.F b/src/tblite_scc_mixer.F index 84a6bf6d4b..237f33576f 100644 --- a/src/tblite_scc_mixer.F +++ b/src/tblite_scc_mixer.F @@ -220,7 +220,7 @@ CONTAINS ALLOCATE (beta(MIN(memory, itn), MIN(memory, itn)), c(MIN(memory, itn), 1)) - omega(it1) = NORM2(dq) + omega(it1) = SQRT(DOT_PRODUCT(dq, dq)) IF (omega(it1) > (wfac/maxw)) THEN omega(it1) = wfac/omega(it1) ELSE @@ -229,7 +229,7 @@ CONTAINS IF (omega(it1) < minw) omega(it1) = minw df(:, it1) = dq - dqlast - inv = MAX(NORM2(df(:, it1)), EPSILON(1.0_wp)) + inv = MAX(SQRT(DOT_PRODUCT(df(:, it1), df(:, it1))), EPSILON(1.0_wp)) inv = 1.0_wp/inv df(:, it1) = inv*df(:, it1) diff --git a/src/tblite_types.F b/src/tblite_types.F index 5ed92fa276..5fb1e505c7 100644 --- a/src/tblite_types.F +++ b/src/tblite_types.F @@ -133,21 +133,16 @@ CONTAINS IF (ALLOCATED(tb_tblite%dcndr)) DEALLOCATE (tb_tblite%dcndr) IF (ALLOCATED(tb_tblite%dcndL)) DEALLOCATE (tb_tblite%dcndL) - IF (ASSOCIATED(tb_tblite%dipbra)) THEN + IF (ASSOCIATED(tb_tblite%dipbra)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%dipbra) - END IF - IF (ASSOCIATED(tb_tblite%dipket)) THEN + IF (ASSOCIATED(tb_tblite%dipket)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%dipket) - END IF - IF (ASSOCIATED(tb_tblite%quadbra)) THEN + IF (ASSOCIATED(tb_tblite%quadbra)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%quadbra) - END IF - IF (ASSOCIATED(tb_tblite%quadket)) THEN + IF (ASSOCIATED(tb_tblite%quadket)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%quadket) - END IF - IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) THEN + IF (ASSOCIATED(tb_tblite%rho_ao_kp_ref)) & CALL dbcsr_deallocate_matrix_set(tb_tblite%rho_ao_kp_ref) - END IF #if defined(__TBLITE) IF (ALLOCATED(tb_tblite%mixer)) DEALLOCATE (tb_tblite%mixer) IF (ALLOCATED(tb_tblite%param)) DEALLOCATE (tb_tblite%param) diff --git a/src/tmc/tmc_analysis.F b/src/tmc/tmc_analysis.F index a8dfda06b5..574ef635c3 100644 --- a/src/tmc/tmc_analysis.F +++ b/src/tmc/tmc_analysis.F @@ -118,15 +118,13 @@ CONTAINS CALL section_vals_val_get(tmc_ana_section, "DENSITY", i_vals=i_arr_tmp) IF (SIZE(i_arr_tmp(:)) == 3) THEN - IF (ANY(i_arr_tmp(:) <= 0)) THEN + IF (ANY(i_arr_tmp(:) <= 0)) & CALL cp_abort(__LOCATION__, "The amount of intervals in each "// & "direction has to be greater than 0.") - END IF nr_bins(:) = i_arr_tmp(:) ELSE IF (SIZE(i_arr_tmp(:)) == 1) THEN - IF (ANY(i_arr_tmp(:) <= 0)) THEN + IF (ANY(i_arr_tmp(:) <= 0)) & CPABORT("The amount of intervals has to be greater than 0.") - END IF nr_bins(:) = i_arr_tmp(1) ELSE IF (SIZE(i_arr_tmp(:)) == 0) THEN nr_bins(:) = 1 @@ -252,15 +250,13 @@ CONTAINS END IF ! init radial distribution function - IF (ASSOCIATED(ana_env%pair_correl)) THEN + IF (ASSOCIATED(ana_env%pair_correl)) & CALL ana_pair_correl_init(ana_pair_correl=ana_env%pair_correl, & atoms=ana_env%atoms, cell=ana_env%cell) - END IF ! init classical dipole moment calculations - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & CALL ana_dipole_moment_init(ana_dip_mom=ana_env%dip_mom, & atoms=ana_env%atoms) - END IF END SUBROUTINE analysis_init ! ************************************************************************************************** @@ -488,21 +484,18 @@ CONTAINS IF (weight_act > 0) THEN ! calculates the 3 dimensional distributed density - IF (ASSOCIATED(ana_env%density_3d)) THEN + IF (ASSOCIATED(ana_env%density_3d)) & CALL calc_density_3d(elem=ana_env%last_elem, & weight=weight_act, atoms=ana_env%atoms, & ana_env=ana_env) - END IF ! calculated the radial distribution function for each atom type - IF (ASSOCIATED(ana_env%pair_correl)) THEN + IF (ASSOCIATED(ana_env%pair_correl)) & CALL calc_paircorrelation(elem=ana_env%last_elem, weight=weight_act, & atoms=ana_env%atoms, ana_env=ana_env) - END IF ! calculates the classical dipole moments - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & CALL calc_dipole_moment(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) - END IF ! calculates the dipole moments analysis and dielectric constant IF (ASSOCIATED(ana_env%dip_ana)) THEN ! in symmetric case use also the dipoles @@ -511,72 +504,64 @@ CONTAINS ! (-x,y,z) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(3) = -ana_env%last_elem%dipole(3) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(3) = -ana_env%dip_mom%last_dip_cl(3) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (-x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! (x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(:) = -ana_env%last_elem%dipole(:) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(:) = -ana_env%dip_mom%last_dip_cl(:) - END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) ! back to (x,y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) dip_tmp(:) = ana_env%last_elem%dipole(:) - IF (ASSOCIATED(ana_env%dip_mom)) THEN + IF (ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) - END IF END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act, & ana_env=ana_env) @@ -615,29 +600,24 @@ CONTAINS ! start the timing CALL timeset(routineN, handle) IF (ASSOCIATED(ana_env%density_3d)) THEN - IF (ana_env%density_3d%conf_counter > 0) THEN + IF (ana_env%density_3d%conf_counter > 0) & CALL print_density_3d(ana_env=ana_env) - END IF END IF IF (ASSOCIATED(ana_env%pair_correl)) THEN - IF (ana_env%pair_correl%conf_counter > 0) THEN + IF (ana_env%pair_correl%conf_counter > 0) & CALL print_paircorrelation(ana_env=ana_env) - END IF END IF IF (ASSOCIATED(ana_env%dip_mom)) THEN - IF (ana_env%dip_mom%conf_counter > 0) THEN + IF (ana_env%dip_mom%conf_counter > 0) & CALL print_dipole_moment(ana_env) - END IF END IF IF (ASSOCIATED(ana_env%dip_ana)) THEN - IF (ana_env%dip_ana%conf_counter > 0) THEN + IF (ana_env%dip_ana%conf_counter > 0) & CALL print_dipole_analysis(ana_env) - END IF END IF IF (ASSOCIATED(ana_env%displace)) THEN - IF (ana_env%displace%conf_counter > 0) THEN + IF (ana_env%displace%conf_counter > 0) & CALL print_average_displacement(ana_env) - END IF END IF ! end the timing @@ -711,18 +691,16 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=elem) END IF ! if there was no previous element, create a new temp element to write in - IF (.NOT. ASSOCIATED(elem)) THEN + IF (.NOT. ASSOCIATED(elem)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem, & nr_dim=nr_dim) - END IF END DO conf_loop END IF ! close the files CALL analyse_files_close(tmc_ana=ana_env) - IF (ASSOCIATED(elem)) THEN + IF (ASSOCIATED(elem)) & CALL deallocate_sub_tree_node(tree_elem=elem) - END IF ! end the timing CALL timestop(handle) @@ -865,12 +843,11 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) THEN + IF (.NOT. flag) & WRITE (file_ptr, FMT='(A8,11A20)') "# conf_nr", "dens_act[g/cm^3]", & - "dens_average[g/cm^3]", "density_variance", & - "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & - "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" - END IF + "dens_average[g/cm^3]", "density_variance", & + "averages:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z", & + "variances:volume", "box_lenth_x", "box_lenth_y", "box_lenth_z" WRITE (file_ptr, FMT="(I8,11F20.10)") ana_env%density_3d%conf_counter + 1 - weight, & SUM(mass_bin(:, :, :))/vol_sub_box/SIZE(mass_bin(:, :, :)), & SUM(ana_env%density_3d%sum_density(:, :, :))/ & @@ -998,12 +975,11 @@ CONTAINS SIZE(ana_env%density_3d%sum_density(:, :, :))/ & REAL(ana_env%density_3d%conf_counter, KIND=dp))**2) WRITE (ana_env%io_unit, FMT="(/,T2,A)") REPEAT("-", 79) - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (ana_env%io_unit, *) "TMC|ANALYSIS_CELL_DENSITY_X= ", & - SUM(ana_env%density_3d%sum_density(:, :, :))/ & - SIZE(ana_env%density_3d%sum_density(:, :, :))/ & - REAL(ana_env%density_3d%conf_counter, KIND=dp) - END IF + SUM(ana_env%density_3d%sum_density(:, :, :))/ & + SIZE(ana_env%density_3d%sum_density(:, :, :))/ & + REAL(ana_env%density_3d%conf_counter, KIND=dp) ! end the timing CALL timestop(handle) END SUBROUTINE print_density_3d @@ -1199,13 +1175,12 @@ CONTAINS END DO CALL close_file(unit_number=file_ptr) - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (*, *) "TMC|ANALYSIS_G_R_"// & - TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & - TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & - SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & - voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) - END IF + TRIM(ana_env%pair_correl%pairs(pair)%f_n)//"_"// & + TRIM(ana_env%pair_correl%pairs(pair)%s_n)//"_X= ", & + SUM(ana_env%pair_correl%g_r(pair, :)/ana_env%pair_correl%conf_counter/ & + voldr*ana_env%pair_correl%pairs(pair)%pair_count/vol) END DO ! end the timing @@ -1322,10 +1297,9 @@ CONTAINS SUBROUTINE print_dipole_moment(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (*, *) "TMC|ANALYSIS_FINAL_CLASS_CELL_DIPOLE_MOMENT_X= ", & - ana_env%dip_mom%last_dip_cl(:) - END IF + ana_env%dip_mom%last_dip_cl(:) END SUBROUTINE print_dipole_moment ! ************************************************************************************************** @@ -1353,9 +1327,8 @@ CONTAINS CPASSERT(ASSOCIATED(ana_env%dip_ana)) weight_act = weight - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & weight_act = weight_act/REAL(8.0, KIND=dp) - END IF ! get the volume ALLOCATE (scaled_cell) @@ -1548,14 +1521,12 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "temperature ", cp_to_string(ana_env%temperature) WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "used configurations ", & cp_to_string(REAL(ana_env%dip_ana%conf_counter, KIND=dp)) - IF (ana_env%dip_ana%ana_type == ana_type_ice) THEN + IF (ana_env%dip_ana%ana_type == ana_type_ice) & WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with directions of hexagonal structure" - END IF - IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN + "ice analysis with directions of hexagonal structure" + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & WRITE (ana_env%io_unit, FMT='(T2,A,"| ",A)') plabel, & - "ice analysis with symmetrized dipoles in each direction." - END IF + "ice analysis with symmetrized dipoles in each direction." WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "for product of 2 directions(per vol):" DO i = 1, 3 @@ -1636,9 +1607,8 @@ CONTAINS CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) - IF (.NOT. flag) THEN + IF (.NOT. flag) & WRITE (file_ptr, *) "# conf squared deviation of the cell" - END IF WRITE (file_ptr, *) elem%nr, disp CALL close_file(unit_number=file_ptr) END IF @@ -1668,10 +1638,9 @@ CONTAINS WRITE (ana_env%io_unit, FMT=fmt_my) plabel, "cell root mean square deviation: ", & cp_to_string(SQRT(ana_env%displace%disp/ & REAL(ana_env%displace%conf_counter, KIND=dp))) - IF (ana_env%print_test_output) THEN + IF (ana_env%print_test_output) & WRITE (*, *) "TMC|ANALYSIS_AVERAGE_CELL_DISPLACEMENT_X= ", & - SQRT(ana_env%displace%disp/ & - REAL(ana_env%displace%conf_counter, KIND=dp)) - END IF + SQRT(ana_env%displace%disp/ & + REAL(ana_env%displace%conf_counter, KIND=dp)) END SUBROUTINE print_average_displacement END MODULE tmc_analysis diff --git a/src/tmc/tmc_analysis_types.F b/src/tmc/tmc_analysis_types.F index 49bd263e20..140aeeeb15 100644 --- a/src/tmc/tmc_analysis_types.F +++ b/src/tmc/tmc_analysis_types.F @@ -156,28 +156,22 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_ana)) - IF (ASSOCIATED(tmc_ana%dirs)) THEN + IF (ASSOCIATED(tmc_ana%dirs)) & DEALLOCATE (tmc_ana%dirs) - END IF - IF (ASSOCIATED(tmc_ana%density_3d)) THEN + IF (ASSOCIATED(tmc_ana%density_3d)) & CALL tmc_ana_dens_release(tmc_ana%density_3d) - END IF - IF (ASSOCIATED(tmc_ana%pair_correl)) THEN + IF (ASSOCIATED(tmc_ana%pair_correl)) & CALL tmc_ana_pair_correl_release(tmc_ana%pair_correl) - END IF - IF (ASSOCIATED(tmc_ana%dip_mom)) THEN + IF (ASSOCIATED(tmc_ana%dip_mom)) & CALL tmc_ana_dipole_moment_release(tmc_ana%dip_mom) - END IF - IF (ASSOCIATED(tmc_ana%dip_ana)) THEN + IF (ASSOCIATED(tmc_ana%dip_ana)) & CALL tmc_ana_dipole_analysis_release(tmc_ana%dip_ana) - END IF - IF (ASSOCIATED(tmc_ana%displace)) THEN + IF (ASSOCIATED(tmc_ana%displace)) & CALL tmc_ana_displacement_release(ana_disp=tmc_ana%displace) - END IF DEALLOCATE (tmc_ana) diff --git a/src/tmc/tmc_calculations.F b/src/tmc/tmc_calculations.F index cb0b3bba1b..e0d9a91e12 100644 --- a/src/tmc/tmc_calculations.F +++ b/src/tmc/tmc_calculations.F @@ -178,9 +178,8 @@ CONTAINS tmp_cell%hmat(:, 3) = tmp_cell%hmat(:, 3)*box_scale(3) CALL init_cell(cell=tmp_cell) - IF (PRESENT(scaled_hmat)) THEN + IF (PRESENT(scaled_hmat)) & scaled_hmat(:, :) = tmp_cell%hmat - END IF IF (PRESENT(vec)) THEN vec = pbc(r=vec, cell=tmp_cell) @@ -612,10 +611,9 @@ CONTAINS eff(:) = 0.0_dp DO i = 1, tmc_env%params%nr_temp - IF (tmc_env%m_env%tree_node_count(i) > 0) THEN + IF (tmc_env%m_env%tree_node_count(i) > 0) & eff(i) = tmc_env%params%move_types%mv_count(0, i)/ & (tmc_env%m_env%tree_node_count(i)*1.0_dp) - END IF eff(0) = eff(0) + tmc_env%params%move_types%mv_count(0, i)/ & (SUM(tmc_env%m_env%tree_node_count(1:))*1.0_dp) END DO diff --git a/src/tmc/tmc_cancelation.F b/src/tmc/tmc_cancelation.F index a0a5bf800a..086541c7ea 100644 --- a/src/tmc/tmc_cancelation.F +++ b/src/tmc/tmc_cancelation.F @@ -97,9 +97,8 @@ CONTAINS //cp_to_string(elem%stat)) END SELECT ! set dot color - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=elem, tmc_params=tmc_env%params) - END IF ! add to list IF (need_to_cancel) THEN diff --git a/src/tmc/tmc_dot_tree.F b/src/tmc/tmc_dot_tree.F index 936874ff42..b231aaa2af 100644 --- a/src/tmc/tmc_dot_tree.F +++ b/src/tmc/tmc_dot_tree.F @@ -339,11 +339,10 @@ CONTAINS END IF IF (.NOT. ASSOCIATED(new_element%parent)) THEN - IF (new_element%nr > 1) THEN + IF (new_element%nr > 1) & CALL cp_warn(__LOCATION__, & "try to create dot, but no parent on node "// & cp_to_string(new_element%nr)//"exists") - END IF ELSE CALL create_dot_branch(parent_nr=new_element%parent%nr, & child_nr=new_element%nr, & diff --git a/src/tmc/tmc_file_io.F b/src/tmc/tmc_file_io.F index 71053815d2..6aa7d1b0f0 100644 --- a/src/tmc/tmc_file_io.F +++ b/src/tmc/tmc_file_io.F @@ -301,11 +301,10 @@ CONTAINS CALL open_file(file_name=file_name, file_status="OLD", file_form="UNFORMATTED", & file_action="READ", unit_number=file_ptr) READ (file_ptr) temp_size - IF (temp_size /= SIZE(tmc_env%params%Temp)) THEN + IF (temp_size /= SIZE(tmc_env%params%Temp)) & CALL cp_abort(__LOCATION__, & "the actual specified temperatures does not "// & "fit in amount with the one from restart file ") - END IF ALLOCATE (tmp_temp(temp_size)) READ (file_ptr) tmp_temp(:), & tmc_env%m_env%gt_act%nr, & @@ -324,10 +323,9 @@ CONTAINS job_counts, & timings - IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) THEN + IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) >= 0.005)) & CALL cp_abort(__LOCATION__, "the temperatures differ from the previous calculation. "// & "There were the following temperatures used:") - END IF IF (ANY(mv_weight_tmp(:) /= tmc_env%params%move_types%mv_weight(:))) THEN CPWARN("The amount of mv types differs between the original and the restart run.") END IF @@ -724,14 +722,13 @@ CONTAINS ! write the different energies ! TODO if necessary - IF (files_conf_missmatch) THEN + IF (files_conf_missmatch) & CALL cp_warn(__LOCATION__, & 'there is a missmatch in the configuration numbering. '// & "Read number of lines (pos|cell|dip)"// & cp_to_string(tmc_ana%lc_traj)//"|"// & cp_to_string(tmc_ana%lc_cell)//"|"// & cp_to_string(tmc_ana%lc_dip)) - END IF ! end the timing CALL timestop(handle) @@ -772,22 +769,20 @@ CONTAINS c_tmp(:) = " " tmc_ana%lc_traj = tmc_ana%lc_traj + 1 READ (tmc_ana%id_traj, '(A)', IOSTAT=status) c_tmp(:) - IF (status > 0) THEN + IF (status > 0) & CALL cp_abort(__LOCATION__, & "configuration header read error at line: "// & cp_to_string(tmc_ana%lc_traj)//": "//c_tmp) - END IF IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK EXIT search_next_conf END IF IF (INDEX(c_tmp, "=") > 0) THEN READ (c_tmp(INDEX(c_tmp, "=") + 1:), *, IOSTAT=status) i_tmp ! read the configuration number - IF (status /= 0) THEN + IF (status /= 0) & CALL cp_abort(__LOCATION__, & "configuration header read error (for conf nr) at line: "// & cp_to_string(tmc_ana%lc_traj)) - END IF IF (i_tmp > conf_nr) THEN ! TODO we could also read the energy ... conf_nr = i_tmp @@ -919,9 +914,8 @@ CONTAINS IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK ELSE IF (status > 0) THEN - IF (status /= 0) THEN + IF (status /= 0) & CPABORT("configuration cell read error at line: "//cp_to_string(tmc_ana%lc_cell)) - END IF stat = TMC_STATUS_FAILED ELSE IF (elem%nr < 0) elem%nr = conf_nr diff --git a/src/tmc/tmc_master.F b/src/tmc/tmc_master.F index b93d15d0eb..20811cce10 100644 --- a/src/tmc/tmc_master.F +++ b/src/tmc/tmc_master.F @@ -135,10 +135,9 @@ CONTAINS CPASSERT(stat /= TMC_STATUS_FAILED) CPASSERT(work_list(wg)%elem%stat /= status_calc_approx_ener) - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: cancel group "//cp_to_string(wg) - END IF + "TMC|master: cancel group "//cp_to_string(wg) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=para_env, tmc_params=tmc_env%params) work_list(wg)%canceled = .TRUE. @@ -248,9 +247,8 @@ CONTAINS walltime_offset = 20 ! default value the whole program needs to finalize ! initialize the different modules - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL init_draw_trees(tmc_params=tmc_env%params) - END IF !-- initialize variables ! nr_of_job: counting the different task send / received @@ -286,11 +284,10 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_params=tmc_env%params, & elem=init_conf, success=flag, wait_for_message=.TRUE.) - IF (stat /= TMC_STAT_START_CONF_RESULT) THEN + IF (stat /= TMC_STAT_START_CONF_RESULT) & CALL cp_abort(__LOCATION__, & "receiving start configuration failed, received stat "// & cp_to_string(stat)) - END IF ! get the atom names from first energy worker CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & @@ -302,11 +299,10 @@ CONTAINS CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%move_types, & mol_array=init_conf%mol) - IF (ASSOCIATED(tmc_env%params%nmc_move_types)) THEN + IF (ASSOCIATED(tmc_env%params%nmc_move_types)) & CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%nmc_move_types, & mol_array=init_conf%mol) - END IF ! set initial configuration ! set initial random number generator seed (rng seed) @@ -352,17 +348,15 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=init_conf) ! regtest output - IF (tmc_env%params%print_test_output .OR. DEBUG > 0) THEN + IF (tmc_env%params%print_test_output .OR. DEBUG > 0) & WRITE (tmc_env%m_env%io_unit, *) "TMC|first_global_tree_rnd_nr_X= ", & - tmc_env%m_env%gt_head%rnd_nr - END IF + tmc_env%m_env%gt_head%rnd_nr ! calculate the approx energy of the first element (later the exact) IF (tmc_env%m_env%gt_head%conf(1)%elem%stat == status_calc_approx_ener) THEN wg = 1 - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & wg = tmc_env%tmc_comp_set%group_ener_nr + 1 - END IF stat = TMC_STAT_APPROX_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -397,30 +391,27 @@ CONTAINS IF (flag .EQV. .FALSE.) EXIT worker_request_loop ! messages from worker group could be faster then the canceling request IF (worker_info(wg)%canceled .AND. (stat /= TMC_CANCELING_RECEIPT)) THEN - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: recv stat "//cp_to_string(stat)// & - " of canceled worker group" - END IF + "TMC|master: recv stat "//cp_to_string(stat)// & + " of canceled worker group" CYCLE worker_request_loop END IF ! in case of parallel tempering canceled element could be reactivated, ! calculated faster and deleted - IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) THEN + IF (.NOT. ASSOCIATED(worker_info(wg)%elem)) & CALL cp_abort(__LOCATION__, & "no tree elem exist when receiving stat "// & cp_to_string(stat)//"of group"//cp_to_string(wg)) - END IF - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: received stat "//cp_to_string(stat)// & - " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & - " elem"//cp_to_string(worker_info(wg)%elem%nr)// & - " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & - " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled - END IF + "TMC|master: received stat "//cp_to_string(stat)// & + " of sub tree "//cp_to_string(worker_info(wg)%elem%sub_tree_nr)// & + " elem"//cp_to_string(worker_info(wg)%elem%nr)// & + " with stat"//cp_to_string(worker_info(wg)%elem%stat)// & + " of group"//cp_to_string(wg)//" group canceled ", worker_info(wg)%canceled SELECT CASE (stat) ! -- FAILED -------------------------- CASE (TMC_STATUS_FAILED) @@ -548,9 +539,8 @@ CONTAINS worker_info(wg)%start_time = m_walltime() - worker_info(wg)%start_time CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay) - IF (.NOT. worker_info(wg)%canceled) THEN + IF (.NOT. worker_info(wg)%canceled) & worker_info(wg)%busy = .FALSE. - END IF ! the first node in tree is always accepted.!. IF (ASSOCIATED(worker_info(wg)%elem, init_conf)) THEN !-- distribute energy of first element to all subtrees @@ -565,10 +555,9 @@ CONTAINS init_conf => NULL() ELSE worker_info(wg)%elem%stat = status_calculated - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(worker_info(wg)%elem, & tmc_params=tmc_env%params) - END IF ! check acceptance of depending nodes ! first (initial) configuration do not have to be checked CALL check_acceptance_of_depending_subtree_nodes(tree_elem=worker_info(wg)%elem, & @@ -589,12 +578,11 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & cancel_count=cancel_count) - IF (DEBUG >= 9) THEN + IF (DEBUG >= 9) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: handled energy result of sub tree ", & - worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & - " with stat", worker_info(wg)%elem%stat - END IF + "TMC|master: handled energy result of sub tree ", & + worker_info(wg)%elem%sub_tree_nr, " elem ", worker_info(wg)%elem%nr, & + " with stat", worker_info(wg)%elem%stat worker_info(wg)%elem => NULL() !-- SCF ENERGY ----------------------- @@ -622,12 +610,11 @@ CONTAINS !-- do tree update (check new results) CALL tree_update(tmc_env=tmc_env, result_acc=flag, & something_updated=l_update_tree) - IF (DEBUG >= 2 .AND. l_update_tree) THEN + IF (DEBUG >= 2 .AND. l_update_tree) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: tree updated "//cp_to_string(l_update_tree)// & - " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & - " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) - END IF + "TMC|master: tree updated "//cp_to_string(l_update_tree)// & + " of with gt elem "//cp_to_string(tmc_env%m_env%gt_act%nr)// & + " with stat"//cp_to_string(tmc_env%m_env%gt_act%stat) CALL send_analysis_tasks(ana_list=tmc_env%m_env%analysis_list, & ana_worker_info=ana_worker_info, & @@ -655,15 +642,13 @@ CONTAINS "(incl. delay", walltime_delay, "and offset", walltime_offset, ") left" ELSE ! calculations finished - IF (tmc_env%params%print_test_output) THEN + IF (tmc_env%params%print_test_output) & WRITE (tmc_env%m_env%io_unit, *) "Total energy: ", & - tmc_env%m_env%result_list(1)%elem%potential - END IF + tmc_env%m_env%result_list(1)%elem%potential END IF - IF (tmc_env%m_env%restart_out_step /= 0) THEN + IF (tmc_env%m_env%restart_out_step /= 0) & CALL print_restart_file(tmc_env=tmc_env, job_counts=nr_of_job, & timings=worker_timings_aver) - END IF EXIT task_loop END IF @@ -671,10 +656,9 @@ CONTAINS ! update the rest of the tree (canceling and deleting elements) ! ======================================================================= IF (l_update_tree) THEN - IF (DEBUG >= 2) THEN + IF (DEBUG >= 2) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: start remove elem and cancel calculation" - END IF + "TMC|master: start remove elem and cancel calculation" !-- CLEANING tree nodes beside the path through the tree from ! end_of_clean_tree to tree_ptr ! --> getting back the end of clean tree @@ -696,15 +680,13 @@ CONTAINS worker_counter = worker_counter + 1 wg = MODULO(worker_counter, tmc_env%tmc_comp_set%para_env_m_w%num_pe - 1) + 1 - IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) THEN + IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) & WRITE (tmc_env%m_env%io_unit, *) "all workers are busy" - END IF IF (.NOT. worker_info(wg)%busy) THEN - IF (DEBUG >= 13) THEN + IF (DEBUG >= 13) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: search new task for worker ", wg - END IF + "TMC|master: search new task for worker ", wg ! no group separation IF (tmc_env%tmc_comp_set%group_cc_nr <= 0) THEN ! search next element to calculate the energy @@ -716,7 +698,7 @@ CONTAINS new_elem=gt_elem_tmp, & reactivation_cc_count=reactivation_cc_count) END IF - ELSE IF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN + ELSEIF (wg > tmc_env%tmc_comp_set%group_ener_nr) THEN ! specialized groups (groups for exact energy and groups for configurational change) ! creating new element (configurational change group) !-- crate new node, configurational change is handled in tmc_tree module @@ -725,9 +707,8 @@ CONTAINS reactivation_cc_count=reactivation_cc_count) ! element could be already created, hence CC worker has nothing to do for this element ! in next round he will get a task - IF (stat == status_created .OR. stat == status_calculate_energy) THEN + IF (stat == status_created .OR. stat == status_calculate_energy) & stat = TMC_STATUS_WAIT_FOR_NEW_TASK - END IF ELSE ! search next element to calculate the energy CALL search_next_energy_calc(gt_head=tmc_env%m_env%gt_act, & @@ -735,11 +716,10 @@ CONTAINS react_count=reactivation_ener_count) END IF - IF (DEBUG >= 10) THEN + IF (DEBUG >= 10) & WRITE (tmc_env%m_env%io_unit, *) & - "TMC|master: send task with elem stat "//cp_to_string(stat)// & - " to group "//cp_to_string(wg) - END IF + "TMC|master: send task with elem stat "//cp_to_string(stat)// & + " to group "//cp_to_string(wg) ! MESSAGE settings: status informations and task for communication SELECT CASE (stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -761,10 +741,9 @@ CONTAINS ! in case of parallel tempering the node can be already be calculating (related to another global tree node !-- send task to calculate system property gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem%stat = status_calculate_energy - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF stat = TMC_STAT_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & @@ -830,30 +809,27 @@ CONTAINS WRITE (tmc_env%m_env%io_unit, FMT=*) & "ener prepared ", tree_elem_counters END IF - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & WRITE (tmc_env%m_env%io_unit, *) & - "canceled cc|E: ", nr_of_job(5:6), & - ", reactivated: cc ", & - reactivation_cc_count, & - ", reactivated: E ", & - reactivation_ener_count - END IF + "canceled cc|E: ", nr_of_job(5:6), & + ", reactivated: cc ", & + reactivation_cc_count, & + ", reactivated: E ", & + reactivation_ener_count WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & " Average time for cc/ener calc ", & worker_timings_aver(1), worker_timings_aver(2) - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & WRITE (tmc_env%m_env%io_unit, FMT='(A,2F10.2)') & - " Average time until cancel cc/ener calc ", & - worker_timings_aver(3), worker_timings_aver(4) - END IF - IF (tmc_env%params%esimate_acc_prob) THEN + " Average time until cancel cc/ener calc ", & + worker_timings_aver(3), worker_timings_aver(4) + IF (tmc_env%params%esimate_acc_prob) & WRITE (tmc_env%m_env%io_unit, *) & - "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & - tmc_env%m_env%estim_corr_wrong(1), & - tmc_env%m_env%estim_corr_wrong(3), " | ", & - tmc_env%m_env%estim_corr_wrong(2), & - tmc_env%m_env%estim_corr_wrong(4) - END IF + "Estimate correct (acc/Nacc) | wrong (acc/nacc)", & + tmc_env%m_env%estim_corr_wrong(1), & + tmc_env%m_env%estim_corr_wrong(3), " | ", & + tmc_env%m_env%estim_corr_wrong(2), & + tmc_env%m_env%estim_corr_wrong(4) WRITE (tmc_env%m_env%io_unit, *) & "Time: ", INT(m_walltime() - run_time_start), "of", & INT(tmc_env%m_env%walltime - walltime_delay - walltime_offset), & @@ -893,11 +869,10 @@ CONTAINS " (MC elements/calculated configuration) global:", & efficiency(0), " sub tree(s): ", efficiency(1:) DEALLOCATE (efficiency) - IF (tmc_env%tmc_comp_set%group_cc_nr > 0) THEN + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & - " (MC elements/created configuration) :", & - tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) - END IF + " (MC elements/created configuration) :", & + tmc_env%m_env%result_count(:)/REAL(nr_of_job(3), KIND=dp) WRITE (tmc_env%m_env%io_unit, FMT="(A,1000F5.2)") & " (MC elements/energy calculated configuration):", & tmc_env%m_env%result_count(:)/REAL(nr_of_job(4), KIND=dp) @@ -934,9 +909,8 @@ CONTAINS CALL free_cancelation_list(tmc_env%m_env%cancelation_list) ! -- write final configuration - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL finalize_draw_tree(tmc_params=tmc_env%params) - END IF WRITE (tmc_env%m_env%io_unit, *) "TMC master: all work done." diff --git a/src/tmc/tmc_messages.F b/src/tmc/tmc_messages.F index 26ae8e290c..82b36f4bdb 100644 --- a/src/tmc/tmc_messages.F +++ b/src/tmc/tmc_messages.F @@ -88,9 +88,8 @@ CONTAINS CPASSERT(ASSOCIATED(para_env)) master = .FALSE. - IF (para_env%mepos == MASTER_COMM_ID) THEN + IF (para_env%mepos == MASTER_COMM_ID) & master = .TRUE. - END IF END FUNCTION check_if_group_master ! ************************************************************************************************** @@ -212,12 +211,11 @@ CONTAINS CPABORT("Unable to send message when m_send%info(4) > 0") !TODO send characters CALL para_env%send(m_send%task_char, dest, message_tag) END IF - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " send element info to ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:), " with comm ", & - para_env%get_handle(), " and tag ", message_tag - END IF + " send element info to ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:), " with comm ", & + para_env%get_handle(), " and tag ", message_tag IF (m_send%info(2) > 0) DEALLOCATE (m_send%task_int) IF (m_send%info(3) > 0) DEALLOCATE (m_send%task_real) IF (m_send%info(4) > 0) DEALLOCATE (m_send%task_char) @@ -292,11 +290,10 @@ CONTAINS ! first get message type and sizes CALL para_env%recv(m_send%info, dest, message_tag) END IF - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (*, *) "TMC|message: ID: ", para_env%mepos, & - " recv element info from ", dest, " of stat ", m_send%info(1), & - " with size int/real/char", m_send%info(2:) - END IF + " recv element info from ", dest, " of stat ", m_send%info(1), & + " with size int/real/char", m_send%info(2:) !-- receive message integer part IF (m_send%info(2) > 0) THEN ALLOCATE (m_send%task_int(m_send%info(2))) @@ -353,16 +350,14 @@ CONTAINS CASE (TMC_STAT_ENERGY_REQUEST, TMC_STAT_APPROX_ENERGY_REQUEST) CALL read_energy_request_message(elem, m_send, tmc_params) CASE (TMC_STAT_ENERGY_RESULT) - IF (PRESENT(elem_array)) THEN + IF (PRESENT(elem_array)) & CALL read_energy_result_message(elem_array(dest)%elem, m_send, tmc_params) - END IF CASE (TMC_STAT_NMC_REQUEST, TMC_STAT_NMC_BROADCAST, & TMC_STAT_MD_REQUEST, TMC_STAT_MD_BROADCAST) CALL read_NMC_request_massage(msg_type, elem, m_send, tmc_params) CASE (TMC_STAT_NMC_RESULT, TMC_STAT_MD_RESULT) - IF (PRESENT(elem_array)) THEN + IF (PRESENT(elem_array)) & CALL read_NMC_result_massage(msg_type, elem_array(dest)%elem, m_send, tmc_params) - END IF CASE (TMC_STATUS_FAILED, TMC_STATUS_STOP_RECEIPT) ! if task is failed, handle situation in outer routine CASE (TMC_STAT_SCF_STEP_ENER_RECEIVE) @@ -1080,9 +1075,8 @@ CONTAINS counter = 0 !then float array with pos, (vel), random number seed, subbox_center msg_size_real = 1 + SIZE(elem%pos) + 1 + SIZE(elem%rng_seed) + 1 + SIZE(elem%subbox_center(:)) + 1 - IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) THEN - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) - END IF ! the velocities + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) & + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) ! the velocities IF (tmc_params%pressure >= 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) ! box size for NpT ALLOCATE (m_send%task_real(msg_size_real)) @@ -1220,10 +1214,9 @@ CONTAINS + 1 + SIZE(tmc_params%nmc_move_types%mv_count) & + 1 + SIZE(tmc_params%nmc_move_types%acc_count) + 1 IF (DEBUG > 0) msg_size_int = msg_size_int + 1 + 1 + 1 + 1 - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & msg_size_int = msg_size_int + 1 + SIZE(tmc_params%nmc_move_types%subbox_count) & + 1 + SIZE(tmc_params%nmc_move_types%subbox_acc_count) - END IF ALLOCATE (m_send%task_int(msg_size_int)) counter = 1 @@ -1277,9 +1270,8 @@ CONTAINS + 1 ! check bit IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_RESULT .OR. & - msg_type == TMC_STAT_MD_BROADCAST) THEN - msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 - END IF ! for MD also: vel, e_kin_befor_md, ekin + msg_type == TMC_STAT_MD_BROADCAST) & + msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 ! for MD also: vel, e_kin_befor_md, ekin ALLOCATE (m_send%task_real(msg_size_real)) ! pos @@ -1408,9 +1400,8 @@ CONTAINS msg_type == TMC_STAT_MD_BROADCAST) THEN elem%vel = m_send%task_real(counter + 1:counter + NINT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) - IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) THEN + IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) & elem%ekin_before_md = m_send%task_real(counter + 1) - END IF counter = counter + 2 elem%ekin = m_send%task_real(counter + 1) counter = counter + 2 @@ -1424,9 +1415,8 @@ CONTAINS END IF DEALLOCATE (mv_counter, acc_counter) - IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & DEALLOCATE (subbox_counter, subbox_acc_counter) - END IF CPASSERT(counter == m_send%info(3)) CPASSERT(m_send%task_int(m_send%info(2)) == message_end_flag) CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) @@ -1574,7 +1564,7 @@ CONTAINS TYPE(mp_para_env_type), POINTER :: para_env CHARACTER(LEN=default_string_length), & - ALLOCATABLE, DIMENSION(:) :: msg + ALLOCATABLE, DIMENSION(:) :: msg(:) INTEGER :: i CPASSERT(ASSOCIATED(para_env)) diff --git a/src/tmc/tmc_move_handle.F b/src/tmc/tmc_move_handle.F index cfa8ab5b31..6354703e49 100644 --- a/src/tmc/tmc_move_handle.F +++ b/src/tmc/tmc_move_handle.F @@ -114,25 +114,22 @@ CONTAINS CALL section_vals_get(nmc_section, explicit=explicit) IF (explicit) THEN ! check the approx potential file, already read - IF (tmc_params%NMC_inp_file == "") THEN + IF (tmc_params%NMC_inp_file == "") & CPABORT("Please specify a valid approximate potential.") - END IF CALL section_vals_val_get(nmc_section, "NR_NMC_STEPS", & i_val=nmc_steps) - IF (nmc_steps <= 0) THEN + IF (nmc_steps <= 0) & CPABORT("Please specify a valid amount of NMC steps (NR_NMC_STEPS {INTEGER}).") - END IF CALL section_vals_val_get(nmc_section, "PROB", r_val=nmc_prob) CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", & r_val=nmc_init_acc_prob) - IF (nmc_init_acc_prob <= 0.0_dp) THEN + IF (nmc_init_acc_prob <= 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for INIT_ACC_PROB") - END IF move_type_section => section_vals_get_subs_vals(nmc_section, "MOVE_TYPE") CALL section_vals_get(move_type_section, n_repetition=n_NMC_items) @@ -153,11 +150,10 @@ CONTAINS ! initilaize the move array with related sizes, probs, etc. CALL move_types_create(tmc_params%move_types, tmc_params%nr_temp) - IF (mv_prob_sum <= 0.0) THEN + IF (mv_prob_sum <= 0.0) & CALL cp_abort(__LOCATION__, & "The probabilities to perform the moves are "// & "in total less equal 0") - END IF ! get the sizes, probs, etc. for each move type and convert units DO i_tmp = 1, n_items + n_NMC_items @@ -192,18 +188,16 @@ CONTAINS ! move sizes are checked afterwards, because not all moves require a valid move size CALL section_vals_val_get(move_type_section, "PROB", i_rep_section=i_rep, & r_val=mv_prob) - IF (mv_prob < 0.0_dp) THEN + IF (mv_prob < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid move probability (>0.0) "// & "for the move type "//inp_kind_name) - END IF CALL section_vals_val_get(move_type_section, "INIT_ACC_PROB", i_rep_section=i_rep, & r_val=init_acc_prob) - IF (init_acc_prob < 0.0_dp) THEN + IF (init_acc_prob < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid initial acceptance probability (>0.0) "// & "for the move type "//inp_kind_name) - END IF ! set the related index and perform unit conversion of move sizes SELECT CASE (inp_kind_name) ! atom / molecule translation @@ -284,9 +278,8 @@ CONTAINS CALL section_vals_val_get(move_type_section, "ATOMS", & i_rep_section=i_rep, i_rep_val=i, & c_vals=move_types%atom_lists(i)%atoms) - IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) THEN + IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) & CPABORT("ATOM_SWAP requires minimum two atom kinds selected. ") - END IF END DO END IF ! gaussian adaptation @@ -297,11 +290,10 @@ CONTAINS CPABORT("A unknown move type is selected: "//inp_kind_name) END SELECT ! check for valid move sizes - IF (delta_x < 0.0_dp) THEN + IF (delta_x < 0.0_dp) & CALL cp_abort(__LOCATION__, & "Please select a valid move size (>0.0) "// & "for the move type "//inp_kind_name) - END IF ! check if not already set IF (move_types%mv_weight(ind) > 0.0) THEN CPABORT("TMC: Each move type can be set only once. ") @@ -349,12 +341,11 @@ CONTAINS move_types%mv_weight(mv_type_mol_rot) > 0.0_dp) THEN ! if there is no molecule information available, ! molecules moves can not be performed - IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) THEN + IF (mol_array(SIZE(mol_array)) == SIZE(mol_array)) & CALL cp_abort(__LOCATION__, & "molecule move: there is no molecule "// & "information available. Please specify molecules when "// & "using molecule moves.") - END IF END IF ! for the atom swap move @@ -372,12 +363,11 @@ CONTAINS EXIT ref_loop END IF END DO ref_loop - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "ATOM_SWAP: The selected atom type ("// & TRIM(move_types%atom_lists(list_i)%atoms(atom_j))// & ") is not contained in the system. ") - END IF ! check if not be swapped with the same atom type IF (ANY(move_types%atom_lists(list_i)%atoms(atom_j) == & move_types%atom_lists(list_i)%atoms(atom_j + 1:))) THEN @@ -399,11 +389,10 @@ CONTAINS END IF END DO ref_lop END IF - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "The system contains only a single atom type,"// & " atom_swap is not possible.") - END IF END IF END IF END SUBROUTINE check_moves @@ -419,9 +408,8 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_params)) CALL move_types_release(tmc_params%move_types) - IF (ASSOCIATED(tmc_params%nmc_move_types)) THEN + IF (ASSOCIATED(tmc_params%nmc_move_types)) & CALL move_types_release(tmc_params%nmc_move_types) - END IF END SUBROUTINE finalize_mv_types ! ************************************************************************************************** @@ -772,9 +760,8 @@ CONTAINS CPASSERT(PRESENT(acc)) IF (PRESENT(subbox)) THEN ! only update subbox acceptance - IF (acc) THEN + IF (acc) & move_types%subbox_acc_count(mv_type, conf_moved) = move_types%subbox_acc_count(mv_type, conf_moved) + 1 - END IF move_types%subbox_count(mv_type, conf_moved) = move_types%subbox_count(mv_type, conf_moved) + 1 ! No more to do change_type = 0 @@ -803,9 +790,8 @@ CONTAINS END IF IF (conf_moved > 0) move_types%mv_count(0, conf_moved) = move_types%mv_count(0, conf_moved) + ABS(change_res) - IF (mv_type >= 0 .AND. conf_moved > 0) THEN + IF (mv_type >= 0 .AND. conf_moved > 0) & move_types%mv_count(mv_type, conf_moved) = move_types%mv_count(mv_type, conf_moved) + ABS(change_type) - END IF IF (prob_opt) THEN WHERE (move_types%mv_count > 0) & diff --git a/src/tmc/tmc_moves.F b/src/tmc/tmc_moves.F index a6e1aec153..3f24f4def5 100644 --- a/src/tmc/tmc_moves.F +++ b/src/tmc/tmc_moves.F @@ -124,9 +124,8 @@ CONTAINS ! rng_seed=elem%rng_seed, rng_seed_last_acc=last_acc_elem%rng_seed) !-- atom translation CASE (mv_type_atom_trans) - IF (act_nr_elem_mv == 0) THEN + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = SIZE(elem%pos)/tmc_params%dim_per_elem - END IF ALLOCATE (elem_center(tmc_params%dim_per_elem)) i = 1 move_elements_loop: DO @@ -168,9 +167,8 @@ CONTAINS CASE (mv_type_mol_trans) nr_molec = MAXVAL(elem%mol(:)) ! if all particles should be displaced, set the amount of molecules - IF (act_nr_elem_mv == 0) THEN + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = nr_molec - END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -183,9 +181,8 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) THEN + ) & mol_in_sb(m) = status_ok - END IF END DO ! displace the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -245,9 +242,8 @@ CONTAINS !-- molecule rotation CASE (mv_type_mol_rot) nr_molec = MAXVAL(elem%mol(:)) - IF (act_nr_elem_mv == 0) THEN + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = nr_molec - END IF ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) mol_in_sb(:) = status_frozen @@ -260,9 +256,8 @@ CONTAINS IF (check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & box_scale=elem%box_scale, tmc_params=tmc_params) & - ) THEN + ) & mol_in_sb(m) = status_ok - END IF END DO ! rotate the selected amount of molecules IF (ANY(mol_in_sb(:) == status_ok)) THEN @@ -708,18 +703,16 @@ CONTAINS CALL find_nearest_proton_acceptor_donator(elem=elem, mol=mol, & donor_acceptor=donor_acceptor, tmc_params=tmc_params, & rng_stream=rng_stream) - IF (ANY(mol_arr(:) == mol)) THEN + IF (ANY(mol_arr(:) == mol)) & EXIT chain_completition_loop - END IF mol_arr(counter) = mol END DO chain_completition_loop counter = counter - 1 ! last searched element is equal to one other in list ! just take the loop of molecules out of the chain DO k = 1, counter - IF (mol_arr(k) == mol) THEN + IF (mol_arr(k) == mol) & EXIT - END IF END DO mol_arr(1:counter - k + 1) = mol_arr(k:counter) counter = counter - k + 1 diff --git a/src/tmc/tmc_setup.F b/src/tmc/tmc_setup.F index f110e1c573..5c6ec41642 100644 --- a/src/tmc/tmc_setup.F +++ b/src/tmc/tmc_setup.F @@ -239,9 +239,8 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_energy_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CPABORT("creating force env result in error "//cp_to_string(ierr)) - END IF END IF ! worker for configurational change IF (tmc_env%params%NMC_inp_file /= "" .AND. & @@ -254,18 +253,15 @@ CONTAINS output_path=TRIM(expand_file_name_int(file_name=tmc_NMC_worker_out_file_name, & ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) - IF (ierr /= 0) THEN + IF (ierr /= 0) & CPABORT("creating approx force env result in error "//cp_to_string(ierr)) - END IF END IF CALL do_tmc_worker(tmc_env=tmc_env) ! start the worker routine - IF (tmc_env%w_env%env_id_ener > 0) THEN + IF (tmc_env%w_env%env_id_ener > 0) & CALL destroy_force_env(tmc_env%w_env%env_id_ener, ierr) - END IF - IF (tmc_env%w_env%env_id_approx > 0) THEN + IF (tmc_env%w_env%env_id_approx > 0) & CALL destroy_force_env(tmc_env%w_env%env_id_approx, ierr) - END IF CALL cp_rm_default_logger() CALL cp_logger_release(logger_sub) @@ -300,9 +296,8 @@ CONTAINS END DO CALL do_tmc_worker(tmc_env=tmc_env, ana_list=tmc_ana_env_list) ! start the worker routine for analysis DO i = 1, tmc_env%params%nr_temp - IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) THEN + IF (ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=tmc_ana_env_list(i)%temp%last_elem) - END IF CALL tmc_ana_env_release(tmc_ana_env_list(i)%temp) END DO DEALLOCATE (tmc_ana_env_list) @@ -406,19 +401,16 @@ CONTAINS CALL analysis_init(ana_env=ana_list(temp)%temp, nr_dim=nr_dim) ! to allocate the dipole array in tree elements IF (ana_list(temp)%temp%costum_dip_file_name /= & - tmc_default_unspecified_name) THEN + tmc_default_unspecified_name) & tmc_env%params%print_dipole = .TRUE. - END IF - IF (.NOT. ASSOCIATED(elem)) THEN + IF (.NOT. ASSOCIATED(elem)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=elem, nr_dim=nr_dim) - END IF CALL analysis_restart_read(ana_env=ana_list(temp)%temp, & elem=elem) - IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (.NOT. ASSOCIATED(elem) .AND. .NOT. ASSOCIATED(ana_list(temp)%temp%last_elem)) & CPABORT("uncorrect initialization of the initial configuration") - END IF ! do for all directories DO dir_ind = 1, SIZE(ana_list(temp)%temp%dirs) WRITE (output_unit, FMT='(T2,A,"| ",A,T41,A40)') "TMC_ANA", & @@ -432,31 +424,25 @@ CONTAINS ! remove the last saved element to start with a new file ! there is no weight for this element IF (dir_ind < SIZE(ana_list(temp)%temp%dirs) .AND. & - ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & ana_list(temp)%temp%conf_offset = ana_list(temp)%temp%conf_offset & + ana_list(temp)%temp%last_elem%nr - END IF END DO CALL finalize_tmc_analysis(ana_env=ana_list(temp)%temp) ! write analysis restart file ! if there is something to write ! shifts the last element to actual element - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL analysis_restart_print(ana_env=ana_list(temp)%temp) - END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - END IF - IF (ASSOCIATED(elem)) THEN + IF (ASSOCIATED(elem)) & CALL deallocate_sub_tree_node(tree_elem=elem) - END IF - IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) THEN + IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - END IF CALL tmc_ana_env_release(ana_list(temp)%temp) END DO @@ -513,9 +499,8 @@ CONTAINS CALL section_vals_val_get(tmc_section, "NR_TEMPERATURE", i_val=nr_temp) CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) THEN + IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) & CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") - END IF IF (nr_temp == 1) THEN nr_temp = SIZE(inp_Temp) ALLOCATE (Temps(nr_temp)) @@ -528,10 +513,9 @@ CONTAINS DO t_act = 2, SIZE(Temps) Temps(t_act) = Temps(t_act - 1) + (tmax - tmin)/(SIZE(Temps) - 1.0_dp) END DO - IF (ANY(Temps < 0.0_dp)) THEN + IF (ANY(Temps < 0.0_dp)) & CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") - END IF END IF ! get multiple directories @@ -612,15 +596,13 @@ CONTAINS CALL section_vals_val_get(tmc_section, "GROUP_ENERGY_NR", i_val=tmc_env%tmc_comp_set%group_ener_nr) CALL section_vals_val_get(tmc_section, "GROUP_CC_SIZE", i_val=tmc_env%tmc_comp_set%group_cc_size) CALL section_vals_val_get(tmc_section, "GROUP_ANALYSIS_NR", i_val=itmp) - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) THEN + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) & tmc_env%tmc_comp_set%ana_on_the_fly = itmp - END IF - IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) THEN + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 1) & CALL cp_abort(__LOCATION__, & "analysing on the fly is up to now not supported for multiple cores. "// & "Restart file witing for this case and temperature "// & "distribution has to be solved.!.") - END IF CALL section_vals_val_get(tmc_section, "RESULT_LIST_IN_MEMORY", l_val=tmc_env%params%USE_REDUCED_TREE) ! swap the variable, because of oposit meaning tmc_env%params%USE_REDUCED_TREE = .NOT. tmc_env%params%USE_REDUCED_TREE @@ -633,24 +615,21 @@ CONTAINS CPABORT("no or a valid NMC input file has to be specified ") ELSE IF (tmc_env%params%NMC_inp_file == "") THEN ! no keyword - IF (tmc_env%tmc_comp_set%group_cc_size > 0) THEN + IF (tmc_env%tmc_comp_set%group_cc_size > 0) & CALL cp_warn(__LOCATION__, & "The configurational groups are deactivated, "// & "because no approximated energy input is specified.") - END IF tmc_env%tmc_comp_set%group_cc_size = 0 ELSE ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%NMC_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) THEN + IF (.NOT. flag .OR. itmp /= 0) & CPABORT("a valid NMC input file has to be specified") - END IF END IF CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) THEN + IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) & CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") - END IF IF (tmc_env%params%nr_temp == 1) THEN tmc_env%params%nr_temp = SIZE(inp_Temp) ALLOCATE (tmc_env%params%Temp(tmc_env%params%nr_temp)) @@ -663,10 +642,9 @@ CONTAINS DO itmp = 2, SIZE(tmc_env%params%Temp) tmc_env%params%Temp(itmp) = tmc_env%params%Temp(itmp - 1) + (tmax - tmin)/(SIZE(tmc_env%params%Temp) - 1.0_dp) END DO - IF (ANY(tmc_env%params%Temp < 0.0_dp)) THEN + IF (ANY(tmc_env%params%Temp < 0.0_dp)) & CALL cp_abort(__LOCATION__, "The temperatures are negative. Should be specified using "// & "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}") - END IF END IF CALL section_vals_val_get(tmc_section, "TASK_TYPE", explicit=explicit_key) @@ -733,14 +711,13 @@ CONTAINS tmc_env%m_env%restart_out_file_name = tmc_default_restart_out_file_name tmc_env%m_env%restart_out_step = HUGE(tmc_env%m_env%restart_out_step) END IF - IF (tmc_env%m_env%restart_out_step < 0) THEN + IF (tmc_env%m_env%restart_out_step < 0) & CALL cp_abort(__LOCATION__, & "Please specify a valid value for the frequency "// & "to write restart files (RESTART_OUT #). "// & "# > 0 to define the amount of Markov chain elements in between, "// & "or 0 to deactivate the restart file writing. "// & "Lonely keyword writes restart file only at the end of the run.") - END IF CALL section_vals_val_get(tmc_section, "INFO_OUT_STEP_SIZE", i_val=tmc_env%m_env%info_out_step_size) CALL section_vals_val_get(tmc_section, "DOT_TREE", c_val=tmc_env%params%dot_file_name) @@ -757,15 +734,13 @@ CONTAINS ! the NMC_FILE_NAME is already read in tmc_preread_input CALL section_vals_val_get(tmc_section, "ENERGY_FILE_NAME", c_val=tmc_env%params%energy_inp_file) ! file name keyword without file name - IF (tmc_env%params%energy_inp_file == "") THEN + IF (tmc_env%params%energy_inp_file == "") & CPABORT("a valid exact energy input file has to be specified ") - END IF ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%energy_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp /= 0) THEN + IF (.NOT. flag .OR. itmp /= 0) & CALL cp_abort(__LOCATION__, "a valid exact energy input file has to be specified, "// & TRIM(tmc_env%params%energy_inp_file)//" does not exist.") - END IF CALL section_vals_val_get(tmc_section, "NUM_MV_ELEM_IN_CELL", i_val=tmc_env%params%nr_elem_mv) @@ -776,12 +751,10 @@ CONTAINS CALL section_vals_val_get(tmc_section, "SUB_BOX", r_vals=r_arr_tmp) IF (SIZE(r_arr_tmp) > 1) THEN - IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) THEN + IF (SIZE(r_arr_tmp) /= tmc_env%params%dim_per_elem) & CPABORT("The entered sub box sizes does not fit in number of dimensions.") - END IF - IF (ANY(r_arr_tmp <= 0.0_dp)) THEN + IF (ANY(r_arr_tmp <= 0.0_dp)) & CPABORT("The entered sub box lengths should be greater than 0.") - END IF DO itmp = 1, SIZE(tmc_env%params%sub_box_size) tmc_env%params%sub_box_size(itmp) = r_arr_tmp(itmp)/au2a END DO @@ -801,17 +774,14 @@ CONTAINS CALL section_vals_val_get(tmc_section, "PRINT_ONLY_ACC", l_val=tmc_env%params%print_only_diff_conf) CALL section_vals_val_get(tmc_section, "PRINT_COORDS", l_val=tmc_env%params%print_trajectory) CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", explicit=explicit) - IF (explicit) THEN + IF (explicit) & CALL section_vals_val_get(tmc_section, "PRINT_DIPOLE", l_val=tmc_env%params%print_dipole) - END IF CALL section_vals_val_get(tmc_section, "PRINT_FORCES", explicit=explicit) - IF (explicit) THEN + IF (explicit) & CALL section_vals_val_get(tmc_section, "PRINT_FORCES", l_val=tmc_env%params%print_forces) - END IF CALL section_vals_val_get(tmc_section, "PRINT_CELL", explicit=explicit) - IF (explicit) THEN + IF (explicit) & CALL section_vals_val_get(tmc_section, "PRINT_CELL", l_val=tmc_env%params%print_cell) - END IF CALL section_vals_val_get(tmc_section, "PRINT_ENERGIES", l_val=tmc_env%params%print_energies) END SUBROUTINE tmc_read_input @@ -880,10 +850,9 @@ CONTAINS - tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr)/ & REAL(tmc_comp_set%group_cc_size, KIND=dp)) - IF (tmc_comp_set%group_cc_nr < 1) THEN + IF (tmc_comp_set%group_cc_nr < 1) & CALL cp_warn(__LOCATION__, & "There are not enougth cores left for creating groups for configurational change.") - END IF IF (flag) success = .FALSE. END IF @@ -1041,10 +1010,9 @@ CONTAINS WRITE (file_nr, FMT=fmt_my) plabel, "cores per group (ener|cc) ", & cp_to_string(tmc_env%tmc_comp_set%group_ener_size)//" | "// & cp_to_string(tmc_env%tmc_comp_set%group_cc_size) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & WRITE (file_nr, FMT=fmt_my) plabel, "Analysis groups ", & - cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) - END IF + cp_to_string(tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1) IF (SIZE(tmc_env%params%Temp(:)) <= 7) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" @@ -1058,20 +1026,18 @@ CONTAINS cp_to_string(tmc_env%m_env%num_MC_elem) WRITE (file_nr, FMT=fmt_my) plabel, "exact potential input file:", & TRIM(tmc_env%params%energy_inp_file) - IF (tmc_env%params%NMC_inp_file /= "") THEN + IF (tmc_env%params%NMC_inp_file /= "") & WRITE (file_nr, FMT=fmt_my) plabel, "approximate potential input file:", & - TRIM(tmc_env%params%NMC_inp_file) - END IF + TRIM(tmc_env%params%NMC_inp_file) IF (ANY(tmc_env%params%sub_box_size > 0.0_dp)) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" WRITE (c_tmp, FMT="(1000F8.2)") tmc_env%params%sub_box_size(:)*au2a WRITE (file_nr, FMT=fmt_tmp) plabel, "Sub box size [A]", TRIM(c_tmp) END IF - IF (tmc_env%params%pressure > 0.0_dp) THEN + IF (tmc_env%params%pressure > 0.0_dp) & WRITE (file_nr, FMT=fmt_my) plabel, "Pressure [bar]: ", & - cp_to_string(tmc_env%params%pressure*au2bar) - END IF + cp_to_string(tmc_env%params%pressure*au2bar) WRITE (file_nr, FMT=fmt_my) plabel, "Numbers of atoms/molecules moved " WRITE (file_nr, FMT=fmt_my) plabel, " within one conf. change", & cp_to_string(tmc_env%params%nr_elem_mv) diff --git a/src/tmc/tmc_tree_acceptance.F b/src/tmc/tmc_tree_acceptance.F index 8a72ab56e6..939f31563c 100644 --- a/src/tmc/tmc_tree_acceptance.F +++ b/src/tmc/tmc_tree_acceptance.F @@ -490,10 +490,9 @@ CONTAINS END IF END IF - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot_color(gt_tree_element=tmp_gt_list_ptr%gt_elem, & tmc_params=tmc_env%params) - END IF END IF tmp_gt_list_ptr => tmp_gt_list_ptr%next END DO @@ -547,9 +546,8 @@ CONTAINS cp_to_string(stat)) END SELECT - IF (tmc_params%DRAW_TREE) THEN + IF (tmc_params%DRAW_TREE) & CALL create_dot_color(tree_element=ptr, tmc_params=tmc_params) - END IF END IF ! end the timing @@ -687,9 +685,8 @@ CONTAINS !-- hence new configurations can be created on basis of this configuration CASE (status_calculate_MD, status_calculate_NMC_steps, status_calculate_energy, & status_created, status_calc_approx_ener) - IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) THEN + IF (gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat /= gt_act_elem%stat) & gt_act_elem%stat = gt_act_elem%conf(gt_act_elem%mv_conf)%elem%stat - END IF CASE (status_calculated) CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -757,10 +754,9 @@ CONTAINS tmc_env%m_env%result_count(gt_act_elem%mv_conf) + 1 ! in case of swapped also count the result for ! the other swapped temperature - IF (gt_act_elem%swaped) THEN + IF (gt_act_elem%swaped) & tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) = & - tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 - END IF + tmc_env%m_env%result_count(gt_act_elem%mv_conf + 1) + 1 ! count also for global tree Markov Chain tmc_env%m_env%result_count(0) = tmc_env%m_env%result_count(0) + 1 @@ -820,16 +816,14 @@ CONTAINS END IF ! result acceptance check !====================================================================== !-- set status accepted or rejected of certain subtree elements - IF (.NOT. gt_act_elem%swaped) THEN + IF (.NOT. gt_act_elem%swaped) & CALL subtree_configuration_stat_change(gt_ptr=gt_act_elem, & stat=gt_act_elem%stat, & tmc_params=tmc_env%params) - END IF - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot_color(gt_tree_element=gt_act_elem, & tmc_params=tmc_env%params) - END IF ! probability update CALL prob_update(move_types=tmc_env%params%move_types, & @@ -841,12 +835,11 @@ CONTAINS result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf, accepted=result_acc, & tmc_params=tmc_env%params) - IF (gt_act_elem%swaped) THEN + IF (gt_act_elem%swaped) & CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & result_count=tmc_env%m_env%result_count, & conf_updated=gt_act_elem%mv_conf + 1, accepted=result_acc, & tmc_params=tmc_env%params) - END IF ! save for analysis IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe > 1 .AND. result_acc) THEN @@ -886,9 +879,8 @@ CONTAINS ready = .FALSE. IF ((elem%scf_energies_count >= 4) & .AND. (elem%stat /= status_deleted) .AND. (elem%stat /= status_deleted_result) & - .AND. (elem%stat /= status_canceled_ener)) THEN + .AND. (elem%stat /= status_canceled_ener)) & ready = .TRUE. - END IF END FUNCTION ready_for_update_acc_prob ! ************************************************************************************************** @@ -1040,10 +1032,9 @@ CONTAINS IF (tmp_prob >= 0.0_dp) THEN tmp_pt_ptr%gt_elem%prob_acc = tmp_prob !-- speculative canceling for the related direction - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & CALL search_canceling_elements(pt_elem_in=tmp_pt_ptr%gt_elem, & prob=tmp_pt_ptr%gt_elem%prob_acc, tmc_env=tmc_env) - END IF END IF ! get next related global tree pointer diff --git a/src/tmc/tmc_tree_build.F b/src/tmc/tmc_tree_build.F index 62a319f9c0..cea018160d 100644 --- a/src/tmc/tmc_tree_build.F +++ b/src/tmc/tmc_tree_build.F @@ -364,11 +364,10 @@ CONTAINS ! simulated annealing start temperature global_tree%Temp = tmc_env%params%Temp(1) - IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) THEN + IF (tmc_env%params%nr_temp /= 1 .AND. tmc_env%m_env%temp_decrease /= 1.0_dp) & CALL cp_abort(__LOCATION__, & "there is no parallel tempering implementation for simulated annealing implemented "// & "(just one Temp per global tree element.") - END IF !-- IF program is restarted, read restart file IF (tmc_env%m_env%restart_in_file_name /= "") THEN @@ -441,12 +440,10 @@ CONTAINS !-- distribute energy of first element to all subtrees DO i = 1, SIZE(gt_tree_ptr%conf) gt_tree_ptr%conf(i)%elem%stat = status_accepted_result - IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) THEN + IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) & gt_tree_ptr%conf(i)%elem%dipole = gt_tree_ptr%conf(1)%elem%dipole - END IF - IF (tmc_env%m_env%restart_in_file_name == "") THEN + IF (tmc_env%m_env%restart_in_file_name == "") & gt_tree_ptr%conf(i)%elem%potential = gt_tree_ptr%conf(1)%elem%potential - END IF END DO IF (tmc_env%m_env%restart_in_file_name == "") THEN @@ -541,12 +538,10 @@ CONTAINS ((.NOT. n_acc) .AND. ASSOCIATED(tmp_elem%nacc))) THEN !set pointer to the actual element - IF (n_acc) THEN + IF (n_acc) & new_elem => tmp_elem%acc - END IF - IF (.NOT. n_acc) THEN + IF (.NOT. n_acc) & new_elem => tmp_elem%nacc - END IF ! check for existing subtree element CPASSERT(ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem)) @@ -575,11 +570,10 @@ CONTAINS CASE (mv_type_MD) new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_MD CASE (mv_type_NMC_moves) - IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) THEN + IF (new_elem%conf(new_elem%mv_conf)%elem%stat /= status_canceled_nmc) & CALL cp_warn(__LOCATION__, & "reactivating tree element with wrong status"// & cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat)) - END IF new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_NMC_steps !IF(DEBUG>=1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", & @@ -605,14 +599,12 @@ CONTAINS !-- set pointers to and from element one level up !-- paste new gt tree node element at right end IF (n_acc) THEN - IF (ASSOCIATED(tmp_elem%acc)) THEN + IF (ASSOCIATED(tmp_elem%acc)) & CPABORT("creating new subtree element on an occupied acc branch") - END IF tmp_elem%acc => new_elem ELSE - IF (ASSOCIATED(tmp_elem%nacc)) THEN + IF (ASSOCIATED(tmp_elem%nacc)) & CPABORT("creating new subtree element on an occupied nacc branch") - END IF tmp_elem%nacc => new_elem END IF new_elem%parent => tmp_elem @@ -695,10 +687,9 @@ CONTAINS new_elem%prob_acc = tmc_env%params%move_types%acc_prob( & mv_type_swap_conf, new_elem%mv_conf) CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) - END IF ! nothing to do for the workers stat = status_calculated keep_on = .FALSE. @@ -719,11 +710,10 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) - END IF END IF ELSE !-- check if child element in REJECTED direction already exist @@ -735,11 +725,10 @@ CONTAINS !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & tmc_env=tmc_env) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, & conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, & tmc_params=tmc_env%params) - END IF END IF END IF ! set approximate probability of acceptance @@ -749,10 +738,9 @@ CONTAINS new_elem%conf(new_elem%mv_conf)%elem%move_type, new_elem%mv_conf) ! add refence and dot CALL add_to_references(gt_elem=new_elem) - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot(new_element=new_elem, & tmc_params=tmc_env%params) - END IF END IF ! swap or no swap END IF ! global tree node already exist. Hence the Subtree node also (it is speculative canceled) END IF ! keep on (checking and creating) @@ -761,9 +749,8 @@ CONTAINS IF (new_elem%stat == status_accepted_result .OR. & new_elem%stat == status_accepted .OR. & new_elem%stat == status_rejected .OR. & - new_elem%stat == status_rejected_result) THEN + new_elem%stat == status_rejected_result) & CPABORT("selected existing RESULT gt node") - END IF !-- set status of global tree element for decision in master routine SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%stat) CASE (status_rejected_result, status_rejected, status_accepted, & @@ -771,18 +758,16 @@ CONTAINS ! energy is already calculated new_elem%stat = status_calculated stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF CASE (status_calc_approx_ener) new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF END IF CASE (status_calculate_MD, status_calculate_energy, & status_calculate_NMC_steps, status_created) @@ -790,10 +775,9 @@ CONTAINS new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF END IF CASE (status_cancel_ener, status_canceled_ener) ! configuration is already created, @@ -803,10 +787,9 @@ CONTAINS ! creation complete, handle energy calculation at a different position ! (for different worker group) stat = status_calculated - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF CASE (status_cancel_nmc, status_canceled_nmc) ! reactivation canceled element (but with new global tree element) new_elem%conf(new_elem%mv_conf)%elem%stat = & @@ -814,10 +797,9 @@ CONTAINS new_elem%stat = status_calculate_NMC_steps stat = new_elem%conf(new_elem%mv_conf)%elem%stat reactivation_cc_count = reactivation_cc_count + 1 - IF (tmc_env%params%DRAW_TREE) THEN + IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & tmc_params=tmc_env%params) - END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & "unknown stat "// & @@ -971,9 +953,8 @@ CONTAINS new_elem%stat = status_calculated ELSE new_elem%stat = status_created - IF (tmc_env%params%NMC_inp_file /= "") THEN + IF (tmc_env%params%NMC_inp_file /= "") & new_elem%stat = status_calc_approx_ener - END IF END IF CASE (mv_type_gausian_adapt) ! still could be implemented @@ -1023,9 +1004,8 @@ CONTAINS ELSE gt_ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & CALL create_global_tree_dot_color(gt_tree_element=gt_ptr, tmc_params=tmc_env%params) - END IF !remove pointer from tree parent IF (ASSOCIATED(gt_ptr%parent)) THEN @@ -1080,13 +1060,12 @@ CONTAINS ! if there is still e reference to a global tree pointer, do not deallocate element IF (ASSOCIATED(ptr%gt_nodes_references)) THEN - IF (ASSOCIATED(ptr%parent)) THEN + IF (ASSOCIATED(ptr%parent)) & CALL cp_warn(__LOCATION__, & "try to deallocate subtree element"// & cp_to_string(ptr%sub_tree_nr)//cp_to_string(ptr%nr)// & " still with global tree element references e.g."// & cp_to_string(ptr%gt_nodes_references%gt_elem%nr)) - END IF CPASSERT(ASSOCIATED(ptr%gt_nodes_references%gt_elem)) ELSE SELECT CASE (ptr%stat) @@ -1116,9 +1095,8 @@ CONTAINS ELSE ptr%stat = status_deleted END IF - IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) THEN + IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & CALL create_dot_color(tree_element=ptr, tmc_params=tmc_env%params) - END IF !remove pointer from tree parent IF (ASSOCIATED(ptr%parent)) THEN @@ -1298,21 +1276,19 @@ CONTAINS ! delete element IF (remove_this) THEN !-- mark as deleted and draw it in tree - IF (.NOT. ASSOCIATED(begin_ptr%parent)) THEN + IF (.NOT. ASSOCIATED(begin_ptr%parent)) & CALL cp_abort(__LOCATION__, & "try to remove unused subtree element "// & cp_to_string(begin_ptr%sub_tree_nr)//" "// & cp_to_string(begin_ptr%nr)// & " but parent does not exist") - END IF tmp_ptr => begin_ptr ! check if a working group is still working on this element removed = .TRUE. DO i = 1, SIZE(working_elem_list(:)) IF (ASSOCIATED(working_elem_list(i)%elem)) THEN - IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) THEN + IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) & removed = .FALSE. - END IF END IF END DO IF (removed) THEN @@ -1357,11 +1333,10 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) THEN + IF (ASSOCIATED(actual_ptr%parent)) & CALL remove_result_g_tree(end_of_clean_tree=end_of_clean_tree, & actual_ptr=actual_ptr%parent, & tmc_env=tmc_env) - END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN !-- deallocate node @@ -1401,10 +1376,9 @@ CONTAINS CALL timeset(routineN, handle) !-- going up to the head ot the subtree - IF (ASSOCIATED(actual_ptr%parent)) THEN + IF (ASSOCIATED(actual_ptr%parent)) & CALL remove_result_s_tree(end_of_clean_tree, actual_ptr%parent, & tmc_env) - END IF !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN @@ -1472,9 +1446,8 @@ CONTAINS actual_ptr=tmp_gt_ptr, tmc_env=tmc_env) !check if something changed, if not no deallocation of result subtree necessary - IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) THEN + IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) & change_trajec = .TRUE. - END IF tmc_env%m_env%gt_head => tmc_env%m_env%gt_clean_end CPASSERT(.NOT. ASSOCIATED(tmc_env%m_env%gt_head%parent)) !IF (DEBUG>=20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr @@ -1486,9 +1459,8 @@ CONTAINS ! get last checked element in trajectory related to the subtree (resultlist order is NOT subtree order) conf_loop: DO i = 1, SIZE(tmc_env%m_env%result_list) last_acc_st_elem => tmc_env%m_env%result_list(i)%elem - IF (last_acc_st_elem%sub_tree_nr == tree) THEN + IF (last_acc_st_elem%sub_tree_nr == tree) & EXIT conf_loop - END IF END DO conf_loop CPASSERT(last_acc_st_elem%sub_tree_nr == tree) CALL remove_unused_s_tree(begin_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, & diff --git a/src/tmc/tmc_tree_search.F b/src/tmc/tmc_tree_search.F index a2371f3447..5de61a8f44 100644 --- a/src/tmc/tmc_tree_search.F +++ b/src/tmc/tmc_tree_search.F @@ -721,12 +721,10 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) THEN + IF (ASSOCIATED(ptr%acc)) & CALL count_nodes_in_global_tree(ptr%acc, counter) - END IF - IF (ASSOCIATED(ptr%nacc)) THEN + IF (ASSOCIATED(ptr%nacc)) & CALL count_nodes_in_global_tree(ptr%nacc, counter) - END IF END SUBROUTINE count_nodes_in_global_tree ! ************************************************************************************************** @@ -743,11 +741,9 @@ CONTAINS counter = counter + 1 - IF (ASSOCIATED(ptr%acc)) THEN + IF (ASSOCIATED(ptr%acc)) & CALL count_nodes_in_tree(ptr%acc, counter) - END IF - IF (ASSOCIATED(ptr%nacc)) THEN + IF (ASSOCIATED(ptr%nacc)) & CALL count_nodes_in_tree(ptr%nacc, counter) - END IF END SUBROUTINE count_nodes_in_tree END MODULE tmc_tree_search diff --git a/src/tmc/tmc_types.F b/src/tmc/tmc_types.F index b7884be56f..02292e1c68 100644 --- a/src/tmc/tmc_types.F +++ b/src/tmc/tmc_types.F @@ -216,28 +216,22 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env%params)) DEALLOCATE (tmc_env%params%sub_box_size) - IF (ASSOCIATED(tmc_env%params%Temp)) THEN + IF (ASSOCIATED(tmc_env%params%Temp)) & DEALLOCATE (tmc_env%params%Temp) - END IF - IF (ASSOCIATED(tmc_env%params%cell)) THEN + IF (ASSOCIATED(tmc_env%params%cell)) & DEALLOCATE (tmc_env%params%cell) - END IF - IF (ASSOCIATED(tmc_env%params%atoms)) THEN + IF (ASSOCIATED(tmc_env%params%atoms)) & CALL deallocate_tmc_atom_type(tmc_env%params%atoms) - END IF DEALLOCATE (tmc_env%params) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_sub_group) CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_w) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_first_w) - END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) & CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_ana) - END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only)) & CALL mp_para_env_release(tmc_env%tmc_comp_set%para_env_m_only) - END IF DEALLOCATE (tmc_env%tmc_comp_set) @@ -287,9 +281,8 @@ CONTAINS DO i = 1, tmc_env%params%nr_temp tmc_env%m_env%st_heads(i)%elem => NULL() tmc_env%m_env%st_clean_ends(i)%elem => NULL() - IF (tmc_env%params%USE_REDUCED_TREE) THEN + IF (tmc_env%params%USE_REDUCED_TREE) & tmc_env%m_env%result_list(i)%elem => NULL() - END IF END DO tmc_env%m_env%gt_head => NULL() tmc_env%m_env%gt_clean_end => NULL() diff --git a/src/tmc/tmc_worker.F b/src/tmc/tmc_worker.F index bdc50bb514..2e2204d988 100644 --- a/src/tmc/tmc_worker.F +++ b/src/tmc/tmc_worker.F @@ -167,15 +167,13 @@ CONTAINS END IF ! set the communicator in the external control for receiving exit tags ! and sending additional information (e.g. the intermediate scf energies) - IF (tmc_env%params%use_scf_energy_info) THEN + IF (tmc_env%params%use_scf_energy_info) & CALL set_intermediate_info_comm(env_id=itmp, & comm=tmc_env%tmc_comp_set%para_env_m_w) - END IF - IF (tmc_env%params%SPECULATIVE_CANCELING) THEN + IF (tmc_env%params%SPECULATIVE_CANCELING) & CALL set_external_comm(comm=tmc_env%tmc_comp_set%para_env_m_w, & in_external_master_id=MASTER_COMM_ID, & in_exit_tag=TMC_CANCELING_MESSAGE) - END IF END IF !-- WORKING LOOP --! master_work_time: DO @@ -189,10 +187,9 @@ CONTAINS result_count=ana_restart_conf, & tmc_params=tmc_env%params, elem=conf) - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & WRITE (tmc_env%w_env%io_unit, *) "worker: group master of group ", & - tmc_env%tmc_comp_set%group_nr, "got task ", work_stat - END IF + tmc_env%tmc_comp_set%group_nr, "got task ", work_stat calc_stat = TMC_STATUS_CALCULATING SELECT CASE (work_stat) CASE (TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -211,10 +208,9 @@ CONTAINS para_env=para_env_m_w, & tmc_params=tmc_env%params) CASE (TMC_STATUS_FAILED) - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%w_env%io_unit, *) "master worker of group", & - tmc_env%tmc_comp_set%group_nr, " exit work time." - END IF + tmc_env%tmc_comp_set%group_nr, " exit work time." EXIT master_work_time !-- group master read the CP2K input file, and write data to master CASE (TMC_STAT_START_CONF_REQUEST) @@ -234,11 +230,10 @@ CONTAINS tmc_params=tmc_env%params, elem=conf, & wait_for_message=.TRUE.) - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w)) & CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & para_env=tmc_env%tmc_comp_set%para_env_m_first_w) - END IF !-- calculate the approximate energy CASE (TMC_STAT_APPROX_ENERGY_REQUEST) CPASSERT(tmc_env%w_env%env_id_approx > 0) @@ -272,7 +267,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -344,11 +339,10 @@ CONTAINS res_exist=flag, ierr=ierr) IF (.NOT. flag) tmc_env%params%print_dipole = .FALSE. ! TODO maybe let run with the changed option, but inform user properly - IF (.NOT. flag) THEN + IF (.NOT. flag) & CALL cp_abort(__LOCATION__, & "TMC: The requested dipoles are not porvided by the "// & "force environment.") - END IF END IF CASE DEFAULT CALL cp_abort(__LOCATION__, & @@ -364,11 +358,10 @@ CONTAINS END SELECT !-- send information back to master - IF (DEBUG >= 1) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%w_env%io_unit, *) "worker group ", & - tmc_env%tmc_comp_set%group_nr, & - "calculations done, send result energy", conf%potential - END IF + tmc_env%tmc_comp_set%group_nr, & + "calculations done, send result energy", conf%potential itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & @@ -393,10 +386,9 @@ CONTAINS CALL analysis_init(ana_env=ana_list(itmp)%temp, nr_dim=num_dim) ana_list(itmp)%temp%print_test_output = tmc_env%params%print_test_output - IF (.NOT. ASSOCIATED(conf)) THEN + IF (.NOT. ASSOCIATED(conf)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & next_el=conf, nr_dim=num_dim) - END IF CALL analysis_restart_read(ana_env=ana_list(itmp)%temp, & elem=conf) !check if we have the read the file @@ -446,14 +438,12 @@ CONTAINS cp_to_string(work_stat)) END SELECT - IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (DEBUG >= 1 .AND. work_stat /= TMC_STATUS_WAIT_FOR_NEW_TASK) & WRITE (tmc_env%w_env%io_unit, *) "worker: group ", & - tmc_env%tmc_comp_set%group_nr, & - "send back status:", work_stat - END IF - IF (ASSOCIATED(conf)) THEN + tmc_env%tmc_comp_set%group_nr, & + "send back status:", work_stat + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=conf) - END IF END DO master_work_time !-- every other group paricipants---------------------------------------- ELSE @@ -499,7 +489,7 @@ CONTAINS CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSE IF (work_stat == TMC_STAT_MD_REQUEST) THEN + ELSEIF (work_stat == TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CPABORT("there is no Hybrid MC implemented yet.") @@ -526,9 +516,8 @@ CONTAINS "group participant got unknown working type "// & cp_to_string(work_stat)) END SELECT - IF (ASSOCIATED(conf)) THEN + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=conf) - END IF END DO worker_work_time END IF ! -------------------------------------------------------------------- @@ -536,9 +525,8 @@ CONTAINS IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana)) THEN DO itmp = 1, tmc_env%params%nr_temp CALL analysis_restart_print(ana_env=ana_list(itmp)%temp) - IF (ASSOCIATED(conf)) THEN + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(itmp)%temp%last_elem) - END IF CALL finalize_tmc_analysis(ana_list(itmp)%temp) END DO END IF @@ -558,10 +546,9 @@ CONTAINS CALL remove_intermediate_info_comm(env_id=itmp) END IF END IF - IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) THEN + IF (ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) & CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_sub_group, & tmc_params=tmc_env%params) - END IF work_stat = TMC_STATUS_STOP_RECEIPT itmp = MASTER_COMM_ID @@ -576,11 +563,10 @@ CONTAINS tmc_params=tmc_env%params) END IF - IF (DEBUG >= 5) THEN + IF (DEBUG >= 5) & WRITE (tmc_env%w_env%io_unit, *) "worker ", & - tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & - tmc_env%tmc_comp_set%group_nr, "stops working!" - END IF + tmc_env%tmc_comp_set%para_env_sub_group%mepos, "of group ", & + tmc_env%tmc_comp_set%group_nr, "stops working!" IF (PRESENT(ana_list)) THEN DO itmp = 1, tmc_env%params%nr_temp @@ -588,9 +574,8 @@ CONTAINS ana_list(itmp)%temp%cell => NULL() END DO END IF - IF (ASSOCIATED(conf)) THEN + IF (ASSOCIATED(conf)) & CALL deallocate_sub_tree_node(tree_elem=conf) - END IF IF (ASSOCIATED(ana_restart_conf)) DEALLOCATE (ana_restart_conf) ! end the timing @@ -887,11 +872,10 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & CALL cp_abort(__LOCATION__, & "the intermediate SCF energy request can not be set "// & "employing this force environment! ") - END IF ! set the information values(1) = REAL(comm%get_handle(), KIND=dp) @@ -926,11 +910,10 @@ CONTAINS CPASSERT(ASSOCIATED(f_env)) CPASSERT(ASSOCIATED(f_env%force_env)) - IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) THEN + IF (.NOT. ASSOCIATED(f_env%force_env%qs_env)) & CALL cp_abort(__LOCATION__, & "the SCF intermediate energy communicator can not be "// & "removed! ") - END IF description = "[EXT_SCF_ENER_COMM]" diff --git a/src/topology.F b/src/topology.F index e482a1cb4c..b82782ec0a 100644 --- a/src/topology.F +++ b/src/topology.F @@ -548,12 +548,11 @@ CONTAINS "connectivity type.") END SELECT END DO - IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) THEN + IF (SIZE(topology%atom_info%id_molname) /= topology%natoms) & CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") - END IF ! Merge defined structures section => section_vals_get_subs_vals(subsys_section, "TOPOLOGY%MOL_SET%MERGE_MOLECULES") @@ -661,9 +660,8 @@ CONTAINS i_val=topology%natoms) CALL timestop(handle2) ! Check on atom numbers - IF (topology%natoms <= 0) THEN + IF (topology%natoms <= 0) & CPABORT("No atomic coordinates have been found! ") - END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & "PRINT%TOPOLOGY_INFO") diff --git a/src/topology_amber.F b/src/topology_amber.F index 10425ea382..8f9bbc4361 100644 --- a/src/topology_amber.F +++ b/src/topology_amber.F @@ -184,9 +184,8 @@ CONTAINS END DO ! Trigger error IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) THEN + IF (j /= natom) & CPABORT("Error while reading CRD file. Unexpected end of file.") - END IF ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom j = natom @@ -231,11 +230,10 @@ CONTAINS END DO setup_velocities = .TRUE. IF ((my_end) .AND. (j /= natom - MOD(natom, 2) + 1)) THEN - IF (j /= natom) THEN + IF (j /= natom) & CALL cp_warn(__LOCATION__, & "No VELOCITY information found in CRD file. Ignoring BOX information. "// & "Please provide the BOX information directly from the main CP2K input! ") - END IF setup_velocities = .FALSE. ELSE IF (MOD(natom, 2) /= 0) THEN ! In case let's handle the last atom @@ -259,11 +257,10 @@ CONTAINS IF (my_end) THEN CPWARN_IF(j /= natom, "BOX information missing in CRD file.") ELSE - IF (j /= natom) THEN + IF (j /= natom) & CALL cp_warn(__LOCATION__, & "BOX information found in CRD file. They will be ignored. "// & "Please provide the BOX information directly from the main CP2K input!") - END IF END IF CALL parser_release(parser) CALL cp_print_key_finished_output(iw, logger, subsys_section, & @@ -1063,18 +1060,16 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i1 ! ************************************************************************************************** @@ -1101,30 +1096,26 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i3 ! ************************************************************************************************** @@ -1152,36 +1143,31 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i4 ! ************************************************************************************************** @@ -1211,42 +1197,36 @@ CONTAINS i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) !array1 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) !array2 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array2(i)) !array3 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array3(i)) !array4 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array4(i)) !array5 - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array5(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_i5 ! ************************************************************************************************** @@ -1270,18 +1250,16 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i), lower_to_upper=.TRUE.) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_c1 ! ************************************************************************************************** @@ -1305,18 +1283,16 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) i = 1 DO WHILE ((i <= dim) .AND. (.NOT. my_end)) - IF (parser_test_next_token(parser) == "EOL") THEN + IF (parser_test_next_token(parser) == "EOL") & CALL parser_get_next_line(parser, 1, at_end=my_end) - END IF IF (my_end) EXIT CALL parser_get_object(parser, array1(i)) i = i + 1 END DO ! Trigger end of file aborting - IF (my_end .AND. (i <= dim)) THEN + IF (my_end .AND. (i <= dim)) & CALL cp_abort(__LOCATION__, & "End of file while reading section "//TRIM(section)//" in amber topology file!") - END IF END SUBROUTINE rd_amber_section_r1 ! ************************************************************************************************** @@ -1345,9 +1321,8 @@ CONTAINS section = TRIM(parser%input_line(indflag:)) ! Input format CALL parser_get_next_line(parser, 1, at_end=my_end) - IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) THEN + IF (INDEX(parser%input_line, "%FORMAT") == 0 .OR. my_end) & CPABORT("Expecting %FORMAT. Not found! Abort reading of AMBER topology file!") - END IF start_f = INDEX(parser%input_line, "(") end_f = INDEX(parser%input_line, ")") @@ -1371,11 +1346,10 @@ CONTAINS LOGICAL :: found_AMBER_V8 CALL parser_search_string(parser, "%VERSION ", .TRUE., found_AMBER_V8, begin_line=.TRUE.) - IF (.NOT. found_AMBER_V8) THEN + IF (.NOT. found_AMBER_V8) & CALL cp_abort(__LOCATION__, & "This is not an AMBER V.8 PRMTOP format file. Cannot interpret older "// & "AMBER file formats. ") - END IF IF (output_unit > 0) WRITE (output_unit, '(" AMBER_INFO| ",A)') "Amber PrmTop V.8 or greater.", & TRIM(parser%input_line) diff --git a/src/topology_cif.F b/src/topology_cif.F index eb3f9250f3..0100632559 100644 --- a/src/topology_cif.F +++ b/src/topology_cif.F @@ -249,10 +249,9 @@ CONTAINS CALL parser_search_string(parser, "_space_group_symop_operation_xyz", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) END IF - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_warn(__LOCATION__, "The fields (_symmetry_equiv_pos_as_xyz) or "// & "(_space_group_symop_operation_xyz) were not found in CIF file!") - END IF IF (iw > 0) WRITE (iw, '(A,I0)') " CIF_INFO| Number of atoms before applying symmetry operations :: ", natom IF (iw > 0) WRITE (iw, '(A10,1X,3F12.6)') (TRIM(id2str(atom_info%id_atmname(ii))), atom_info%r(1:3, ii), ii=1, natom) isym = 0 @@ -291,6 +290,7 @@ CONTAINS DO jj = 1, natom r2 = atom_info%r(1:3, jj) r = pbc(r1 - r2, cell) + ! SQRT(DOT_PRODUCT(r, r)) <= threshold IF (DOT_PRODUCT(r, r) <= (threshold*threshold)) THEN check = .FALSE. EXIT diff --git a/src/topology_connectivity_util.F b/src/topology_connectivity_util.F index 7518b6dfc0..8506ee4119 100644 --- a/src/topology_connectivity_util.F +++ b/src/topology_connectivity_util.F @@ -74,7 +74,7 @@ CONTAINS inter_bends, inter_bonds, inter_imprs, inter_torsions, inter_ubs, intra_bends, & intra_bonds, intra_imprs, intra_torsions, intra_ubs, inum, ires, istart_mol, istart_typ, & itorsion, ityp, iub, iw, j, j1, j2, j3, j4, jind, last, min_index, natom, nelectron, & - nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit + nsgf, nval_tot1, nval_tot2, nvar1, nvar2, output_unit, stat INTEGER, DIMENSION(:), POINTER :: c_var_a, c_var_b, c_var_c, c_var_d, c_var_type, & first_list, last_list, map_atom_mol, map_atom_type, map_cvar_mol, map_cvars, map_var_mol, & map_vars, molecule_list @@ -225,7 +225,7 @@ CONTAINS found = .TRUE. found_last = .FALSE. imol = ABS(map_atom_mol(i)) - ELSE IF (ikind == topology%nmol_type) THEN + ELSEIF (ikind == topology%nmol_type) THEN found = .TRUE. found_last = .TRUE. imol = ABS(map_atom_mol(natom)) @@ -1057,8 +1057,9 @@ CONTAINS END IF molecule_kind => molecule_kind_set(i) nval_tot2 = nval_tot2 + iimpr*SIZE(molecule_kind%molecule_list) - ALLOCATE (impr_list(iimpr)) - ALLOCATE (opbend_list(iimpr)) + ALLOCATE (impr_list(iimpr), STAT=stat) + ALLOCATE (opbend_list(iimpr), STAT=stat) + CPASSERT(stat == 0) iimpr = 0 DO j = bnd_type(1, i), bnd_type(2, i) IF (j == 0) CYCLE diff --git a/src/topology_constraint_util.F b/src/topology_constraint_util.F index 2980507f15..b7d07a8b12 100644 --- a/src/topology_constraint_util.F +++ b/src/topology_constraint_util.F @@ -241,13 +241,11 @@ CONTAINS END IF END IF CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", n_rep_val=nrep) - IF (nrep /= 0) THEN + IF (nrep /= 0) & CALL section_vals_val_get(hbonds_section, "ATOM_TYPE", c_vals=atom_typeh) - END IF CALL section_vals_val_get(hbonds_section, "TARGETS", n_rep_val=nrep) - IF (nrep /= 0) THEN + IF (nrep /= 0) & CALL section_vals_val_get(hbonds_section, "TARGETS", r_vals=hdist) - END IF IF (ASSOCIATED(hdist)) THEN CPASSERT(SIZE(hdist) == SIZE(atom_typeh)) END IF @@ -344,7 +342,7 @@ CONTAINS IF (ishbond) THEN nhdist = nhdist + 1 rvec = particle_set(offset + bond_list(k)%a)%r - particle_set(offset + bond_list(k)%b)%r - rmod = NORM2(rvec) + rmod = SQRT(DOT_PRODUCT(rvec, rvec)) IF (ASSOCIATED(hdist)) THEN IF (SIZE(hdist) > 0) THEN IF (bond_list(k)%a == j) atomic_kind => atom_list(bond_list(k)%b)%atomic_kind @@ -752,13 +750,13 @@ CONTAINS IF (fix_fixed_atom) THEN fixd_list(kk)%restraint%active = cons_info%fixed_restraint(k2loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_k0(k2loc) - ELSE IF (fix_atom_qm) THEN + ELSEIF (fix_atom_qm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_qm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_qm_k0 - ELSE IF (fix_atom_mm) THEN + ELSEIF (fix_atom_mm) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mm_restraint fixd_list(kk)%restraint%k0 = cons_info%fixed_mm_k0 - ELSE IF (fix_atom_molname) THEN + ELSEIF (fix_atom_molname) THEN fixd_list(kk)%restraint%active = cons_info%fixed_mol_restraint(k1loc) fixd_list(kk)%restraint%k0 = cons_info%fixed_mol_k0(k1loc) ELSE @@ -815,9 +813,8 @@ CONTAINS CASE (use_perd_xyz) CPASSERT(SIZE(r) == 3) fixd_list(kk)%coord(1:3) = r(1:3) - IF (ASSOCIATED(topology%cell_muc)) THEN + IF (ASSOCIATED(topology%cell_muc)) & CALL cell_transform_input_cartesian(topology%cell_muc, fixd_list(kk)%coord) - END IF END SELECT ELSE ! Write coord0 value for restraint @@ -1341,12 +1338,11 @@ CONTAINS ! Intramolecular constraint IF (const_mol(i) /= 0) THEN k = const_mol(i) - IF (k > SIZE(molecule_kind_set)) THEN + IF (k > SIZE(molecule_kind_set)) & CALL cp_abort(__LOCATION__, & "A constraint has been specified providing the molecule index. But the"// & " molecule index ("//cp_to_string(k)//") is out of range of the possible"// & " molecule kinds ("//cp_to_string(SIZE(molecule_kind_set))//").") - END IF isize = SIZE(constr_x_mol(k)%constr) CALL reallocate(constr_x_mol(k)%constr, 1, isize + 1) constr_x_mol(k)%constr(isize + 1) = i @@ -1383,14 +1379,13 @@ CONTAINS LOGICAL, INTENT(IN) :: found CHARACTER(LEN=*), INTENT(IN) :: name - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_warn(__LOCATION__, & " MOLNAME ("//TRIM(name)//") was defined for constraints, but this molecule name "// & "is not defined. Please check carefully your PDB, PSF (has priority over PDB) or "// & "input driven CP2K coordinates. In case you may not find the reason for this warning "// & "it may be a good idea to print all molecule information (including kind name) activating "// & "the print_key MOLECULES specific of the SUBSYS%PRINT section. ") - END IF END SUBROUTINE print_warning_molname diff --git a/src/topology_coordinate_util.F b/src/topology_coordinate_util.F index 63584a9429..e2a1b91768 100644 --- a/src/topology_coordinate_util.F +++ b/src/topology_coordinate_util.F @@ -198,9 +198,8 @@ CONTAINS CALL reallocate(mass, 1, counter) CALL reallocate(id_element, 1, counter) CALL reallocate(charge, 1, counter) - IF (iw > 0) THEN + IF (iw > 0) & WRITE (iw, '(5X,A,I3)') "Total Number of Atomic Kinds = ", topology%natom_type - END IF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -339,11 +338,10 @@ CONTAINS END DO my_ignore_outside_box = .FALSE. IF (PRESENT(ignore_outside_box)) my_ignore_outside_box = ignore_outside_box - IF (.NOT. my_ignore_outside_box .AND. .NOT. check) THEN + IF (.NOT. my_ignore_outside_box .AND. .NOT. check) & CALL cp_abort(__LOCATION__, & "A non-periodic calculation has been requested but the system size "// & "exceeds the cell size in at least one of the non-periodic directions!") - END IF IF (do_center) THEN CALL section_vals_val_get(subsys_section, & "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT", explicit=explicit) @@ -638,23 +636,20 @@ CONTAINS ! copy of data, not copy of pointer exclusions(iatom)%list_onfo = ex_onfo_list(iatom)%array1 IF (iw > 0) THEN - IF (ASSOCIATED(list)) THEN + IF (ASSOCIATED(list)) & WRITE (iw, *) "exclusion list_vdw :: ", & - "atom num :", iatom, "exclusion list ::", & - list - END IF + "atom num :", iatom, "exclusion list ::", & + list IF (topology%exclude_vdw /= topology%exclude_ei) THEN - IF (ASSOCIATED(list2)) THEN + IF (ASSOCIATED(list2)) & WRITE (iw, *) "exclusion list_ei :: ", & - "atom num :", iatom, "exclusion list ::", & - list2 - END IF + "atom num :", iatom, "exclusion list ::", & + list2 END IF - IF (ASSOCIATED(exclusions(iatom)%list_onfo)) THEN + IF (ASSOCIATED(exclusions(iatom)%list_onfo)) & WRITE (iw, *) "onfo list :: ", & - "atom num :", iatom, "onfo list ::", & - exclusions(iatom)%list_onfo - END IF + "atom num :", iatom, "onfo list ::", & + exclusions(iatom)%list_onfo END IF END DO ! deallocate onfo diff --git a/src/topology_generate_util.F b/src/topology_generate_util.F index 5e17f4df5a..718c42ac9b 100644 --- a/src/topology_generate_util.F +++ b/src/topology_generate_util.F @@ -1669,7 +1669,7 @@ CONTAINS nvar=nvar, & Ilist=Ilist) Ilist(it_levl) = -1 - ELSE IF (it_levl == max_levl) THEN + ELSEIF (it_levl == max_levl) THEN IF (Ilist(1) > ind) CYCLE Ilist(it_levl) = ind nvar = nvar + 1 diff --git a/src/topology_gromos.F b/src/topology_gromos.F index 743d890308..d3ddfa9858 100644 --- a/src/topology_gromos.F +++ b/src/topology_gromos.F @@ -607,12 +607,10 @@ CONTAINS DEALLOCATE (na) DEALLOCATE (am) DEALLOCATE (ac) - IF (ASSOCIATED(ba)) THEN + IF (ASSOCIATED(ba)) & DEALLOCATE (ba) - END IF - IF (ASSOCIATED(bb)) THEN + IF (ASSOCIATED(bb)) & DEALLOCATE (bb) - END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw, logger, subsys_section, & diff --git a/src/topology_input.F b/src/topology_input.F index 6aad5946ca..4aa95dfb4b 100644 --- a/src/topology_input.F +++ b/src/topology_input.F @@ -64,9 +64,8 @@ CONTAINS CALL section_vals_val_get(topology_section, "CHARGE_BETA", l_val=topology%charge_beta) CALL section_vals_val_get(topology_section, "CHARGE_EXTENDED", l_val=topology%charge_extended) ival = COUNT([topology%charge_occup, topology%charge_beta, topology%charge_extended]) - IF (ival > 1) THEN + IF (ival > 1) & CPABORT("Only one between can be defined! ") - END IF CALL section_vals_val_get(topology_section, "PARA_RES", l_val=topology%para_res) CALL section_vals_val_get(topology_section, "GENERATE%REORDER", l_val=topology%reorder_atom) CALL section_vals_val_get(topology_section, "GENERATE%CREATE_MOLECULES", l_val=topology%create_molecules) diff --git a/src/topology_multiple_unit_cell.F b/src/topology_multiple_unit_cell.F index 771768035e..bd93f27785 100644 --- a/src/topology_multiple_unit_cell.F +++ b/src/topology_multiple_unit_cell.F @@ -65,21 +65,19 @@ CONTAINS i_vals=multiple_unit_cell) ! Fail is one of the value is set to zero.. - IF (ANY(multiple_unit_cell <= 0)) THEN + IF (ANY(multiple_unit_cell <= 0)) & CALL cp_abort(__LOCATION__, "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL accepts "// & "only integer values greater than zero.") - END IF IF (ANY(multiple_unit_cell /= 1)) THEN ! Check that the setup between CELL and TOPOLOGY is the same CALL section_vals_val_get(subsys_section, "CELL%MULTIPLE_UNIT_CELL", & i_vals=iwork) - IF (ANY(iwork /= multiple_unit_cell)) THEN + IF (ANY(iwork /= multiple_unit_cell)) & CALL cp_abort(__LOCATION__, "The input parameters for "// & "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL and "// & "SUBSYS%CELL%MULTIPLE_UNIT_CELL have to agree.") - END IF cell => topology%cell_muc natoms = topology%natoms*PRODUCT(multiple_unit_cell) @@ -90,10 +88,9 @@ CONTAINS IF (explicit) THEN CALL section_vals_val_get(work_section, '_DEFAULT_KEYWORD_', n_rep_val=nrep) check = nrep == natoms - IF (.NOT. check) THEN + IF (.NOT. check) & CALL cp_abort(__LOCATION__, "The number of available entries in the "// & "VELOCITY section is not compatible with the number of atoms.") - END IF END IF CALL reallocate(topology%atom_info%id_molname, 1, natoms) diff --git a/src/topology_pdb.F b/src/topology_pdb.F index f995d732a2..481169411a 100644 --- a/src/topology_pdb.F +++ b/src/topology_pdb.F @@ -185,20 +185,12 @@ CONTAINS ELSE atom_info%id_resname(natom) = id0 END IF - ! Some information is not always given, so we mark it as used to prevent linters from crying - ! regarding never a never used variable 'istat' READ (UNIT=line(23:26), FMT=*, IOSTAT=istat) atom_info%resid(natom) - MARK_USED(istat) READ (UNIT=line(31:38), FMT=*, IOSTAT=istat) atom_info%r(1, natom) - MARK_USED(istat) READ (UNIT=line(39:46), FMT=*, IOSTAT=istat) atom_info%r(2, natom) - MARK_USED(istat) READ (UNIT=line(47:54), FMT=*, IOSTAT=istat) atom_info%r(3, natom) - MARK_USED(istat) READ (UNIT=line(55:60), FMT=*, IOSTAT=istat) atom_info%occup(natom) - MARK_USED(istat) READ (UNIT=line(61:66), FMT=*, IOSTAT=istat) atom_info%beta(natom) - MARK_USED(istat) READ (UNIT=line(73:76), FMT=*, IOSTAT=istat) strtmp IF (istat == 0) THEN atom_info%id_molname(natom) = str2id(s2s(strtmp)) @@ -217,7 +209,7 @@ CONTAINS IF (topology%charge_occup) atom_info%atm_charge(natom) = atom_info%occup(natom) IF (topology%charge_beta) atom_info%atm_charge(natom) = atom_info%beta(natom) IF (topology%charge_extended) THEN - READ (UNIT=line(81:), FMT=*) atom_info%atm_charge(natom) + READ (UNIT=line(81:), FMT=*, IOSTAT=istat) atom_info%atm_charge(natom) END IF IF (atom_info%id_element(natom) == id0) THEN @@ -318,9 +310,8 @@ CONTAINS CALL section_vals_val_get(print_key, "CHARGE_BETA", l_val=charge_beta) CALL section_vals_val_get(print_key, "CHARGE_EXTENDED", l_val=charge_extended) i = COUNT([charge_occup, charge_beta, charge_extended]) - IF (i > 1) THEN + IF (i > 1) & CPABORT("Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected") - END IF atom_info => topology%atom_info record = cp_print_key_generate_filename(logger, print_key, & @@ -380,9 +371,8 @@ CONTAINS END IF IF (ASSOCIATED(atom_info%atm_charge)) THEN IF (ANY([charge_occup, charge_beta, charge_extended]) .AND. & - (atom_info%atm_charge(i) == -HUGE(0.0_dp))) THEN + (atom_info%atm_charge(i) == -HUGE(0.0_dp))) & CPABORT("No atomic charges found yet (after the topology setup)") - END IF IF (charge_occup) THEN WRITE (UNIT=line(55:60), FMT="(F6.2)") atom_info%atm_charge(i) ELSE IF (charge_beta) THEN diff --git a/src/topology_psf.F b/src/topology_psf.F index ce03e59dae..91aaec84e7 100644 --- a/src/topology_psf.F +++ b/src/topology_psf.F @@ -113,10 +113,9 @@ CONTAINS c_int = 'I8' label = 'PSF' CALL parser_search_string(parser, label, .TRUE., found, begin_line=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CALL cp_abort(__LOCATION__, & "Missing PSF specification line in <"//TRIM(filename)//">") - END IF DO WHILE (parser_test_next_token(parser) /= "EOL") CALL parser_get_object(parser, field) SELECT CASE (field(1:3)) @@ -148,12 +147,11 @@ CONTAINS natom = 0 ELSE CALL parser_get_object(parser, natom) - IF (natom_prev + natom > topology%natoms) THEN + IF (natom_prev + natom > topology%natoms) & CALL cp_abort(__LOCATION__, & "Number of atoms in connectivity control is larger than the "// & "number of atoms in coordinate control. check coordinates and "// & "connectivity. ") - END IF IF (iw > 0) WRITE (iw, '(T2,A,'//TRIM(c_int)//')') 'PSF_INFO| NATOM = ', natom !malloc the memory that we need CALL reallocate(atom_info%id_molname, 1, natom_prev + natom) diff --git a/src/topology_types.F b/src/topology_types.F index 6300d6809b..440becf6d0 100644 --- a/src/topology_types.F +++ b/src/topology_types.F @@ -68,13 +68,12 @@ MODULE topology_types REAL(KIND=dp) :: hbonds_k0 = -1.0_dp ! Restraints control ! Fixed Atoms INTEGER :: nfixed_atoms = -1 - INTEGER, DIMENSION(:), POINTER :: fixed_atoms => NULL(), fixed_type => NULL(), fixed_mol_type => NULL() - LOGICAL, DIMENSION(:), POINTER :: fixed_restraint => NULL() ! Restraints control - REAL(KIND=dp), DIMENSION(:), POINTER :: fixed_k0 => NULL() ! Restraints control + INTEGER, POINTER :: fixed_atoms(:) => NULL(), fixed_type(:) => NULL(), fixed_mol_type(:) => NULL() + LOGICAL, POINTER :: fixed_restraint(:) => NULL() ! Restraints control + REAL(KIND=dp), POINTER :: fixed_k0(:) => NULL() ! Restraints control ! Freeze QM or MM INTEGER :: freeze_qm = -1, freeze_mm = -1, freeze_qm_type = -1, freeze_mm_type = -1 - ! Restraints control - LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. + LOGICAL :: fixed_mm_restraint = .FALSE., fixed_qm_restraint = .FALSE. ! Restraints control REAL(KIND=dp) :: fixed_mm_k0 = -1.0_dp, fixed_qm_k0 = -1.0_dp ! Restraints control ! Freeze with molnames LOGICAL, POINTER :: fixed_mol_restraint(:) => NULL() ! Restraints control @@ -525,9 +524,8 @@ CONTAINS !----------------------------------------------------------------------------- ! 3. DEALLOCATE things in topology%cons_info !----------------------------------------------------------------------------- - IF (ASSOCIATED(topology%cons_info)) THEN + IF (ASSOCIATED(topology%cons_info)) & CALL deallocate_constraint(topology%cons_info) - END IF !----------------------------------------------------------------------------- ! 4. DEALLOCATE things in topology !----------------------------------------------------------------------------- diff --git a/src/topology_util.F b/src/topology_util.F index 0a042423bb..b53ba161c7 100644 --- a/src/topology_util.F +++ b/src/topology_util.F @@ -1207,12 +1207,11 @@ CONTAINS END IF ! This is clearly a user error - IF (.NOT. found .AND. defined_kind_section) THEN + IF (.NOT. found .AND. defined_kind_section) & CALL cp_abort(__LOCATION__, "Element <"//TRIM(element_symbol)// & "> provided for KIND <"//TRIM(atom_name_in)//"> "// & "which cannot be mapped with any standard element label. Please correct your "// & "input file!") - END IF ! Last chance.. are these atom_kinds of AMBER or CHARMM or GROMOS FF ? CALL uppercase(element_symbol) diff --git a/src/topology_xtl.F b/src/topology_xtl.F index 29b87259ff..42f6839993 100644 --- a/src/topology_xtl.F +++ b/src/topology_xtl.F @@ -144,9 +144,8 @@ CONTAINS ! Check for _cell_length_a CALL parser_search_string(parser, "CELL", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field CELL was not found in XTL file! ") - END IF CALL parser_get_next_line(parser, 1) ! CELL LENGTH A CALL parser_get_object(parser, cell_lengths(1)) @@ -179,15 +178,13 @@ CONTAINS ! Check for _atom_site_label CALL parser_search_string(parser, "ATOMS", ignore_case=.FALSE., found=found, & begin_line=.FALSE., search_from_begin_of_file=.TRUE.) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field ATOMS was not found in XTL file! ") - END IF CALL parser_get_next_line(parser, 1) ! Paranoic syntax check.. if this fails one should improve the description of XTL files found = (INDEX(parser%input_line, "NAME X Y Z") /= 0) - IF (.NOT. found) THEN + IF (.NOT. found) & CPABORT("The field ATOMS in XTL file, is not followed by name and coordinates tags! ") - END IF CALL parser_get_next_line(parser, 1) ! Parse real info natom = 0 diff --git a/src/topology_xyz.F b/src/topology_xyz.F index 6f881238c9..b01a1cab08 100644 --- a/src/topology_xyz.F +++ b/src/topology_xyz.F @@ -151,12 +151,11 @@ CONTAINS CALL parser_get_next_line(parser, 1, at_end=my_end) my_end = my_end .OR. (LEN_TRIM(parser%input_line) == 0) IF (my_end) THEN - IF (j /= natom) THEN + IF (j /= natom) & CALL cp_abort(__LOCATION__, & "Number of lines in XYZ format not equal to the number of atoms."// & " Error in XYZ format. Very probably the line with title is missing or is empty."// & " Please check the XYZ file and rerun your job!") - END IF EXIT Frames END IF END DO diff --git a/src/torch_c_api.cpp b/src/torch_c_api.cpp index 9293fd6425..9349653ebf 100644 --- a/src/torch_c_api.cpp +++ b/src/torch_c_api.cpp @@ -7,7 +7,6 @@ #if defined(__LIBTORCH) -#include #include #include #include @@ -17,7 +16,6 @@ #include #include -#include #include #include #include @@ -49,38 +47,7 @@ private: ******************************************************************************/ static bool use_cuda_if_available = true; -static bool get_positive_int_env(const char *name, int &value) { - const char *raw = std::getenv(name); - if (raw == nullptr || raw[0] == '\0') { - return false; - } - char *end = nullptr; - const long parsed = std::strtol(raw, &end, 10); - if (end == raw || *end != '\0' || parsed <= 0 || parsed > INT_MAX) { - return false; - } - value = static_cast(parsed); - return true; -} - -static void initialize_torch_threads_from_env() { - static bool initialized = false; - if (initialized) { - return; - } - initialized = true; - - int num_threads = 0; - if (get_positive_int_env("CP2K_TORCH_NUM_THREADS", num_threads)) { - at::set_num_threads(num_threads); - } - if (get_positive_int_env("CP2K_TORCH_NUM_INTEROP_THREADS", num_threads)) { - at::set_num_interop_threads(num_threads); - } -} - static torch::Device get_device() { - initialize_torch_threads_from_env(); if (!use_cuda_if_available || !torch::cuda::is_available()) { return torch::kCPU; } @@ -140,7 +107,6 @@ static torch_c_tensor_t *tensor_from_array(const torch::Dtype dtype, const bool req_grad, const int ndims, const int64_t sizes[], void *source) { - initialize_torch_threads_from_env(); const auto opts = torch::TensorOptions().dtype(dtype).requires_grad(req_grad); const auto sizes_ref = c10::IntArrayRef(sizes, ndims); return new torch_c_tensor_t(torch::from_blob(source, sizes_ref, opts)); diff --git a/src/transport.F b/src/transport.F index f13949bfea..fd9cc1ef24 100644 --- a/src/transport.F +++ b/src/transport.F @@ -381,11 +381,10 @@ CONTAINS CALL timeset(routineN, handle) CALL C_F_PROCPOINTER(transport_env%ext_c_method_ptr, c_method) - IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) THEN + IF (.NOT. C_ASSOCIATED(transport_env%ext_c_method_ptr)) & CALL cp_abort(__LOCATION__, & "MISSING C/C++ ROUTINE: The TRANSPORT section is meant to be used together with an external "// & "program, e.g. the quantum transport code OMEN, that provides CP2K with a density matrix.") - END IF transport_env%params%n_occ = nelectron_spin transport_env%params%n_atoms = natoms diff --git a/src/wannier90.F b/src/wannier90.F index 79dcc46327..24c5901510 100644 --- a/src/wannier90.F +++ b/src/wannier90.F @@ -672,7 +672,7 @@ CONTAINS counter = counter + 1 lmn(1, counter) = l; lmn(2, counter) = m; lmn(3, counter) = n pos = MATMUL(lmn(:, counter), recip_lattice) - dist(counter) = NORM2(pos) + dist(counter) = SQRT(DOT_PRODUCT(pos, pos)) END DO END DO END DO @@ -776,8 +776,8 @@ CONTAINS DO loop_s = 1, num_shells DO loop_b = 1, multi(shell_list(loop_s)) delta = DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_b, loop_s))/ & - NORM2(bvector(:, loop_bn, cur_shell))* & - NORM2(bvector(:, loop_b, loop_s)) + SQRT(DOT_PRODUCT(bvector(:, loop_bn, cur_shell), bvector(:, loop_bn, cur_shell))* & + DOT_PRODUCT(bvector(:, loop_b, loop_s), bvector(:, loop_b, loop_s))) IF (ABS(ABS(delta) - 1.0_dp) < eps6) lpar = .TRUE. END DO END DO @@ -871,7 +871,7 @@ CONTAINS IF (.NOT. b1sat) THEN IF (shell < search_shells .AND. iprint >= 3) THEN WRITE (stdout, '(1x,a,24x,a1)') '| B1 condition is not satisfied: Adding another shell', '|' - ELSE IF (shell == search_shells) THEN + ELSEIF (shell == search_shells) THEN WRITE (stdout, *) ' ' WRITE (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', search_shells, ' shells' WRITE (stdout, '(1x,a)') 'Your cell might be very long, or you may have an irregular MP grid' diff --git a/src/xas_methods.F b/src/xas_methods.F index f14f3915eb..8258506b41 100644 --- a/src/xas_methods.F +++ b/src/xas_methods.F @@ -316,7 +316,7 @@ CONTAINS WRITE (UNIT=output_unit, FMT="( A , I7, A, I7)") " The sub-set contains states from ", & qs_loc_env%localized_wfn_control%lu_bound_states(1, my_spin), " to ", & qs_loc_env%localized_wfn_control%lu_bound_states(2, my_spin) - ELSE IF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN + ELSEIF (qs_loc_env%localized_wfn_control%set_of_states == state_loc_list) THEN WRITE (UNIT=output_unit, FMT="( A )") " The sub-set contains states given in the input list" END IF @@ -431,9 +431,8 @@ CONTAINS CALL get_mo_set(mos(my_spin), nmo=nmo) CALL get_xas_env(xas_env, occ_estate=occ_estate, xas_nelectron=xas_nelectron) tmp = xas_nelectron + 1.0_dp - occ_estate - IF (nmo < tmp) THEN + IF (nmo < tmp) & CPABORT("CLS: the required method needs added_mos to the ground state") - END IF ! If the restart file for this atom exists, the mos and the ! occupation numbers are overwritten ! It is necessary that the restart is for the same xas method @@ -725,31 +724,31 @@ CONTAINS nele = REAL(nelectron, dp) - 0.5_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSE IF (xas_control%xas_method == xas_tp_xhh) THEN + ELSEIF (xas_control%xas_method == xas_tp_xhh) THEN occ_estate = 0.5_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 0.5_dp - ELSE IF (xas_control%xas_method == xas_tp_fh) THEN + ELSEIF (xas_control%xas_method == xas_tp_fh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) - 1.0_dp occ_homo = 1.0_dp occ_homo_plus = 0._dp - ELSE IF (xas_control%xas_method == xas_tp_xfh) THEN + ELSEIF (xas_control%xas_method == xas_tp_xfh) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSE IF (xas_control%xas_method == xes_tp_val) THEN + ELSEIF (xas_control%xas_method == xes_tp_val) THEN occ_estate = xas_control%xes_core_occupation nele = REAL(nelectron, dp) - xas_control%xes_core_occupation occ_homo = xas_control%xes_homo_occupation - ELSE IF (xas_control%xas_method == xas_dscf) THEN + ELSEIF (xas_control%xas_method == xas_dscf) THEN occ_estate = 0.0_dp nele = REAL(nelectron, dp) occ_homo = 1.0_dp occ_homo_plus = 1._dp - ELSE IF (xas_control%xas_method == xas_tp_flex) THEN + ELSEIF (xas_control%xas_method == xas_tp_flex) THEN nele = REAL(xas_control%nel_tot, dp) occ_estate = REAL(xas_control%xas_core_occupation, dp) IF (nele < 0.0_dp) nele = REAL(nelectron, dp) - (1.0_dp - occ_estate) @@ -858,7 +857,7 @@ CONTAINS "xas_env%ostrength_sm-"//TRIM(ADJUSTL(cp_to_string(i)))) CALL dbcsr_set(xas_env%ostrength_sm(i)%matrix, 0.0_dp) END DO - ELSE IF (xas_control%dipole_form == xas_dip_vel) THEN + ELSEIF (xas_control%dipole_form == xas_dip_vel) THEN ! ! prepare for allocation natom = SIZE(particle_set, 1) @@ -919,31 +918,31 @@ CONTAINS IF (xas_control%state_type == xas_1s_type) THEN nq(1) = 1 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_2s_type) THEN + ELSEIF (xas_control%state_type == xas_2s_type) THEN nq(1) = 2 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_2p_type) THEN + ELSEIF (xas_control%state_type == xas_2p_type) THEN nq(1) = 2 lq(1) = 1 - ELSE IF (xas_control%state_type == xas_3s_type) THEN + ELSEIF (xas_control%state_type == xas_3s_type) THEN nq(1) = 3 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_3p_type) THEN + ELSEIF (xas_control%state_type == xas_3p_type) THEN nq(1) = 3 lq(1) = 1 - ELSE IF (xas_control%state_type == xas_3d_type) THEN + ELSEIF (xas_control%state_type == xas_3d_type) THEN nq(1) = 3 lq(1) = 2 - ELSE IF (xas_control%state_type == xas_4s_type) THEN + ELSEIF (xas_control%state_type == xas_4s_type) THEN nq(1) = 4 lq(1) = 0 - ELSE IF (xas_control%state_type == xas_4p_type) THEN + ELSEIF (xas_control%state_type == xas_4p_type) THEN nq(1) = 4 lq(1) = 1 - ELSE IF (xas_control%state_type == xas_4d_type) THEN + ELSEIF (xas_control%state_type == xas_4d_type) THEN nq(1) = 4 lq(1) = 2 - ELSE IF (xas_control%state_type == xas_4f_type) THEN + ELSEIF (xas_control%state_type == xas_4f_type) THEN nq(1) = 4 lq(1) = 3 ELSE @@ -1660,8 +1659,7 @@ CONTAINS END DO END IF - ! Scales down the 2d-array to the minimal size - CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) + CALL reallocate(xas_env%state_of_atom, 1, nexc_atoms, 1, MAXVAL(nexc_states)) ! Scales down the 2d-array to the minimal size ELSE ! Manually selected orbital indices diff --git a/src/xas_restart.F b/src/xas_restart.F index 42864330d3..6ecc1dda59 100644 --- a/src/xas_restart.F +++ b/src/xas_restart.F @@ -183,14 +183,12 @@ CONTAINS READ (rst_unit) nexc_search_read, nexc_atoms_read, occ_estate_read, xas_nelectron_read READ (rst_unit) xas_estate_read - IF (xas_method_read /= xas_method) THEN + IF (xas_method_read /= xas_method) & CPABORT("READ XAS RESTART: restart with different XAS method is not possible.") - END IF - IF (nexc_atoms_read /= nexc_atoms) THEN + IF (nexc_atoms_read /= nexc_atoms) & CALL cp_abort(__LOCATION__, & "READ XAS RESTART: restart with different excited atoms "// & "is not possible. Start instead a new XAS run with the new set of atoms.") - END IF END IF CALL para_env%bcast(xas_estate_read) @@ -208,9 +206,8 @@ CONTAINS CALL cp_fm_set_all(mo_coeff, 0.0_dp) IF (para_env%is_source()) THEN READ (rst_unit) nao_read, nmo_read - IF (nao /= nao_read) THEN + IF (nao /= nao_read) & CPABORT("To change basis is not possible. ") - END IF ALLOCATE (eig_read(nmo_read), occ_read(nmo_read)) eig_read = 0.0_dp occ_read = 0.0_dp @@ -219,11 +216,10 @@ CONTAINS eigenvalues(1:nmo) = eig_read(1:nmo) occupation_numbers(1:nmo) = occ_read(1:nmo) IF (nmo_read > nmo) THEN - IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) THEN + IF (occupation_numbers(nmo) >= EPSILON(0.0_dp)) & CALL cp_warn(__LOCATION__, & "The number of occupied MOs on the restart unit is larger than "// & "the allocated MOs.") - END IF END IF DEALLOCATE (eig_read, occ_read) diff --git a/src/xas_tdp_atom.F b/src/xas_tdp_atom.F index faa3fe4633..87df1c0f2a 100644 --- a/src/xas_tdp_atom.F +++ b/src/xas_tdp_atom.F @@ -1186,7 +1186,7 @@ CONTAINS ! Point to the rho_set densities rhoa => rho_set%rhoa rhob => rho_set%rhob - rhoa = 0.0_dp; rhob = 0.0_dp + rhoa = 0.0_dp; rhob = 0.0_dp; IF (do_gga) THEN DO dir = 1, 3 rho_set%drhoa(dir)%array = 0.0_dp diff --git a/src/xas_tdp_correction.F b/src/xas_tdp_correction.F index 05fc8df3b9..91aa6cd919 100644 --- a/src/xas_tdp_correction.F +++ b/src/xas_tdp_correction.F @@ -1880,7 +1880,7 @@ CONTAINS !The SOC corrected KS eigenvalues ALLOCATE (tmp_shifts(ndo_mo, 2)) - ialpha = 1; ibeta = 1 + ialpha = 1; ibeta = 1; DO ido_mo = 1, ndo_so !need to find out whether the eigenvalue corresponds to an alpha or beta spin-orbtial alpha_tot_contrib = REAL(DOT_PRODUCT(evecs(1:ndo_mo, ido_mo), evecs(1:ndo_mo, ido_mo))) diff --git a/src/xas_tdp_kernel.F b/src/xas_tdp_kernel.F index 4c4890a407..8524077535 100644 --- a/src/xas_tdp_kernel.F +++ b/src/xas_tdp_kernel.F @@ -164,8 +164,7 @@ CONTAINS ! Broadcast the integrals to all procs (deleted after all donor states for this atoms are treated) lb = 1; IF (do_sf .AND. .NOT. do_sc) lb = 4 - ub = 2; IF (do_sc) ub = 3 - IF (do_sf) ub = 4 + ub = 2; IF (do_sc) ub = 3; IF (do_sf) ub = 4 DO i = lb, ub IF (.NOT. ASSOCIATED(xas_tdp_env%ri_fxc(ri_atom, i)%array)) THEN ALLOCATE (xas_tdp_env%ri_fxc(ri_atom, i)%array(nsgfp, nsgfp)) @@ -1369,9 +1368,9 @@ CONTAINS ! If on-diagonal quadrants only, can skip jso < iso IF (.NOT. quadrants(2) .AND. jso < iso) CYCLE - i = iso; j = jso + i = iso; j = jso; IF (my_mt) THEN - i = jso; j = iso + i = jso; j = iso; END IF ! Take the product lhs*rhs^T diff --git a/src/xas_tdp_methods.F b/src/xas_tdp_methods.F index 5383697020..4b35c3fb8c 100644 --- a/src/xas_tdp_methods.F +++ b/src/xas_tdp_methods.F @@ -800,9 +800,8 @@ CONTAINS IF (do_uks) nspins = 2 !in roks, same MOs for both spins ! by default, all (doubly occupied) homo are localized - IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) THEN + IF (xas_tdp_control%n_search < 0 .OR. xas_tdp_control%n_search > MINVAL(homo)) & xas_tdp_control%n_search = MINVAL(homo) - END IF CALL qs_loc_control_init(qs_loc_env, loc_section, do_homo=.TRUE., do_xas=.TRUE., & nloc_xas=xas_tdp_control%n_search, spin_xas=1) @@ -2650,11 +2649,9 @@ CONTAINS DO ispin = 1, 2 CALL duplicate_mo_set(restart_mos(ispin), mos(1)) - ! Set the new occupation number in the case of spin-independent based calculation - ! since the restart is spin-depedent - IF (SIZE(mos) == 1) THEN + ! Set the new occupation number in the case of spin-independent based calculation since the restart is spin-depedent + IF (SIZE(mos) == 1) & restart_mos(ispin)%occupation_numbers = mos(1)%occupation_numbers/2 - END IF END DO CALL cp_fm_to_fm_submat(msource=lr_coeffs, mtarget=restart_mos(1)%mo_coeff, nrow=nao, & diff --git a/src/xas_tp_scf.F b/src/xas_tp_scf.F index 6ddd2c0d29..cfe95963c8 100644 --- a/src/xas_tp_scf.F +++ b/src/xas_tp_scf.F @@ -545,9 +545,8 @@ CONTAINS END IF END DO ! istate - IF (my_state == 0) THEN + IF (my_state == 0) & CPABORT("Could not identify the core state to be excited") - END IF xas_estate = my_state CALL get_mo_set(mos(my_spin), mo_coeff=mo_coeff) CALL cp_fm_get_submatrix(mo_coeff, vecbuffer, 1, xas_estate, & diff --git a/src/xc/xc.F b/src/xc/xc.F index d7c24f7e27..dde7ee5893 100644 --- a/src/xc/xc.F +++ b/src/xc/xc.F @@ -277,7 +277,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -312,7 +312,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -349,7 +349,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -378,7 +378,7 @@ CONTAINS IF (my_rho < rho_smooth_cutoff) THEN IF (my_rho < rho_cutoff) THEN pot(i, j, k) = 0.0_dp - ELSE IF (my_rho < rho_smooth_cutoff_2) THEN + ELSEIF (my_rho < rho_smooth_cutoff_2) THEN my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2 my_rho_n2 = my_rho_n*my_rho_n pot(i, j, k) = pot(i, j, k)* & @@ -990,9 +990,8 @@ CONTAINS needs = xc_functionals_get_needs(xc_fun_section, lsd, .TRUE.) IF (needs%tau .OR. needs%tau_spin) THEN - IF (.NOT. ASSOCIATED(tau1_r)) THEN + IF (.NOT. ASSOCIATED(tau1_r)) & CPABORT("Tau-dependent functionals requires allocated kinetic energy density grid") - END IF ALLOCATE (v_xc_tau(nspins)) DO ispin = 1, nspins CALL pw_pool%create_pw(v_xc_tau(ispin)) @@ -2166,9 +2165,8 @@ CONTAINS END DO END IF - IF (laplace_f .AND. my_gapw) THEN + IF (laplace_f .AND. my_gapw) & CPABORT("Laplace-dependent functional not implemented with GAPW!") - END IF IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) CALL allocate_pw(virial_pw, pw_pool, bo) @@ -3418,7 +3416,8 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) tau => tau_r + IF (PRESENT(tau_r)) & + tau => tau_r IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 2, & @@ -3482,7 +3481,8 @@ CONTAINS lsd = (nspins /= 1) NULLIFY (rho_g, tau) - IF (PRESENT(tau_r)) tau => tau_r + IF (PRESENT(tau_r)) & + tau => tau_r my_do_sf = .FALSE. IF (PRESENT(do_sf)) my_do_sf = do_sf @@ -3590,9 +3590,8 @@ CONTAINS CPABORT("Normalization of derivative requires any of norm_drhob or drhob!") END IF CASE (deriv_rho, deriv_tau, deriv_laplace_rho) - IF (lsd) THEN + IF (lsd) & CPABORT(TRIM(id_to_desc(split_desc(idesc)))//" not handled in lsd!'") - END IF CASE (deriv_rhoa, deriv_rhob, deriv_tau_a, deriv_tau_b, deriv_laplace_rhoa, deriv_laplace_rhob) CASE default CPABORT("Unknown derivative id") diff --git a/src/xc/xc_derivative_set_types.F b/src/xc/xc_derivative_set_types.F index 3c696c4fbe..a7227a7135 100644 --- a/src/xc/xc_derivative_set_types.F +++ b/src/xc/xc_derivative_set_types.F @@ -121,9 +121,8 @@ CONTAINS derivative_set%pw_pool => pw_pool CALL pw_pool%retain() IF (PRESENT(local_bounds)) THEN - IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) THEN + IF (ANY(pw_pool%pw_grid%bounds_local /= local_bounds)) & CPABORT("incompatible local_bounds and pw_pool") - END IF END IF ELSE !FM ugly hack, should be replaced by a pool only for 3d arrays diff --git a/src/xc/xc_derivatives.F b/src/xc/xc_derivatives.F index 16702c65f9..431bb25b6e 100644 --- a/src/xc/xc_derivatives.F +++ b/src/xc/xc_derivatives.F @@ -11,9 +11,7 @@ MODULE xc_derivatives USE input_section_types, ONLY: section_vals_get_subs_vals2,& section_vals_type,& section_vals_val_get - USE kinds, ONLY: default_string_length,& - dp - USE string_utilities, ONLY: uppercase + USE kinds, ONLY: dp USE xc_b97, ONLY: b97_lda_eval,& b97_lda_info,& b97_lsd_eval,& @@ -283,14 +281,9 @@ CONTAINS CALL pbe_lda_info(functional, reference, shortform, needs, max_deriv) END IF CASE ("GAUXC") - IF (gauxc_model_none_selected(functional)) THEN - CALL gauxc_model_none_xc_info(functional, lsd, reference, shortform, & - needs, max_deriv, print_warn) - ELSE - CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) - ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F - ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) - END IF + CALL skala_info(functional, lsd, reference, shortform, needs, max_deriv) + ! Note: SKALA functional routes through apply_gauxc in qs_ks_methods.F + ! when USE_GAUXC = .TRUE. (requires dft_control%use_gauxc to be set) CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_info(reference, shortform, needs, max_deriv) @@ -514,11 +507,7 @@ CONTAINS CALL pbe_lda_eval(rho_set, deriv_set, deriv_order, functional) END IF CASE ("GAUXC") - IF (gauxc_model_none_selected(functional)) THEN - CALL gauxc_model_none_xc_eval(functional, lsd, rho_set, deriv_set, deriv_order) - ELSE - CPABORT(abort_message_skala) - END IF + CPABORT(abort_message_skala) CASE ("XWPBE") IF (lsd) THEN CALL xwpbe_lsd_eval(rho_set, deriv_set, deriv_order, functional) @@ -563,155 +552,6 @@ CONTAINS CALL timestop(handle) END SUBROUTINE xc_functional_eval -! ************************************************************************************************** -!> \brief true for GAUXC sections that wrap a conventional LibXC functional -!> \param functional the GAUXC section -!> \return whether MODEL NONE is active -! ************************************************************************************************** - FUNCTION gauxc_model_none_selected(functional) - TYPE(section_vals_type), POINTER :: functional - LOGICAL :: gauxc_model_none_selected - - CHARACTER(LEN=default_string_length) :: model_key, model_name, xc_fun_name, & - xc_key - - CALL section_vals_val_get(functional, "MODEL", c_val=model_name) - CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) - model_key = ADJUSTL(model_name) - xc_key = ADJUSTL(xc_fun_name) - CALL uppercase(model_key) - CALL uppercase(xc_key) - gauxc_model_none_selected = (TRIM(model_key) == "" .OR. TRIM(model_key) == "NONE" .OR. & - TRIM(model_key) == TRIM(xc_key)) - END FUNCTION gauxc_model_none_selected - -! ************************************************************************************************** -!> \brief map GAUXC MODEL NONE shorthand names to LibXC exchange/correlation components -!> \param functional the GAUXC section -!> \param xc_fun_name the GAUXC FUNCTIONAL value -!> \param libxc_names LibXC section names to evaluate and add -!> \param nfunc number of LibXC components -! ************************************************************************************************** - SUBROUTINE gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) - TYPE(section_vals_type), POINTER :: functional - CHARACTER(LEN=*), INTENT(OUT) :: xc_fun_name - CHARACTER(LEN=*), DIMENSION(:), INTENT(OUT) :: libxc_names - INTEGER, INTENT(OUT) :: nfunc - - CHARACTER(LEN=default_string_length) :: xc_key - - CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) - xc_key = ADJUSTL(xc_fun_name) - CALL uppercase(xc_key) - libxc_names(:) = "" - SELECT CASE (TRIM(xc_key)) - CASE ("LDA", "PADE") - nfunc = 2 - libxc_names(1) = "LDA_X" - libxc_names(2) = "LDA_C_PW" - CASE ("VWN") - nfunc = 2 - libxc_names(1) = "LDA_X" - libxc_names(2) = "LDA_C_VWN" - CASE ("PBE") - nfunc = 2 - libxc_names(1) = "GGA_X_PBE" - libxc_names(2) = "GGA_C_PBE" - CASE ("BLYP") - nfunc = 2 - libxc_names(1) = "GGA_X_B88" - libxc_names(2) = "GGA_C_LYP" - CASE ("BP") - nfunc = 2 - libxc_names(1) = "GGA_X_B88" - libxc_names(2) = "GGA_C_P86" - CASE ("TPSS") - nfunc = 2 - libxc_names(1) = "MGGA_X_TPSS" - libxc_names(2) = "MGGA_C_TPSS" - CASE ("R2SCAN") - nfunc = 2 - libxc_names(1) = "MGGA_X_R2SCAN" - libxc_names(2) = "MGGA_C_R2SCAN" - CASE DEFAULT - nfunc = 1 - libxc_names(1) = TRIM(xc_key) - END SELECT - END SUBROUTINE gauxc_model_none_libxc_names - -! ************************************************************************************************** -!> \brief needs information for GAUXC MODEL NONE one-center GAPW corrections -!> \param functional the GAUXC section -!> \param lsd whether spin-polarized derivatives are needed -!> \param reference reference string for the wrapped functional -!> \param shortform short name for printout -!> \param needs density ingredients needed by the wrapped functional -!> \param max_deriv maximum implemented derivative order -!> \param print_warn whether LibXC should print development warnings -! ************************************************************************************************** - SUBROUTINE gauxc_model_none_xc_info(functional, lsd, reference, shortform, & - needs, max_deriv, print_warn) - TYPE(section_vals_type), POINTER :: functional - LOGICAL, INTENT(in) :: lsd - CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform - TYPE(xc_rho_cflags_type), INTENT(inout), OPTIONAL :: needs - INTEGER, INTENT(out), OPTIONAL :: max_deriv - LOGICAL, INTENT(IN), OPTIONAL :: print_warn - - CHARACTER(LEN=default_string_length) :: libxc_names(2), xc_fun_name - INTEGER :: ifunc, max_deriv_i, max_deriv_min, nfunc - - CALL gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) - max_deriv_min = HUGE(max_deriv_min) - DO ifunc = 1, nfunc - IF (lsd) THEN - CALL libxc_lsd_info(functional, needs=needs, max_deriv=max_deriv_i, & - print_warn=print_warn, & - func_name_override=TRIM(libxc_names(ifunc))) - ELSE - CALL libxc_lda_info(functional, needs=needs, max_deriv=max_deriv_i, & - print_warn=print_warn, & - func_name_override=TRIM(libxc_names(ifunc))) - END IF - max_deriv_min = MIN(max_deriv_min, max_deriv_i) - END DO - IF (PRESENT(max_deriv)) max_deriv = max_deriv_min - IF (PRESENT(reference)) THEN - reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" - END IF - IF (PRESENT(shortform)) shortform = "GAUXC ("//TRIM(xc_fun_name)//")" - END SUBROUTINE gauxc_model_none_xc_info - -! ************************************************************************************************** -!> \brief one-center GAPW correction evaluation for GAUXC MODEL NONE -!> \param functional the GAUXC section -!> \param lsd whether spin-polarized derivatives are evaluated -!> \param rho_set density ingredients -!> \param deriv_set derivative accumulator -!> \param deriv_order derivative order to evaluate -! ************************************************************************************************** - SUBROUTINE gauxc_model_none_xc_eval(functional, lsd, rho_set, deriv_set, deriv_order) - TYPE(section_vals_type), POINTER :: functional - LOGICAL, INTENT(in) :: lsd - TYPE(xc_rho_set_type), INTENT(IN) :: rho_set - TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set - INTEGER, INTENT(IN) :: deriv_order - - CHARACTER(LEN=default_string_length) :: libxc_names(2), xc_fun_name - INTEGER :: ifunc, nfunc - - CALL gauxc_model_none_libxc_names(functional, xc_fun_name, libxc_names, nfunc) - DO ifunc = 1, nfunc - IF (lsd) THEN - CALL libxc_lsd_eval(rho_set, deriv_set, deriv_order, functional, & - func_name_override=TRIM(libxc_names(ifunc))) - ELSE - CALL libxc_lda_eval(rho_set, deriv_set, deriv_order, functional, & - func_name_override=TRIM(libxc_names(ifunc))) - END IF - END DO - END SUBROUTINE gauxc_model_none_xc_eval - ! ************************************************************************************************** !> \brief ... !> \param functionals a section containing the functional combination to be diff --git a/src/xc/xc_functionals_utilities.F b/src/xc/xc_functionals_utilities.F index ac52974c52..933ead184a 100644 --- a/src/xc/xc_functionals_utilities.F +++ b/src/xc/xc_functionals_utilities.F @@ -259,20 +259,16 @@ CONTAINS IF (m >= 2) fx(ip, 3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(ip, 4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) THEN + IF (m >= 0) & fx(ip, 1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - END IF - IF (m >= 1) THEN + IF (m >= 1) & fx(ip, 2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - END IF - IF (m >= 2) THEN + IF (m >= 2) & fx(ip, 3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - END IF - IF (m >= 3) THEN + IF (m >= 3) & fx(ip, 4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) - END IF END IF END IF END DO @@ -318,20 +314,16 @@ CONTAINS IF (m >= 2) fx(3) = f13*f43*fxfac/2.0_dp**f23 IF (m >= 3) fx(4) = -f23*f13*f43*fxfac/2.0_dp**f53 ELSE - IF (m >= 0) THEN + IF (m >= 0) & fx(1) = ((1.0_dp + x)**f43 + (1.0_dp - x)**f43 - 2.0_dp)*fxfac - END IF - IF (m >= 1) THEN + IF (m >= 1) & fx(2) = ((1.0_dp + x)**f13 - (1.0_dp - x)**f13)*fxfac*f43 - END IF - IF (m >= 2) THEN + IF (m >= 2) & fx(3) = ((1.0_dp + x)**(-f23) + (1.0_dp - x)**(-f23))* & fxfac*f43*f13 - END IF - IF (m >= 3) THEN + IF (m >= 3) & fx(4) = ((1.0_dp + x)**(-f53) - (1.0_dp - x)**(-f53))* & fxfac*f43*f13*(-f23) - END IF END IF END IF diff --git a/src/xc/xc_gauxc_cache.F b/src/xc/xc_gauxc_cache.F deleted file mode 100644 index 0d83d432e7..0000000000 --- a/src/xc/xc_gauxc_cache.F +++ /dev/null @@ -1,475 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright 2000-2026 CP2K developers group ! -! ! -! SPDX-License-Identifier: GPL-2.0-or-later ! -!--------------------------------------------------------------------------------------------------! - -#ifdef __GAUXC -#include "gauxc/gauxc_config.f" -#endif - -MODULE xc_gauxc_cache - - USE iso_c_binding, ONLY: c_double - USE kinds, ONLY: default_path_length,& - default_string_length - USE message_passing, ONLY: mp_comm_self,& - mp_para_env_type - USE particle_types, ONLY: particle_type - USE qs_kind_types, ONLY: qs_kind_type - USE xc_gauxc_interface, ONLY: & - cp_gauxc_basisset_type, cp_gauxc_grid_type, cp_gauxc_integrator_type, & - cp_gauxc_molecule_type, cp_gauxc_status_type, gauxc_check_status, gauxc_create_basisset, & - gauxc_create_grid, gauxc_create_integrator, gauxc_create_molecule, gauxc_destroy_basisset, & - gauxc_destroy_grid, gauxc_destroy_integrator, gauxc_destroy_molecule -#include "../base/base_uses.f90" - - IMPLICIT NONE - PRIVATE - - TYPE cp_gauxc_cache_params - INTEGER :: natom = -1 - INTEGER :: nspins = -1 - INTEGER :: batch_size = -1 - REAL(c_double) :: device_runtime_fill_fraction = 0.0_c_double - CHARACTER(LEN=default_string_length) :: xc_fun_name = "" - CHARACTER(LEN=default_string_length) :: grid_type = "" - CHARACTER(LEN=default_string_length) :: radial_quadrature = "" - CHARACTER(LEN=default_string_length) :: pruning_scheme = "" - CHARACTER(LEN=default_string_length) :: lb_exec_space = "" - CHARACTER(LEN=default_string_length) :: int_exec_space = "" - CHARACTER(LEN=default_path_length) :: model_eval_name = "" - CHARACTER(len=default_string_length) :: lwd_kernel = "" - LOGICAL :: use_mpi_runtime = .FALSE. - LOGICAL :: use_gradient_mpi_runtime = .FALSE. - LOGICAL :: use_self_runtime = .FALSE. - LOGICAL :: use_gradient_self_runtime = .FALSE. - LOGICAL :: use_fd_gradient = .FALSE. - LOGICAL :: use_gauxc_model = .FALSE. - END TYPE cp_gauxc_cache_params - - TYPE, extends(cp_gauxc_cache_params) :: cp_gauxc_cache_type - TYPE(cp_gauxc_molecule_type) :: molecule = cp_gauxc_molecule_type() - TYPE(cp_gauxc_basisset_type) :: basisset = cp_gauxc_basisset_type() - TYPE(cp_gauxc_grid_type) :: grid = cp_gauxc_grid_type() - TYPE(cp_gauxc_grid_type) :: gradient_grid = cp_gauxc_grid_type() - TYPE(cp_gauxc_integrator_type) :: integrator = cp_gauxc_integrator_type() - TYPE(cp_gauxc_integrator_type) :: gradient_integrator = cp_gauxc_integrator_type() - INTEGER :: mpi_comm = -1 - LOGICAL :: is_init = .FALSE. - REAL(c_double), DIMENSION(:, :), ALLOCATABLE :: last_positions - CONTAINS - - PROCEDURE, PUBLIC :: needs_gradient_grid => gauxc_cache_type_needs_gradient_grid - PROCEDURE, PUBLIC :: max_l => gauxc_cache_type_max_l - END TYPE cp_gauxc_cache_type - - PUBLIC :: & - cp_gauxc_cache_type, & - gauxc_cache_init, & - gauxc_cache_is_valid, & - gauxc_cache_release, cp_gauxc_cache_params - -CONTAINS - -! ************************************************************************************************** -!> \brief ... -!> \param this ... -!> \return ... -! ************************************************************************************************** - FUNCTION gauxc_cache_type_needs_gradient_grid(this) RESULT(res) - class(cp_gauxc_cache_type) :: this - LOGICAL :: res - - res = this%use_gradient_self_runtime - END FUNCTION gauxc_cache_type_needs_gradient_grid - -! ************************************************************************************************** -!> \brief ... -!> \param this ... -!> \return ... -! ************************************************************************************************** - FUNCTION gauxc_cache_type_max_l(this) RESULT(res) - class(cp_gauxc_cache_type) :: this - INTEGER :: res - - res = this%basisset%max_l - END FUNCTION gauxc_cache_type_max_l - -! ************************************************************************************************** -!> \brief ... -!> \param cache ... -!> \param params ... -!> \param para_env ... -!> \param particle_set ... -!> \param qs_kind_set ... -!> \param status ... -! ************************************************************************************************** - SUBROUTINE gauxc_cache_init( & - cache, & - params, & - para_env, & - particle_set, & - qs_kind_set, & - status) - - TYPE(cp_gauxc_cache_type), INTENT(inout) :: cache - TYPE(cp_gauxc_cache_params), INTENT(inout) :: params - TYPE(mp_para_env_type), INTENT(in), POINTER :: para_env - TYPE(particle_type), DIMENSION(:), INTENT(in), & - POINTER :: particle_set - TYPE(qs_kind_type), DIMENSION(:), INTENT(in), & - POINTER :: qs_kind_set - TYPE(cp_gauxc_status_type), INTENT(inout) :: status - -#ifdef __GAUXC - IF (gauxc_cache_is_valid( & - cache, & - params, & - para_env, & - particle_set)) THEN - status%status%code = 0 - RETURN - END IF - - CALL gauxc_cache_release(cache) - - cache%molecule = gauxc_create_molecule( & - particle_set, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_molecule() - RETURN - END IF - - cache%basisset = gauxc_create_basisset( & - qs_kind_set, & - particle_set, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_basisset() - RETURN - END IF - - params%use_fd_gradient = & - params%use_fd_gradient .AND. (cache%max_l() > 3) - params%use_gradient_mpi_runtime = & - params%use_gradient_mpi_runtime .AND. .NOT. params%use_fd_gradient - params%use_gradient_self_runtime = & - params%use_gradient_self_runtime .AND. .NOT. params%use_gradient_mpi_runtime - - IF (params%use_fd_gradient .AND. para_env%mepos == 0) THEN - CALL cp_warn( & - __LOCATION__, & - "Using finite-difference GauXC XC gradients for METHOD GAPW/GAPW_XC with "// & - "basis functions beyond f shells. The upstream analytical GauXC gradient path is "// & - "not yet reliable for this case.") - END IF - IF (params%use_self_runtime .OR. .NOT. params%use_gauxc_model) THEN - ! SKALA currently needs a replicated molecular runtime for reproducible - ! open-shell densities across CP2K MPI ranks. - ! Conventional GauXC also uses a replicated runtime here: CP2K has - ! already allreduced the dense AO density matrix on every rank. - cache%grid = gauxc_create_grid( & - cache%molecule, & - cache%basisset, & - params%grid_type, & - params%radial_quadrature, & - params%pruning_scheme, & - params%lb_exec_space, & - params%batch_size, & - params%device_runtime_fill_fraction, & - status, & - mpi_comm=mp_comm_self%get_handle(), & - force_new_runtime=.TRUE.) - ELSE - ! Use the QS force-evaluation communicator rather than GauXC's global - ! runtime. In mixed CDFT the diabatic states can be built on disjoint - ! MPI subgroups; using the global communicator would make GauXC wait - ! for ranks that are working on another state. - cache%grid = gauxc_create_grid( & - cache%molecule, & - cache%basisset, & - params%grid_type, & - params%radial_quadrature, & - params%pruning_scheme, & - params%lb_exec_space, & - params%batch_size, & - params%device_runtime_fill_fraction, & - status, & - mpi_comm=para_env%get_handle()) - END IF - IF (status%status%code /= 0) THEN - CALL cleanup_after_grid() - RETURN - END IF - - cache%integrator = gauxc_create_integrator( & - TRIM(params%xc_fun_name), & - cache%grid, & - params%int_exec_space, & - params%lwd_kernel, & - params%nspins, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_integrator() - RETURN - END IF - - IF (params%use_gradient_self_runtime) THEN - ! Upstream GauXC does not yet support OneDFT/SKALA nuclear gradients - ! on an MPI runtime. Keep the energy/VXC path on the normal MPI - ! runtime and use an isolated runtime only for the replicated gradient. - cache%gradient_grid = gauxc_create_grid( & - cache%molecule, & - cache%basisset, & - params%grid_type, & - params%radial_quadrature, & - params%pruning_scheme, & - params%lb_exec_space, & - params%batch_size, & - params%device_runtime_fill_fraction, & - status, & - mpi_comm=mp_comm_self%get_handle(), & - force_new_runtime=.TRUE.) - IF (status%status%code /= 0) THEN - CALL cleanup_after_gradient_grid() - RETURN - END IF - cache%gradient_integrator = gauxc_create_integrator( & - TRIM(params%xc_fun_name), & - cache%gradient_grid, & - params%int_exec_space, & - params%lwd_kernel, & - params%nspins, & - status) - IF (status%status%code /= 0) THEN - CALL cleanup_after_gradient_integrator() - RETURN - END IF - END IF - - cache%natom = params%natom - cache%nspins = params%nspins - cache%batch_size = params%batch_size - cache%device_runtime_fill_fraction = REAL(params%device_runtime_fill_fraction, c_double) - cache%xc_fun_name = TRIM(params%xc_fun_name) - cache%grid_type = TRIM(params%grid_type) - cache%radial_quadrature = TRIM(params%radial_quadrature) - cache%pruning_scheme = TRIM(params%pruning_scheme) - cache%lb_exec_space = TRIM(params%lb_exec_space) - cache%int_exec_space = TRIM(params%int_exec_space) - cache%model_eval_name = TRIM(params%model_eval_name) - cache%lwd_kernel = TRIM(params%lwd_kernel) - cache%use_gradient_mpi_runtime = params%use_gradient_mpi_runtime - cache%use_mpi_runtime = params%use_mpi_runtime - cache%use_gradient_self_runtime = params%use_gradient_self_runtime - cache%use_self_runtime = params%use_self_runtime - cache%use_fd_gradient = params%use_fd_gradient - IF (ALLOCATED(cache%last_positions)) THEN - DEALLOCATE (cache%last_positions) - END IF - ALLOCATE (cache%last_positions(3, params%natom)) - - BLOCK - INTEGER :: iatom - DO iatom = 1, params%natom - cache%last_positions(:, iatom) = REAL(particle_set(iatom)%r(:), c_double) - END DO - END BLOCK - - cache%mpi_comm = para_env%get_handle() - cache%is_init = .TRUE. - -#else - MARK_USED(params) - MARK_USED(para_env) - MARK_USED(particle_set) - MARK_USED(qs_kind_set) - MARK_USED(status) - cache%is_init = .FALSE. -#endif - - CONTAINS -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_gradient_integrator() - CALL gauxc_destroy_integrator(cache%gradient_integrator, status) - CALL gauxc_check_status(status) - CALL cleanup_after_gradient_grid() - END SUBROUTINE cleanup_after_gradient_integrator - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_gradient_grid() - CALL gauxc_destroy_grid(cache%gradient_grid, status) - CALL gauxc_check_status(status) - CALL cleanup_after_integrator() - END SUBROUTINE cleanup_after_gradient_grid - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_integrator() - CALL gauxc_destroy_integrator(cache%integrator, status) - CALL gauxc_check_status(status) - CALL cleanup_after_grid() - END SUBROUTINE cleanup_after_integrator - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_grid() - CALL gauxc_destroy_grid(cache%grid, status) - CALL gauxc_check_status(status) - CALL cleanup_after_basisset() - END SUBROUTINE cleanup_after_grid - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_basisset() - CALL gauxc_destroy_basisset(cache%basisset, status) - CALL gauxc_check_status(status) - CALL cleanup_after_molecule() - END SUBROUTINE cleanup_after_basisset - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_after_molecule() - CALL gauxc_destroy_molecule(cache%molecule, status) - CALL gauxc_check_status(status) - CALL cleanup_final() - END SUBROUTINE cleanup_after_molecule - -! ************************************************************************************************** -!> \brief ... -! ************************************************************************************************** - SUBROUTINE cleanup_final() - IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) - cache%is_init = .FALSE. - END SUBROUTINE cleanup_final - - END SUBROUTINE gauxc_cache_init - -! ************************************************************************************************** -!> \brief Release all GauXC objects in a cache and deallocate arrays -!> \param cache ... -! ************************************************************************************************** - SUBROUTINE gauxc_cache_release(cache) - TYPE(cp_gauxc_cache_type), INTENT(INOUT) :: cache - -#ifdef __GAUXC - TYPE(cp_gauxc_status_type) :: status - - IF (cache%is_init) THEN - IF (cache%needs_gradient_grid()) THEN - CALL gauxc_destroy_integrator(cache%gradient_integrator, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_grid(cache%gradient_grid, status) - CALL gauxc_check_status(status) - END IF - CALL gauxc_destroy_integrator(cache%integrator, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_grid(cache%grid, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_basisset(cache%basisset, status) - CALL gauxc_check_status(status) - CALL gauxc_destroy_molecule(cache%molecule, status) - CALL gauxc_check_status(status) - END IF - IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) - cache%is_init = .FALSE. -#else - MARK_USED(cache) - IF (ALLOCATED(cache%last_positions)) DEALLOCATE (cache%last_positions) - cache%is_init = .FALSE. -#endif - END SUBROUTINE gauxc_cache_release - -! ************************************************************************************************** -!> \brief Check if the GauXC cache is valid for the given parameters -!> \param cache ... -!> \param params ... -!> \param para_env ... -!> \param particle_set ... -!> \return ... -!> \retval cache_valid ... -! ************************************************************************************************** - FUNCTION gauxc_cache_is_valid( & - cache, & - params, & - para_env, & - particle_set) & - RESULT(cache_valid) - - TYPE(cp_gauxc_cache_type), INTENT(IN) :: cache - TYPE(cp_gauxc_cache_params), INTENT(in) :: params - TYPE(mp_para_env_type), INTENT(in), POINTER :: para_env - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - LOGICAL :: use_gradient_self_runtime, use_gradient_mpi_runtime, use_fd_gradient - LOGICAL :: cache_valid - -#ifdef __GAUXC - INTEGER :: iatom - REAL(c_double), PARAMETER :: pos_tol = 1.0E-8_c_double - - cache_valid = .FALSE. - IF (.NOT. cache%is_init) RETURN - IF (cache%natom /= params%natom) RETURN - IF (cache%nspins /= params%nspins) RETURN - IF (cache%batch_size /= params%batch_size) RETURN - IF (ABS(cache%device_runtime_fill_fraction - REAL(params%device_runtime_fill_fraction, c_double)) > & - 1.0E-10_c_double) RETURN - IF (TRIM(cache%xc_fun_name) /= TRIM(params%xc_fun_name)) RETURN - IF (TRIM(cache%grid_type) /= TRIM(params%grid_type)) RETURN - IF (TRIM(cache%radial_quadrature) /= TRIM(params%radial_quadrature)) RETURN - IF (TRIM(cache%pruning_scheme) /= TRIM(params%pruning_scheme)) RETURN - IF (TRIM(cache%lb_exec_space) /= TRIM(params%lb_exec_space)) RETURN - IF (TRIM(cache%int_exec_space) /= TRIM(params%int_exec_space)) RETURN - IF (TRIM(cache%model_eval_name) /= TRIM(params%model_eval_name)) RETURN - IF (TRIM(cache%lwd_kernel) /= TRIM(params%lwd_kernel)) RETURN - IF (cache%use_self_runtime .NEQV. params%use_self_runtime) RETURN - IF (cache%use_mpi_runtime .NEQV. params%use_mpi_runtime) RETURN - - ! These three are modified during cache init, so we must emulate these changes here - use_gradient_self_runtime = params%use_gradient_self_runtime - use_gradient_mpi_runtime = params%use_gradient_mpi_runtime - use_fd_gradient = params%use_fd_gradient - - use_fd_gradient = & - use_fd_gradient .AND. (cache%max_l() > 3) - use_gradient_mpi_runtime = & - use_gradient_mpi_runtime .AND. .NOT. use_fd_gradient - use_gradient_self_runtime = & - use_gradient_self_runtime .AND. .NOT. use_gradient_mpi_runtime - - IF (cache%use_gradient_mpi_runtime .NEQV. use_gradient_mpi_runtime) RETURN - IF (cache%use_fd_gradient .NEQV. use_fd_gradient) RETURN - IF (cache%use_gradient_self_runtime .NEQV. use_gradient_self_runtime) RETURN - IF (cache%mpi_comm /= para_env%get_handle()) RETURN - - IF (.NOT. ALLOCATED(cache%last_positions)) RETURN - IF (SIZE(cache%last_positions, 2) /= params%natom) RETURN - DO iatom = 1, params%natom - IF (ANY(ABS(cache%last_positions(:, iatom) - & - REAL(particle_set(iatom)%r(:), c_double)) > pos_tol)) RETURN - END DO - cache_valid = .TRUE. -#else - MARK_USED(cache) - MARK_USED(particle_set) - MARK_USED(params) - MARK_USED(use_gradient_self_runtime) - MARK_USED(use_gradient_mpi_runtime) - MARK_USED(use_fd_gradient) - MARK_USED(para_env) - cache_valid = .FALSE. -#endif - END FUNCTION gauxc_cache_is_valid - -END MODULE xc_gauxc_cache diff --git a/src/xc/xc_gauxc_functional.F b/src/xc/xc_gauxc_functional.F index 2a850d6def..3c12631d2f 100644 --- a/src/xc/xc_gauxc_functional.F +++ b/src/xc/xc_gauxc_functional.F @@ -49,9 +49,6 @@ MODULE xc_gauxc_functional qs_rho_type USE qs_scf_types, ONLY: qs_scf_env_type USE string_utilities, ONLY: uppercase - USE xc_gauxc_cache, ONLY: cp_gauxc_cache_params,& - cp_gauxc_cache_type,& - gauxc_cache_init USE xc_gauxc_interface, ONLY: & cp_gauxc_basisset_type, cp_gauxc_grid_type, cp_gauxc_integrator_type, & cp_gauxc_molecule_type, cp_gauxc_status_type, cp_gauxc_xc_gradient_type, cp_gauxc_xc_type, & @@ -120,26 +117,24 @@ CONTAINS !> \brief ... !> \param dbcsr_mat ... !> \param dense_mat ... -!> \param para_env ... ! ************************************************************************************************** - SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat, para_env) - USE cp_dbcsr_api, ONLY: dbcsr_distribution_get, dbcsr_distribution_type, dbcsr_get_info, & - dbcsr_get_matrix_type, dbcsr_get_readonly_block_p, & - dbcsr_get_stored_coordinates, dbcsr_type_antisymmetric, & - dbcsr_type_symmetric + SUBROUTINE dbcsr_to_dense(dbcsr_mat, dense_mat) + USE cp_dbcsr_api, ONLY: dbcsr_get_info, dbcsr_get_matrix_type, dbcsr_iterator_type, & + dbcsr_iterator_start, dbcsr_iterator_next_block, dbcsr_iterator_blocks_left, & + dbcsr_iterator_stop, dbcsr_type_antisymmetric, dbcsr_type_symmetric TYPE(dbcsr_p_type), INTENT(IN) :: dbcsr_mat REAL(c_double), ALLOCATABLE, DIMENSION(:, :), & INTENT(INOUT) :: dense_mat - TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env CHARACTER :: matrix_type - INTEGER :: col, col_end, col_start, icol, irow, mynode, nblkcols_total, nblkrows_total, & - ncols, nrows, numnodes, owner, row, row_end, row_start + INTEGER :: col, col_end, col_start, icol, irow, & + nblkcols_total, nblkrows_total, ncols, & + nrows, row, row_end, row_start INTEGER, ALLOCATABLE, DIMENSION(:) :: c_offset, r_offset INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size - LOGICAL :: found + LOGICAL :: transposed REAL(c_double), POINTER :: block(:, :) - TYPE(dbcsr_distribution_type) :: dist + TYPE(dbcsr_iterator_type) :: iter CALL dbcsr_get_info(dbcsr_mat%matrix, & row_blk_size=row_blk_size, & @@ -147,9 +142,7 @@ CONTAINS nblkrows_total=nblkrows_total, & nblkcols_total=nblkcols_total, & nfullrows_total=nrows, & - nfullcols_total=ncols, & - distribution=dist) - CALL dbcsr_distribution_get(dist, mynode=mynode, numnodes=numnodes) + nfullcols_total=ncols) matrix_type = dbcsr_get_matrix_type(dbcsr_mat%matrix) IF (.NOT. ALLOCATED(dense_mat)) THEN @@ -173,19 +166,23 @@ CONTAINS c_offset(col) = c_offset(col - 1) + col_blk_size(col - 1) END DO - ! Replicated DBCSR blocks must enter the following MPI sum exactly once. - DO irow = 1, nblkrows_total - DO icol = 1, nblkcols_total - IF (numnodes == 1 .AND. para_env%num_pe > 1 .AND. para_env%mepos /= 0) CYCLE - CALL dbcsr_get_stored_coordinates(dbcsr_mat%matrix, irow, icol, owner) - IF (owner /= mynode) CYCLE - CALL dbcsr_get_readonly_block_p(matrix=dbcsr_mat%matrix, row=irow, col=icol, & - block=block, found=found) - IF (.NOT. found) CYCLE - row_start = r_offset(irow) - row_end = row_start + row_blk_size(irow) - 1 - col_start = c_offset(icol) - col_end = col_start + col_blk_size(icol) - 1 + CALL dbcsr_iterator_start(iter, dbcsr_mat%matrix) + DO WHILE (dbcsr_iterator_blocks_left(iter)) + CALL dbcsr_iterator_next_block(iter, irow, icol, block, transposed=transposed) + row_start = r_offset(irow) + row_end = row_start + row_blk_size(irow) - 1 + col_start = c_offset(icol) + col_end = col_start + col_blk_size(icol) - 1 + IF (transposed) THEN + dense_mat(row_start:row_end, col_start:col_end) = TRANSPOSE(block) + IF (irow /= icol) THEN + IF (matrix_type == dbcsr_type_symmetric) THEN + dense_mat(col_start:col_end, row_start:row_end) = block + ELSE IF (matrix_type == dbcsr_type_antisymmetric) THEN + dense_mat(col_start:col_end, row_start:row_end) = -block + END IF + END IF + ELSE dense_mat(row_start:row_end, col_start:col_end) = block IF (irow /= icol) THEN IF (matrix_type == dbcsr_type_symmetric) THEN @@ -194,8 +191,9 @@ CONTAINS dense_mat(col_start:col_end, row_start:row_end) = -TRANSPOSE(block) END IF END IF - END DO + END IF END DO + CALL dbcsr_iterator_stop(iter) DEALLOCATE (r_offset, c_offset) @@ -574,8 +572,7 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & gauxc_status, & - mpi_comm=mp_comm_self%get_handle(), & - force_new_runtime=.TRUE.) + mpi_comm=mp_comm_self%get_handle()) CALL gauxc_check_status(gauxc_status) gauxc_integrator_fd = gauxc_create_integrator( & TRIM(xc_fun_name), & @@ -898,36 +895,31 @@ CONTAINS INTEGER, INTENT(out), OPTIONAL :: max_deriv CHARACTER(len=default_path_length) :: model_key, model_name - CHARACTER(len=default_string_length) :: xc_fun_key, xc_fun_name + CHARACTER(len=default_string_length) :: xc_fun_name LOGICAL :: native_grid CALL section_vals_val_get(functional, "FUNCTIONAL", c_val=xc_fun_name) CALL section_vals_val_get(functional, "MODEL", c_val=model_name) CALL section_vals_val_get(functional, "NATIVE_GRID", l_val=native_grid) model_key = ADJUSTL(model_name) - xc_fun_key = ADJUSTL(xc_fun_name) CALL uppercase(model_key) - CALL uppercase(xc_fun_key) IF (PRESENT(reference)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & - TRIM(model_key) == TRIM(xc_fun_key)) THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN reference = "Functional computed by GauXC (underlying: "//TRIM(xc_fun_name)//")" ELSE reference = "Functional computed by GauXC Skala model "//TRIM(model_name) END IF END IF IF (PRESENT(shortform)) THEN - IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "" .OR. & - TRIM(model_key) == TRIM(xc_fun_key)) THEN + IF (TRIM(model_key) == "NONE" .OR. TRIM(model_key) == "") THEN shortform = "GAUXC ("//TRIM(xc_fun_name)//")" ELSE shortform = "GAUXC Skala" END IF END IF IF (PRESENT(needs)) THEN - IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "" .AND. & - TRIM(model_key) /= TRIM(xc_fun_key)) THEN + IF (native_grid .AND. TRIM(model_key) /= "NONE" .AND. TRIM(model_key) /= "") THEN IF (lsd) THEN needs%rho_spin = .TRUE. needs%drho_spin = .TRUE. @@ -969,21 +961,26 @@ CONTAINS REAL(KIND=dp), PARAMETER :: gapw_fd_gradient_dx = 1.0E-4_dp CHARACTER(len=default_path_length) :: model_key, model_name, output_path - CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, & - grid_key, pruning_key, skala_runtime, & - skala_runtime_key, xc_fun_key - INTEGER :: atom_chunk_size, env_status, img, ispin, & - nimages + CHARACTER(len=default_string_length) :: gradient_runtime, gradient_runtime_key, grid_key, & + grid_type, int_exec_space, lb_exec_space, lwd_kernel, pruning_key, pruning_scheme, & + radial_quadrature, skala_runtime, skala_runtime_key, xc_fun_name + INTEGER :: atom_chunk_size, batch_size, env_status, & + img, ispin, natom, nimages, nspins LOGICAL :: atom_chunk_size_explicit, do_kpoints, gapw_method, gapw_paw_pseudopotentials, & gapw_pseudopotentials, grid_explicit, hdf5_output, is_periodic, molecular_virial, & molecular_virial_debug, need_xc_gradient, periodic_reference, pruning_explicit, & - use_skala_model, write_hdf5_output - REAL(KIND=dp) :: molecular_virial_debug_dx + use_fd_gradient, use_gauxc_model, use_gradient_mpi_runtime, use_gradient_self_runtime, & + use_self_runtime, use_skala_model, write_hdf5_output + REAL(KIND=dp) :: device_runtime_fill_fraction, & + molecular_virial_debug_dx REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: density_scalar, density_zeta TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell - TYPE(cp_gauxc_cache_params) :: params - TYPE(cp_gauxc_cache_type), POINTER :: cache + TYPE(cp_gauxc_basisset_type) :: gauxc_basis + TYPE(cp_gauxc_grid_type) :: gauxc_gradient_grid_result, & + gauxc_grid_result + TYPE(cp_gauxc_integrator_type) :: gauxc_gradient_integrator_result, gauxc_integrator_result + TYPE(cp_gauxc_molecule_type) :: gauxc_mol TYPE(cp_gauxc_status_type) :: gauxc_status TYPE(cp_gauxc_xc_gradient_type) :: exc_grad TYPE(cp_gauxc_xc_type) :: gauxc_xc_result @@ -1026,7 +1023,7 @@ CONTAINS energy=energy, & ks_env=ks_env, & matrix_vxc=matrix_vxc, & - natom=params%natom, & + natom=natom, & atomic_kind_set=atomic_kind_set, & force=force, & para_env=para_env, & @@ -1053,7 +1050,7 @@ CONTAINS rho_ao_kp=rho_ao) nimages = dft_control%nimages - params%nspins = dft_control%nspins + nspins = dft_control%nspins is_periodic = .FALSE. IF (ASSOCIATED(cell)) is_periodic = ANY(cell%perd /= 0) @@ -1068,7 +1065,7 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "FUNCTIONAL", & - c_val=params%xc_fun_name) + c_val=xc_fun_name) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL", & @@ -1076,25 +1073,25 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "GRID", & - c_val=params%grid_type, & + c_val=grid_type, & explicit=grid_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "RADIAL_QUADRATURE", & - c_val=params%radial_quadrature) + c_val=radial_quadrature) CALL section_vals_val_get( & gauxc_functional_section, & "PRUNING_SCHEME", & - c_val=params%pruning_scheme, & + c_val=pruning_scheme, & explicit=pruning_explicit) CALL section_vals_val_get( & gauxc_functional_section, & "BATCH_SIZE", & - i_val=params%batch_size) + i_val=batch_size) CALL section_vals_val_get( & gauxc_functional_section, & "DEVICE_RUNTIME_FILL_FRACTION", & - r_val=params%device_runtime_fill_fraction) + r_val=device_runtime_fill_fraction) CALL section_vals_val_get( & gauxc_functional_section, & "MODEL_ATOM_CHUNK_SIZE", & @@ -1119,15 +1116,15 @@ CONTAINS CALL section_vals_val_get( & gauxc_functional_section, & "LB_EXECUTION_SPACE", & - c_val=params%lb_exec_space) + c_val=lb_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "INT_EXECUTION_SPACE", & - c_val=params%int_exec_space) + c_val=int_exec_space) CALL section_vals_val_get( & gauxc_functional_section, & "LWD_KERNEL", & - c_val=params%lwd_kernel) + c_val=lwd_kernel) CALL section_vals_val_get( & gauxc_functional_section, & "SKALA_RUNTIME", & @@ -1143,21 +1140,20 @@ CONTAINS model_key = ADJUSTL(model_name) CALL uppercase(model_key) - xc_fun_key = ADJUSTL(params%xc_fun_name) - CALL uppercase(xc_fun_key) skala_runtime_key = ADJUSTL(skala_runtime) CALL uppercase(skala_runtime_key) gradient_runtime_key = ADJUSTL(gradient_runtime) CALL uppercase(gradient_runtime_key) - params%use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE" .AND. & - TRIM(model_key) /= TRIM(xc_fun_key)) + use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE") use_skala_model = (INDEX(TRIM(model_key), "SKALA") > 0) - params%model_eval_name = model_name - IF (.NOT. params%use_gauxc_model) THEN - ! MODEL NONE and MODEL equal to FUNCTIONAL select conventional GauXC. - params%model_eval_name = "NONE" + IF (gapw_pseudopotentials .AND. .NOT. use_gauxc_model) THEN + CALL cp_abort(__LOCATION__, & + "GauXC with METHOD GAPW/GAPW_XC and pseudopotentials is supported only for "// & + "Skala-style models that replace the molecular XC term. "// & + "Use POTENTIAL ALL for local/semi-local GauXC GAPW validation or METHOD GPW "// & + "with pseudopotentials.") END IF - IF (gapw_pseudopotentials .AND. params%use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & + IF (gapw_pseudopotentials .AND. use_gauxc_model .AND. .NOT. dft_control%qs_control%gapw_xc .AND. & .NOT. gapw_paw_pseudopotentials .AND. para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1167,7 +1163,7 @@ CONTAINS "XC correction is used for those regular-grid kinds.") END IF END IF - IF (params%device_runtime_fill_fraction <= 0.0_dp .OR. params%device_runtime_fill_fraction > 1.0_dp) THEN + IF (device_runtime_fill_fraction <= 0.0_dp .OR. device_runtime_fill_fraction > 1.0_dp) THEN CALL cp_abort(__LOCATION__, & "GAUXC%DEVICE_RUNTIME_FILL_FRACTION must be > 0 and <= 1.") END IF @@ -1195,21 +1191,21 @@ CONTAINS END IF END IF END IF - IF (params%use_gauxc_model) THEN + IF (use_gauxc_model) THEN IF (has_nlcc(qs_kind_set)) THEN CALL cp_abort(__LOCATION__, & "GauXC Skala with NLCC pseudopotentials is not implemented. "// & "The frozen core density would need a SKALA-consistent feature definition.") END IF END IF - IF (params%use_gauxc_model) THEN + IF (use_gauxc_model) THEN CALL set_gauxc_model_atom_chunk_env( & atom_chunk_size, atom_chunk_size_explicit) - IF (.NOT. grid_explicit) params%grid_type = "SUPERFINE" - IF (.NOT. pruning_explicit) params%pruning_scheme = "UNPRUNED" + IF (.NOT. grid_explicit) grid_type = "SUPERFINE" + IF (.NOT. pruning_explicit) pruning_scheme = "UNPRUNED" - grid_key = ADJUSTL(params%grid_type) - pruning_key = ADJUSTL(params%pruning_scheme) + grid_key = ADJUSTL(grid_type) + pruning_key = ADJUSTL(pruning_scheme) CALL uppercase(grid_key) CALL uppercase(pruning_key) IF (use_skala_model .AND. need_xc_gradient .AND. & @@ -1224,36 +1220,35 @@ CONTAINS IF (env_status /= 0 .OR. LEN_TRIM(model_name) == 0) THEN CPABORT("MODEL SKALA requires the GAUXC_SKALA_MODEL environment variable") END IF - params%model_eval_name = model_name END IF END IF SELECT CASE (TRIM(skala_runtime_key)) CASE ("AUTO") - params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. params%nspins > 1 + use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 .AND. nspins > 1 CASE ("MPI") - params%use_self_runtime = .FALSE. + use_self_runtime = .FALSE. CASE ("SELF") - params%use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 + use_self_runtime = use_skala_model .AND. para_env%num_pe > 1 CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%SKALA_RUNTIME value.") END SELECT - IF (.NOT. use_skala_model) params%use_self_runtime = .FALSE. + IF (.NOT. use_skala_model) use_self_runtime = .FALSE. SELECT CASE (TRIM(gradient_runtime_key)) CASE ("AUTO", "SELF") - params%use_gradient_mpi_runtime = .FALSE. - params%use_gradient_self_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. & - para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime + use_gradient_mpi_runtime = .FALSE. + use_gradient_self_runtime = need_xc_gradient .AND. use_gauxc_model .AND. & + para_env%num_pe > 1 .AND. .NOT. use_self_runtime CASE ("MPI") - params%use_gradient_mpi_runtime = need_xc_gradient .AND. params%use_gauxc_model .AND. para_env%num_pe > 1 - params%use_gradient_self_runtime = .FALSE. + use_gradient_mpi_runtime = need_xc_gradient .AND. use_gauxc_model .AND. para_env%num_pe > 1 + use_gradient_self_runtime = .FALSE. CASE DEFAULT CALL cp_abort(__LOCATION__, "Unknown GAUXC%MODEL_GRADIENT_RUNTIME value.") END SELECT - IF (.NOT. params%use_gauxc_model) THEN - params%use_gradient_mpi_runtime = .FALSE. - params%use_gradient_self_runtime = .FALSE. + IF (.NOT. use_gauxc_model) THEN + use_gradient_mpi_runtime = .FALSE. + use_gradient_self_runtime = .FALSE. END IF - IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. params%use_self_runtime .AND. & + IF (use_skala_model .AND. para_env%num_pe > 1 .AND. .NOT. use_self_runtime .AND. & para_env%mepos == 0 .AND. ASSOCIATED(scf_env)) THEN IF (scf_env%iter_count == 1) THEN CALL cp_warn( & @@ -1264,19 +1259,15 @@ CONTAINS END IF END IF - ! After creating the basisset, we will have to check max_l>3 as a further condition - params%use_fd_gradient = gapw_method .AND. need_xc_gradient - - IF (.NOT. ASSOCIATED(qs_env%gauxc_cache)) ALLOCATE (qs_env%gauxc_cache) - cache => qs_env%gauxc_cache - CALL gauxc_cache_init( & - cache, & - params, & - para_env, & - particle_set, & - qs_kind_set, & - gauxc_status) - + gauxc_mol = gauxc_create_molecule( & + particle_set, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) + gauxc_basis = gauxc_create_basisset( & + qs_kind_set, & + particle_set, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) hdf5_output = (TRIM(output_path) /= "") write_hdf5_output = hdf5_output .AND. para_env%mepos == 0 IF (write_hdf5_output .AND. ASSOCIATED(scf_env)) THEN @@ -1284,20 +1275,98 @@ CONTAINS END IF IF (write_hdf5_output) THEN CALL gauxc_write_molecule_hdf5( & - cache%molecule, & + gauxc_mol, & output_path, & "molecule.h5", & "molecule", & gauxc_status) CALL gauxc_check_status(gauxc_status) CALL gauxc_write_basisset_hdf5( & - cache%basisset, & + gauxc_basis, & output_path, & "basisset.h5", & "basisset", & gauxc_status) CALL gauxc_check_status(gauxc_status) END IF + use_fd_gradient = gapw_method .AND. need_xc_gradient .AND. (gauxc_basis%max_l > 3) + IF (use_fd_gradient) use_gradient_mpi_runtime = .FALSE. + IF (use_gradient_mpi_runtime) THEN + use_gradient_self_runtime = .FALSE. + END IF + IF (use_fd_gradient .AND. para_env%mepos == 0) THEN + CALL cp_warn( & + __LOCATION__, & + "Using finite-difference GauXC XC gradients for METHOD GAPW/GAPW_XC with "// & + "basis functions beyond f shells. The upstream analytical GauXC gradient path is "// & + "not yet reliable for this case.") + END IF + IF (use_self_runtime) THEN + ! SKALA currently needs a replicated molecular runtime for reproducible + ! open-shell densities across CP2K MPI ranks. + gauxc_grid_result = gauxc_create_grid( & + gauxc_mol, & + gauxc_basis, & + grid_type, & + radial_quadrature, & + pruning_scheme, & + lb_exec_space, & + batch_size, & + device_runtime_fill_fraction, & + gauxc_status, & + mpi_comm=mp_comm_self%get_handle()) + ELSE + ! Use the QS force-evaluation communicator rather than GauXC's global + ! runtime. In mixed CDFT the diabatic states can be built on disjoint + ! MPI subgroups; using the global communicator would make GauXC wait + ! for ranks that are working on another state. + gauxc_grid_result = gauxc_create_grid( & + gauxc_mol, & + gauxc_basis, & + grid_type, & + radial_quadrature, & + pruning_scheme, & + lb_exec_space, & + batch_size, & + device_runtime_fill_fraction, & + gauxc_status, & + mpi_comm=para_env%get_handle()) + END IF + CALL gauxc_check_status(gauxc_status) + gauxc_integrator_result = gauxc_create_integrator( & + TRIM(xc_fun_name), & + gauxc_grid_result, & + int_exec_space, & + lwd_kernel, & + nspins, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) + + IF (use_gradient_self_runtime) THEN + ! Upstream GauXC does not yet support Skala nuclear gradients + ! on an MPI runtime. Keep the energy/VXC path on the normal MPI + ! runtime and use an isolated runtime only for the replicated gradient. + gauxc_gradient_grid_result = gauxc_create_grid( & + gauxc_mol, & + gauxc_basis, & + grid_type, & + radial_quadrature, & + pruning_scheme, & + lb_exec_space, & + batch_size, & + device_runtime_fill_fraction, & + gauxc_status, & + mpi_comm=mp_comm_self%get_handle()) + CALL gauxc_check_status(gauxc_status) + gauxc_gradient_integrator_result = gauxc_create_integrator( & + TRIM(xc_fun_name), & + gauxc_gradient_grid_result, & + int_exec_space, & + lwd_kernel, & + nspins, & + gauxc_status) + CALL gauxc_check_status(gauxc_status) + END IF IF (qs_env%run_rtp) THEN CPABORT("GAUXC XC energy currently does not support real-time propagation") @@ -1306,46 +1375,46 @@ CONTAINS energy%exc = 0 IF (ASSOCIATED(matrix_vxc)) CALL dbcsr_deallocate_matrix_set(matrix_vxc) - CALL dbcsr_allocate_matrix_set(matrix_vxc, params%nspins) + CALL dbcsr_allocate_matrix_set(matrix_vxc, nspins) DO img = 1, nimages IF (img > 1) THEN CPABORT("UNIMPLEMENTED: Handling nimg>1 in k-point integration") END IF - CALL dbcsr_to_dense(rho_ao(1, img), density_scalar, para_env) + CALL dbcsr_to_dense(rho_ao(1, img), density_scalar) CALL para_env%sum(density_scalar) - IF (params%nspins == 1) THEN + IF (nspins == 1) THEN gauxc_xc_result = gauxc_compute_xc( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & - nspins=params%nspins, & + nspins=nspins, & status=gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (params%use_fd_gradient) THEN + IF (use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & - params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, nspins, model_name, & + xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad) - ELSE IF (params%use_gradient_self_runtime) THEN + ELSE IF (use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - cache%gradient_integrator, & + gauxc_gradient_integrator_result, & density_scalar, & - nspins=params%nspins, & - natom=params%natom, & + nspins=nspins, & + natom=natom, & status=gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & - nspins=params%nspins, & - natom=params%natom, & + nspins=nspins, & + natom=natom, & status=gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1360,19 +1429,19 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & - params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & + model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, molecular_virial_debug_dx, para_env) END IF DEALLOCATE (exc_grad%exc_grad) END IF ELSE - CPASSERT(params%nspins == 2) + CPASSERT(nspins == 2) ! In here: ! scalar <- rho_ao(1, :) + rho_ao(2, :) ! zeta <- rho_ao(1, :) - rho_ao(2, :) - CALL dbcsr_to_dense(rho_ao(2, img), density_zeta, para_env) + CALL dbcsr_to_dense(rho_ao(2, img), density_zeta) CALL para_env%sum(density_zeta) ! Do NOT reorder the following lines! density_scalar(:, :) = density_scalar(:, :) + density_zeta(:, :) @@ -1382,39 +1451,39 @@ CONTAINS ! This style lowers memory footprint. density_zeta(:, :) = density_scalar(:, :) - 2.0_dp*density_zeta(:, :) gauxc_xc_result = gauxc_compute_xc( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & density_zeta, & - params%nspins, & + nspins, & gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) CALL gauxc_check_status(gauxc_status) IF (need_xc_gradient) THEN - IF (params%use_fd_gradient) THEN + IF (use_fd_gradient) THEN CALL gauxc_xc_gradient_fd( & - particle_set, qs_kind_set, density_scalar, params%nspins, params%model_eval_name, & - params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & + particle_set, qs_kind_set, density_scalar, nspins, model_name, & + xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, gapw_fd_gradient_dx, para_env, & exc_grad%exc_grad, density_zeta=density_zeta) - ELSE IF (params%use_gradient_self_runtime) THEN + ELSE IF (use_gradient_self_runtime) THEN exc_grad = gauxc_compute_xc_gradient( & - cache%gradient_integrator, & + gauxc_gradient_integrator_result, & density_scalar, & density_zeta, & - params%nspins, & - params%natom, & + nspins, & + natom, & gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) ELSE exc_grad = gauxc_compute_xc_gradient( & - cache%integrator, & + gauxc_integrator_result, & density_scalar, & density_zeta, & - params%nspins, & - params%natom, & + nspins, & + natom, & gauxc_status, & - model=TRIM(params%model_eval_name)) + model=TRIM(model_name)) END IF CALL gauxc_check_status(gauxc_status) IF (calculate_forces) THEN @@ -1429,10 +1498,10 @@ CONTAINS END IF IF (molecular_virial_debug) THEN CALL debug_gauxc_molecular_virial( & - exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, params%nspins, & - params%model_eval_name, params%xc_fun_name, params%grid_type, params%radial_quadrature, params%pruning_scheme, & - params%lb_exec_space, params%int_exec_space, params%lwd_kernel, params%batch_size, & - params%device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & + exc_grad%exc_grad, particle_set, qs_kind_set, density_scalar, nspins, & + model_name, xc_fun_name, grid_type, radial_quadrature, pruning_scheme, & + lb_exec_space, int_exec_space, lwd_kernel, batch_size, & + device_runtime_fill_fraction, molecular_virial_debug_dx, para_env, & density_zeta=density_zeta) END IF DEALLOCATE (exc_grad%exc_grad) @@ -1441,14 +1510,14 @@ CONTAINS energy%exc = energy%exc + gauxc_xc_result%exc - IF (params%nspins == 1) THEN + IF (nspins == 1) THEN IF (img == 1) THEN matrix_vxc(1) = dense_to_dbcsr(gauxc_xc_result%vxc_scalar, rho_ao(1, img)) ELSE CPABORT("UNIMPLEMENTED: Handling multiple result matrices in k-point integration") END IF ELSE - CPASSERT(params%nspins == 2) + CPASSERT(nspins == 2) ! Transform derivatives from total/spin density back to alpha/beta channels. vxc_zeta_tmp = dense_to_dbcsr(gauxc_xc_result%vxc_zeta, rho_ao(1, img)) IF (img == 1) THEN @@ -1475,10 +1544,25 @@ CONTAINS IF (ALLOCATED(gauxc_xc_result%vxc_zeta)) DEALLOCATE (gauxc_xc_result%vxc_zeta) CALL set_ks_env(ks_env, matrix_vxc=matrix_vxc) - DO ispin = 1, params%nspins + DO ispin = 1, nspins CALL dbcsr_finalize(matrix_vxc(ispin)%matrix) END DO + IF (use_gradient_self_runtime) THEN + CALL gauxc_destroy_integrator(gauxc_gradient_integrator_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_grid(gauxc_gradient_grid_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + END IF + CALL gauxc_destroy_integrator(gauxc_integrator_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_grid(gauxc_grid_result, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_basisset(gauxc_basis, gauxc_status) + CALL gauxc_check_status(gauxc_status) + CALL gauxc_destroy_molecule(gauxc_mol, gauxc_status) + CALL gauxc_check_status(gauxc_status) + END SUBROUTINE apply_gauxc END MODULE xc_gauxc_functional diff --git a/src/xc/xc_gauxc_interface.F b/src/xc/xc_gauxc_interface.F index e79a8fdd87..ed1356ebde 100644 --- a/src/xc/xc_gauxc_interface.F +++ b/src/xc/xc_gauxc_interface.F @@ -506,7 +506,6 @@ CONTAINS !> \param device_runtime_fill_fraction ... !> \param status ... !> \param mpi_comm optional communicator for a grid-local GauXC runtime -!> \param force_new_runtime force creation of a grid-local GauXC runtime !> \return ... ! ************************************************************************************************** FUNCTION gauxc_create_grid( & @@ -519,8 +518,7 @@ CONTAINS batch_size, & device_runtime_fill_fraction, & status, & - mpi_comm, & - force_new_runtime) RESULT(res) + mpi_comm) RESULT(res) TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule TYPE(cp_gauxc_basisset_type), INTENT(in) :: basis @@ -530,14 +528,13 @@ CONTAINS REAL(c_double), INTENT(IN) :: device_runtime_fill_fraction TYPE(cp_gauxc_status_type), INTENT(OUT) :: status INTEGER, INTENT(IN), OPTIONAL :: mpi_comm - LOGICAL, INTENT(IN), OPTIONAL :: force_new_runtime TYPE(cp_gauxc_grid_type) :: res #ifdef __GAUXC INTEGER(c_int) :: grid_type_local, int_exec_space_local, & lb_exec_space_local, & pruning_scheme_local, radial_quad_local - LOGICAL :: force_new_runtime_local, use_device_runtime + LOGICAL :: use_device_runtime grid_type_local = read_atomic_grid_size(grid_type) radial_quad_local = read_radial_quad(radial_quadrature) @@ -545,8 +542,6 @@ CONTAINS lb_exec_space_local = read_execution_space(lb_exec_space) int_exec_space_local = read_execution_space("host") use_device_runtime = (lb_exec_space_local == gauxc_executionspace%device) - force_new_runtime_local = .FALSE. - IF (PRESENT(force_new_runtime)) force_new_runtime_local = force_new_runtime res%owns_rt = .FALSE. IF (use_device_runtime) THEN @@ -575,8 +570,7 @@ CONTAINS IF (PRESENT(mpi_comm)) THEN ! Reuse the global runtime when the requested communicator matches ! the communicator used during gauxc_init. - IF (force_new_runtime_local .OR. .NOT. rt_has_mpi_comm .OR. & - mpi_comm /= rt_mpi_comm) THEN + IF (.NOT. rt_has_mpi_comm .OR. mpi_comm /= rt_mpi_comm) THEN res%rt = gauxc_runtime_environment_new(status%status, mpi_comm) GAUXC_RETURN_IF_ERROR(status) res%owns_rt = .TRUE. @@ -584,7 +578,6 @@ CONTAINS END IF #else MARK_USED(mpi_comm) - MARK_USED(force_new_runtime) #endif END IF @@ -644,7 +637,6 @@ CONTAINS MARK_USED(grid_type) MARK_USED(lb_exec_space) MARK_USED(mpi_comm) - MARK_USED(force_new_runtime) MARK_USED(molecule) MARK_USED(pruning_scheme) MARK_USED(radial_quadrature) diff --git a/src/xc/xc_libxc.F b/src/xc/xc_libxc.F index 6b0340a0bf..3faed929f3 100644 --- a/src/xc/xc_libxc.F +++ b/src/xc/xc_libxc.F @@ -307,11 +307,9 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & - func_name_override) + SUBROUTINE libxc_lda_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -319,7 +317,6 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -329,13 +326,8 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -406,7 +398,6 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & @@ -424,11 +415,9 @@ CONTAINS !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param print_warn whether to print warning about development status of a functional -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn, & - func_name_override) + SUBROUTINE libxc_lsd_info(libxc_params, reference, shortform, needs, max_deriv, print_warn) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -436,7 +425,6 @@ CONTAINS INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv LOGICAL, INTENT(IN), OPTIONAL :: print_warn - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(LEN=128) :: s1, s2 @@ -446,13 +434,8 @@ CONTAINS TYPE(xc_f03_func_t) :: xc_func TYPE(xc_f03_func_info_t) :: xc_info - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) CALL cite_reference(Marques2012) CALL cite_reference(Lehtola2018) @@ -525,7 +508,6 @@ CONTAINS MARK_USED(needs) MARK_USED(max_deriv) MARK_USED(print_warn) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are "// & "asking for a functional of the LibXC library, "// & @@ -560,16 +542,14 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) + SUBROUTINE libxc_lda_eval(rho_set, deriv_set, grad_deriv, libxc_params) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lda_eval' @@ -594,23 +574,15 @@ CONTAINS NULLIFY (dummy) NULLIFY (rho, norm_drho, laplace_rho, tau) - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_UNPOLARIZED) xc_info = xc_f03_func_get_info(xc_func) - no_exc = .FALSE. - IF (.NOT. PRESENT(func_name_override)) THEN - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) - END IF + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rho=rho, norm_drho=norm_drho, laplace_rho=laplace_rho, & @@ -790,7 +762,6 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & "you have to download and install the library!") @@ -806,16 +777,14 @@ CONTAINS !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) -!> \param func_name_override optional LibXC functional name overriding the section name !> \author F. Tran ! ************************************************************************************************** - SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params, func_name_override) + SUBROUTINE libxc_lsd_eval(rho_set, deriv_set, grad_deriv, libxc_params) TYPE(xc_rho_set_type), INTENT(IN) :: rho_set TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: func_name_override #if defined (__LIBXC) CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lsd_eval' @@ -854,23 +823,15 @@ CONTAINS NULLIFY (rhoa, rhob, norm_drho, norm_drhoa, norm_drhob, laplace_rhoa, & laplace_rhob, tau_a, tau_b) - IF (PRESENT(func_name_override)) THEN - func_name = func_name_override - func_scale = 1.0_dp - ELSE - func_name = libxc_params%section%name - CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) - END IF + func_name = libxc_params%section%name + CALL section_vals_val_get(libxc_params, "scale", r_val=func_scale) IF (ABS(func_scale - 1.0_dp) < 1.0e-10_dp) func_scale = 1.0_dp func_id = xc_libxc_wrap_functional_get_number(func_name) CALL xc_f03_func_init(xc_func, func_id, XC_POLARIZED) xc_info = xc_f03_func_get_info(xc_func) - no_exc = .FALSE. - IF (.NOT. PRESENT(func_name_override)) THEN - CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) - END IF + CALL xc_libxc_wrap_functional_set_params(xc_func, xc_info, libxc_params, no_exc) CALL xc_rho_set_get(rho_set, can_return_null=.TRUE., & rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, & @@ -1329,7 +1290,6 @@ CONTAINS MARK_USED(deriv_set) MARK_USED(grad_deriv) MARK_USED(libxc_params) - MARK_USED(func_name_override) CALL cp_abort(__LOCATION__, "Unknown functional! If you are asking "// & "for a functional of the LibXC library, "// & diff --git a/src/xc/xc_libxc_wrap.F b/src/xc/xc_libxc_wrap.F index e070d9f6f3..b8c0ed8962 100644 --- a/src/xc/xc_libxc_wrap.F +++ b/src/xc/xc_libxc_wrap.F @@ -105,10 +105,9 @@ MODULE xc_libxc_wrap section_release, & section_type, section_vals_type, section_vals_val_get #include "../base/base_uses.f90" -#endif + IMPLICIT NONE PRIVATE -#if defined (__LIBXC) CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xc_libxc_wrap' diff --git a/src/xc/xc_pade.F b/src/xc/xc_pade.F index 2a2b413b26..2be8e39fa3 100644 --- a/src/xc/xc_pade.F +++ b/src/xc/xc_pade.F @@ -118,9 +118,8 @@ CONTAINS END IF IF (PRESENT(needs)) THEN - IF (.NOT. PRESENT(lsd)) THEN + IF (.NOT. PRESENT(lsd)) & CPABORT("Arguments mismatch.") - END IF IF (lsd) THEN needs%rho_spin = .TRUE. ELSE diff --git a/src/xc/xc_perdew86.F b/src/xc/xc_perdew86.F index 559927a21e..386c1bd48e 100644 --- a/src/xc/xc_perdew86.F +++ b/src/xc/xc_perdew86.F @@ -36,6 +36,8 @@ MODULE xc_perdew86 PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_perdew_zunger.F b/src/xc/xc_perdew_zunger.F index c5870410fd..eede7b4efa 100644 --- a/src/xc/xc_perdew_zunger.F +++ b/src/xc/xc_perdew_zunger.F @@ -296,7 +296,7 @@ CONTAINS dummy => a e_0 => dummy - ea => dummy + ea => dummy; eaa => dummy; eab => dummy; ebb => dummy eaaa => dummy; eaab => dummy; eabb => dummy; ebbb => dummy diff --git a/src/xc/xc_rho_set_types.F b/src/xc/xc_rho_set_types.F index da711debed..f44aaf8ce4 100644 --- a/src/xc/xc_rho_set_types.F +++ b/src/xc/xc_rho_set_types.F @@ -620,9 +620,8 @@ CONTAINS do_sf = .FALSE. IF (PRESENT(spinflip)) do_sf = spinflip - IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) THEN + IF (ANY(rho_set%local_bounds /= pw_pool%pw_grid%bounds_local)) & CPABORT("pw_pool cr3d have different size than expected") - END IF nspins = SIZE(rho_r) rho_set%local_bounds = rho_r(1)%pw_grid%bounds_local rho_cutoff = 0.5*rho_set%rho_cutoff diff --git a/src/xc/xc_tfw.F b/src/xc/xc_tfw.F index 57f1d74478..c46167a7d2 100644 --- a/src/xc/xc_tfw.F +++ b/src/xc/xc_tfw.F @@ -16,7 +16,6 @@ MODULE xc_tfw USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_norm_drho,& deriv_norm_drhoa,& deriv_norm_drhob,& @@ -38,6 +37,8 @@ MODULE xc_tfw PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_thomas_fermi.F b/src/xc/xc_thomas_fermi.F index 32584bd0ae..61765ad154 100644 --- a/src/xc/xc_thomas_fermi.F +++ b/src/xc/xc_thomas_fermi.F @@ -18,7 +18,6 @@ MODULE xc_thomas_fermi USE cp_array_utils, ONLY: cp_3d_r_cp_type USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& deriv_rhob @@ -37,6 +36,8 @@ MODULE xc_thomas_fermi PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13, & diff --git a/src/xc/xc_vwn.F b/src/xc/xc_vwn.F index 29739a1179..528117d098 100644 --- a/src/xc/xc_vwn.F +++ b/src/xc/xc_vwn.F @@ -200,13 +200,13 @@ CONTAINS CALL xc_derivative_get(deriv, deriv_data=e_rho) CALL vwn_lda_01(rho, x, e_0, e_rho, npoints, sc) - ELSE IF (order >= 0) THEN + ELSEIF (order >= 0) THEN deriv => xc_dset_get_derivative(deriv_set, [INTEGER::], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_0) CALL vwn_lda_0(rho, x, e_0, npoints, sc) - ELSE IF (order == -1) THEN + ELSEIF (order == -1) THEN deriv => xc_dset_get_derivative(deriv_set, [deriv_rho], & allocate_deriv=.TRUE.) CALL xc_derivative_get(deriv, deriv_data=e_rho) diff --git a/src/xc/xc_xalpha.F b/src/xc/xc_xalpha.F index e9a0912979..8c260959e5 100644 --- a/src/xc/xc_xalpha.F +++ b/src/xc/xc_xalpha.F @@ -21,7 +21,6 @@ MODULE xc_xalpha USE input_section_types, ONLY: section_vals_type,& section_vals_val_get USE kinds, ONLY: dp - USE mathconstants, ONLY: pi USE pw_types, ONLY: pw_r3d_rs_type USE xc_derivative_desc, ONLY: deriv_rho,& deriv_rhoa,& @@ -41,6 +40,8 @@ MODULE xc_xalpha PRIVATE ! *** Global parameters *** + + REAL(KIND=dp), PARAMETER :: pi = 3.14159265358979323846264338_dp REAL(KIND=dp), PARAMETER :: f13 = 1.0_dp/3.0_dp, & f23 = 2.0_dp*f13, & f43 = 4.0_dp*f13 diff --git a/src/xc_adiabatic_utils.F b/src/xc_adiabatic_utils.F index f50f1f790a..7a304c6770 100644 --- a/src/xc_adiabatic_utils.F +++ b/src/xc_adiabatic_utils.F @@ -134,11 +134,10 @@ CONTAINS CASE (do_adiabatic_hybrid_mcy3) SELECT CASE (adiabatic_model) CASE (do_adiabatic_model_pade) - IF (n_rep_hf /= 2) THEN + IF (n_rep_hf /= 2) & CALL cp_abort(__LOCATION__, & "For this kind of adiababatic hybrid functional 2 HF sections have to be provided. "// & "Please check your input file.") - END IF CALL rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & adiabatic_omega, scale_dEx1, scale_ddW0, scale_dDFA, & scale_dEx2, total_energy_xc) diff --git a/src/xc_pot_saop.F b/src/xc_pot_saop.F index 2034fd550c..186d29c5d6 100644 --- a/src/xc_pot_saop.F +++ b/src/xc_pot_saop.F @@ -855,35 +855,29 @@ CONTAINS IF (lsd) THEN DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) THEN + IF (rho_set_h%rhoa(ia, ir, 1) > rho_set_h%rho_cutoff) & vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rhoa(ia, ir, 1) - END IF - IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) THEN + IF (rho_set_h%rhob(ia, ir, 1) > rho_set_h%rho_cutoff) & vxc_GLLB_h(ia, ir, 2) = vxc_GLLB_h(ia, ir, 2) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 2)/rho_set_h%rhob(ia, ir, 1) - END IF - IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) THEN + IF (rho_set_s%rhoa(ia, ir, 1) > rho_set_s%rho_cutoff) & vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rhoa(ia, ir, 1) - END IF - IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) THEN + IF (rho_set_s%rhob(ia, ir, 1) > rho_set_s%rho_cutoff) & vxc_GLLB_s(ia, ir, 2) = vxc_GLLB_s(ia, ir, 2) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 2)/rho_set_s%rhob(ia, ir, 1) - END IF END DO END DO ELSE DO ir = 1, nr DO ia = 1, na - IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) THEN + IF (rho_set_h%rho(ia, ir, 1) > rho_set_h%rho_cutoff) & vxc_GLLB_h(ia, ir, 1) = vxc_GLLB_h(ia, ir, 1) + & weight_h(ia, ir)*vxc_tmp_h(ia, ir, 1)/rho_set_h%rho(ia, ir, 1) - END IF - IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) THEN + IF (rho_set_s%rho(ia, ir, 1) > rho_set_s%rho_cutoff) & vxc_GLLB_s(ia, ir, 1) = vxc_GLLB_s(ia, ir, 1) + & weight_s(ia, ir)*vxc_tmp_s(ia, ir, 1)/rho_set_s%rho(ia, ir, 1) - END IF END DO END DO END IF diff --git a/src/xtb_coulomb.F b/src/xtb_coulomb.F index a95fdcede7..f079817d9b 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(:, :) - ELSE IF (rab > rcut) THEN + ELSEIF (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 - ELSE IF (rab > rcut) THEN + ELSEIF (rab > rcut) THEN dgmat(:, :) = 0.0_dp ELSE eta = eta**(-kg) diff --git a/src/xtb_hcore.F b/src/xtb_hcore.F index 8b7565eb05..0e182950b3 100644 --- a/src/xtb_hcore.F +++ b/src/xtb_hcore.F @@ -156,7 +156,7 @@ CONTAINS CALL get_atomic_kind(atomic_kind_set(ikind), z=za) IF (metal(za)) THEN kcnlk(0:3, ikind) = 0.0_dp - ELSE IF (early3d(za)) THEN + ELSEIF (early3d(za)) THEN kcnlk(0, ikind) = kcns kcnlk(1, ikind) = kcnp kcnlk(2, ikind) = 0.005_dp @@ -278,7 +278,7 @@ CONTAINS ELSE km = km*kdiff END IF - ELSE IF (zb == 1 .AND. nb == 2) THEN + ELSEIF (zb == 1 .AND. nb == 2) THEN km = km*kdiff END IF kijab(i, j, ikind, jkind) = km diff --git a/src/xtb_ks_matrix.F b/src/xtb_ks_matrix.F index b9725df4fe..527f5f20b0 100644 --- a/src/xtb_ks_matrix.F +++ b/src/xtb_ks_matrix.F @@ -190,10 +190,9 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge equilibration energy: ", energy%eeq, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF + "Correction for nonbonded interactions: ", energy%xtb_nonbonded IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield @@ -442,14 +441,12 @@ CONTAINS "Zeroth order Hamiltonian energy: ", energy%core, & "Charge fluctuation energy: ", energy%hartree, & "London dispersion energy: ", energy%dispersion - IF (dft_control%qs_control%xtb_control%xb_interaction) THEN + IF (dft_control%qs_control%xtb_control%xb_interaction) & WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for halogen bonding: ", energy%xtb_xb_inter - END IF - IF (dft_control%qs_control%xtb_control%do_nonbonded) THEN + "Correction for halogen bonding: ", energy%xtb_xb_inter + IF (dft_control%qs_control%xtb_control%do_nonbonded) & WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & - "Correction for nonbonded interactions: ", energy%xtb_nonbonded - END IF + "Correction for nonbonded interactions: ", energy%xtb_nonbonded IF (ABS(energy%efield) > 1.e-12_dp) THEN WRITE (UNIT=iounit, FMT="(T9,A,T60,F20.10)") & "Electric field interaction energy: ", energy%efield diff --git a/src/xtb_parameters.F b/src/xtb_parameters.F index 67bb511bd2..0c79a46c19 100644 --- a/src/xtb_parameters.F +++ b/src/xtb_parameters.F @@ -69,11 +69,9 @@ MODULE xtb_parameters 0.98_dp, 1.57_dp, 2.04_dp, 2.55_dp, 3.04_dp, 3.44_dp, 3.98_dp, 4.50_dp, & ! 10 0.93_dp, 1.31_dp, 1.61_dp, 1.90_dp, 2.19_dp, 2.58_dp, 3.16_dp, 3.50_dp, & ! 18 0.82_dp, 1.00_dp, 1.36_dp, 1.54_dp, 1.63_dp, 1.66_dp, 1.55_dp, 1.83_dp, & - 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, & - 2.96_dp, 3.00_dp, & ! 36 + 1.88_dp, 1.91_dp, 1.90_dp, 1.65_dp, 1.81_dp, 2.01_dp, 2.18_dp, 2.55_dp, 2.96_dp, 3.00_dp, & ! 36 0.82_dp, 0.95_dp, 1.22_dp, 1.33_dp, 1.60_dp, 2.16_dp, 1.90_dp, 2.20_dp, & - 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, & - 2.66_dp, 2.60_dp, & ! 54 + 2.28_dp, 2.20_dp, 1.93_dp, 1.69_dp, 1.78_dp, 1.96_dp, 2.05_dp, 2.10_dp, 2.66_dp, 2.60_dp, & ! 54 0.79_dp, 0.89_dp, 1.10_dp, & 1.12_dp, 1.13_dp, 1.14_dp, 1.15_dp, 1.17_dp, 1.18_dp, 1.20_dp, 1.21_dp, & 1.22_dp, 1.23_dp, 1.24_dp, 1.25_dp, 1.26_dp, 1.27_dp, & ! Lanthanides @@ -118,11 +116,9 @@ MODULE xtb_parameters 1.30_dp, 0.99_dp, 0.84_dp, 0.75_dp, 0.71_dp, 0.64_dp, 0.60_dp, 0.62_dp, & ! 10 1.60_dp, 1.40_dp, 1.24_dp, 1.14_dp, 1.09_dp, 1.04_dp, 1.00_dp, 1.01_dp, & ! 18 2.00_dp, 1.74_dp, 1.59_dp, 1.48_dp, 1.44_dp, 1.30_dp, 1.29_dp, 1.24_dp, & - 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, & - 1.17_dp, 1.16_dp, & ! 36 + 1.18_dp, 1.17_dp, 1.22_dp, 1.20_dp, 1.23_dp, 1.20_dp, 1.20_dp, 1.18_dp, 1.17_dp, 1.16_dp, & ! 36 2.15_dp, 1.90_dp, 1.76_dp, 1.64_dp, 1.56_dp, 1.46_dp, 1.38_dp, 1.36_dp, & - 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, & - 1.36_dp, 1.36_dp, & ! 54 + 1.34_dp, 1.30_dp, 1.36_dp, 1.40_dp, 1.42_dp, 1.40_dp, 1.40_dp, 1.37_dp, 1.36_dp, 1.36_dp, & ! 54 2.38_dp, 2.06_dp, 1.94_dp, & 1.84_dp, 1.90_dp, 1.88_dp, 1.86_dp, 1.85_dp, 1.83_dp, 1.82_dp, 1.81_dp, & 1.80_dp, 1.79_dp, 1.77_dp, 1.77_dp, 1.78_dp, 1.74_dp, & ! Lanthanides @@ -142,11 +138,9 @@ MODULE xtb_parameters 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 10 1.05_dp, 2.05_dp, 3.00_dp, 4.00_dp, 3.00_dp, 2.00_dp, 1.25_dp, 1.00_dp, & ! 18 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 1.25_dp, 1.00_dp, & ! 36 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 36 1.05_dp, 2.05_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, & - 1.25_dp, 1.00_dp, & ! 54 + 3.50_dp, 3.50_dp, 3.50_dp, 2.50_dp, 2.50_dp, 3.50_dp, 3.50_dp, 3.50_dp, 1.25_dp, 1.00_dp, & ! 54 1.05_dp, 2.05_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, 3.00_dp, & ! Lanthanides @@ -652,14 +646,14 @@ CONTAINS CASE (78) kab = 0.80_dp END SELECT - ELSE IF (za == 5 .OR. zb == 5) THEN + ELSEIF (za == 5 .OR. zb == 5) THEN ! Boron z = za + zb - 5 SELECT CASE (z) CASE (15) kab = 0.97_dp END SELECT - ELSE IF (za == 7 .OR. zb == 7) THEN + ELSEIF (za == 7 .OR. zb == 7) THEN ! Nitrogen z = za + zb - 7 SELECT CASE (z) @@ -668,21 +662,21 @@ CONTAINS ! in the paper this is Kab for B-Si kab = 1.01_dp END SELECT - ELSE IF (za > 20 .AND. za < 30) THEN + ELSEIF (za > 20 .AND. za < 30) THEN ! 3d IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 1.10_dp - ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 0.50_dp*(1.20_dp + 1.10_dp) END IF - ELSE IF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN + ELSEIF ((za > 38 .AND. za < 48) .OR. (za > 56 .AND. za < 80)) THEN ! 4d/5d/4f IF (zb > 20 .AND. zb < 30) THEN ! 3d kab = 0.50_dp*(1.20_dp + 1.10_dp) - ELSE IF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN + ELSEIF ((zb > 38 .AND. zb < 48) .OR. (zb > 56 .AND. zb < 80)) THEN ! 4d/5d/4f kab = 1.20_dp END IF diff --git a/src/xtb_potentials.F b/src/xtb_potentials.F index 07dab22561..36028812aa 100644 --- a/src/xtb_potentials.F +++ b/src/xtb_potentials.F @@ -807,11 +807,10 @@ CONTAINS ((name_atm_a) == (nonbonded%pot(ingp)%pot%at2)))) THEN CALL pair_potential_single_copy(nonbonded%pot(ingp)%pot, pot) ! multiple potential not implemented, simply overwriting - IF (found) THEN + IF (found) & CALL cp_warn(__LOCATION__, & "Multiple NONBONDED declaration: "//TRIM(name_atm_a)// & " and "//TRIM(name_atm_b)//" OVERWRITING! ") - END IF !IF (iw > 0) WRITE (iw, *) " FOUND ", TRIM(name_atm_a), " ", TRIM(name_atm_b) found = .TRUE. END IF diff --git a/src/xtb_types.F b/src/xtb_types.F index 9ec859eae6..51240aabdf 100644 --- a/src/xtb_types.F +++ b/src/xtb_types.F @@ -99,9 +99,8 @@ CONTAINS TYPE(xtb_atom_type), POINTER :: xtb_parameter - IF (ASSOCIATED(xtb_parameter)) THEN + IF (ASSOCIATED(xtb_parameter)) & CALL deallocate_xtb_atom_param(xtb_parameter) - END IF ALLOCATE (xtb_parameter) diff --git a/tests/Fist/regtest-mace/TEST_FILES.toml b/tests/Fist/regtest-mace/TEST_FILES.toml deleted file mode 100644 index 4e86987486..0000000000 --- a/tests/Fist/regtest-mace/TEST_FILES.toml +++ /dev/null @@ -1,3 +0,0 @@ -# Test of MACE using libtorch https://pytorch.org/cppdocs/installing.html -"mace_test.inp" = [{matcher="M011", tol=1.0E-9, ref=-1532.363300232407482}] -#EOF \ No newline at end of file diff --git a/tests/Fist/regtest-mace/mace-test.xyz b/tests/Fist/regtest-mace/mace-test.xyz deleted file mode 100644 index de5d503ae3..0000000000 --- a/tests/Fist/regtest-mace/mace-test.xyz +++ /dev/null @@ -1,34 +0,0 @@ -32 -Lattice="7.23 0.0 0.0 0.0 7.23 0.0 0.0 0.0 7.23" Properties=species:S:1:pos:R:3 pbc="T T T" -Cu 7.19929385 0.07184150 7.15208419 -Cu 7.14664045 2.10236709 2.01651087 -Cu 1.82143618 0.04226192 1.92285339 -Cu 1.99446521 1.95857840 7.03556683 -Cu 0.04124875 0.03433693 3.81793753 -Cu 0.13296440 1.50725440 5.36672362 -Cu 2.05785380 7.16421454 5.34153878 -Cu 1.87904775 2.29484159 3.46181587 -Cu 7.14343690 3.63361819 0.04539203 -Cu 0.07856581 5.42264104 2.00907147 -Cu 1.70046840 3.49032697 1.45196525 -Cu 1.52838588 5.29338639 0.08402179 -Cu 7.04010983 3.63297407 3.45547313 -Cu 0.04993241 5.06858718 5.39256856 -Cu 1.57620067 3.46938961 5.22644546 -Cu 1.85045246 5.47919762 3.50191702 -Cu 3.66469285 0.20246133 0.01048150 -Cu 3.65200112 1.80572076 1.95822174 -Cu 5.62157919 7.09211077 1.57513403 -Cu 5.42582769 1.92125447 7.13092135 -Cu 3.74438701 7.22849521 3.62250140 -Cu 3.71553234 1.93544475 5.27911967 -Cu 5.41897600 6.88436492 5.32462967 -Cu 5.23975470 1.60760854 3.77619340 -Cu 3.72354623 3.71850028 0.15023152 -Cu 3.53953689 5.32915887 1.66932471 -Cu 5.31356798 3.64843433 1.81519742 -Cu 5.24884208 5.54500604 0.06504144 -Cu 3.76661054 3.88873128 3.46537226 -Cu 3.74258866 5.40276336 5.55936212 -Cu 5.45073160 3.94041922 5.40526077 -Cu 5.72305460 5.42694152 3.73428797 diff --git a/tests/Fist/regtest-mace/mace_test.inp b/tests/Fist/regtest-mace/mace_test.inp deleted file mode 100644 index feabc680c5..0000000000 --- a/tests/Fist/regtest-mace/mace_test.inp +++ /dev/null @@ -1,41 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT mace_test - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD FIST - #STRESS_TENSOR ANALYTICAL - &MM - &FORCEFIELD - &NONBONDED - &MACE - ATOMS Cu - POT_FILE_NAME MACE/MACE_scratch_run-3.model-cp2k.pth - &END MACE - &END NONBONDED - &END FORCEFIELD - &POISSON - &EWALD - EWALD_TYPE none - &END EWALD - &END POISSON - &END MM - &PRINT - &FORCES ON - &END FORCES - #&STRESS_TENSOR ON - #&END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - CELL_FILE_FORMAT XYZ - CELL_FILE_NAME ./mace-test.xyz - &END CELL - &TOPOLOGY - COORD_FILE_FORMAT XYZ - COORD_FILE_NAME ./mace-test.xyz - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md index b369135c48..c7e9b8747a 100644 --- a/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md +++ b/tests/QS/GAPW_ACCURATE_XCINT_COVERAGE.md @@ -20,8 +20,6 @@ used to move towards making accurate XC integration the GAPW default in a future | DC-DFT/Energy Correction | `regtest-acc-2/HF-ec1.inp`, `HF-ec2.inp`, `HF-ec3.inp` | `HF-ec4.inp`, `HF-ec5.inp`, `HF-ec6.inp`, and `HF-ec7.inp` now also use explicit accurate integration | | TDDFPT forces | `regtest-acc-5/h2o_f01.inp` | `regtest-acc-5/h2o_f01_fine.inp` | | ADMM-GAPW TDDFPT response | `regtest-acc-5/ft3.inp` | `regtest-acc-5/ft3_fine.inp` | -| UZH basis/potential data | all-electron UZH HF force-debug tests in `regtest-acc-1` | GAPW all-electron and GAPW/GAPW_XC GTH finite-difference force and stress checks with `BASIS_MOLOPT_UZH` and `POTENTIAL_UZH` | -| def2-ECP data | def2-SVP ECP GAPW energy checks in `regtest-ecp` and `regtest-ecp-2` | GAPW mixed all-electron/ECP and GAPW_XC ECP-only finite-difference force and stress checks | | XAS/RT response | XAS_TDP and RTBSE coverage in `regtest-xastdp` and `regtest-rtbse` | open-shell GAPW XAS_TDP and GAPW RTBSE smoke tests in `regtest-acc-3` | | KG embedding | existing `regtest-kg` GPW cases | GAPW/GAPW_XC energy and stress checks for libxc KG, meta-GGA/tau KG, and RI embedding | | KG atomic potential | `regtest-kg/H2_KG-1.inp` | GAPW/GAPW_XC energy and stress checks for `TNADD_METHOD ATOMIC` | @@ -57,16 +55,6 @@ Finite-difference checks with `STOP_ON_MISMATCH` are included for: is kept diagonal in the targeted debug tests above. - GAPW_XC forces and diagonal stress: `regtest-acc-1/h2o-gapw_xc-force-1.inp`, `regtest-acc-1/h2o-gapw_xc-stress-debug-1.inp`. -- UZH all-electron GAPW forces and analytical stress smoke: - `regtest-acc-1/h2o-uzh-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp`. -- UZH GTH GAPW/GAPW_XC forces and analytical stress smoke: - `regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp`, `regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp`, - `regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp`, and - `regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp`. -- ECP GAPW/GAPW_XC targeted force and analytical stress smoke checks: - `regtest-ecp/ICl_lanl2dz_gapw_force.inp`, `ICl_lanl2dz_gapw_stress.inp`, - `ICl_lanl2dz_gapw_xc_force.inp`, and `ICl_lanl2dz_gapw_xc_stress.inp`; the def2-ECP energy path - remains covered by `regtest-ecp/SbH3_def2_gapw.inp`. - ADMM-GAPW forces: `regtest-acc-1/HF-d5.inp`, `regtest-acc-5/ft3_fine.inp`. - ADMM-GAPW diagonal stress: `regtest-acc-2/h2o-admm-gapw-stress-debug-1.inp`, `regtest-acc-2/h2o-admm-gapw-pbe-stress-debug-1.inp`. diff --git a/tests/QS/regtest-acc-1/TEST_FILES.toml b/tests/QS/regtest-acc-1/TEST_FILES.toml index d26801d538..41e4817c71 100644 --- a/tests/QS/regtest-acc-1/TEST_FILES.toml +++ b/tests/QS/regtest-acc-1/TEST_FILES.toml @@ -36,10 +36,4 @@ "h2o-gapw_xc-stress-debug-1.inp" = [] "h2o-gapw_xc-full-stress-1.inp" = [{matcher="M011", tol=1e-08, ref=-17.256333793570239}, {matcher="M031", tol=1e-08, ref=3.91898639036E+03}] -"h2o-uzh-gapw-force-1.inp" = [] -"h2o-uzh-gapw-stress-debug-1.inp" = [] -"h2o-uzh-gth-gapw-force-1.inp" = [] -"h2o-uzh-gth-gapw-stress-debug-1.inp" = [] -"h2o-uzh-gth-gapw_xc-force-1.inp" = [] -"h2o-uzh-gth-gapw_xc-stress-debug-1.inp" = [] #EOF diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp deleted file mode 100644 index 9e6684b46a..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gapw-force-1.inp +++ /dev/null @@ -1,63 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gapw-force-1 - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &KIND O - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp deleted file mode 100644 index 920bbbf7a1..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gapw-stress-debug-1.inp +++ /dev/null @@ -1,60 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gapw-stress-debug-1 - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &KIND O - BASIS_SET SVP-MOLOPT-PBE-ae - POTENTIAL ALL - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp deleted file mode 100644 index 924f9670d2..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-force-1.inp +++ /dev/null @@ -1,67 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw-force-1 - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp deleted file mode 100644 index 3c80d1546e..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw-stress-debug-1.inp +++ /dev/null @@ -1,64 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw-stress-debug-1 - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp deleted file mode 100644 index 412457eafe..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-force-1.inp +++ /dev/null @@ -1,69 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw_xc-force-1 - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp b/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp deleted file mode 100644 index 5bceffa537..0000000000 --- a/tests/QS/regtest-acc-1/h2o-uzh-gth-gapw_xc-stress-debug-1.inp +++ /dev/null @@ -1,66 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT h2o-uzh-gth-gapw_xc-stress-debug-1 - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME BASIS_MOLOPT_UZH - POTENTIAL_FILE_NAME POTENTIAL_UZH - &MGRID - CUTOFF 240 - NGRIDS 5 - REL_CUTOFF 40 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-10 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - O 0.110000 0.170000 -0.045587 - H 0.260000 -0.627136 0.570545 - H -0.180000 0.897136 0.440545 - &END COORD - &KIND H - BASIS_SET DZVP-MOLOPT-PBE-GTH-q1 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q1 - RADIAL_GRID 50 - &END KIND - &KIND O - BASIS_SET DZVP-MOLOPT-PBE-GTH-q6 - LEBEDEV_GRID 50 - POTENTIAL GTH-PBE-q6 - RADIAL_GRID 50 - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-admm-libxc/TEST_FILES.toml b/tests/QS/regtest-admm-libxc/TEST_FILES.toml index 548bfe1fbe..640bfb052e 100644 --- a/tests/QS/regtest-admm-libxc/TEST_FILES.toml +++ b/tests/QS/regtest-admm-libxc/TEST_FILES.toml @@ -2,8 +2,8 @@ "H2O-BP-OPTX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.173082884557527}] "H2O-BP-BECKEX.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172192115148068}] "H2O-BP-Coul.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.172925552133442}] -"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689027640}] +"H2O-BP-sr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.712074689018060}] "H2O-BP-lr.inp" = [{matcher="M011", tol=1.0E-13, ref=-16.689871565334784}] -"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754561230}] -"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992363387}] +"H2O-BP-cl.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.635078754585429}] +"H2O-BP-cl-trunc.inp" = [{matcher="M011", tol=1.0E-13, ref=-17.629884992387993}] #EOF diff --git a/tests/QS/regtest-debug-3/TEST_FILES.toml b/tests/QS/regtest-debug-3/TEST_FILES.toml index 150a32d80b..f5340fcf68 100644 --- a/tests/QS/regtest-debug-3/TEST_FILES.toml +++ b/tests/QS/regtest-debug-3/TEST_FILES.toml @@ -6,8 +6,8 @@ "h2o_pbe0.inp" = [{matcher="M060", tol=1e-05, ref=0.411901963703}] "h2o_pbe0_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.426369189904}] # -"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.445432754543}] -"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.442023635799}] +"h2o_HSE06.inp" = [{matcher="M060", tol=1e-05, ref=0.436263865396}] +"h2o_HSE06_admm.inp" = [{matcher="M060", tol=1e-05, ref=0.381688458912}] #h2o_B88_mixcl.inp functional B88_LR 60 1e-05 0.000000000000E+00 #h2o_B88_mixcl_admm.inp functional B88_LR 60 1e-05 0.000000000000E+00 "h2o_pbe0TC.inp" = [{matcher="M060", tol=1e-05, ref=0.430192264863}] diff --git a/tests/QS/regtest-debug-3/h2o_HSE06.inp b/tests/QS/regtest-debug-3/h2o_HSE06.inp index c57938acb0..8330db4771 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06.inp @@ -21,7 +21,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 150 + CUTOFF 200 &END MGRID &PRINT &MOMENTS ON @@ -80,7 +80,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 5.0 5.0 5.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp index c46674b366..a96d0a06ff 100644 --- a/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp +++ b/tests/QS/regtest-debug-3/h2o_HSE06_admm.inp @@ -28,7 +28,7 @@ &EFIELD &END EFIELD &MGRID - CUTOFF 150 + CUTOFF 200 &END MGRID &PRINT &MOMENTS ON @@ -87,7 +87,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 4.0 4.0 4.0 + ABC [angstrom] 5.0 5.0 5.0 PERIODIC NONE &END CELL &COORD diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp deleted file mode 100644 index 35a8618cc7..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_force.inp +++ /dev/null @@ -1,62 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_force - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp deleted file mode 100644 index aa73463cd3..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_stress.inp +++ /dev/null @@ -1,59 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_stress - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - GAPW_ACCURATE_XCINT T - METHOD GAPW - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 5.0 0.0 0.0 - B 0.25 5.1 0.0 - C 0.15 0.35 5.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp deleted file mode 100644 index a1fd01ce1e..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_force.inp +++ /dev/null @@ -1,64 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_xc_force - RUN_TYPE DEBUG -&END GLOBAL - -&DEBUG - CHECK_ATOM_FORCE 1 x - DEBUG_FORCES T - DEBUG_STRESS_TENSOR F - DX 0.0005 - MAX_RELATIVE_ERROR 0.10 - STOP_ON_MISMATCH T -&END DEBUG - -&FORCE_EVAL - METHOD Quickstep - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &SUBSYS - &CELL - A 6.0 0.0 0.0 - B 0.25 6.1 0.0 - C 0.15 0.35 6.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp b/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp deleted file mode 100644 index b94b1a47a1..0000000000 --- a/tests/QS/regtest-ecp/ICl_lanl2dz_gapw_xc_stress.inp +++ /dev/null @@ -1,61 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT ICl_lanl2dz_gapw_xc_stress - RUN_TYPE ENERGY_FORCE -&END GLOBAL - -&FORCE_EVAL - METHOD Quickstep - STRESS_TENSOR ANALYTICAL - &DFT - BASIS_SET_FILE_NAME ./ECP_BASIS_POT - POTENTIAL_FILE_NAME ./ECP_BASIS_POT - &MGRID - CUTOFF 160 - NGRIDS 4 - REL_CUTOFF 30 - &END MGRID - &QS - ALPHA_WEIGHTS 6.5 - EPS_DEFAULT 1.0E-9 - FORCE_PAW - GAPW_1C_BASIS EXT_SMALL - GAPW_ACCURATE_XCINT T - METHOD GAPW_XC - &END QS - &SCF - EPS_SCF 1.0E-7 - MAX_SCF 80 - SCF_GUESS ATOMIC - &END SCF - &XC - DENSITY_CUTOFF 1.0E-11 - &XC_FUNCTIONAL PBE - &END XC_FUNCTIONAL - &END XC - &END DFT - &PRINT - &STRESS_TENSOR - COMPONENTS - &END STRESS_TENSOR - &END PRINT - &SUBSYS - &CELL - A 6.0 0.0 0.0 - B 0.25 6.1 0.0 - C 0.15 0.35 6.2 - &END CELL - &COORD - Cl 0.000000 0.000000 0.000000 - I 0.250000 0.100000 2.490000 - &END COORD - &KIND Cl - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &KIND I - BASIS_SET LANL2DZ - POTENTIAL ECP LANL2DZ_ECP - &END KIND - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/QS/regtest-ecp/TEST_FILES.toml b/tests/QS/regtest-ecp/TEST_FILES.toml index 914bf20fb4..77e7b87d8e 100644 --- a/tests/QS/regtest-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-ecp/TEST_FILES.toml @@ -3,7 +3,3 @@ "SbH3_def2_gapw.inp" = [{matcher="M011", tol=1.0E-11, ref=-241.414769303399083}] "HCl_ccECP.inp" = [{matcher="M011", tol=1.0E-12, ref=-15.457709431781252}] "HCl_force.inp" = [] -"ICl_lanl2dz_gapw_force.inp" = [] -"ICl_lanl2dz_gapw_stress.inp" = [] -"ICl_lanl2dz_gapw_xc_force.inp" = [] -"ICl_lanl2dz_gapw_xc_stress.inp" = [] diff --git a/tests/QS/regtest-gauxc-api/TEST_FILES.toml b/tests/QS/regtest-gauxc-api/TEST_FILES.toml index e9ee7d1cee..c03ead6223 100644 --- a/tests/QS/regtest-gauxc-api/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-api/TEST_FILES.toml @@ -1,7 +1,7 @@ "1H2_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163125608332391}] "1H2_GAUXC_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] -"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121772046629}] +"1H2_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-10, ref=-1.163121899608445}] "NH3_GAUXC_MODEL_PBE_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722432805445091}] -"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722557896081605}] +"NH3_GAUXC_MODEL_PBE.inp" = [{matcher="E_total", tol=1e-9, ref=-11.722558568119791}] "OH_GAUXC_MODEL_PBE_UKS.inp" = [{matcher="E_total", tol=5e-6, ref=-16.541584062034670}] "CH4_DIMER_GAUXC_PBE_D3.inp" = [{matcher="M033", tol=1e-14, ref=-0.00355123783846}] diff --git a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml index db816e3a27..3bd87ffe71 100644 --- a/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-cdft/TEST_FILES.toml @@ -1,11 +1,11 @@ "H2_PBE_CDFT_REFERENCE.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157232743213941}, {matcher="M071", tol=1e-8, ref=0.197625731046}] -"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229340943540}, +"H2_GAUXC_MODEL_PBE_CDFT.inp" = [{matcher="E_total", tol=1e-9, ref=-1.157229554329094}, {matcher="M071", tol=1e-8, ref=0.197624070585}] "H2_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.216557647288}] "H2_GAPW_SKALA_CDFT.inp" = [{matcher="M071", tol=1e-3, ref=0.217417757774}] "H2_PBE_CDFT_CI_REFERENCE.inp" = [{matcher="M073", tol=1e-8, ref=345.364329058819}, {matcher="M077", tol=1e-8, ref=-1.16295181842678}] -"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325380057211}, - {matcher="M077", tol=1e-8, ref=-1.16294801624740}] +"H2_GAUXC_MODEL_PBE_CDFT_CI_NGROUPS.inp" = [{matcher="M073", tol=1e-8, ref=345.325437357859}, + {matcher="M077", tol=1e-8, ref=-1.16294823026735}] "H2_SKALA_CDFT_CI.inp" = [{matcher="M077", tol=5e-8, ref=-1.39020335005227}] diff --git a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml index babec12d78..274511571a 100644 --- a/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-ecp/TEST_FILES.toml @@ -1,8 +1,8 @@ "HCl_GAPW_SKALA_ECP_ENERGY.inp" = [{matcher="E_total", tol=5e-6, ref=-15.464581508021762}] -"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44142596263930}] +"HCl_NATIVE_SKALA_GAPW_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.45263701}] "HCl_NATIVE_SKALA_GAPW_GPWTYPE_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36078871}] -"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.35170807520943}] +"HCl_NATIVE_SKALA_GAPW_XC_ECP_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.36291913}] "H2_NATIVE_SKALA_GAPW_ECP_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=6e-1, ref=0.0}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] -"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.43466946670853}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_INV_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] +"HCl_NATIVE_SKALA_GAPW_ECP_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=5e-6, ref=-15.44577629}] diff --git a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml index dea40ed44e..80fac5377e 100644 --- a/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth-kp/TEST_FILES.toml @@ -1,3 +1,3 @@ -"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] -"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.94951222851689}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_INV_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SYM_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] +"H2_NATIVE_SKALA_GAPW_GTH_KP_SPGLIB_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.97063781133388}] diff --git a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml index fbeaab6fca..300b8bb9d2 100644 --- a/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gapw-gth/TEST_FILES.toml @@ -1,8 +1,8 @@ -"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] -"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.97019845356640}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833172}] +"H2_NATIVE_SKALA_GAPW_GTH_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9912833169}] "H2_NATIVE_SKALA_GAPW_GPWTYPE_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="M072", tol=1e-4, ref=5.37252718E-05}, {matcher="M031", tol=1e-5, ref=-8.58976831594E+04}] -"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.94877811114650}] +"H2_NATIVE_SKALA_GAPW_XC_GTH_STRESS.inp" = [{matcher="E_total", tol=5e-8, ref=-0.9698629747}] "H2_NATIVE_SKALA_GAPW_GTH_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=2e-1, ref=0.0}] "H2_NATIVE_SKALA_GAPW_GTH_STRESS_DEBUG.inp" = [{matcher="DEBUG_stress_sum", tol=2e-1, ref=0.0}] diff --git a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp index d2a3f65b34..683adc123c 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp +++ b/tests/QS/regtest-gauxc-gpw-mech/H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp @@ -27,7 +27,7 @@ &SCF EPS_SCF 1.0E-5 IGNORE_CONVERGENCE_FAILURE T - MAX_SCF 2 + MAX_SCF 1 SCF_GUESS ATOMIC &DIAGONALIZATION &END DIAGONALIZATION diff --git a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml index 5899459292..d1858ded5d 100644 --- a/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml +++ b/tests/QS/regtest-gauxc-gpw-mech/TEST_FILES.toml @@ -2,7 +2,7 @@ "H2_NATIVE_SKALA_GPW_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=5e-3, ref=0.0}] "H2P_NATIVE_SKALA_GPW_UKS_PBC_FORCE_DEBUG.inp" = [{matcher="DEBUG_force_sum", tol=1e-3, ref=0.0}] "H2_NATIVE_SKALA_GPW_STRESS.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] -"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-1.04111543882624}] +"H2_NATIVE_SKALA_GPW_STRESS_CHUNK_REQUEST.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258894337}] "H2_NATIVE_SKALA_GPW_SMOOTH.inp" = [{matcher="E_total", tol=1e-8, ref=-0.96567258919119}, {matcher="SKALA_GPW_feature_electrons", tol=1e-8, ref=2.00000875882}, {matcher="SKALA_GPW_feature_spin_moment", tol=1e-12, ref=0.0}, diff --git a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml index e821736011..15a43ace67 100644 --- a/tests/QS/regtest-tddfpt-4/TEST_FILES.toml +++ b/tests/QS/regtest-tddfpt-4/TEST_FILES.toml @@ -12,10 +12,10 @@ {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53343196E+00}] "test04.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102641E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53056622E+00}] -"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101772E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53053109E+00}] -"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102040E+01}, - {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.51211743E+00}] +"test05.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101974E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.53306556E+00}] +"test06.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.102171E+01}, + {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.52845348E+00}] "test07.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.101792E+01}, {matcher="TDDFPT_Check_Osc_Strength", tol=1.0E-06, ref=0.55939759E+00}] "test08.inp" = [{matcher="TDDFPT_Check_Energy", tol=5.0E-06, ref=0.103120E+01}, diff --git a/tests/QS/regtest-tddfpt-4/test05.inp b/tests/QS/regtest-tddfpt-4/test05.inp index a52cb822b3..ca5adb36c1 100644 --- a/tests/QS/regtest-tddfpt-4/test05.inp +++ b/tests/QS/regtest-tddfpt-4/test05.inp @@ -11,8 +11,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 120 - REL_CUTOFF 50 + CUTOFF 200 + REL_CUTOFF 60 &END MGRID &POISSON PERIODIC NONE diff --git a/tests/QS/regtest-tddfpt-4/test06.inp b/tests/QS/regtest-tddfpt-4/test06.inp index 7e9dbaa5e7..8ac7bef886 100644 --- a/tests/QS/regtest-tddfpt-4/test06.inp +++ b/tests/QS/regtest-tddfpt-4/test06.inp @@ -19,8 +19,8 @@ STATE 1 &END EXCITED_STATES &MGRID - CUTOFF 120 - REL_CUTOFF 30 + CUTOFF 200 + REL_CUTOFF 40 &END MGRID &POISSON PERIODIC NONE diff --git a/tests/TEST_DIRS b/tests/TEST_DIRS index 4bcedaf889..268a1b191e 100644 --- a/tests/TEST_DIRS +++ b/tests/TEST_DIRS @@ -3,7 +3,6 @@ # Directories have been reordered according the execution time needed for a gfortran pdbg run using 2 MPI tasks # in case a new directory is added just add it at the top of the list.. # the order will be regularly checked and modified... -Fist/regtest-mace libtorch QS/regtest-floquet QS/regtest-dft-d4-auto-ref libdftd4 libint !ifx QS/regtest-dft-d2-auto-ref libint !ifx @@ -219,7 +218,7 @@ Fist/regtest-1-3 QS/regtest-md-extrap Fist/regtest-15 xTB/regtest-3 -xTB/regtest-3-spglib spglib tblite +xTB/regtest-3-spglib spglib QS/regtest-debug-3 libint libxc !ifx QS/regtest-lrigpw-2 QS/regtest-hybrid-4 libint libxc !ifx diff --git a/tools/conventions/conventions.supp b/tools/conventions/conventions.supp index 758c77d9a2..cc7033ad48 100644 --- a/tools/conventions/conventions.supp +++ b/tools/conventions/conventions.supp @@ -95,6 +95,7 @@ kpsym.F: Found GOTO statement in procedure "primlatt" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "remove" https://cp2k.org/conv#c201 kpsym.F: Found GOTO statement in procedure "sppt2" https://cp2k.org/conv#c201 libcp2k.F: Found type eri2array without initializer https://cp2k.org/conv#c016 +libgrpp_integrals.F: Module "libgrpp" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 libint_wrapper.F: Found type cp_libint_t without initializer https://cp2k.org/conv#c016 libint_wrapper.F: Module "libint_f" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 library_tests.F: Found CALL RANDOM_NUMBER in procedure "copy_test" https://cp2k.org/conv#c104 @@ -152,6 +153,7 @@ message_passing.F: Module "pmpi_f08" USEd without ONLY clause or not PRIVATE htt message_passing.F: USE statement at (1) has no ONLY qualifier [-Wuse-without-only] message_passing.fypp: Type mismatch between actual argument at (1) and actual argument at (2) (COMPLEX(8)/COMPLEX(4)). mltfftsg_tools.F: Found WRITE statement with hardcoded unit in "ctrig" https://cp2k.org/conv#c012 +mode_selective.F: Found READ with unchecked STAT in "bfgs_guess" https://cp2k.org/conv#c001 mp_perf_test.F: Module "mpi_f08" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 negf_methods.F: Found CALL with NULL() as argument in procedure "converge_density" https://cp2k.org/conv#c007 negf_methods.F: Found CALL with NULL() as argument in procedure "guess_fermi_level" https://cp2k.org/conv#c007 @@ -169,6 +171,7 @@ ps_wavelet_kernel.F: Found WRITE statement with hardcoded unit in "indices" http ps_wavelet_scaling_function.F: Found WRITE statement with hardcoded unit in "ftest" https://cp2k.org/conv#c012 pwdft_environment_types.F: Module "sirius" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 pw_grids.F: Found WRITE statement with hardcoded unit in "pw_grid_sort" https://cp2k.org/conv#c012 +qcschema.F: Module "hdf5_wrapper" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 qs_active_space_methods.F: Found type eri_fcidump_checksum without initializer https://cp2k.org/conv#c016 qs_active_space_methods.F: Found type eri_fcidump_print without initializer https://cp2k.org/conv#c016 qs_charge_mixing.F: Module "mctc_env" USEd without ONLY clause or not PRIVATE https://cp2k.org/conv#c002 diff --git a/tools/docker/scripts/test_misc.sh b/tools/docker/scripts/test_misc.sh index d3fc3dc645..fe39415cc9 100755 --- a/tools/docker/scripts/test_misc.sh +++ b/tools/docker/scripts/test_misc.sh @@ -44,7 +44,6 @@ run_test ./tools/pao-ml/pao-validate.py --threshold=1e-5 --model="tests/QS/regte run_test ./tools/vibronic_spec/main.py ./tools/vibronic_spec/example/example_config.toml run_test mypy --strict ./tools/pao-ml/ -run_test mypy --strict ./tools/mace/create_cp2k_model.py run_test mypy --strict ./tools/minimax_tools/minimax_to_fortran_source.py run_test mypy --strict ./tools/dashboard/generate_dashboard.py run_test mypy --strict ./tools/regtesting/optimize_test_dirs.py diff --git a/tools/mace/create_cp2k_model.py b/tools/mace/create_cp2k_model.py deleted file mode 100644 index 16b097b0ce..0000000000 --- a/tools/mace/create_cp2k_model.py +++ /dev/null @@ -1,190 +0,0 @@ -# pylint: disable=wrong-import-position -""" -Export a trained MACE model to a TorchScript file that can be loaded by CP2K. - -The export script must be executed in an environment where MACE is installed. - -Required packages: - * torch: required for loading and converting the model. - * e3nn: required by MACE for JIT compilation. - * mace-torch: required because the trained MACE model is loaded using - torch and its original model classes must be available. - -The MACE version used for export should be compatible with the version -used for training the model. - -After exporting, the CP2K-compatible `.pth` file can be loaded by CP2K -through the LibTorch interface. No MACE, e3nn, or Python installation is -required during CP2K simulations. - -Usage: - python create_cp2k_model.py my_mace.model --dtype float64 --head default - -> writes my_mace.model-cp2k.pth -""" - -import argparse -import os -from typing import Any, Dict, Optional - -os.environ["TORCH_FORCE_NO_WEIGHTS_ONLY_LOAD"] = "1" - -import torch -from e3nn.util import jit # type: ignore -from e3nn.util.jit import compile_mode # type: ignore - -# Z -> chemical symbol table (index == atomic number). Covers the dummy X plus -# all 118 known elements, matching CP2K's src/common/periodic_table.F. -chemical_symbols = ["X"] + """ - H He Li Be B C N O F Ne Na Mg Al Si P S Cl Ar K Ca Sc Ti V Cr Mn Fe Co - Ni Cu Zn Ga Ge As Se Br Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb - Te I Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu Hf Ta W Re Os - Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm - Md No Lr Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og -""".split() - - -@compile_mode("script") -class CP2K_MACE(torch.nn.Module): - """MACE model wrapped for CP2K's single-dictionary libtorch interface.""" - - head: torch.Tensor - - def __init__(self, model: Any, head: Optional[str] = None) -> None: - super().__init__() - self.model = model - self.register_buffer("atomic_numbers", model.atomic_numbers) - self.register_buffer("r_max", model.r_max) - self.register_buffer("num_interactions", model.num_interactions) - self.num_types: int = int(model.atomic_numbers.shape[0]) - - if not hasattr(model, "heads"): - model.heads = [None] - if head is not None and head in model.heads: - head_idx = model.heads.index(head) - else: - head_idx = len(model.heads) - 1 - self.register_buffer( - "head", torch.tensor(head_idx, dtype=torch.long).unsqueeze(0) - ) - - for param in self.model.parameters(): - param.requires_grad = False - - def forward( - self, data: Dict[str, torch.Tensor] - ) -> Dict[str, Optional[torch.Tensor]]: - pos = data["pos"] - edge_index = data["edge_index"] - unit_shifts = data["edge_cell_shift"] - cell = data["cell"].view(3, 3) - atom_types = data["atom_types"].to(torch.long) - n_atoms = pos.shape[0] - - # one-hot node attributes expected by MACE - node_attrs = torch.nn.functional.one_hot( - atom_types, num_classes=self.num_types - ).to(pos.dtype) - - # real-space edge shift vectors: unit_shifts @ cell (Angstrom) - shifts = torch.matmul(unit_shifts, cell) - - batch = torch.zeros(n_atoms, dtype=torch.long, device=pos.device) - ptr = torch.tensor([0, n_atoms], dtype=torch.long, device=pos.device) - - mace_in: Dict[str, torch.Tensor] = { - "positions": pos, - "node_attrs": node_attrs, - "edge_index": edge_index, - "shifts": shifts, - "unit_shifts": unit_shifts, - "cell": cell, - "batch": batch, - "ptr": ptr, - "head": self.head, - } - - out = self.model( - mace_in, - training=False, - compute_force=True, - compute_virials=True, - compute_stress=False, - compute_displacement=True, - ) - - node_energy = out["node_energy"] - forces = out["forces"] - virials = out["virials"] - - atomic_energy: Optional[torch.Tensor] = None - if node_energy is not None: - atomic_energy = node_energy.unsqueeze(-1) - - virial: Optional[torch.Tensor] = None - if virials is not None: - virial = virials.view(3, 3) - - return { - "atomic_energy": atomic_energy, - "forces": forces, - "virial": virial, - } - - -def build_metadata(model: Any, dtype: str) -> Dict[str, str]: - z = model.atomic_numbers.to(torch.long).tolist() - type_names = " ".join(chemical_symbols[int(zi)] for zi in z) - return { - "num_types": str(len(z)), - "r_max": repr(float(model.r_max)), - "type_names": type_names, - "model_dtype": dtype, - "allow_tf32": "0", - # MACE uses a single global cutoff; leave per-edge-type cutoffs empty so - # CP2K's reader falls back to filling the cutoff matrix with r_max**2. - "per_edge_type_cutoff": "", - } - - -def parse_args() -> argparse.Namespace: - p = argparse.ArgumentParser(description=__doc__) - p.add_argument("model_path", help="Path to the trained MACE .model file") - p.add_argument( - "--head", default=None, help="Model head to export (multi-head models)" - ) - p.add_argument("--dtype", choices=["float64", "float32"], default="float64") - p.add_argument( - "--output", default=None, help="Output path (default: -cp2k.pth)" - ) - return p.parse_args() - - -def main() -> None: - args = parse_args() - model = torch.load(args.model_path, map_location="cpu") - if args.dtype == "float64": - model = model.double() - else: - print("Converting model to float32, this may cause loss of precision.") - model = model.float() - model = model.to("cpu") - - wrapper = CP2K_MACE(model, head=args.head) - wrapper.eval() - - scripted = jit.compile(wrapper) - - metadata = build_metadata(model, args.dtype) - extra_files = {k: v.encode("utf-8") for k, v in metadata.items()} - - out_path = args.output or (args.model_path + "-cp2k.pth") - scripted.save(out_path, _extra_files=extra_files) - - print(f"Wrote CP2K MACE model to: {out_path}") - print("Metadata:") - for k, v in metadata.items(): - print(f" {k}: {v}") - - -if __name__ == "__main__": - main() diff --git a/tools/pao-ml/requirements.txt b/tools/pao-ml/requirements.txt index 179df2da5d..fedca401bb 100644 --- a/tools/pao-ml/requirements.txt +++ b/tools/pao-ml/requirements.txt @@ -1,6 +1,6 @@ e3nn==0.6.0 nequip==0.17.1 -torch==2.13.0 +torch==2.11.0 #EOF diff --git a/tools/precommit/fortitude.toml b/tools/precommit/fortitude.toml index f613397e65..71813b713f 100644 --- a/tools/precommit/fortitude.toml +++ b/tools/precommit/fortitude.toml @@ -7,51 +7,39 @@ ignore = [ "non-standard-file-extension", "implicit-external-procedures", # requires Fortran 2018 "missing-intent", - "bad-quote-string", - "literal-kind", "assumed-size", "assumed-size-character-intent", - "interface-implicit-typing", - "missing-default-case", "external-procedure", - "trailing-backslash", + "literal-kind", + "interface-implicit-typing", + "implicit-typing", + "missing-accessibility-statement", ] # ============================================================================== # The following files can not be parsed by Fortitude. # Usually because Fortran statements are inter-leafed with pre-processor macros. exclude = [ - "local_gemm_api.F", - "smeagol_control_types.F", - "ai_contraction_sphi.F", - "qs_loc_states.F", - "dbt_array_list_methods.F", - "cp_cfm_basic_linalg.F", - "cp_cfm_diag.F", - "cp_fm_basic_linalg.F", - "cp_fm_cholesky.F", - "cp_fm_diag.F", - "message_passing.F", - "dbt_split.F", - "cp_cfm_cholesky.F", "pw_methods.F", - "xc_libxc_wrap.F", + "local_gemm_api.F", + "cp_fm_diag.F", + "cp_fm_cholesky.F", + "cp_fm_basic_linalg.F", + "cp_cfm_diag.F", + "cp_cfm_cholesky.F", + "cp_cfm_basic_linalg.F", + "dbt_split.F", "dbt_tas_util.F", + "dbt_array_list_methods.F", + "xc_libxc_wrap.F", + "ai_contraction_sphi.F", + "smeagol_control_types.F", ] # ============================================================================== [check.per-file-ignores] -"environment.F" = ["line-too-long"] -"libgint_wrapper.F" = ["trailing-backslash"] -"qs_block_davidson_types.F" = ["trailing-backslash"] -"qs_linres_current.F" = ["trailing-backslash"] -"qs_local_properties.F" = ["unreachable-statement"] -"qs_tddfpt2_subgroups.F" = ["trailing-backslash"] -"semi_empirical_int_ana.F" = ["misleading-inline-if-semicolon"] -"pilaenv_hack.F" = ["procedure-not-in-module"] "semi_empirical_int_debug.F" = ["procedure-not-in-module"] -"eri_mme_lattice_summation.F" = ["trailing-whitespace"] "gopt_f77_methods.F" = ["procedure-not-in-module"] -"fftw3_lib.F" = ["misleading-inline-if-semicolon"] +"pilaenv_hack.F" = ["procedure-not-in-module"] #EOF diff --git a/tools/precommit/requirements.txt b/tools/precommit/requirements.txt index ff1aa191ec..efef9f6b05 100644 --- a/tools/precommit/requirements.txt +++ b/tools/precommit/requirements.txt @@ -4,7 +4,7 @@ click==8.3.1 cmake-format==0.6.13 cmakelang==0.6.13 Flask==3.1.3 -fortitude-lint==0.9.0 +fortitude-lint==0.7.5 gunicorn==25.1.0 itsdangerous==2.2.0 Jinja2==3.1.6 diff --git a/tools/spack/cp2k_deps_p.yaml b/tools/spack/cp2k_deps_p.yaml index 894db1cdb2..81c2bb12fa 100644 --- a/tools/spack/cp2k_deps_p.yaml +++ b/tools/spack/cp2k_deps_p.yaml @@ -184,7 +184,7 @@ spack: repos: builtin: - commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 + commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 specs: # Build tools @@ -215,7 +215,7 @@ spack: - "libsmeagol@1.2" - "libvdwxc@0.5.0" - "libvori@220621" - - "libxc@7.1.2" + - "libxc@7.0.0" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/spack/cp2k_deps_s-static.yaml b/tools/spack/cp2k_deps_s-static.yaml index 3f3ef30670..0fcbfba865 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: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 + commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 specs: # Build tools @@ -113,7 +113,7 @@ spack: - "libfci@0.1.0" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.1.2" + - "libxc@7.0.0" - "libxs@1.0.0" - "libxsmm@2.0.0" - "openblas@0.3.33" diff --git a/tools/spack/cp2k_deps_s.yaml b/tools/spack/cp2k_deps_s.yaml index f284738378..8cbf31adc4 100644 --- a/tools/spack/cp2k_deps_s.yaml +++ b/tools/spack/cp2k_deps_s.yaml @@ -117,7 +117,7 @@ spack: repos: builtin: - commit: 131214174051056d434e43d34f7c7645a385a835 # 2026-07-21 + commit: fc7222b5b8ababa8588be2e23ff39b33ecc9ce12 # 2026-07-09 specs: # Build tools @@ -138,7 +138,7 @@ spack: # - "libgint@release_v1" - "libint@2.13.1-cp2k-lmax-5" - "libvori@220621" - - "libxc@7.1.2" + - "libxc@7.0.0" - "libxs@1.0.0" - "libxsmm@2.0.0" # - "libxstream@1.0.0" diff --git a/tools/toolchain/scripts/stage3/install_libxc.sh b/tools/toolchain/scripts/stage3/install_libxc.sh index 712612cce9..c08347ebb0 100755 --- a/tools/toolchain/scripts/stage3/install_libxc.sh +++ b/tools/toolchain/scripts/stage3/install_libxc.sh @@ -6,8 +6,8 @@ [ "${BASH_SOURCE[0]}" ] && SCRIPT_NAME="${BASH_SOURCE[0]}" || SCRIPT_NAME=$0 SCRIPT_DIR="$(cd "$(dirname "$SCRIPT_NAME")/.." && pwd -P)" -libxc_ver="7.1.2" -libxc_sha256="3915fac94416e4c415534223ea492ad2663f928acf27e98662c861b094a6c306" +libxc_ver="7.0.0" +libxc_sha256="e9ae69f8966d8de6b7585abd9fab588794ada1fab8f689337959a35abbf9527d" source "${SCRIPT_DIR}"/common_vars.sh source "${SCRIPT_DIR}"/tool_kit.sh source "${SCRIPT_DIR}"/signal_trap.sh @@ -34,23 +34,34 @@ case "$with_libxc" in cd libxc-${libxc_ver} mkdir build cd build - if [ "${with_gcc}" != "__DONTUSE__" ] && - [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then - # Turn off variable tracking - LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" - else - LIBXC_CFLAGS="" + + # Lower the optimization level of KXC functionals for GCC to reduce time cost + # LXC functionals are not used so ignore them + if [ "${with_gcc}" != "__DONTUSE__" ]; then + if [ "${with_intel}" = "__DONTUSE__" ] && [ "${with_amd}" = "__DONTUSE__" ]; then + MAPLE2C_DIR="../src/maple2c" + for f in "$MAPLE2C_DIR"/gga_exc/*.c "$MAPLE2C_DIR"/mgga_exc/*.c "$MAPLE2C_DIR"/lda_exc/*.c; do + [ -f "$f" ] || continue + if grep -q "^func_kxc_" "$f" && ! grep -q "__attribute__((optimize" "$f"; then + sed -i 's/^func_kxc_/__attribute__((optimize("O1"))) func_kxc_/' "$f" + fi + done + LIBXC_CFLAGS="${CFLAGS} -fno-var-tracking" + else + LIBXC_CFLAGS="${CFLAGS}" + fi fi - # CP2K make use of third derivatives in libxc + + # CP2K does not make use of fourth derivatives, so skip their compilation with -DDISABLE_KXC=OFF + # Add "-DCMAKE_POLICY_VERSION_MINIMUM=3.5" to keep legacy compatibility for CMake version 4.x CFLAGS="${LIBXC_CFLAGS}" cmake \ - -DCMAKE_BUILD_TYPE="RelWithDebInfo" \ -DCMAKE_INSTALL_PREFIX="${pkg_install_dir}" \ - -DCMAKE_INSTALL_LIBDIR="lib" \ + -DCMAKE_INSTALL_LIBDIR=lib \ -DCMAKE_VERBOSE_MAKEFILE=ON \ - -DBUILD_SHARED_LIBS=OFF \ -DBUILD_TESTING=OFF \ -DENABLE_FORTRAN=ON \ - -DMAXORDER=3 \ + -DDISABLE_KXC=OFF \ + -DCMAKE_POLICY_VERSION_MINIMUM=3.5 \ .. > configure.log 2>&1 || tail_excerpt configure.log make -j $(get_nprocs) > make.log 2>&1 || tail_excerpt make.log make install > install.log 2>&1 || tail_excerpt install.log