From b08f77308bb0df790b2565eb6e473448caf7d721 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ole=20Sch=C3=BCtt?= Date: Fri, 7 Nov 2025 13:29:33 +0100 Subject: [PATCH] Enable Fortitude rule deprecated-relational-operator --- src/almo_scf.F | 122 +++---- src/almo_scf_diis_types.F | 66 ++-- src/almo_scf_env_methods.F | 34 +- src/almo_scf_lbfgs_types.F | 10 +- src/almo_scf_methods.F | 76 ++-- src/almo_scf_optimizer.F | 356 +++++++++--------- src/almo_scf_qs.F | 60 ++-- src/almo_scf_types.F | 18 +- src/aobasis/ai_elec_field.F | 78 ++-- src/aobasis/ai_fermi_contact.F | 12 +- src/aobasis/ai_operators_r12.F | 2 +- src/aobasis/ai_os_rr.F | 34 +- src/aobasis/ai_spin_orbit.F | 36 +- src/aobasis/ao_util.F | 20 +- src/aobasis/aux_basis_set.F | 2 +- src/aobasis/basis_set_types.F | 16 +- src/arnoldi/arnoldi_data_methods.F | 10 +- src/arnoldi/arnoldi_geev.F | 6 +- src/arnoldi/arnoldi_methods.F | 8 +- src/arnoldi/arnoldi_vector.F | 24 +- src/atom_grb.F | 2 +- src/atom_utils.F | 12 +- src/base/machine.F | 10 +- src/beta_gamma_psi.F | 86 ++--- src/bse_iterative.F | 4 +- src/bse_util.F | 16 +- src/bsse.F | 6 +- src/colvar_methods.F | 38 +- src/common/cp_array_utils.F | 4 +- src/common/cp_min_heap.F | 22 +- src/common/cp_result_methods.F | 6 +- src/common/erf_complex.F | 44 +-- src/common/fparser.F | 4 +- src/common/kahan_sum.F | 2 +- src/common/mathlib.F | 24 +- src/common/parallel_rng_types.F | 2 +- src/common/parallel_rng_types_unittest.F | 2 +- src/common/powell.F | 2 +- src/common/reference_manager.F | 2 +- src/common/string_table.F | 2 +- src/common/string_utilities.F | 2 +- src/common/timings.F | 4 +- src/commutator_rpnl.F | 2 +- src/cp_control_utils.F | 8 +- src/cp_dbcsr_cp2k_link.F | 8 +- src/cp_dbcsr_operations.F | 58 +-- src/cp_dbcsr_output.F | 2 +- src/cp_ddapc.F | 2 +- src/cp_ddapc_methods.F | 10 +- src/cp_ddapc_util.F | 10 +- src/cp_eri_mme_interface.F | 20 +- src/cp_external_control.F | 10 +- src/ct_methods.F | 60 ++-- src/dbm/dbm_tests.F | 8 +- src/dbt/dbt_array_list_methods.F | 6 +- src/dbt/dbt_block.F | 2 +- src/dbt/dbt_io.F | 6 +- src/dbt/dbt_methods.F | 20 +- src/dbt/dbt_split.F | 2 +- src/dbt/dbt_test.F | 14 +- src/dbt/dbt_types.F | 10 +- src/dbt/dbt_unittest.F | 2 +- src/dbt/tas/dbt_tas_io.F | 2 +- src/dbt/tas/dbt_tas_mm.F | 4 +- src/dbt/tas/dbt_tas_reshape_ops.F | 6 +- src/dbt/tas/dbt_tas_split.F | 12 +- src/dbt/tas/dbt_tas_test.F | 8 +- src/dbt/tas/dbt_tas_unittest.F | 2 +- src/dbt/tas/dbt_tas_util.F | 4 +- src/distribution_2d_types.F | 8 +- src/distribution_methods.F | 30 +- src/dkh_main.F | 68 ++-- src/dm_ls_scf.F | 12 +- src/dm_ls_scf_create.F | 16 +- src/dm_ls_scf_curvy.F | 60 ++-- src/dm_ls_scf_methods.F | 6 +- src/dm_ls_scf_qs.F | 4 +- src/domain_submatrix_methods.F | 134 +++---- src/ec_environment.F | 8 +- src/ec_orth_solver.F | 32 +- src/efield_utils.F | 14 +- src/eip_silicon.F | 204 +++++------ src/embed_main.F | 2 +- src/emd/rt_delta_pulse.F | 4 +- src/emd/rt_propagation_methods.F | 10 +- src/emd/rt_propagation_output.F | 2 +- src/energy_corrections.F | 2 +- src/environment.F | 12 +- src/eri_mme/eri_mme_error_control.F | 34 +- src/eri_mme/eri_mme_gaussian.F | 12 +- src/eri_mme/eri_mme_integrate.F | 24 +- src/eri_mme/eri_mme_lattice_summation.F | 48 +-- src/eri_mme/eri_mme_test.F | 8 +- src/eri_mme/eri_mme_types.F | 16 +- src/f77_interface.F | 4 +- src/farming_methods.F | 8 +- src/fm/cp_blacs_env.F | 4 +- src/fm/cp_cfm_basic_linalg.F | 10 +- src/fm/cp_cfm_cholesky.F | 4 +- src/fm/cp_cfm_types.F | 36 +- src/fm/cp_fm_basic_linalg.F | 26 +- src/fm/cp_fm_cholesky.F | 8 +- src/fm/cp_fm_diag.F | 8 +- src/fm/cp_fm_diag_utils.F | 2 +- src/fm/cp_fm_elpa.F | 8 +- src/fm/cp_fm_struct.F | 8 +- src/fm/cp_fm_types.F | 44 +-- src/force_env_methods.F | 32 +- src/force_fields_input.F | 6 +- src/graphcon.F | 28 +- src/gw_integrals.F | 8 +- src/gw_large_cell_gamma.F | 8 +- src/gw_small_cell_full_kp.F | 10 +- src/gw_utils.F | 26 +- src/hairy_probes.F | 30 +- src/hartree_local_methods.F | 2 +- src/hfx_communication.F | 8 +- src/hfx_derivatives.F | 6 +- src/hfx_energy_potential.F | 10 +- src/hfx_helpers.F | 2 +- src/hfx_load_balance_methods.F | 28 +- src/hfx_ri.F | 2 +- src/hfx_ri_kp.F | 56 +-- src/hfx_types.F | 16 +- src/input/cp_output_handling.F | 2 +- src/input/input_parsing.F | 2 +- src/input/input_section_types.F | 2 +- src/input_cp2k_almo.F | 16 +- src/input_cp2k_pwdft.F | 4 +- src/iterate_matrix.F | 58 +-- src/kg_environment.F | 8 +- src/kg_vertex_coloring_methods.F | 24 +- src/kpoint_coulomb_2c.F | 4 +- src/kpoint_methods.F | 4 +- src/kpsym.F | 438 +++++++++++------------ src/libint_2c_3c.F | 16 +- src/libint_wrapper.F | 6 +- src/ls_matrix_exp.F | 4 +- src/manybody_gal.F | 8 +- src/matrix_exp.F | 54 +-- src/metadyn_tools/graph.F | 62 ++-- src/metadyn_tools/graph_methods.F | 36 +- src/metadynamics_utils.F | 2 +- src/minimax/minimax_exp.F | 44 +-- src/mixed_cdft_methods.F | 122 +++---- src/mixed_cdft_utils.F | 42 +-- src/mm_collocate_potential.F | 14 +- src/mode_selective.F | 74 ++-- src/molden_utils.F | 4 +- src/molecular_states.F | 2 +- src/motion/bfgs_optimizer.F | 46 +-- src/motion/cg_utils.F | 50 +-- src/motion/cp_lbfgs.F | 16 +- src/motion/free_energy_methods.F | 4 +- src/motion/helium_common.F | 66 ++-- src/motion/helium_interactions.F | 2 +- src/motion/helium_io.F | 34 +- src/motion/helium_methods.F | 46 +-- src/motion/helium_sampling.F | 38 +- src/motion/input_cp2k_restarts.F | 2 +- src/motion/integrator.F | 2 +- src/motion/mc/mc_control.F | 14 +- src/motion/mc/mc_coordinates.F | 38 +- src/motion/mc/mc_ensembles.F | 84 ++--- src/motion/mc/mc_ge_moves.F | 40 +-- src/motion/mc/mc_misc.F | 18 +- src/motion/mc/mc_move_control.F | 56 +-- src/motion/mc/mc_moves.F | 94 ++--- src/motion/mc/mc_run.F | 2 +- src/motion/mc/mc_types.F | 78 ++-- src/motion/md_energies.F | 2 +- src/motion/md_util.F | 2 +- src/motion/md_vel_utils.F | 14 +- src/motion/neb_utils.F | 6 +- src/motion/pint_io.F | 18 +- src/motion/pint_methods.F | 12 +- src/motion/pint_public.F | 2 +- src/motion/velocity_verlet_control.F | 2 +- src/motion/vibrational_analysis.F | 4 +- src/mp2.F | 14 +- src/mp2_eri.F | 22 +- src/mp2_gpw_method.F | 4 +- src/mp2_grids.F | 4 +- src/mp2_integrals.F | 14 +- src/mp2_ri_2c.F | 8 +- src/mp2_ri_grad.F | 4 +- src/mp2_ri_grad_util.F | 2 +- src/mp2_setup.F | 6 +- src/mp2_types.F | 2 +- src/mpiwrap/message_passing.F | 106 +++--- src/mpiwrap/mp_perf_test.F | 30 +- src/mscfg_methods.F | 20 +- src/mscfg_types.F | 18 +- src/mulliken.F | 8 +- src/negf_control_types.F | 4 +- src/nnp_acsf.F | 64 ++-- src/nnp_environment.F | 16 +- src/optimize_basis.F | 2 +- src/optimize_basis_utils.F | 24 +- src/optimize_embedding_potential.F | 106 +++--- src/optimize_input.F | 8 +- src/pao_io.F | 8 +- src/pao_ml.F | 4 +- src/pao_model.F | 4 +- src/paw_proj_set_types.F | 4 +- src/pexsi_interface.F | 10 +- src/pexsi_methods.F | 30 +- src/pexsi_types.F | 10 +- src/post_scf_bandstructure_utils.F | 18 +- src/preconditioner_makes.F | 12 +- src/preconditioner_solvers.F | 4 +- src/preconditioner_types.F | 2 +- src/pw/cube_utils.F | 4 +- src/pw/dct.F | 74 ++-- src/pw/dielectric_methods.F | 84 ++--- src/pw/dirichlet_bc_methods.F | 152 ++++---- src/pw/fft/fft_lib.F | 10 +- src/pw/fft/fftw3_lib.F | 12 +- src/pw/fft/mltfftsg_tools.F | 2 +- src/pw/fft_tools.F | 2 +- src/pw/mt_util.F | 8 +- src/pw/ps_implicit_methods.F | 98 ++--- src/pw/ps_implicit_types.F | 2 +- src/pw/ps_wavelet_base.F | 152 ++++---- src/pw/ps_wavelet_fft3d.F | 50 +-- src/pw/ps_wavelet_kernel.F | 38 +- src/pw/ps_wavelet_methods.F | 50 +-- src/pw/ps_wavelet_scaling_function.F | 26 +- src/pw/ps_wavelet_util.F | 14 +- src/pw/pw_grid_info.F | 2 +- src/pw/pw_grids.F | 4 +- src/pw/pw_poisson_types.F | 4 +- src/pw/realspace_grid_cube.F | 34 +- src/pw/realspace_grid_types.F | 96 ++--- src/pw/rs_methods.F | 24 +- src/pw_env/gaussian_gridlevels.F | 2 +- src/pw_env_methods.F | 24 +- src/pw_poisson_read_input.F | 4 +- src/qmmm_elpot.F | 4 +- src/qmmm_gaussian_init.F | 2 +- src/qmmm_gaussian_input.F | 8 +- src/qmmm_gpw_energy.F | 2 +- src/qmmm_gpw_forces.F | 12 +- src/qmmm_image_charge.F | 2 +- src/qmmm_init.F | 10 +- src/qmmm_pw_grid.F | 4 +- src/qmmm_types_low.F | 2 +- src/qmmm_util.F | 2 +- src/qs_atomic_block.F | 2 +- src/qs_cdft_methods.F | 24 +- src/qs_cdft_opt_types.F | 8 +- src/qs_cdft_scf_utils.F | 12 +- src/qs_cdft_utils.F | 14 +- src/qs_cneo_methods.F | 8 +- src/qs_collocate_density.F | 38 +- src/qs_condnum.F | 2 +- src/qs_core_hamiltonian.F | 4 +- src/qs_dcdr_utils.F | 12 +- src/qs_dftb_matrices.F | 16 +- src/qs_dftb_utils.F | 22 +- src/qs_diis.F | 2 +- src/qs_dispersion_d3.F | 8 +- src/qs_dispersion_nonloc.F | 4 +- src/qs_dispersion_pairpot.F | 2 +- src/qs_efield_berry.F | 2 +- src/qs_electric_field_gradient.F | 2 +- src/qs_environment.F | 2 +- src/qs_epr_hyp.F | 2 +- src/qs_external_density.F | 6 +- src/qs_external_potential.F | 2 +- src/qs_fb_atomic_halo_types.F | 2 +- src/qs_fb_atomic_matrix_methods.F | 18 +- src/qs_fb_buffer_types.F | 28 +- src/qs_fb_distribution_methods.F | 34 +- src/qs_fb_env_methods.F | 16 +- src/qs_fb_filter_matrix_methods.F | 2 +- src/qs_fb_hash_table_types.F | 10 +- src/qs_fb_matrix_data_types.F | 6 +- src/qs_gapw_densities.F | 8 +- src/qs_harmonics_atom.F | 16 +- src/qs_hash_table_functions.F | 4 +- src/qs_initial_guess.F | 18 +- src/qs_integrate_potential_product.F | 12 +- src/qs_ks_atom.F | 2 +- src/qs_ks_methods.F | 12 +- src/qs_ks_utils.F | 18 +- src/qs_linres_atom_current.F | 40 +-- src/qs_linres_current.F | 152 ++++---- src/qs_linres_current_utils.F | 52 +-- src/qs_linres_epr_ownutils.F | 4 +- src/qs_linres_issc_utils.F | 12 +- src/qs_linres_methods.F | 24 +- src/qs_linres_nmr_shift.F | 8 +- src/qs_linres_nmr_utils.F | 6 +- src/qs_linres_op.F | 8 +- src/qs_loc_states.F | 2 +- src/qs_localization_methods.F | 82 ++--- src/qs_mo_io.F | 4 +- src/qs_mo_methods.F | 32 +- src/qs_neighbor_list_types.F | 4 +- src/qs_neighbor_lists.F | 8 +- src/qs_nl_hash_table_types.F | 12 +- src/qs_o3c_types.F | 4 +- src/qs_oce_methods.F | 8 +- src/qs_operators_ao.F | 18 +- src/qs_ot.F | 68 ++-- src/qs_ot_minimizer.F | 66 ++-- src/qs_ot_types.F | 28 +- src/qs_outer_scf.F | 8 +- src/qs_resp.F | 2 +- src/qs_rho_atom_methods.F | 8 +- src/qs_rho_methods.F | 4 +- src/qs_scf.F | 34 +- src/qs_scf_initialization.F | 2 +- src/qs_scf_output.F | 2 +- src/qs_scf_post_gpw.F | 26 +- src/qs_scf_wfn_mix.F | 4 +- src/qs_tddfpt2_assign.F | 8 +- src/qs_tddfpt2_bse_utils.F | 4 +- src/qs_tddfpt2_fhxc.F | 4 +- src/qs_tddfpt2_fhxc_forces.F | 10 +- src/qs_tddfpt2_forces.F | 12 +- src/qs_tddfpt2_operators.F | 2 +- src/qs_tddfpt2_properties.F | 4 +- src/qs_tddfpt2_smearing_methods.F | 2 +- src/qs_tddfpt2_soc.F | 10 +- src/qs_tddfpt2_soc_utils.F | 4 +- src/qs_tddfpt2_utils.F | 2 +- src/qs_vcd.F | 2 +- src/qs_vcd_ao.F | 10 +- src/qs_vcd_utils.F | 10 +- src/qs_vxc.F | 12 +- src/qs_vxc_atom.F | 12 +- src/qs_wf_history_methods.F | 32 +- src/rmsd.F | 2 +- src/rpa_exchange.F | 4 +- src/rpa_gw.F | 10 +- src/rpa_gw_kpoints_util.F | 2 +- src/rpa_im_time.F | 32 +- src/rpa_main.F | 6 +- src/rpa_rse.F | 4 +- src/rpa_util.F | 2 +- src/rt_propagation_types.F | 2 +- src/scf_control_types.F | 2 +- src/sirius_interface.F | 2 +- src/soc_pseudopotential_utils.F | 2 +- src/start/cp2k_runs.F | 8 +- src/start/libcp2k.F | 2 +- src/statistical_methods.F | 8 +- src/submatrix_dissection.F | 92 ++--- src/submatrix_types.F | 8 +- src/subsys/molecule_types.F | 2 +- src/task_list_methods.F | 72 ++-- src/tblite_interface.F | 2 +- src/tmc/tmc_analysis.F | 76 ++-- src/tmc/tmc_analysis_types.F | 12 +- src/tmc/tmc_calculations.F | 34 +- src/tmc/tmc_dot_tree.F | 24 +- src/tmc/tmc_file_io.F | 140 ++++---- src/tmc/tmc_master.F | 86 ++--- src/tmc/tmc_messages.F | 298 +++++++-------- src/tmc/tmc_move_handle.F | 86 ++--- src/tmc/tmc_moves.F | 134 +++---- src/tmc/tmc_setup.F | 134 +++---- src/tmc/tmc_tree_acceptance.F | 92 ++--- src/tmc/tmc_tree_build.F | 78 ++-- src/tmc/tmc_tree_search.F | 18 +- src/tmc/tmc_tree_types.F | 6 +- src/tmc/tmc_types.F | 4 +- src/tmc/tmc_worker.F | 70 ++-- src/topology_amber.F | 4 +- src/topology_constraint_util.F | 6 +- src/topology_coordinate_util.F | 4 +- src/topology_gromos.F | 16 +- src/topology_psf.F | 2 +- src/topology_util.F | 4 +- src/transport.F | 14 +- src/voronoi_interface.F | 2 +- src/wannier90.F | 32 +- src/xas_env_types.F | 2 +- src/xas_methods.F | 8 +- src/xas_tdp_atom.F | 8 +- src/xas_tdp_integrals.F | 6 +- src/xas_tdp_kernel.F | 2 +- src/xas_tdp_methods.F | 14 +- src/xas_tdp_types.F | 14 +- src/xas_tdp_utils.F | 6 +- src/xas_tp_scf.F | 6 +- src/xc/xc_tpss.F | 4 +- src/xc/xc_xpbe_hole_t_c_lr.F | 16 +- src/xtb_matrices.F | 2 +- src/xtb_parameters.F | 2 +- tools/precommit/fortitude.toml | 1 - 393 files changed, 4630 insertions(+), 4631 deletions(-) diff --git a/src/almo_scf.F b/src/almo_scf.F index 008837706d..eaa2bc12e8 100644 --- a/src/almo_scf.F +++ b/src/almo_scf.F @@ -236,17 +236,17 @@ CONTAINS almo_scf_env%smear = dft_control%smear IF (almo_scf_env%smear) THEN CALL cite_reference(Staub2019) - IF ((almo_scf_env%almo_update_algorithm .NE. almo_scf_diag) .OR. & - ((almo_scf_env%deloc_method .NE. almo_deloc_none) .AND. & - (almo_scf_env%xalmo_update_algorithm .NE. almo_scf_diag))) THEN + IF ((almo_scf_env%almo_update_algorithm /= almo_scf_diag) .OR. & + ((almo_scf_env%deloc_method /= almo_deloc_none) .AND. & + (almo_scf_env%xalmo_update_algorithm /= almo_scf_diag))) THEN CPABORT("ALMO smearing is currently implemented for DIAG algorithm only") END IF - IF (qs_env%scf_control%smear%method .NE. smear_fermi_dirac) THEN + IF (qs_env%scf_control%smear%method /= smear_fermi_dirac) THEN CPABORT("Only Fermi-Dirac smearing is currently compatible with ALMO") END IF almo_scf_env%smear_e_temp = qs_env%scf_control%smear%electronic_temperature - IF ((almo_scf_env%mat_distr_aos .NE. almo_mat_distr_molecular) .OR. & - (almo_scf_env%domain_layout_mos .NE. almo_domain_layout_molecular)) THEN + IF ((almo_scf_env%mat_distr_aos /= almo_mat_distr_molecular) .OR. & + (almo_scf_env%domain_layout_mos /= almo_domain_layout_molecular)) THEN CPABORT("ALMO smearing was designed to work with molecular fragments only") END IF END IF @@ -303,7 +303,7 @@ CONTAINS nelec_b = nelec - nelec_a !! Initializing an occupation-rescaling trick if smearing is on IF (almo_scf_env%smear) THEN - CPWARN_IF(multip .GT. 1, "BEWARE: Non singlet state detected, treating it as closed-shell") + CPWARN_IF(multip > 1, "BEWARE: Non singlet state detected, treating it as closed-shell") !! Save real number of electrons of each spin, as it is required for Fermi-dirac smearing !! BEWARE : Non singlet states are allowed but treated as closed-shell almo_scf_env%real_ne_of_domain(idomain, :) = REAL(nelec, KIND=dp)/2.0_dp @@ -314,8 +314,8 @@ CONTAINS - almo_scf_env%first_atom_of_domain(idomain) + 1) ELSE almo_scf_env%nocc_of_domain(idomain, 1) = nelec_a - IF (nelec_a .NE. nelec_b) THEN - IF (nspins .EQ. 1) THEN + IF (nelec_a /= nelec_b) THEN + IF (nspins == 1) THEN WRITE (*, *) "Domain ", idomain, " out of ", ndomains, ". Electrons = ", nelec CPABORT("odd e- -- use unrestricted methods") END IF @@ -412,29 +412,29 @@ CONTAINS almo_scf_env%calc_forces = calc_forces IF (calc_forces) THEN CALL cite_reference(Scheiber2018) - IF (almo_scf_env%deloc_method .EQ. almo_deloc_x .OR. & - almo_scf_env%deloc_method .EQ. almo_deloc_xalmo_x .OR. & - almo_scf_env%deloc_method .EQ. almo_deloc_xalmo_1diag) THEN + IF (almo_scf_env%deloc_method == almo_deloc_x .OR. & + almo_scf_env%deloc_method == almo_deloc_xalmo_x .OR. & + almo_scf_env%deloc_method == almo_deloc_xalmo_1diag) THEN CPABORT("Forces for perturbative methods are NYI. Change DELOCALIZE_METHOD") END IF ! switch to ASPC after a certain number of exact steps is done - IF (almo_scf_env%almo_history%istore .GT. (almo_scf_env%almo_history%nstore + 1)) THEN - IF (almo_scf_env%opt_block_diag_pcg%eps_error_early .GT. 0.0_dp) THEN + IF (almo_scf_env%almo_history%istore > (almo_scf_env%almo_history%nstore + 1)) THEN + IF (almo_scf_env%opt_block_diag_pcg%eps_error_early > 0.0_dp) THEN almo_scf_env%opt_block_diag_pcg%eps_error = almo_scf_env%opt_block_diag_pcg%eps_error_early almo_scf_env%opt_block_diag_pcg%early_stopping_on = .TRUE. IF (unit_nr > 0) WRITE (*, *) "ALMO_OPTIMIZER_PCG: EPS_ERROR_EARLY is on" END IF - IF (almo_scf_env%opt_block_diag_diis%eps_error_early .GT. 0.0_dp) THEN + IF (almo_scf_env%opt_block_diag_diis%eps_error_early > 0.0_dp) THEN almo_scf_env%opt_block_diag_diis%eps_error = almo_scf_env%opt_block_diag_diis%eps_error_early almo_scf_env%opt_block_diag_diis%early_stopping_on = .TRUE. IF (unit_nr > 0) WRITE (*, *) "ALMO_OPTIMIZER_DIIS: EPS_ERROR_EARLY is on" END IF - IF (almo_scf_env%opt_block_diag_pcg%max_iter_early .GT. 0) THEN + IF (almo_scf_env%opt_block_diag_pcg%max_iter_early > 0) THEN almo_scf_env%opt_block_diag_pcg%max_iter = almo_scf_env%opt_block_diag_pcg%max_iter_early almo_scf_env%opt_block_diag_pcg%early_stopping_on = .TRUE. IF (unit_nr > 0) WRITE (*, *) "ALMO_OPTIMIZER_PCG: MAX_ITER_EARLY is on" END IF - IF (almo_scf_env%opt_block_diag_diis%max_iter_early .GT. 0) THEN + IF (almo_scf_env%opt_block_diag_diis%max_iter_early > 0) THEN almo_scf_env%opt_block_diag_diis%max_iter = almo_scf_env%opt_block_diag_diis%max_iter_early almo_scf_env%opt_block_diag_diis%early_stopping_on = .TRUE. IF (unit_nr > 0) WRITE (*, *) "ALMO_OPTIMIZER_DIIS: MAX_ITER_EARLY is on" @@ -443,13 +443,13 @@ CONTAINS almo_scf_env%opt_block_diag_diis%early_stopping_on = .FALSE. almo_scf_env%opt_block_diag_pcg%early_stopping_on = .FALSE. END IF - IF (almo_scf_env%xalmo_history%istore .GT. (almo_scf_env%xalmo_history%nstore + 1)) THEN - IF (almo_scf_env%opt_xalmo_pcg%eps_error_early .GT. 0.0_dp) THEN + IF (almo_scf_env%xalmo_history%istore > (almo_scf_env%xalmo_history%nstore + 1)) THEN + IF (almo_scf_env%opt_xalmo_pcg%eps_error_early > 0.0_dp) THEN almo_scf_env%opt_xalmo_pcg%eps_error = almo_scf_env%opt_xalmo_pcg%eps_error_early almo_scf_env%opt_xalmo_pcg%early_stopping_on = .TRUE. IF (unit_nr > 0) WRITE (*, *) "XALMO_OPTIMIZER_PCG: EPS_ERROR_EARLY is on" END IF - IF (almo_scf_env%opt_xalmo_pcg%max_iter_early .GT. 0.0_dp) THEN + IF (almo_scf_env%opt_xalmo_pcg%max_iter_early > 0.0_dp) THEN almo_scf_env%opt_xalmo_pcg%max_iter = almo_scf_env%opt_xalmo_pcg%max_iter_early almo_scf_env%opt_xalmo_pcg%early_stopping_on = .TRUE. IF (unit_nr > 0) WRITE (*, *) "XALMO_OPTIMIZER_PCG: MAX_ITER_EARLY is on" @@ -748,7 +748,7 @@ CONTAINS kTS_sum=kTS_sum) IF (unit_nr > 0) THEN - IF (almo_scf_env%almo_scf_guess .EQ. molecular_guess) THEN + IF (almo_scf_env%almo_scf_guess == molecular_guess) THEN WRITE (unit_nr, '(T2,A38,F40.10)') "Single-molecule energy:", & SUM(mscfg_env%energy_of_frag) END IF @@ -839,8 +839,8 @@ CONTAINS ! exrapolate xalmos? delocalization_uses_extrapolation = & - .NOT. ((almo_scf_env%deloc_method .EQ. almo_deloc_none) .OR. & - (almo_scf_env%deloc_method .EQ. almo_deloc_xalmo_1diag)) + .NOT. ((almo_scf_env%deloc_method == almo_deloc_none) .OR. & + (almo_scf_env%deloc_method == almo_deloc_xalmo_1diag)) IF (almo_scf_env%xalmo_history%nstore > 0 .AND. & delocalization_uses_extrapolation) THEN @@ -933,7 +933,7 @@ CONTAINS WRITE (unit_nr, '(T2,A,T48,E33.3)') "eps_filter:", almo_scf_env%eps_filter - IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_skip) THEN + IF (almo_scf_env%almo_update_algorithm == almo_scf_skip) THEN WRITE (unit_nr, '(T2,A)') "skip optimization of block-diagonal ALMOs" ELSE WRITE (unit_nr, '(T2,A)') "optimization of block-diagonal ALMOs:" @@ -968,7 +968,7 @@ CONTAINS END SELECT WRITE (unit_nr, '(T2,A,T48,A33)') "delocalization:", TRIM(deloc_method_string) - IF (almo_scf_env%deloc_method .NE. almo_deloc_none) THEN + IF (almo_scf_env%deloc_method /= almo_deloc_none) THEN SELECT CASE (almo_scf_env%deloc_method) CASE (almo_deloc_x, almo_deloc_scf, almo_deloc_x_then_scf) @@ -980,7 +980,7 @@ CONTAINS almo_scf_env%quencher_r0_factor END SELECT - IF (almo_scf_env%deloc_method .EQ. almo_deloc_xalmo_1diag) THEN + IF (almo_scf_env%deloc_method == almo_deloc_xalmo_1diag) THEN ! print nothing because no actual optimization is done ELSE WRITE (unit_nr, '(T2,A)') "optimization of extended orbitals:" @@ -1088,7 +1088,7 @@ CONTAINS DO idomain = 1, almo_scf_env%ndomains - IF (idomain .EQ. 1) THEN + IF (idomain == 1) THEN index1_prev = 1 ELSE index1_prev = almo_scf_env%domain_map(1)%index1(idomain - 1) @@ -1118,7 +1118,7 @@ CONTAINS WRITE (unit_nr, '(T2,A)') REPEAT("-", 79) WRITE (unit_nr, '()') - IF (almo_scf_env%ndomains .LE. 64) THEN + IF (almo_scf_env%ndomains <= 64) THEN ! print fragment info WRITE (unit_nr, '(T2,A10,A13,A13,A13,A13,A13)') & @@ -1158,7 +1158,7 @@ CONTAINS WRITE (unit_nr, '(T2,A)') REPEAT("-", 79) DO idomain = 1, almo_scf_env%ndomains - IF (idomain .EQ. 1) THEN + IF (idomain == 1) THEN index1_prev = 1 ELSE index1_prev = almo_scf_env%domain_map(1)%index1(idomain - 1) @@ -1235,7 +1235,7 @@ CONTAINS CALL dbcsr_filter(almo_scf_env%matrix_s(1), almo_scf_env%eps_filter) CALL dbcsr_filter(almo_scf_env%matrix_s_blk(1), almo_scf_env%eps_filter) - IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_diag) THEN + IF (almo_scf_env%almo_update_algorithm == almo_scf_diag) THEN CALL matrix_sqrt_Newton_Schulz(almo_scf_env%matrix_s_blk_sqrt(1), & almo_scf_env%matrix_s_blk_sqrt_inv(1), & almo_scf_env%matrix_s_blk(1), & @@ -1244,7 +1244,7 @@ CONTAINS !order=0, & eps_lanczos=almo_scf_env%eps_lanczos, & max_iter_lanczos=almo_scf_env%max_iter_lanczos) - ELSE IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_dm_sign) THEN + ELSE IF (almo_scf_env%almo_update_algorithm == almo_scf_dm_sign) THEN CALL invert_Hotelling(almo_scf_env%matrix_s_blk_inv(1), & almo_scf_env%matrix_s_blk(1), & threshold=almo_scf_env%eps_filter, & @@ -1399,7 +1399,7 @@ CONTAINS matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_reserve_all_blocks(no_quench(1)) CALL dbcsr_set(no_quench(1), 1.0_dp) - IF (almo_scf_env%nspins .GT. 1) THEN + IF (almo_scf_env%nspins > 1) THEN DO ispin = 2, almo_scf_env%nspins CALL dbcsr_create(no_quench(ispin), & template=almo_scf_env%matrix_t(1), & @@ -1443,7 +1443,7 @@ CONTAINS !!!ENDIF !!!CALL harris_foulkes_correction(qs_env,almo_scf_env) - IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_pcg) THEN + IF (almo_scf_env%xalmo_update_algorithm == almo_scf_pcg) THEN CALL almo_scf_xalmo_pcg(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1451,11 +1451,11 @@ CONTAINS quench_t=no_quench, & matrix_t_in=almo_scf_env%matrix_t_blk, & matrix_t_out=almo_scf_env%matrix_t, & - assume_t0_q0x=(almo_scf_env%xalmo_trial_wf .EQ. xalmo_trial_r0_out), & + assume_t0_q0x=(almo_scf_env%xalmo_trial_wf == xalmo_trial_r0_out), & perturbation_only=.TRUE., & special_case=xalmo_case_fully_deloc) - ELSE IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_trustr) THEN + ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CALL almo_scf_xalmo_trustr(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1474,7 +1474,7 @@ CONTAINS CASE (almo_deloc_xalmo_1diag) - IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_diag) THEN + IF (almo_scf_env%xalmo_update_algorithm == almo_scf_diag) THEN almo_scf_env%perturbative_delocalization = .TRUE. DO ispin = 1, almo_scf_env%nspins @@ -1492,7 +1492,7 @@ CONTAINS CASE (almo_deloc_xalmo_x) - IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_pcg) THEN + IF (almo_scf_env%xalmo_update_algorithm == almo_scf_pcg) THEN CALL almo_scf_xalmo_pcg(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1500,11 +1500,11 @@ CONTAINS quench_t=almo_scf_env%quench_t, & matrix_t_in=almo_scf_env%matrix_t_blk, & matrix_t_out=almo_scf_env%matrix_t, & - assume_t0_q0x=(almo_scf_env%xalmo_trial_wf .EQ. xalmo_trial_r0_out), & + assume_t0_q0x=(almo_scf_env%xalmo_trial_wf == xalmo_trial_r0_out), & perturbation_only=.TRUE., & special_case=xalmo_case_normal) - ELSE IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_trustr) THEN + ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CALL almo_scf_xalmo_trustr(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1523,7 +1523,7 @@ CONTAINS CASE (almo_deloc_xalmo_scf) - IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_diag) THEN + IF (almo_scf_env%xalmo_update_algorithm == almo_scf_diag) THEN CPABORT("Should not be here: convergence will fail!") @@ -1535,7 +1535,7 @@ CONTAINS CALL almo_scf_xalmo_eigensolver(qs_env, almo_scf_env, & arbitrary_optimizer) - ELSE IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_pcg) THEN + ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_pcg) THEN CALL almo_scf_xalmo_pcg(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1543,7 +1543,7 @@ CONTAINS quench_t=almo_scf_env%quench_t, & matrix_t_in=almo_scf_env%matrix_t_blk, & matrix_t_out=almo_scf_env%matrix_t, & - assume_t0_q0x=(almo_scf_env%xalmo_trial_wf .EQ. xalmo_trial_r0_out), & + assume_t0_q0x=(almo_scf_env%xalmo_trial_wf == xalmo_trial_r0_out), & perturbation_only=.FALSE., & special_case=xalmo_case_normal) @@ -1559,7 +1559,7 @@ CONTAINS arbitrary_optimizer) END IF ! experimental - ELSE IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_trustr) THEN + ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CALL almo_scf_xalmo_trustr(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1585,11 +1585,11 @@ CONTAINS SELECT CASE (almo_scf_env%deloc_method) CASE (almo_deloc_scf, almo_deloc_x_then_scf) - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN CPABORT("full scf is NYI for truncated virtual space") END IF - IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_pcg) THEN + IF (almo_scf_env%xalmo_update_algorithm == almo_scf_pcg) THEN CALL almo_scf_xalmo_pcg(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1601,7 +1601,7 @@ CONTAINS perturbation_only=.FALSE., & special_case=xalmo_case_fully_deloc) - ELSE IF (almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_trustr) THEN + ELSE IF (almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CALL almo_scf_xalmo_trustr(qs_env=qs_env, & almo_scf_env=almo_scf_env, & @@ -1671,7 +1671,7 @@ CONTAINS CALL construct_nlmos_wrapper(qs_env, almo_scf_env, virtuals=.TRUE.) END IF - IF (almo_scf_env%opt_nlmo_pcg%opt_penalty%compactification_filter_start .GT. 0.0_dp) THEN + IF (almo_scf_env%opt_nlmo_pcg%opt_penalty%compactification_filter_start > 0.0_dp) THEN CALL nlmo_compactification(qs_env, almo_scf_env, almo_scf_env%matrix_t) END IF @@ -1703,7 +1703,7 @@ CONTAINS ! loop over the strength of the orthogonalization penalty prev_determinant = 10.0_dp - DO WHILE (almo_scf_env%overlap_determinant .GT. almo_scf_env%opt_nlmo_pcg%opt_penalty%final_determinant) + DO WHILE (almo_scf_env%overlap_determinant > almo_scf_env%opt_nlmo_pcg%opt_penalty%final_determinant) IF (.NOT. virtuals) THEN CALL almo_scf_construct_nlmos(qs_env=qs_env, & @@ -1912,7 +1912,7 @@ CONTAINS nspins = SIZE(matrix) element_by_element = .FALSE. - IF (nspins .EQ. 1) THEN + IF (nspins == 1) THEN spin_factor = 2.0_dp ELSE spin_factor = 1.0_dp @@ -1966,7 +1966,7 @@ CONTAINS IF (element_by_element) THEN DO irow = 1, iblock_row_size - IF (ABS(data_p(irow, icol)) .LT. eps_local) THEN + IF (ABS(data_p(irow, icol)) < eps_local) THEN data_p(irow, icol) = 0.0_dp ELSE retained(ispin) = retained(ispin) + 1 @@ -1977,11 +1977,11 @@ CONTAINS max_element = 0.0_dp DO irow = 1, iblock_row_size - IF (ABS(data_p(irow, icol)) .GT. max_element) THEN + IF (ABS(data_p(irow, icol)) > max_element) THEN max_element = ABS(data_p(irow, icol)) END IF END DO - IF (max_element .LT. eps_local) THEN + IF (max_element < eps_local) THEN DO irow = 1, iblock_row_size data_p(irow, icol) = 0.0_dp END DO @@ -2037,7 +2037,7 @@ CONTAINS almo_scf_env%eps_filter, & almo_scf_env%mat_distr_aos) - IF (nspins .LT. 2) occ(2) = occ(1) + IF (nspins < 2) occ(2) = occ(1) IF (unit_nr > 0) WRITE (unit_nr, '(T2,E13.3,F20.10,F20.10,F25.15)') & eps_local, occ(1), occ(2), energy @@ -2206,7 +2206,7 @@ CONTAINS symmetry_new=dbcsr_type_symmetric, & spin_key=0, & init_domains=.TRUE.) - IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_diag) THEN + IF (almo_scf_env%almo_update_algorithm == almo_scf_diag) THEN CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_s_blk_sqrt_inv(1), & matrix_qs=matrix_s0, & almo_scf_env=almo_scf_env, & @@ -2223,7 +2223,7 @@ CONTAINS symmetry_new=dbcsr_type_symmetric, & spin_key=0, & init_domains=.TRUE.) - ELSE IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_dm_sign) THEN + ELSE IF (almo_scf_env%almo_update_algorithm == almo_scf_dm_sign) THEN CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_s_blk_inv(1), & matrix_qs=matrix_s0, & almo_scf_env=almo_scf_env, & @@ -2364,7 +2364,7 @@ CONTAINS ALLOCATE (almo_scf_env%matrix_sigma_vv_sqrt_inv(nspins)) ALLOCATE (almo_scf_env%matrix_vv_full_blk(nspins)) - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN ALLOCATE (almo_scf_env%matrix_k_blk(nspins)) ALLOCATE (almo_scf_env%matrix_k_blk_ones(nspins)) ALLOCATE (almo_scf_env%matrix_k_tr(nspins)) @@ -2466,7 +2466,7 @@ CONTAINS template=almo_scf_env%matrix_sigma_vv(ispin), & matrix_type=dbcsr_type_no_symmetry) - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN CALL matrix_almo_create(matrix_new=almo_scf_env%opt_k_t_rr(ispin), & matrix_qs=matrix_s0, & almo_scf_env=almo_scf_env, & @@ -2657,10 +2657,10 @@ CONTAINS ! release matrices CALL dbcsr_release(almo_scf_env%matrix_s(1)) CALL dbcsr_release(almo_scf_env%matrix_s_blk(1)) - IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_diag) THEN + IF (almo_scf_env%almo_update_algorithm == almo_scf_diag) THEN CALL dbcsr_release(almo_scf_env%matrix_s_blk_sqrt_inv(1)) CALL dbcsr_release(almo_scf_env%matrix_s_blk_sqrt(1)) - ELSE IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_dm_sign) THEN + ELSE IF (almo_scf_env%almo_update_algorithm == almo_scf_dm_sign) THEN CALL dbcsr_release(almo_scf_env%matrix_s_blk_inv(1)) END IF DO ispin = 1, almo_scf_env%nspins @@ -2697,7 +2697,7 @@ CONTAINS CALL dbcsr_release(almo_scf_env%matrix_sigma_vv_sqrt(ispin)) CALL dbcsr_release(almo_scf_env%matrix_sigma_vv_sqrt_inv(ispin)) CALL dbcsr_release(almo_scf_env%matrix_vv_full_blk(ispin)) - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN CALL dbcsr_release(almo_scf_env%matrix_k_tr(ispin)) CALL dbcsr_release(almo_scf_env%matrix_k_blk(ispin)) CALL dbcsr_release(almo_scf_env%matrix_k_blk_ones(ispin)) @@ -2748,7 +2748,7 @@ CONTAINS DEALLOCATE (almo_scf_env%matrix_sigma_vv_sqrt) DEALLOCATE (almo_scf_env%matrix_sigma_vv_sqrt_inv) DEALLOCATE (almo_scf_env%matrix_vv_full_blk) - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN DEALLOCATE (almo_scf_env%matrix_k_tr) DEALLOCATE (almo_scf_env%matrix_k_blk) DEALLOCATE (almo_scf_env%matrix_v_disc) diff --git a/src/almo_scf_diis_types.F b/src/almo_scf_diis_types.F index 26fc19cfbd..6c4f3d1314 100644 --- a/src/almo_scf_diis_types.F +++ b/src/almo_scf_diis_types.F @@ -105,7 +105,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (max_length .LE. 0) THEN + IF (max_length <= 0) THEN CPABORT("DIIS: max_length is less than zero") END IF @@ -135,7 +135,7 @@ CONTAINS ! hack into d_b structure to gain full control diis_env%m_b(:)%domain = 100 ! arbitrary positive number DO idomain = 1, ndomains - IF (diis_env%m_b(idomain)%domain .GT. 0) THEN + IF (diis_env%m_b(idomain)%domain > 0) THEN ALLOCATE (diis_env%m_b(idomain)%mdata(1, 1)) diis_env%m_b(idomain)%mdata(:, :) = 0.0_dp END IF @@ -169,7 +169,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (max_length .LE. 0) THEN + IF (max_length <= 0) THEN CPABORT("DIIS: max_length is less than zero") END IF @@ -196,7 +196,7 @@ CONTAINS ! distribute matrices as the err/var matrices diis_env%m_b(:)%domain = sample_err(:)%domain DO idomain = 1, ndomains - IF (diis_env%m_b(idomain)%domain .GT. 0) THEN + IF (diis_env%m_b(idomain)%domain > 0) THEN ALLOCATE (diis_env%m_b(idomain)%mdata(1, 1)) diis_env%m_b(idomain)%mdata(:, :) = 0.0_dp END IF @@ -232,11 +232,11 @@ CONTAINS CALL timeset(routineN, handle) - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN IF (.NOT. (PRESENT(var) .AND. PRESENT(err))) THEN CPABORT("provide DBCSR matrices") END IF - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN IF (.NOT. (PRESENT(d_var) .AND. PRESENT(d_err))) THEN CPABORT("provide domain submatrices") END IF @@ -247,10 +247,10 @@ CONTAINS in_point = diis_env%in_point ! store a var-error pair - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN CALL dbcsr_copy(diis_env%m_var(in_point), var) CALL dbcsr_copy(diis_env%m_err(in_point), err) - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN CALL copy_submatrices(d_var, diis_env%d_var(in_point, :), copy_data=.TRUE.) CALL copy_submatrices(d_err, diis_env%d_err(in_point, :), copy_data=.TRUE.) END IF @@ -258,7 +258,7 @@ 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 .GT. diis_env%max_buffer_length) & + IF (diis_env%buffer_length > diis_env%max_buffer_length) & diis_env%buffer_length = diis_env%max_buffer_length !!!! resize B matrix @@ -285,10 +285,10 @@ CONTAINS ! resize B matrix and update its elements ndomains = SIZE(diis_env%m_b) - IF (old_buffer_length .LT. diis_env%buffer_length) THEN + IF (old_buffer_length < diis_env%buffer_length) THEN ALLOCATE (m_b_tmp(diis_env%buffer_length + 1, diis_env%buffer_length + 1)) DO idomain = 1, ndomains - IF (diis_env%m_b(idomain)%domain .GT. 0) THEN + IF (diis_env%m_b(idomain)%domain > 0) THEN m_b_tmp(:, :) = 0.0_dp m_b_tmp(1:diis_env%buffer_length, 1:diis_env%buffer_length) = & diis_env%m_b(idomain)%mdata(:, :) @@ -301,14 +301,14 @@ CONTAINS DEALLOCATE (m_b_tmp) END IF DO idomain = 1, ndomains - IF (diis_env%m_b(idomain)%domain .GT. 0) THEN + IF (diis_env%m_b(idomain)%domain > 0) THEN diis_env%m_b(idomain)%mdata(1, in_point + 1) = -1.0_dp diis_env%m_b(idomain)%mdata(in_point + 1, 1) = -1.0_dp DO irow = 1, diis_env%buffer_length - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN trace0 = almo_scf_diis_error_overlap(diis_env, & A=diis_env%m_err(irow), B=diis_env%m_err(in_point)) - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN trace0 = almo_scf_diis_error_overlap(diis_env, & d_A=diis_env%d_err(irow, idomain), & d_B=diis_env%d_err(in_point, idomain)) @@ -321,7 +321,7 @@ CONTAINS ! update the insertion point for the next "PUSH" diis_env%in_point = diis_env%in_point + 1 - IF (diis_env%in_point .GT. diis_env%max_buffer_length) diis_env%in_point = 1 + IF (diis_env%in_point > diis_env%max_buffer_length) diis_env%in_point = 1 CALL timestop(handle) @@ -361,11 +361,11 @@ CONTAINS unit_nr = -1 END IF - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN IF (.NOT. PRESENT(extr_var)) THEN CPABORT("provide DBCSR matrix") END IF - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN IF (.NOT. PRESENT(d_extr_var)) THEN CPABORT("provide domain submatrices") END IF @@ -381,7 +381,7 @@ CONTAINS DO idomain = 1, ndomains - IF (diis_env%m_b(idomain)%domain .GT. 0) THEN + IF (diis_env%m_b(idomain)%domain > 0) THEN m_b_copy(:, :) = diis_env%m_b(idomain)%mdata(:, :) @@ -397,7 +397,7 @@ CONTAINS ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', diis_env%buffer_length + 1, m_b_copy, & diis_env%buffer_length + 1, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) CPABORT("DSYEV failed") + IF (INFO /= 0) CPABORT("DSYEV failed") DEALLOCATE (WORK) ! use the eigensystem to invert (implicitly) B matrix @@ -422,14 +422,14 @@ CONTAINS ! extrapolate the variable checksum = 0.0_dp - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN CALL dbcsr_set(extr_var, 0.0_dp) DO im = 1, diis_env%buffer_length CALL dbcsr_add(extr_var, diis_env%m_var(im), & 1.0_dp, coeff(im + 1)) checksum = checksum + coeff(im + 1) END DO - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN CALL copy_submatrices(diis_env%d_var(1, idomain), & d_extr_var(idomain), & copy_data=.FALSE.) @@ -483,11 +483,11 @@ CONTAINS CALL timeset(routineN, handle) - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN IF (.NOT. (PRESENT(A) .AND. PRESENT(B))) THEN CPABORT("provide DBCSR matrices") END IF - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN IF (.NOT. (PRESENT(d_A) .AND. PRESENT(d_B))) THEN CPABORT("provide domain submatrices") END IF @@ -497,14 +497,14 @@ CONTAINS SELECT CASE (diis_env%error_type) CASE (diis_error_orthogonal) - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN CALL dbcsr_dot(A, B, trace) - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN - CPASSERT(SIZE(d_A%mdata, 1) .EQ. SIZE(d_B%mdata, 1)) - CPASSERT(SIZE(d_A%mdata, 2) .EQ. SIZE(d_B%mdata, 2)) - CPASSERT(d_A%domain .EQ. d_B%domain) - CPASSERT(d_A%domain .GT. 0) - CPASSERT(d_B%domain .GT. 0) + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN + CPASSERT(SIZE(d_A%mdata, 1) == SIZE(d_B%mdata, 1)) + CPASSERT(SIZE(d_A%mdata, 2) == SIZE(d_B%mdata, 2)) + CPASSERT(d_A%domain == d_B%domain) + CPASSERT(d_A%domain > 0) + CPASSERT(d_B%domain > 0) trace = SUM(d_A%mdata(:, :)*d_B%mdata(:, :)) END IF CASE DEFAULT @@ -535,16 +535,16 @@ CONTAINS ! release matrices DO im = 1, diis_env%max_buffer_length - IF (diis_env%diis_env_type .EQ. diis_env_dbcsr) THEN + IF (diis_env%diis_env_type == diis_env_dbcsr) THEN CALL dbcsr_release(diis_env%m_err(im)) CALL dbcsr_release(diis_env%m_var(im)) - ELSE IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + ELSE IF (diis_env%diis_env_type == diis_env_domain) THEN CALL release_submatrices(diis_env%d_var(im, :)) CALL release_submatrices(diis_env%d_err(im, :)) END IF END DO - IF (diis_env%diis_env_type .EQ. diis_env_domain) THEN + IF (diis_env%diis_env_type == diis_env_domain) THEN CALL release_submatrices(diis_env%m_b(:)) END IF diff --git a/src/almo_scf_env_methods.F b/src/almo_scf_env_methods.F index 6c969ea573..f4c55813aa 100644 --- a/src/almo_scf_env_methods.F +++ b/src/almo_scf_env_methods.F @@ -502,8 +502,8 @@ CONTAINS almo_scf_env%integer05 = 0 ! not used ! check for conflicts between options - IF (almo_scf_env%xalmo_trial_wf .EQ. xalmo_trial_r0_out .AND. & - almo_scf_env%xalmo_update_algorithm .EQ. almo_scf_trustr) THEN + IF (almo_scf_env%xalmo_trial_wf == xalmo_trial_r0_out .AND. & + almo_scf_env%xalmo_update_algorithm == almo_scf_trustr) THEN CPABORT("Trust region algorithm cannot optimize projected XALMOs") END IF @@ -511,40 +511,40 @@ CONTAINS i_val=almo_scf_env%xalmo_update_algorithm) CALL section_vals_val_get(almo_scf_section, "XALMO_TRIAL_WF", & i_val=almo_scf_env%xalmo_trial_wf) - IF (almo_scf_env%deloc_method .EQ. almo_deloc_xalmo_1diag .AND. & - almo_scf_env%xalmo_update_algorithm .NE. almo_scf_diag) THEN + IF (almo_scf_env%deloc_method == almo_deloc_xalmo_1diag .AND. & + almo_scf_env%xalmo_update_algorithm /= almo_scf_diag) THEN CPABORT("1-step delocalization correction requires a different algorithm") END IF - IF (almo_scf_env%xalmo_trial_wf .EQ. xalmo_trial_r0_out .AND. & - almo_scf_env%almo_update_algorithm .EQ. almo_scf_skip .AND. & - almo_scf_env%almo_scf_guess .NE. molecular_guess) THEN + IF (almo_scf_env%xalmo_trial_wf == xalmo_trial_r0_out .AND. & + almo_scf_env%almo_update_algorithm == almo_scf_skip .AND. & + almo_scf_env%almo_scf_guess /= molecular_guess) THEN CPABORT("R0 projector requires optimized ALMOs") END IF - IF (almo_scf_env%deloc_method .EQ. almo_deloc_none .AND. & - almo_scf_env%almo_update_algorithm .EQ. almo_scf_skip) THEN + IF (almo_scf_env%deloc_method == almo_deloc_none .AND. & + almo_scf_env%almo_update_algorithm == almo_scf_skip) THEN CPABORT("No optimization requested") END IF - IF (almo_scf_env%deloc_truncate_virt .EQ. virt_number .AND. & - almo_scf_env%deloc_virt_per_domain .LE. 0) THEN + IF (almo_scf_env%deloc_truncate_virt == virt_number .AND. & + almo_scf_env%deloc_virt_per_domain <= 0) THEN CPABORT("specify a positive number of virtual orbitals") END IF - IF (almo_scf_env%deloc_truncate_virt .EQ. virt_minimal) THEN + IF (almo_scf_env%deloc_truncate_virt == virt_minimal) THEN CPABORT("VIRT TRUNCATION TO MINIMAL BASIS IS NIY") END IF - IF (almo_scf_env%domain_layout_mos .NE. almo_domain_layout_molecular) THEN + IF (almo_scf_env%domain_layout_mos /= almo_domain_layout_molecular) THEN CPABORT("use MOLECULAR domains") END IF - IF (almo_scf_env%domain_layout_aos .NE. almo_domain_layout_molecular) THEN + IF (almo_scf_env%domain_layout_aos /= almo_domain_layout_molecular) THEN CPABORT("use MOLECULAR domains") END IF - IF (almo_scf_env%mat_distr_mos .NE. almo_mat_distr_molecular) THEN + IF (almo_scf_env%mat_distr_mos /= almo_mat_distr_molecular) THEN CPABORT("use MOLECULAR distr for MOs") END IF @@ -558,7 +558,7 @@ CONTAINS CPABORT("MO blocks cannot be larger than domains") END IF - IF (almo_scf_env%quencher_r1_factor .GT. almo_max_cutoff_multiplier) THEN + IF (almo_scf_env%quencher_r1_factor > almo_max_cutoff_multiplier) THEN CALL cp_abort(__LOCATION__, & "XALMO_R_CUTOFF_FACTOR is larger than almo_max_cutoff_multiplier. "// & "Increase the hard-coded almo_max_cutoff_multiplier") @@ -568,7 +568,7 @@ CONTAINS IF (almo_scf_env%almo_analysis%do_analysis) THEN IF (almo_scf_env%almo_analysis%frozen_mo_energy_term == almo_frz_crystal & - .AND. almo_scf_env%almo_scf_guess .NE. molecular_guess) THEN + .AND. almo_scf_env%almo_scf_guess /= molecular_guess) THEN CPABORT("To compute frozen-MO energy term set ALMO_SCF_GUESS MOLECULAR") END IF diff --git a/src/almo_scf_lbfgs_types.F b/src/almo_scf_lbfgs_types.F index 97a4d4d0ee..a1fdbaca9a 100644 --- a/src/almo_scf_lbfgs_types.F +++ b/src/almo_scf_lbfgs_types.F @@ -209,7 +209,7 @@ CONTAINS !END IF IF (history%istore(vartype) <= history%nstore .AND. & - action .EQ. 1) THEN + action == 1) THEN !WRITE(*,*) "ZCRE: ispin,istore,vartype", ispin, istore, vartype CALL dbcsr_create(history%matrix(ispin, istore, vartype), & template=matrix(ispin)) @@ -218,7 +218,7 @@ CONTAINS !END IF END IF - IF (action .EQ. 1) THEN + IF (action == 1) THEN CALL dbcsr_copy(history%matrix(ispin, istore, vartype), matrix(ispin)) ELSE CALL dbcsr_add(history%matrix(ispin, istore, vartype), matrix(ispin), -1.0_dp, 1.0_dp) @@ -228,7 +228,7 @@ CONTAINS ! allow the pointer to move forward only if deltas are stored (action==2) ! otherwise return the pointer to the previous value - IF (action .EQ. 1) THEN + IF (action == 1) THEN history%istore(vartype) = history%istore(vartype) - 1 END IF @@ -258,7 +258,7 @@ CONTAINS ! unit_nr = -1 !ENDIF - IF (history%istore(1) .NE. history%istore(2)) THEN + IF (history%istore(1) /= history%istore(2)) THEN CPABORT("BFGS APIs are not used correctly") END IF @@ -291,7 +291,7 @@ CONTAINS ! use the most recent term to ! compute gamma_k, Nocedal (7.20) and then get H0 - IF (iterm .EQ. 1) THEN + IF (iterm == 1) THEN CALL dbcsr_dot(history%matrix(ispin, istore, 2), history%matrix(ispin, istore, 2), gammak) gammak = 1.0_dp/(gammak*history%rho(ispin, istore)) !IF (unit_nr > 0) THEN diff --git a/src/almo_scf_methods.F b/src/almo_scf_methods.F index 588e2d08d0..de95e2e03c 100644 --- a/src/almo_scf_methods.F +++ b/src/almo_scf_methods.F @@ -584,7 +584,7 @@ CONTAINS !!!!!! use intermediate matrices to get the error vector !!!!!!! !!!!!! make sure s_blk_sqrt and its inverse exist (i.e. we use diag algorithm) - CPASSERT(almo_scf_env%almo_update_algorithm .EQ. almo_scf_diag) + CPASSERT(almo_scf_env%almo_update_algorithm == almo_scf_diag) ! tmp_err = (1-S.T_blk.SigInv.tr(T_blk)).F.T_blk.SigInv CALL dbcsr_create(matrix_tmp_err, & template=almo_scf_env%matrix_t_blk(ispin)) @@ -799,7 +799,7 @@ CONTAINS DO idomain = 1, ndomains ! check if the submatrix exists - IF (subm_ks_xx_orthog(idomain)%domain .GT. 0) THEN + IF (subm_ks_xx_orthog(idomain)%domain > 0) THEN iblock_size = subm_ks_xx_orthog(idomain)%nrows @@ -818,10 +818,10 @@ CONTAINS ! Allocate the workspace and solve the eigenproblem ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', iblock_size, data_copy, iblock_size, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) CPABORT("DSYEV failed") + IF (INFO /= 0) CPABORT("DSYEV failed") ! Copy occupied eigenvectors - IF (almo_scf_env%domain_t(idomain, ispin)%ncols .NE. & + IF (almo_scf_env%domain_t(idomain, ispin)%ncols /= & almo_scf_env%nocc_of_domain(idomain, ispin)) THEN CPABORT("wrong domain structure") END IF @@ -940,13 +940,13 @@ CONTAINS DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, iblock_row, iblock_col, data_p, row_size=iblock_size) - IF (iblock_row .NE. iblock_col) THEN + IF (iblock_row /= iblock_col) THEN CPABORT("off-diagonal block found") END IF block_needed = .TRUE. - IF (almo_scf_env%nocc_of_domain(iblock_col, ispin) .EQ. 0 .AND. & - almo_scf_env%nvirt_of_domain(iblock_col, ispin) .EQ. 0) THEN + IF (almo_scf_env%nocc_of_domain(iblock_col, ispin) == 0 .AND. & + almo_scf_env%nvirt_of_domain(iblock_col, ispin) == 0) THEN block_needed = .FALSE. END IF @@ -967,7 +967,7 @@ CONTAINS ! Allocate the workspace and solve the eigenproblem ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', iblock_size, data_copy, iblock_size, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) CPABORT("DSYEV failed") + IF (INFO /= 0) CPABORT("DSYEV failed") !!! RZK-warning !!! !!! IT IS EXTREMELY IMPORTANT THAT THE DIAGONAL BLOCKS OF THE !!! @@ -977,7 +977,7 @@ CONTAINS ! copy eigenvectors into two dbcsr matrices - occupied and virtuals nocc_of_block = almo_scf_env%nocc_of_domain(iblock_col, ispin) - IF (nocc_of_block .GT. 0) THEN + IF (nocc_of_block > 0) THEN CALL dbcsr_put_block(matrix_t_blk_orthog, iblock_row, iblock_col, & block=data_copy(:, 1:nocc_of_block)) ! copy eigenvalues into diagonal dbcsr matrix - Eoo @@ -1005,7 +1005,7 @@ CONTAINS ! now virtuals nvirt_of_block = almo_scf_env%nvirt_of_domain(iblock_col, ispin) - IF (nvirt_of_block .GT. 0) THEN + IF (nvirt_of_block > 0) THEN CALL dbcsr_put_block(matrix_v_blk_orthog, iblock_row, iblock_col, & block=data_copy(:, (nocc_of_block + 1):(nocc_of_block + nvirt_of_block))) ! virtual energies @@ -1201,7 +1201,7 @@ CONTAINS ! Allocate the workspace and solve the eigenproblem ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', iblock_size, data_copy, iblock_size, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) THEN + IF (INFO /= 0) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, *) 'BLOCK = ', iblock_row WRITE (unit_nr, *) 'INFO =', INFO @@ -2075,7 +2075,7 @@ CONTAINS operator2_required = .FALSE. matrix_trimmer_required = .FALSE. - IF (my_action .EQ. 1) operator2_required = .TRUE. + IF (my_action == 1) operator2_required = .TRUE. IF (my_use_trimmer) THEN matrix_trimmer_required = .TRUE. @@ -2107,11 +2107,11 @@ CONTAINS !!!TRIM dpattern,map,node_of_domain,select_row) !!!TRIM ENDIF - IF (my_action .EQ. 0) THEN + IF (my_action == 0) THEN ! for example, apply preconditioner CALL multiply_submatrices('N', 'N', 1.0_dp, operator1, & subm_in, 0.0_dp, subm_out) - ELSE IF (my_action .EQ. 1) THEN + ELSE IF (my_action == 1) THEN ! use for projectors CALL copy_submatrices(subm_in, subm_out, .TRUE.) CALL multiply_submatrices('N', 'N', 1.0_dp, operator1, & @@ -2219,8 +2219,8 @@ CONTAINS matrix_trimmer_required = .FALSE. matrix_r_required = .FALSE. - IF (my_action .EQ. -1) matrix_s_inv_required = .TRUE. - IF (my_action .EQ. -1) matrix_r_required = .TRUE. + IF (my_action == -1) matrix_s_inv_required = .TRUE. + IF (my_action == -1) matrix_r_required = .TRUE. IF (my_use_trimmer) THEN matrix_trimmer_required = .TRUE. CPABORT("TRIMMED PRECONDITIONER DISABLED!") @@ -2269,7 +2269,7 @@ CONTAINS !!!TRIM dpattern,map,node_of_domain,select_row) !!!TRIM ENDIF - IF (my_action .EQ. -1) THEN + IF (my_action == -1) THEN ! project out the local occupied space !tmp=MATMUL(subm_r(idomain)%mdata,Minv) !Minv=MATMUL(tmp,subm_main(idomain)%mdata) @@ -2300,10 +2300,10 @@ CONTAINS DO idomain = 1, ndomains ! check if the submatrix exists - IF (subm_main(idomain)%domain .GT. 0) THEN + IF (subm_main(idomain)%domain > 0) THEN ! find sizes of MO submatrices - IF (idomain .EQ. 1) THEN + IF (idomain == 1) THEN index1_start = 1 ELSE index1_start = map%index1(idomain - 1) @@ -2427,8 +2427,8 @@ CONTAINS CALL timeset(routineN, handle) CALL dbcsr_get_info(dpattern, nblkcols_total=ndomains) - CPASSERT(SIZE(subm_s_sqrt) .EQ. ndomains) - CPASSERT(SIZE(subm_s_sqrt_inv) .EQ. ndomains) + CPASSERT(SIZE(subm_s_sqrt) == ndomains) + CPASSERT(SIZE(subm_s_sqrt_inv) == ndomains) ALLOCATE (subm_s(ndomains)) CALL init_submatrices(subm_s) @@ -2439,7 +2439,7 @@ CONTAINS DO idomain = 1, ndomains ! check if the submatrix exists - IF (subm_s(idomain)%domain .GT. 0) THEN + IF (subm_s(idomain)%domain > 0) THEN naos = subm_s(idomain)%nrows @@ -2500,7 +2500,7 @@ CONTAINS CALL dbcsr_get_info(dpattern, nblkcols_total=ndomains) - CPASSERT(SIZE(subm_s_inv) .EQ. ndomains) + CPASSERT(SIZE(subm_s_inv) == ndomains) ALLOCATE (subm_s(ndomains)) CALL init_submatrices(subm_s) @@ -2511,7 +2511,7 @@ CONTAINS DO idomain = 1, ndomains ! check if the submatrix exists - IF (subm_s(idomain)%domain .GT. 0) THEN + IF (subm_s(idomain)%domain > 0) THEN naos = subm_s(idomain)%nrows @@ -2590,7 +2590,7 @@ CONTAINS CALL dbcsr_release(m_tmp_no_2) CALL dbcsr_get_info(dpattern, nblkcols_total=ndomains) - CPASSERT(SIZE(subm_r_down) .EQ. ndomains) + CPASSERT(SIZE(subm_r_down) == ndomains) CALL construct_submatrices(matrix_r, subm_r_down, & dpattern, map, node_of_domain, select_row_col) @@ -2638,12 +2638,12 @@ CONTAINS END IF !CALL dpotrf('L', N, Ainv, N, INFO ) - !IF( INFO.NE.0 ) THEN + !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.NE.0 ) THEN + !IF( INFO/=0 ) THEN ! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed") ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !END IF @@ -2666,7 +2666,7 @@ CONTAINS ! Allocate the workspace and solve the eigenproblem ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', N, Asqrtinv, N, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) THEN + IF (INFO /= 0) THEN IF (unit_nr > 0) WRITE (unit_nr, *) 'DSYEV ERROR MESSAGE: ', INFO CPABORT("DSYEV failed") END IF @@ -2762,7 +2762,7 @@ CONTAINS unit_nr = -1 END IF - IF (method .EQ. 1) THEN + IF (method == 1) THEN IF ((PRESENT(range1) .AND. (.NOT. PRESENT(range2))) .OR. (PRESENT(range2) .AND. (.NOT. PRESENT(range1)))) THEN CPABORT("range1 and range2 must be provided together") @@ -2826,7 +2826,7 @@ CONTAINS ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', N, Ainv, N, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) THEN + IF (INFO /= 0) THEN IF (unit_nr > 0) WRITE (unit_nr, *) 'EIGENSYSTEM ERROR MESSAGE: ', INFO CPABORT("Eigenproblem routine failed") END IF @@ -2847,7 +2847,7 @@ CONTAINS IF (use_both) THEN DO jj = 1, N - IF ((jj .LE. range2) .AND. (eigenvalues(jj) .LT. range1_thr)) THEN + IF ((jj <= range2) .AND. (eigenvalues(jj) < range1_thr)) THEN temp1(jj, :) = temp2(:, jj)*0.0_dp IF (PRESENT(bad_modes_projector_down)) temp3(jj, :) = Ainv(:, jj)*1.0_dp range1_eiv = range1_eiv + 1 @@ -2860,11 +2860,11 @@ CONTAINS ELSE IF (use_ranges_only) THEN DO jj = 1, N - IF (jj .LE. range1) THEN + IF (jj <= range1) THEN temp1(jj, :) = temp2(:, jj)*0.0_dp IF (PRESENT(bad_modes_projector_down)) temp3(jj, :) = Ainv(:, jj)*1.0_dp range1_eiv = range1_eiv + 1 - ELSE IF (jj .LE. range2) THEN + ELSE IF (jj <= range2) THEN temp1(jj, :) = temp2(:, jj)*1.0_dp IF (PRESENT(bad_modes_projector_down)) temp3(jj, :) = Ainv(:, jj)*1.0_dp range2_eiv = range2_eiv + 1 @@ -2876,7 +2876,7 @@ CONTAINS END DO ELSE IF (use_thr_only) THEN DO jj = 1, N - IF (eigenvalues(jj) .LT. range1_thr) THEN + IF (eigenvalues(jj) < range1_thr) THEN temp1(jj, :) = temp2(:, jj)*0.0_dp IF (PRESENT(bad_modes_projector_down)) temp3(jj, :) = Ainv(:, jj)*1.0_dp range1_eiv = range1_eiv + 1 @@ -3018,7 +3018,7 @@ CONTAINS ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', N, Apow, N, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) THEN + IF (INFO /= 0) THEN IF (unit_nr > 0) WRITE (unit_nr, *) 'EIGENSYSTEM ERROR MESSAGE: ', INFO CPABORT("Eigenproblem routine failed") END IF @@ -3038,7 +3038,7 @@ CONTAINS IF (use_both) THEN DO jj = 1, N - IF ((jj .LE. range1) .AND. (eigenvalues(jj) .LT. range1_thr)) THEN + IF ((jj <= range1) .AND. (eigenvalues(jj) < range1_thr)) THEN temp1(jj, :) = temp2(:, jj)*0.0_dp range1_eiv = range1_eiv + 1 ELSE @@ -3048,7 +3048,7 @@ CONTAINS ELSE IF (use_ranges) THEN DO jj = 1, N - IF (jj .LE. range1) THEN + IF (jj <= range1) THEN temp1(jj, :) = temp2(:, jj)*0.0_dp range1_eiv = range1_eiv + 1 ELSE @@ -3058,7 +3058,7 @@ CONTAINS ELSE IF (use_thr) THEN DO jj = 1, N - IF (eigenvalues(jj) .LT. range1_thr) THEN + IF (eigenvalues(jj) < range1_thr) THEN temp1(jj, :) = temp2(:, jj)*0.0_dp range1_eiv = range1_eiv + 1 diff --git a/src/almo_scf_optimizer.F b/src/almo_scf_optimizer.F index 2bd4c07c14..1f1952a2d2 100644 --- a/src/almo_scf_optimizer.F +++ b/src/almo_scf_optimizer.F @@ -228,12 +228,12 @@ CONTAINS 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 .EQ. 1) error_norm = error_norm_ispin - IF (ispin .GT. 1 .AND. error_norm_ispin .GT. error_norm) & + IF (ispin == 1) error_norm = error_norm_ispin + IF (ispin > 1 .AND. error_norm_ispin > error_norm) & error_norm = error_norm_ispin END DO - IF (error_norm .LT. almo_scf_env%eps_prev_guess) THEN + IF (error_norm < almo_scf_env%eps_prev_guess) THEN use_prev_as_guess = .TRUE. ELSE use_prev_as_guess = .FALSE. @@ -241,7 +241,7 @@ CONTAINS ! check convergence converged = .TRUE. - IF (error_norm .GT. optimizer%eps_error) converged = .FALSE. + IF (error_norm > optimizer%eps_error) converged = .FALSE. ! check other exit criteria: max SCF steps and timing CALL external_control(should_stop, "SCF", & @@ -253,13 +253,13 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf .EQ. 1) & + IF (optimizer%early_stopping_on .AND. iscf == 1) & prepare_to_exit = .FALSE. IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix ! perform mixing of KS matrices - IF (iscf .NE. 1) THEN + IF (iscf /= 1) THEN IF (use_diis) THEN ! use diis instead of mixing DO ispin = 1, nspin CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), & @@ -582,7 +582,7 @@ CONTAINS error_norm = dbcsr_maxabs(almo_scf_env%matrix_err_xx(ispin)) CALL maxnorm_submatrices(almo_scf_env%domain_err(:, ispin), & norm=error_norm_0) - IF (error_norm .GT. optimizer%eps_error) THEN + IF (error_norm > optimizer%eps_error) THEN converged = .FALSE. EXIT ! no need to check the other spin END IF @@ -596,13 +596,13 @@ CONTAINS END IF ! if early stopping is on do at least one iteration - IF (optimizer%early_stopping_on .AND. iscf .EQ. 1) & + IF (optimizer%early_stopping_on .AND. iscf == 1) & prepare_to_exit = .FALSE. IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix ! perform mixing of KS matrices - IF (iscf .NE. 1) THEN + IF (iscf /= 1) THEN IF (.FALSE.) THEN ! use diis instead of mixing DO ispin = 1, nspin CALL add_submatrices( & @@ -634,7 +634,7 @@ CONTAINS DO ispin = 1, nspin ! save the initial density matrix (to get the perturbative energy lowering) - IF (iscf .EQ. 1) THEN + IF (iscf == 1) THEN CALL dbcsr_create(matrix_p_almo_scf_converged, & template=almo_scf_env%matrix_p(ispin)) CALL dbcsr_copy(matrix_p_almo_scf_converged, & @@ -680,7 +680,7 @@ CONTAINS ! obtain perturbative estimate (at no additional cost) ! of the energy lowering relative to the block-diagonal ALMOs - IF (iscf .EQ. 1) THEN + IF (iscf == 1) THEN CALL dbcsr_add(matrix_p_almo_scf_converged, & almo_scf_env%matrix_p(ispin), -1.0_dp, 1.0_dp) @@ -757,7 +757,7 @@ CONTAINS END DO ! print out the energy lowering - IF (iscf .EQ. 1) THEN + IF (iscf == 1) THEN CALL energy_lowering_report( & unit_nr=unit_nr, & ref_energy=almo_scf_env%almo_scf_energy, & @@ -921,7 +921,7 @@ CONTAINS ! if unprojected XALMOs are optimized ! then we must use the "blissful_neglect" procedure blissful_neglect = .FALSE. - IF (my_special_case .EQ. xalmo_case_normal .AND. .NOT. assume_t0_q0x) THEN + IF (my_special_case == xalmo_case_normal .AND. .NOT. assume_t0_q0x) THEN blissful_neglect = .TRUE. END IF @@ -959,9 +959,9 @@ CONTAINS 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 & - !.NE. penalty_type_none .AND. my_special_case .EQ. xalmo_case_fully_deloc ) + !/= penalty_type_none .AND. my_special_case == xalmo_case_fully_deloc ) penalty_occ_local = .FALSE. !( optimizer%opt_penalty%occ_loc_method & - !.NE. penalty_type_none .AND. my_special_case .EQ. xalmo_case_fully_deloc ) + !/= 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)) @@ -1139,7 +1139,7 @@ CONTAINS ! invert S domains if necessary ! Note: domains for alpha and beta electrons might be different ! that is why the inversion of the AO overlap is inside the spin loop - IF (my_special_case .EQ. xalmo_case_normal) THEN + IF (my_special_case == xalmo_case_normal) THEN CALL construct_domain_s_inv( & matrix_s=almo_scf_env%matrix_s(1), & subm_s_inv=almo_scf_env%domain_s_inv(:, ispin), & @@ -1160,7 +1160,7 @@ CONTAINS IF (assume_t0_q0x) THEN ! save S.T_0.siginv_0 - IF (my_special_case .EQ. xalmo_case_fully_deloc) THEN + IF (my_special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, & almo_scf_env%matrix_s(1), & almo_scf_env%matrix_t_blk(ispin), & @@ -1174,7 +1174,7 @@ CONTAINS END IF ! construct domain-projector - IF (my_special_case .EQ. xalmo_case_normal) THEN + IF (my_special_case == xalmo_case_normal) THEN CALL construct_domain_r_down( & matrix_t=almo_scf_env%matrix_t_blk(ispin), & matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin), & @@ -1268,7 +1268,7 @@ CONTAINS DO - just_started = (iteration .EQ. 0) .AND. (outer_iteration .EQ. 0) + just_started = (iteration == 0) .AND. (outer_iteration == 0) CALL main_var_to_xalmos_and_loss_func( & almo_scf_env=almo_scf_env, & @@ -1369,7 +1369,7 @@ CONTAINS DO ispin = 1, nspins IF (just_started .AND. almo_mathematica) THEN - CPWARN_IF(ispin .GT. 1, "Mathematica files will be overwritten") + CPWARN_IF(ispin > 1, "Mathematica files will be overwritten") CALL print_mathematica_matrix(almo_scf_env%matrix_s(1), "matrixS.dat") CALL print_mathematica_matrix(almo_scf_env%matrix_ks(ispin), "matrixF.dat") CALL print_mathematica_matrix(matrix_t_out(ispin), "matrixT.dat") @@ -1379,15 +1379,15 @@ 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 .EQ. 0 .AND. iteration .NE. 0) & + IF (line_search_iteration == 0 .AND. iteration /= 0) & CALL dbcsr_copy(prev_grad(ispin), grad(ispin)) END DO ! ispin ! compute the energy gradient if necessary - skip_grad = (iteration .GT. 0 .AND. & - fixed_line_search_niter .NE. 0 .AND. & - line_search_iteration .NE. fixed_line_search_niter) + skip_grad = (iteration > 0 .AND. & + fixed_line_search_niter /= 0 .AND. & + line_search_iteration /= fixed_line_search_niter) IF (.NOT. skip_grad) THEN @@ -1437,7 +1437,7 @@ CONTAINS DO ispin = 1, nspins !compute the prec only for the first step, !but project the gradient every step - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN CALL compute_preconditioner( & domain_prec_out=almo_scf_env%domain_preconditioner(:, ispin), & bad_modes_projector_down_out=bad_modes_projector_down(:, ispin), & @@ -1489,15 +1489,15 @@ CONTAINS END DO ! ispin grad_norm = MAXVAL(grad_norm_spin) - converged = (grad_norm .LE. optimizer%eps_error) - IF (converged .OR. (iteration .GE. max_iter)) THEN + converged = (grad_norm <= optimizer%eps_error) + IF (converged .OR. (iteration >= max_iter)) THEN prepare_to_exit = .TRUE. END IF ! if early stopping is on do at least one iteration IF (optimizer%early_stopping_on .AND. just_started) & prepare_to_exit = .FALSE. - IF (grad_norm .LT. almo_scf_env%eps_prev_guess) & + IF (grad_norm < almo_scf_env%eps_prev_guess) & use_guess = .TRUE. ! it is not time to exit just yet @@ -1506,9 +1506,9 @@ CONTAINS ! check the gradient along the step direction ! and decide whether to switch to the line-search mode ! do not do this in the first iteration - IF (iteration .NE. 0) THEN + IF (iteration /= 0) THEN - IF (fixed_line_search_niter .EQ. 0) THEN + IF (fixed_line_search_niter == 0) THEN ! enforce at least one line search ! without even checking the error @@ -1540,13 +1540,13 @@ CONTAINS ! (must be close to zero at convergence) line_search_error = line_search_error/SQRT(denom)/SQRT(denom2) - IF (ABS(line_search_error) .GT. optimizer%lin_search_eps_error) THEN + IF (ABS(line_search_error) > optimizer%lin_search_eps_error) THEN line_search = .TRUE. line_search_iteration = line_search_iteration + 1 ELSE line_search = .FALSE. line_search_iteration = 0 - IF (grad_norm .LT. eps_skip_gradients) THEN + IF (grad_norm < eps_skip_gradients) THEN fixed_line_search_niter = ABS(almo_scf_env%integer04) END IF END IF @@ -1559,7 +1559,7 @@ CONTAINS line_search = .TRUE. line_search_iteration = line_search_iteration + 1 ELSE - IF (line_search_iteration .EQ. fixed_line_search_niter) THEN + IF (line_search_iteration == fixed_line_search_niter) THEN line_search = .FALSE. line_search_iteration = 0 line_search_iteration = line_search_iteration + 1 @@ -1630,7 +1630,7 @@ CONTAINS ! compute and invert preconditioner? IF (.NOT. blissful_neglect .AND. & ((just_started .AND. perturbation_only) .OR. & - (iteration .EQ. 0 .AND. (.NOT. perturbation_only))) & + (iteration == 0 .AND. (.NOT. perturbation_only))) & ) THEN ! computing preconditioner @@ -1667,8 +1667,8 @@ CONTAINS ! WRITE(unit_nr,*) "....applying precomputed preconditioner...." !ENDIF - IF (my_special_case .EQ. xalmo_case_block_diag .OR. & - my_special_case .EQ. xalmo_case_fully_deloc) THEN + IF (my_special_case == xalmo_case_block_diag .OR. & + my_special_case == xalmo_case_fully_deloc) THEN DO ispin = 1, nspins @@ -1727,7 +1727,7 @@ CONTAINS END SELECT ! preconditioner type fork ! check whether we need to reset conjugate directions - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN reset_conjugator = .TRUE. END IF @@ -1784,10 +1784,10 @@ CONTAINS CALL dbcsr_dot(grad(ispin), step(ispin), tempreal) g0 = g0 + tempreal END DO ! ispin - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN step_size = optimizer%lin_search_step_size_guess ELSE - IF (next_step_size_guess .LE. 0.0_dp) THEN + IF (next_step_size_guess <= 0.0_dp) THEN step_size = optimizer%lin_search_step_size_guess ELSE ! take the last value @@ -1800,7 +1800,7 @@ CONTAINS !ENDIF next_step_size_guess = step_size ELSE - IF (fixed_line_search_niter .EQ. 0) THEN + IF (fixed_line_search_niter == 0) THEN e1 = energy_new g1 = 0.0_dp DO ispin = 1, nspins @@ -1870,7 +1870,7 @@ CONTAINS END IF END IF - IF (my_special_case .EQ. xalmo_case_block_diag) THEN + IF (my_special_case == xalmo_case_block_diag) THEN IF (penalty_occ_vol) THEN almo_scf_env%almo_scf_energy = energy_new - penalty_func_new - localization_obj_function ELSE @@ -1885,7 +1885,7 @@ CONTAINS END DO ! inner SCF loop - IF (converged .OR. (outer_iteration .GE. outer_max_iter)) THEN + IF (converged .OR. (outer_iteration >= outer_max_iter)) THEN outer_prepare_to_exit = .TRUE. END IF @@ -1896,7 +1896,7 @@ CONTAINS DO ispin = 1, nspins IF (converged .AND. almo_mathematica) THEN - CPWARN_IF(ispin .GT. 1, "Mathematica files will be overwritten") + CPWARN_IF(ispin > 1, "Mathematica files will be overwritten") CALL print_mathematica_matrix(matrix_t_out(ispin), "matrixTf.dat") END IF END DO ! ispin @@ -2158,8 +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 .NE. penalty_type_none ) - !penalty_local = ( optimizer%opt_penalty%occ_loc_method .NE. penalty_type_none ) + !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 @@ -2167,8 +2167,8 @@ CONTAINS ! use diagonal BFGS if preconditioner is set d_bfgs = .FALSE. l_bfgs = .FALSE. - IF (prec_type .NE. xalmo_prec_zero) l_bfgs = .TRUE. - IF (l_bfgs .AND. (optimizer%conjugator .NE. cg_zero)) THEN + IF (prec_type /= xalmo_prec_zero) l_bfgs = .TRUE. + IF (l_bfgs .AND. (optimizer%conjugator /= cg_zero)) THEN CPABORT("Cannot use conjugators with BFGS") END IF IF (l_bfgs) THEN @@ -2366,7 +2366,7 @@ CONTAINS END DO ! ispin - IF (optimizer%opt_penalty%operator_type .EQ. op_loc_berry) THEN + IF (optimizer%opt_penalty%operator_type == op_loc_berry) THEN DO idim0 = 1, SIZE(op_sm_set_qs, 2) ! this loop is over miller ind DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im DEALLOCATE (op_sm_set_qs(reim, idim0)%matrix) @@ -2406,7 +2406,7 @@ CONTAINS DO - just_started = (iteration .EQ. 0) .AND. (outer_iteration .EQ. 0) + just_started = (iteration == 0) .AND. (outer_iteration == 0) DO ispin = 1, nspins @@ -2479,7 +2479,7 @@ 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 .EQ. 0 .AND. iteration .NE. 0) THEN + IF (line_search_iteration == 0 .AND. iteration /= 0) THEN CALL dbcsr_copy(prev_grad(ispin), grad(ispin)) END IF @@ -2515,8 +2515,8 @@ CONTAINS END DO ! ispin grad_norm = MAXVAL(grad_norm_spin) - converged = (grad_norm .LE. optimizer%eps_error) - IF (converged .OR. (iteration .GE. max_iter)) THEN + converged = (grad_norm <= optimizer%eps_error) + IF (converged .OR. (iteration >= max_iter)) THEN prepare_to_exit = .TRUE. END IF @@ -2526,7 +2526,7 @@ CONTAINS ! check the gradient along the step direction ! and decide whether to switch to the line-search mode ! do not do this in the first iteration - IF (iteration .NE. 0) THEN + IF (iteration /= 0) THEN ! enforce at least one line search ! without even checking the error @@ -2558,7 +2558,7 @@ CONTAINS ! (must be close to zero at convergence) line_search_error = line_search_error/SQRT(denom)/SQRT(denom2) - IF (ABS(line_search_error) .GT. optimizer%lin_search_eps_error) THEN + IF (ABS(line_search_error) > optimizer%lin_search_eps_error) THEN line_search = .TRUE. line_search_iteration = line_search_iteration + 1 ELSE @@ -2589,7 +2589,7 @@ CONTAINS ! compute the new step: ! if available use second derivative info - bfgs, hessian, preconditioner - IF (prec_type .EQ. xalmo_prec_zero) THEN ! no second derivatives + IF (prec_type == xalmo_prec_zero) THEN ! no second derivatives ! no preconditioner DO ispin = 1, nspins @@ -2602,13 +2602,13 @@ CONTAINS ELSE ! use second derivatives ! compute and invert hessian/precond? - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN IF (d_bfgs) THEN ! create matrix filled with 1.0 here CALL fill_matrix_with_ones(approx_inv_hessian(1)) - IF (nspins .GT. 1) THEN + IF (nspins > 1) THEN DO ispin = 2, nspins CALL dbcsr_copy(approx_inv_hessian(ispin), approx_inv_hessian(1)) END DO @@ -2725,7 +2725,7 @@ CONTAINS END IF ! second derivative type fork ! check whether we need to reset conjugate directions - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN reset_conjugator = .TRUE. END IF @@ -2778,11 +2778,11 @@ CONTAINS g0 = g0 + tempreal END DO ! ispin g0sign = SIGN(1.0_dp, g0) ! sign of g0 - IF (linear_search_type .EQ. 1) THEN ! this is quadratic LS - IF (iteration .EQ. 0) THEN + IF (linear_search_type == 1) THEN ! this is quadratic LS + IF (iteration == 0) THEN step_size = optimizer%lin_search_step_size_guess ELSE - IF (next_step_size_guess .LE. 0.0_dp) THEN + IF (next_step_size_guess <= 0.0_dp) THEN step_size = optimizer%lin_search_step_size_guess ELSE ! take the last value @@ -2790,7 +2790,7 @@ CONTAINS !step_size = next_step_size_guess*1.05_dp END IF END IF - ELSE IF (linear_search_type .EQ. 2) THEN ! this is cautious LS + ELSE IF (linear_search_type == 2) THEN ! this is cautious LS ! this LS type is designed not to trust quadratic appr ! so it always restarts from a safe step size step_size = optimizer%lin_search_step_size_guess @@ -2808,7 +2808,7 @@ CONTAINS g1 = g1 + tempreal END DO ! ispin g1sign = SIGN(1.0_dp, g1) ! sign of g1 - IF (linear_search_type .EQ. 1) THEN + IF (linear_search_type == 1) THEN ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der = (g1 - g0)/step_size @@ -2817,10 +2817,10 @@ CONTAINS ! "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 .EQ. 2) THEN + ELSE IF (linear_search_type == 2) THEN ! alternative method for finding step size ! do not use quadratic approximation, only gradient signs - IF (g1sign .NE. g0sign) THEN + IF (g1sign /= g0sign) THEN step_size = -step_size/2.0; ELSE step_size = step_size*1.5; @@ -2873,7 +2873,7 @@ CONTAINS END DO ! inner loop - IF (converged .OR. (outer_iteration .GE. outer_max_iter)) THEN + IF (converged .OR. (outer_iteration >= outer_max_iter)) THEN outer_prepare_to_exit = .TRUE. END IF @@ -3239,14 +3239,14 @@ CONTAINS 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 + IF (iblock_row /= iblock_col) THEN CPABORT("off-diagonal block found") END IF retained_v = almo_scf_env%nvirt_of_domain(iblock_col, ispin) discarded_v = almo_scf_env%nvirt_disc_of_domain(iblock_col, ispin) - CPASSERT(retained_v .GT. 0) - CPASSERT(discarded_v .GT. 0) + CPASSERT(retained_v > 0) + CPASSERT(discarded_v > 0) CALL dbcsr_put_block(almo_scf_env%matrix_v_disc_blk(ispin), iblock_row, iblock_col, & block=data_p(:, (retained_v + 1):iblock_col_size)) CALL dbcsr_put_block(almo_scf_env%matrix_v_blk(ispin), iblock_row, iblock_col, & @@ -3317,7 +3317,7 @@ CONTAINS nspin = almo_scf_env%nspins energy_correction_final = 0.0_dp - IF (nspin .EQ. 1) THEN + IF (nspin == 1) THEN spin_factor = 2.0_dp ELSE spin_factor = 1.0_dp @@ -3394,7 +3394,7 @@ CONTAINS END IF END DO - IF (almo_scf_env%almo_update_algorithm .EQ. almo_scf_diag) THEN + IF (almo_scf_env%almo_update_algorithm == almo_scf_diag) THEN DO ispin = 1, nspin @@ -3412,7 +3412,7 @@ CONTAINS grad_norm = 0.0_dp grad_norm_frob = 0.0_dp CALL dbcsr_set(almo_scf_env%matrix_x(ispin), 0.0_dp) - IF (almo_scf_env%deloc_truncate_virt .EQ. virt_full) outer_opt_k_max_iter = 0 + IF (almo_scf_env%deloc_truncate_virt == virt_full) outer_opt_k_max_iter = 0 DO @@ -3454,7 +3454,7 @@ CONTAINS CALL dbcsr_filter(sigma_vv_sqrt_inv_guess, almo_scf_env%eps_filter) ! do things required to optimize virtuals - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN ! project retained virtuals out of discarded block-by-block ! (1-Q^VR_ALMO)|ALMO_vd> @@ -3633,14 +3633,14 @@ CONTAINS gfun1 = 0.0_dp step_size_quadratic_approx = 0.0_dp reset_step_size = .TRUE. - IF (almo_scf_env%deloc_truncate_virt .EQ. virt_full) opt_k_max_iter = 0 + IF (almo_scf_env%deloc_truncate_virt == virt_full) opt_k_max_iter = 0 ! start cg iterations to optimize matrix_k_blk DO CALL timeset('k_opt_vr', handle1) - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN ! construct k-excited virtuals CALL dbcsr_multiply("N", "N", 1.0_dp, vd_fixed, & @@ -3663,7 +3663,7 @@ CONTAINS eps_filter=almo_scf_env%eps_filter) ! use either cholesky or sqrt !! RZK-warning: strangely, cholesky does not work with k-optimization - IF (almo_scf_env%deloc_truncate_virt .EQ. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt == virt_full) THEN CALL timeset('cholesky', handle2) t1cholesky = m_walltime() @@ -3764,8 +3764,8 @@ CONTAINS ! compute excitation amplitudes (to the current set of retained virtuals) ! set convergence criterion for x-optimization - IF ((iteration .EQ. 0) .AND. (.NOT. line_search) .AND. & - (outer_opt_k_iteration .EQ. 0)) THEN + IF ((iteration == 0) .AND. (.NOT. line_search) .AND. & + (outer_opt_k_iteration == 0)) THEN x_opt_eps_adaptive = & almo_scf_env%deloc_cayley_eps_convergence ELSE @@ -3814,7 +3814,7 @@ CONTAINS ! back and forth between orth and up_down representations energy_correction(1) = energy_correction(1)*spin_factor - IF (opt_k_max_iter .NE. 0) THEN + IF (opt_k_max_iter /= 0) THEN CALL timeset('k_opt_t_curr', handle3) @@ -3837,7 +3837,7 @@ CONTAINS metric=almo_scf_env%matrix_s(1), & retain_overlap_sparsity=.FALSE., & eps_filter=almo_scf_env%eps_filter) - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN CALL invert_Hotelling(sigma_oo_curr_inv, & sigma_oo_curr, & threshold=almo_scf_env%eps_filter, & @@ -3948,8 +3948,8 @@ CONTAINS ! check convergence and other exit criteria grad_norm_frob = dbcsr_frobenius_norm(grad) grad_norm = dbcsr_maxabs(grad) - converged = (grad_norm .LT. almo_scf_env%opt_k_eps_convergence) - IF (converged .OR. (iteration .GE. opt_k_max_iter)) THEN + converged = (grad_norm < almo_scf_env%opt_k_eps_convergence) + IF (converged .OR. (iteration >= opt_k_max_iter)) THEN prepare_to_exit = .TRUE. END IF CALL timestop(handle5) @@ -3981,9 +3981,9 @@ CONTAINS CALL timeset('k_opt_step', handle7) IF ((.NOT. md_in_k_space) .AND. & - (iteration .GE. MAX(0, almo_scf_env%opt_k_prec_iter_start) .AND. & + (iteration >= MAX(0, almo_scf_env%opt_k_prec_iter_start) .AND. & MOD(iteration - almo_scf_env%opt_k_prec_iter_start, & - almo_scf_env%opt_k_prec_iter_freq) .EQ. 0)) THEN + almo_scf_env%opt_k_prec_iter_freq) == 0)) THEN !IF ((iteration.eq.0).AND.(.NOT.md_in_k_space)) THEN @@ -4027,9 +4027,9 @@ CONTAINS ! check whether we need to reset conjugate directions reset_conjugator = .FALSE. ! first check if manual reset is active - IF (iteration .LT. MAX(almo_scf_env%opt_k_conj_iter_start, 1) .OR. & + IF (iteration < MAX(almo_scf_env%opt_k_conj_iter_start, 1) .OR. & MOD(iteration - almo_scf_env%opt_k_conj_iter_start, & - almo_scf_env%opt_k_conj_iter_freq) .EQ. 0) THEN + almo_scf_env%opt_k_conj_iter_freq) == 0) THEN reset_conjugator = .TRUE. @@ -4043,7 +4043,7 @@ CONTAINS CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom) conjugacy_error = numer/denom - IF (conjugacy_error .GT. MIN(0.5_dp, conjugacy_error_threshold)) THEN + IF (conjugacy_error > MIN(0.5_dp, conjugacy_error_threshold)) THEN reset_conjugator = .TRUE. IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Lack of progress, conjugacy error is ", conjugacy_error @@ -4051,11 +4051,11 @@ CONTAINS END IF ! check the gradient along the previous direction - IF ((iteration .NE. 0) .AND. (.NOT. reset_conjugator)) THEN + IF ((iteration /= 0) .AND. (.NOT. reset_conjugator)) THEN CALL dbcsr_dot(grad, prev_step, numer) CALL dbcsr_dot(prev_grad, prev_step, denom) line_search_error = numer/denom - IF (line_search_error .GT. line_search_error_threshold) THEN + IF (line_search_error > line_search_error_threshold) THEN reset_conjugator = .TRUE. IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Bad line search, line search error is ", line_search_error @@ -4148,7 +4148,7 @@ CONTAINS CPABORT("illegal conjugator") END SELECT - IF (beta .LT. 0.0_dp) THEN + IF (beta < 0.0_dp) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Beta is negative, ", beta END IF @@ -4200,7 +4200,7 @@ CONTAINS safety_multiplier = 1.0E+1_dp ! must be more than one num_threshold = MAX(EPSILON(1.0_dp), & safety_multiplier*(almo_scf_env%eps_filter**2)*almo_scf_env%ndomains) - IF (ABS(fun1 - fun0 - gfun0*step_size) .LT. num_threshold) THEN + IF (ABS(fun1 - fun0 - gfun0*step_size) < num_threshold) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,1X,E17.7)') & "Numerical accuracy is too low to observe non-linear behavior", & @@ -4211,7 +4211,7 @@ CONTAINS END IF CPABORT("") END IF - IF (ABS(gfun0) .LT. num_threshold) THEN + IF (ABS(gfun0) < num_threshold) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,1X,E17.7,A,1X,E12.3)') "Linear gradient", & ABS(gfun0), & @@ -4229,8 +4229,8 @@ CONTAINS ! use f0, f1, g1 step_size_quadratic_approx2 = -(fun1 - fun0 - step_size*gfun1/2.0_dp)/(gfun1 - (fun1 - fun0)/step_size) - IF ((step_size_quadratic_approx .LT. 0.0_dp) .AND. & - (step_size_quadratic_approx2 .LT. 0.0_dp)) THEN + IF ((step_size_quadratic_approx < 0.0_dp) .AND. & + (step_size_quadratic_approx2 < 0.0_dp)) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,1X,E17.7,1X,E17.7,1X,A)') & "Quadratic approximation gives negative steps", & @@ -4240,10 +4240,10 @@ CONTAINS use_cubic_approximation = .TRUE. use_quadratic_approximation = .FALSE. ELSE - IF (step_size_quadratic_approx .LT. 0.0_dp) THEN + IF (step_size_quadratic_approx < 0.0_dp) THEN step_size_quadratic_approx = step_size_quadratic_approx2 END IF - IF (step_size_quadratic_approx2 .LT. 0.0_dp) THEN + IF (step_size_quadratic_approx2 < 0.0_dp) THEN step_size_quadratic_approx2 = step_size_quadratic_approx END IF END IF @@ -4252,7 +4252,7 @@ CONTAINS IF (use_quadratic_approximation) THEN quadratic_approx_error = ABS(step_size_quadratic_approx - & step_size_quadratic_approx2)/step_size_quadratic_approx - IF (quadratic_approx_error .GT. quadratic_approx_error_threshold) THEN + IF (quadratic_approx_error > quadratic_approx_error_threshold) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,1X,E17.7,1X,E17.7,1X,A)') "Quadratic approximation is poor", & step_size_quadratic_approx, step_size_quadratic_approx2, & @@ -4272,7 +4272,7 @@ CONTAINS bb = (-step_size*gfun1 + 3.0_dp*(fun1 - fun0) - 2.0_dp*step_size*gfun0)/(step_size*step_size) aa = (gfun1 - 2.0_dp*step_size*bb - gfun0)/(3.0_dp*step_size*step_size) - IF (ABS(gfun1 - 2.0_dp*step_size*bb - gfun0) .LT. num_threshold) THEN + IF (ABS(gfun1 - 2.0_dp*step_size*bb - gfun0) < num_threshold) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,1X,E17.7)') & "Numerical accuracy is too low to observe cubic behavior", & @@ -4281,7 +4281,7 @@ CONTAINS use_cubic_approximation = .FALSE. use_quadratic_approximation = .TRUE. END IF - IF (ABS(gfun1) .LT. num_threshold) THEN + IF (ABS(gfun1) < num_threshold) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,1X,E17.7,A,1X,E12.3)') "Linear gradient", & ABS(gfun1), & @@ -4297,7 +4297,7 @@ CONTAINS ! to obtain the minimum of the cubic function solve the quadratic equation ! 0.0*x**3 + 3.0*aa*x**2 + 2.0*bb*x + cc = 0 CALL analytic_line_search(0.0_dp, 3.0_dp*aa, 2.0_dp*bb, gfun0, minima, nmins) - IF (nmins .LT. 1) THEN + IF (nmins < 1) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A)') & "Cubic approximation gives zero soultions! Use quadratic approximation" @@ -4306,7 +4306,7 @@ CONTAINS use_cubic_approximation = .TRUE. ELSE step_size = minima(1) - IF (nmins .GT. 1) THEN + IF (nmins > 1) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A)') & "More than one solution found! Use quadratic approximation" @@ -4325,7 +4325,7 @@ CONTAINS END IF ! one more check on the step size - IF (step_size .LT. 0.0_dp) THEN + IF (step_size < 0.0_dp) THEN CPABORT("Negative step proposed") END IF @@ -4342,7 +4342,7 @@ CONTAINS IF (md_in_k_space) THEN ! update velocities v(i) = v(i-1) + 0.5*dT*(a(i-1) + a(i)) - IF (iteration .NE. 0) THEN + IF (iteration /= 0) THEN CALL dbcsr_add(velocity, & step, 1.0_dp, 0.5_dp*time_step) CALL dbcsr_add(velocity, & @@ -4413,11 +4413,11 @@ CONTAINS END DO ! end iterations on K - IF (converged .OR. (outer_opt_k_iteration .GE. outer_opt_k_max_iter)) THEN + IF (converged .OR. (outer_opt_k_iteration >= outer_opt_k_max_iter)) THEN outer_opt_k_prepare_to_exit = .TRUE. END IF - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, *) "Updating ALMO virtuals" @@ -4550,7 +4550,7 @@ CONTAINS ! RZK-warning released outside the outer loop CALL dbcsr_release(sigma_vv_sqrt) CALL dbcsr_release(sigma_vv_sqrt_inv) - IF (almo_scf_env%deloc_truncate_virt .NE. virt_full) THEN + 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) @@ -5624,7 +5624,7 @@ CONTAINS !! iblock_row_size,eigenvalues,left_vectors,iblock_row_size,& !! right_vectors,iblock_col_size,WORK,LWORK,INFO) !! deallocate(WORK) -!! IF( INFO.NE.0 ) THEN +!! IF( INFO/=0 ) THEN !! CPABORT("DGESVD failed") !! END IF !! @@ -6234,7 +6234,7 @@ CONTAINS ! project out the occupied space from the gradient IF (assume_t0_q0x) THEN - IF (special_case .EQ. xalmo_case_fully_deloc) THEN + IF (special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_copy(m_grad_out, m_tmp_no_1) CALL dbcsr_multiply("T", "N", 1.0_dp, & m_t0, & @@ -6246,7 +6246,7 @@ CONTAINS m_tmp_oo_1, & 1.0_dp, m_grad_out, & filter_eps=eps_filter) - ELSE IF (special_case .EQ. xalmo_case_block_diag) THEN + ELSE IF (special_case == xalmo_case_block_diag) THEN CPABORT("Cannot project the zero-order space from itself") ELSE ! no special case: normal xALMOs @@ -6370,7 +6370,7 @@ CONTAINS ! serial code only CALL dbcsr_get_info(matrix, distribution=dist) CALL dbcsr_distribution_get(dist, numnodes=ncores) - IF (ncores .GT. 1) THEN + IF (ncores > 1) THEN CPABORT("mathematica files: serial code only") END IF @@ -6557,7 +6557,7 @@ CONTAINS ! save the current determinant overlap_determinant = det1 - IF (just_started .AND. penalty_amplitude .LT. 0.0_dp) THEN + IF (just_started .AND. penalty_amplitude < 0.0_dp) THEN penalty_vol_prefactor = -(-penalty_amplitude)*localization_obj_function_ispin END IF penalty_func_ispin = penalty_func_ispin + penalty_vol_prefactor*LOG(det1) @@ -6838,7 +6838,7 @@ CONTAINS WRITE (unit_nr, *) "Maximum allowed amplitude: ", & envelope_amplitude END IF - IF (t_norm .GT. envelope_amplitude .AND. just_started) THEN + IF (t_norm > envelope_amplitude .AND. just_started) THEN CPABORT("Max norm of the initial guess is too large") END IF ! use artanh to tame MOs @@ -6850,7 +6850,7 @@ CONTAINS ! project out R_0 IF (assume_t0_q0x) THEN - IF (special_case .EQ. xalmo_case_fully_deloc) THEN + IF (special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("T", "N", 1.0_dp, & m_STsiginv0, & m_t_out, & @@ -6861,7 +6861,7 @@ CONTAINS m_tmp_oo_1, & 1.0_dp, m_t_out, & filter_eps=eps_filter) - ELSE IF (special_case .EQ. xalmo_case_block_diag) THEN + ELSE IF (special_case == xalmo_case_block_diag) THEN CPABORT("cannot use projector with block-daigonal ALMOs") ELSE ! no special case @@ -7009,7 +7009,7 @@ CONTAINS IF (PRESENT(m_STsiginv_out)) THEN CALL dbcsr_copy(m_STsiginv_out, m_tmp_no_3) END IF - IF (special_case .EQ. xalmo_case_fully_deloc) THEN + IF (special_case == xalmo_case_fully_deloc) THEN ! use S instead of S-SRS ELSE CALL dbcsr_multiply("N", "T", -1.0_dp, & @@ -7077,7 +7077,7 @@ CONTAINS CALL dbcsr_copy(m_tmp_nn_1, m_prec_out) ! invert using various algorithms - IF (special_case .EQ. xalmo_case_block_diag) THEN ! non-overlapping diagonal blocks + IF (special_case == xalmo_case_block_diag) THEN ! non-overlapping diagonal blocks IF (skip_inversion) THEN @@ -7102,7 +7102,7 @@ CONTAINS END IF - ELSE IF (special_case .EQ. xalmo_case_fully_deloc) THEN ! the entire system is a block + ELSE IF (special_case == xalmo_case_fully_deloc) THEN ! the entire system is a block IF (skip_inversion) THEN CALL dbcsr_copy(m_prec_out, m_tmp_nn_1) @@ -7283,18 +7283,18 @@ CONTAINS END IF IF (.NOT. PRESENT(prev_minus_prec_grad)) THEN - IF (conjugator .EQ. cg_fletcher_reeves .OR. & - conjugator .EQ. cg_polak_ribiere .OR. & - conjugator .EQ. cg_hager_zhang) THEN + IF (conjugator == cg_fletcher_reeves .OR. & + conjugator == cg_polak_ribiere .OR. & + conjugator == cg_hager_zhang) THEN CPABORT("conjugator needs more input") END IF END IF ! return num denom so beta can be calculated spin-by-spin IF (PRESENT(numer) .OR. PRESENT(denom)) THEN - IF (conjugator .EQ. cg_hestenes_stiefel .OR. & - conjugator .EQ. cg_dai_yuan .OR. & - conjugator .EQ. cg_hager_zhang) THEN + IF (conjugator == cg_hestenes_stiefel .OR. & + conjugator == cg_dai_yuan .OR. & + conjugator == cg_hager_zhang) THEN CPABORT("cannot return numer/denom") END IF END IF @@ -7381,7 +7381,7 @@ CONTAINS END DO ! i - nsize - IF (beta .LT. 0.0_dp) THEN + IF (beta < 0.0_dp) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, *) " Resetting conjugator because beta is negative: ", beta END IF @@ -7493,7 +7493,7 @@ CONTAINS END IF ! set optimizer options - use_preconditioner = (optimizer%preconditioner .NE. xalmo_prec_zero) + use_preconditioner = (optimizer%preconditioner /= xalmo_prec_zero) outer_max_iter = optimizer%max_iter_outer_loop max_iter = optimizer%max_iter eps_error_target = optimizer%eps_error @@ -7656,8 +7656,8 @@ CONTAINS IF (use_preconditioner) THEN - IF (special_case .EQ. xalmo_case_block_diag .OR. & - special_case .EQ. xalmo_case_fully_deloc) THEN + IF (special_case == xalmo_case_block_diag .OR. & + special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, & m_prec(ispin), & @@ -7763,8 +7763,8 @@ CONTAINS ! check convergence and other exit criteria residue_norm = MAXVAL(residue_max_norm) - converged = (residue_norm .LT. eps_error_target) - IF (converged .OR. (iteration .GE. max_iter)) THEN + converged = (residue_norm < eps_error_target) + IF (converged .OR. (iteration >= max_iter)) THEN prepare_to_exit = .TRUE. END IF @@ -7782,8 +7782,8 @@ CONTAINS ! WRITE(unit_nr,*) "....applying preconditioner...." !ENDIF - IF (special_case .EQ. xalmo_case_block_diag .OR. & - special_case .EQ. xalmo_case_fully_deloc) THEN + IF (special_case == xalmo_case_block_diag .OR. & + special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, & m_prec(ispin), & @@ -7851,7 +7851,7 @@ CONTAINS END DO ! inner loop - IF (converged .OR. (outer_iteration .GE. outer_max_iter)) THEN + IF (converged .OR. (outer_iteration >= outer_max_iter)) THEN outer_prepare_to_exit = .TRUE. END IF @@ -8022,7 +8022,7 @@ CONTAINS nspins = SIZE(m_ks) - IF (nspins .EQ. 1) THEN + IF (nspins == 1) THEN spin_factor = 2.0_dp ELSE spin_factor = 1.0_dp @@ -8082,7 +8082,7 @@ CONTAINS END IF ! normalize_orbitals - IF (path_num .EQ. hessian_path_reuse) THEN + IF (path_num == hessian_path_reuse) THEN ! apply pre-computed F_vv and S_vv to X @@ -8210,7 +8210,7 @@ CONTAINS ! CALL dbcsr_add(m_x_out(ispin),m_tmp_no_2,& ! 1.0_dp,-1.0_dp) - ELSE IF (path_num .EQ. hessian_path_assemble) THEN + ELSE IF (path_num == hessian_path_assemble) THEN ! compute F_vv.X and S_vv.X directly ! this path will be advantageous if the number @@ -8356,7 +8356,7 @@ CONTAINS ! serial code only CALL dbcsr_get_info(matrix=matrix_S_ao, distribution=main_dist) CALL dbcsr_distribution_get(main_dist, numnodes=ncores) - IF (ncores .GT. 1) THEN + IF (ncores > 1) THEN CPABORT("serial code only") END IF @@ -8528,7 +8528,7 @@ CONTAINS lev2_hori_offset = 0 DO orb_i = 1, mo_block_sizes(col) - IF (orb_i .EQ. orb_j .AND. row .EQ. col) THEN + 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(:,:) @@ -8813,7 +8813,7 @@ CONTAINS ! Allocate the workspace and solve the eigenproblem ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', H_size, Hinv, H_size, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) THEN + IF (INFO /= 0) THEN WRITE (unit_nr, *) 'DSYEV ERROR MESSAGE: ', INFO CPABORT("DSYEV failed") END IF @@ -8845,7 +8845,7 @@ CONTAINS zero_neg_eiv = 0 DO jj = 1, H_size WRITE (unit_nr, "(I10,F20.10,F20.10)") jj, eigenvalues(jj), Step_vec(jj) - IF (eigenvalues(jj) .GT. eps_zero) THEN + IF (eigenvalues(jj) > eps_zero) THEN test(jj, :) = Hinv(:, jj)/eigenvalues(jj) ELSE test(jj, :) = Hinv(:, jj)*0.0_dp @@ -8884,12 +8884,12 @@ CONTAINS !!!! Hinv=H !!!! INFO=0 !!!! CALL dpotrf('L', H_size, Hinv, H_size, INFO ) -!!!! IF( INFO.NE.0 ) THEN +!!!! 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.NE.0 ) THEN +!!!! IF( INFO/=0 ) THEN !!!! WRITE(*,*) 'DPOTRI ERROR MESSAGE: ', INFO !!!! CPABORT("DPOTRI failed") !!!! END IF @@ -9135,8 +9135,8 @@ CONTAINS ! penalty amplitude adjusts the strength of volume conservation penalty_occ_vol = .FALSE. - !(almo_scf_env%penalty%occ_vol_method .NE. almo_occ_vol_penalty_none .AND. & - ! my_special_case .EQ. xalmo_case_fully_deloc) + !(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)) @@ -9265,7 +9265,7 @@ CONTAINS ! invert S domains if necessary ! Note: domains for alpha and beta electrons might be different ! that is why the inversion of the AO overlap is inside the spin loop - IF (my_special_case .EQ. xalmo_case_normal) THEN + IF (my_special_case == xalmo_case_normal) THEN CALL construct_domain_s_inv( & matrix_s=almo_scf_env%matrix_s(1), & @@ -9279,7 +9279,7 @@ CONTAINS END DO ! ispin ! invert metric for special case where metric is spin independent - IF (my_special_case .EQ. xalmo_case_block_diag) THEN + IF (my_special_case == xalmo_case_block_diag) THEN CALL dbcsr_create(m_s_inv, & template=almo_scf_env%matrix_s(1), & @@ -9289,7 +9289,7 @@ CONTAINS threshold=almo_scf_env%eps_filter, & filter_eps=almo_scf_env%eps_filter) - ELSE IF (my_special_case .EQ. xalmo_case_fully_deloc) THEN + ELSE IF (my_special_case == xalmo_case_fully_deloc) THEN ! invert S using cholesky CALL dbcsr_create(m_s_inv, & @@ -9343,7 +9343,7 @@ CONTAINS do_penalty=penalty_occ_vol, & special_case=my_special_case) loss_start = energy_start + penalty_start - IF (my_special_case .EQ. xalmo_case_block_diag) THEN + IF (my_special_case == xalmo_case_block_diag) THEN almo_scf_env%almo_scf_energy = energy_start END IF DO ispin = 1, nspins @@ -9425,11 +9425,11 @@ CONTAINS time=t2outer - t1outer) t1outer = m_walltime() - IF (grad_norm_ref .LE. optimizer%eps_error) THEN + IF (grad_norm_ref <= optimizer%eps_error) THEN scf_converged = .TRUE. border_reached = .FALSE. expected_reduction = 0.0_dp - IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration .EQ. 1)) & + IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) & EXIT adjust_r_loop ELSE scf_converged = .FALSE. @@ -9440,8 +9440,8 @@ CONTAINS CALL dbcsr_copy(m_model_r(ispin), grad(ispin)) CALL dbcsr_scale(m_model_r(ispin), -1.0_dp) - IF (my_special_case .EQ. xalmo_case_block_diag .OR. & - my_special_case .EQ. xalmo_case_fully_deloc) THEN + IF (my_special_case == xalmo_case_block_diag .OR. & + my_special_case == xalmo_case_fully_deloc) THEN IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Multiply Sinv.r" CALL dbcsr_multiply("N", "N", 1.0_dp, & @@ -9450,7 +9450,7 @@ CONTAINS 0.0_dp, m_model_rt(ispin), & filter_eps=almo_scf_env%eps_filter) - ELSE IF (my_special_case .EQ. xalmo_case_normal) THEN + ELSE IF (my_special_case == xalmo_case_normal) THEN IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Multiply Sinv_xx.r" CALL apply_domain_operators( & @@ -9536,8 +9536,8 @@ CONTAINS DO ispin = 1, nspins ! Get B.d - IF (my_special_case .EQ. xalmo_case_block_diag .OR. & - my_special_case .EQ. xalmo_case_fully_deloc) THEN + IF (my_special_case == xalmo_case_block_diag .OR. & + my_special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, & m_model_hessian(ispin), & @@ -9567,7 +9567,7 @@ CONTAINS IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Curvature: ", y_scalar ! step to the border - IF (y_scalar .LT. 0.0_dp) THEN + IF (y_scalar < 0.0_dp) THEN CALL step_size_to_border( & step_size_out=step_size, & @@ -9639,7 +9639,7 @@ CONTAINS IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step norm: ", step_norm ! Do not step beyond the trust radius - IF (step_norm .GT. radius_current) THEN + IF (step_norm > radius_current) THEN IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Norm is too large" CALL step_size_to_border( & @@ -9702,7 +9702,7 @@ CONTAINS END IF - IF (optimizer%trustr_algorithm .EQ. trustr_cauchy) THEN + IF (optimizer%trustr_algorithm == trustr_cauchy) THEN ! trustr_steihaug, trustr_cauchy, trustr_dogleg border_reached = .FALSE. @@ -9733,14 +9733,14 @@ CONTAINS EXIT fixed_r_loop ! the inner loop - ELSE IF (optimizer%trustr_algorithm .EQ. trustr_dogleg) THEN + ELSE IF (optimizer%trustr_algorithm == trustr_dogleg) THEN ! invert or pseudo-invert B SELECT CASE (prec_type) CASE (xalmo_prec_domain) IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Pseudo-invert model Hessian" - IF (special_case .EQ. xalmo_case_block_diag) THEN ! non-overlapping diagonal blocks + IF (special_case == xalmo_case_block_diag) THEN ! non-overlapping diagonal blocks DO ispin = 1, nspins CALL pseudo_invert_diagonal_blk( & @@ -9750,7 +9750,7 @@ CONTAINS ) END DO - ELSE IF (special_case .EQ. xalmo_case_fully_deloc) THEN ! the entire system is a block + ELSE IF (special_case == xalmo_case_fully_deloc) THEN ! the entire system is a block ! invert using cholesky decomposition DO ispin = 1, nspins @@ -9826,8 +9826,8 @@ CONTAINS DO ispin = 1, nspins ! Get B.d - IF (my_special_case .EQ. xalmo_case_block_diag .OR. & - my_special_case .EQ. xalmo_case_fully_deloc) THEN + IF (my_special_case == xalmo_case_block_diag .OR. & + my_special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, & m_model_hessian_inv(ispin), & @@ -9862,7 +9862,7 @@ CONTAINS IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...pB norm: ", step_norm ! Do not step beyond the trust radius - IF (step_norm .LE. radius_current) THEN + IF (step_norm <= radius_current) THEN IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Full dogleg" @@ -9897,7 +9897,7 @@ CONTAINS eps_filter_in=almo_scf_env%eps_filter & ) IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step size to border: ", step_size - IF (step_size .GT. 1.0_dp .OR. step_size .LT. 0.0_dp) THEN + IF (step_size > 1.0_dp .OR. step_size < 0.0_dp) THEN IF (unit_nr > 0) & WRITE (unit_nr, *) "Step size (", step_size, ") must lie inside (0,1)" CPABORT("Wrong dog leg step. We should never end up here.") @@ -9973,7 +9973,7 @@ CONTAINS ! Check norm reduction grad_norm_ratio = model_grad_norm/grad_norm_ref - IF (grad_norm_ratio .LT. optimizer%model_grad_norm_ratio) THEN + IF (grad_norm_ratio < optimizer%model_grad_norm_ratio) THEN border_reached = .FALSE. inner_loop_success = .TRUE. @@ -10013,8 +10013,8 @@ CONTAINS DO ispin = 1, nspins - IF (my_special_case .EQ. xalmo_case_block_diag .OR. & - my_special_case .EQ. xalmo_case_fully_deloc) THEN + IF (my_special_case == xalmo_case_block_diag .OR. & + my_special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, & m_s_inv, & @@ -10022,7 +10022,7 @@ CONTAINS 0.0_dp, m_model_rt(ispin), & filter_eps=almo_scf_env%eps_filter) - ELSE IF (my_special_case .EQ. xalmo_case_normal) THEN + ELSE IF (my_special_case == xalmo_case_normal) THEN CALL apply_domain_operators( & matrix_in=m_model_r(ispin), & @@ -10125,12 +10125,12 @@ CONTAINS energy_start = energy_trial penalty_start = penalty_trial same_position = .FALSE. - IF (my_special_case .EQ. xalmo_case_block_diag) THEN + IF (my_special_case == xalmo_case_block_diag) THEN almo_scf_env%almo_scf_energy = energy_trial END IF ELSE same_position = .TRUE. - IF (my_special_case .EQ. xalmo_case_block_diag) THEN + IF (my_special_case == xalmo_case_block_diag) THEN almo_scf_env%almo_scf_energy = energy_start END IF END IF ! finalize step @@ -10187,8 +10187,8 @@ CONTAINS CALL release_submatrices(domain_model_hessian_inv(:, ispin)) END DO ! ispin - IF (my_special_case .EQ. xalmo_case_block_diag .OR. & - my_special_case .EQ. xalmo_case_fully_deloc) THEN + IF (my_special_case == xalmo_case_block_diag .OR. & + my_special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_release(m_s_inv) END IF @@ -10392,7 +10392,7 @@ CONTAINS IF (perturbation_only) THEN ! calculate objective function Tr(F_0 R) - IF (ispin .EQ. 1) energy_out = 0.0_dp + IF (ispin == 1) energy_out = 0.0_dp CALL dbcsr_dot(m_t_out(ispin), m_FTsiginv_out(ispin), energy_ispin) energy_out = energy_out + energy_ispin*spin_factor END IF @@ -10500,9 +10500,9 @@ CONTAINS ! solve the quadratic equation discriminant = coef(2)*coef(2) - 4.0_dp*coef(1)*coef(3) - IF (discriminant .GT. TINY(discriminant)) THEN + IF (discriminant > TINY(discriminant)) THEN nsolutions = 2 - ELSE IF (discriminant .LT. 0.0_dp) THEN + ELSE IF (discriminant < 0.0_dp) THEN nsolutions = 0 CPABORT("Step to border: no solutions") ELSE @@ -10513,7 +10513,7 @@ CONTAINS nsolutions_found = 0 DO isol = 1, nsolutions solution = (-coef(2) + discrim_sign*SQRT(discriminant))/(2.0_dp*coef(1)) - IF (solution .GT. 0.0_dp) THEN + IF (solution > 0.0_dp) THEN nsolutions_found = nsolutions_found + 1 step_size_out = solution END IF @@ -10651,8 +10651,8 @@ CONTAINS my_reduction = my_reduction + temp_real ! Get Hess.step - IF (special_case .EQ. xalmo_case_block_diag .OR. & - special_case .EQ. xalmo_case_fully_deloc) THEN + IF (special_case == xalmo_case_block_diag .OR. & + special_case == xalmo_case_fully_deloc) THEN CALL dbcsr_multiply("N", "N", 1.0_dp, & hess_in(ispin), & diff --git a/src/almo_scf_qs.F b/src/almo_scf_qs.F index 4f641342db..115178590b 100644 --- a/src/almo_scf_qs.F +++ b/src/almo_scf_qs.F @@ -299,7 +299,7 @@ CONTAINS !QQQ iblock_col = col !QQQ CALL dbcsr_get_stored_coordinates(matrix_new, iblock_row, iblock_col, tr, hold) - !QQQ IF(hold.EQ.mynode) THEN + !QQQ IF(hold==mynode) THEN !QQQ !QQQ ! RZK-warning replace with a function which says if this !QQQ ! distribution block is active or not @@ -353,7 +353,7 @@ CONTAINS iblock_col = row CALL dbcsr_get_stored_coordinates(matrix_new, iblock_row, iblock_col, hold) - IF (hold .EQ. mynode) THEN + IF (hold == mynode) THEN active = .TRUE. @@ -910,7 +910,7 @@ CONTAINS matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_get_info(almo_scf_env%matrix_s(1), & matrix_type=sym) - IF (sym .EQ. dbcsr_type_no_symmetry) THEN + IF (sym == dbcsr_type_no_symmetry) THEN CALL dbcsr_copy(matrix_s_sym, almo_scf_env%matrix_s(1)) ELSE CALL dbcsr_desymmetrize(almo_scf_env%matrix_s(1), & @@ -1001,7 +1001,7 @@ CONTAINS ! add to the list current_number_neighbors(idomain2) = current_number_neighbors(idomain2) + 1 ! add j,i with i,j - IF (idomain2 .NE. jdomain2) THEN + IF (idomain2 /= jdomain2) THEN current_number_neighbors(jdomain2) = current_number_neighbors(jdomain2) + 1 END IF END DO @@ -1020,7 +1020,7 @@ CONTAINS jdomain2 = almo_scf_env%domain_index_of_atom(jatom2) already_listed = .FALSE. DO ineighbor = 1, current_number_neighbors(idomain2) - IF (domain_neighbor_list_excessive(idomain2, ineighbor) .EQ. jdomain2) THEN + IF (domain_neighbor_list_excessive(idomain2, ineighbor) == jdomain2) THEN already_listed = .TRUE. EXIT END IF @@ -1030,7 +1030,7 @@ CONTAINS current_number_neighbors(idomain2) = current_number_neighbors(idomain2) + 1 domain_neighbor_list_excessive(idomain2, current_number_neighbors(idomain2)) = jdomain2 ! add j,i with i,j - IF (idomain2 .NE. jdomain2) THEN + IF (idomain2 /= jdomain2) THEN current_number_neighbors(jdomain2) = current_number_neighbors(jdomain2) + 1 domain_neighbor_list_excessive(jdomain2, current_number_neighbors(jdomain2)) = idomain2 END IF @@ -1064,7 +1064,7 @@ CONTAINS CALL dbcsr_get_stored_coordinates(almo_scf_env%quench_t(ispin), & iblock_row, iblock_col, hold) - IF (hold .EQ. mynode) THEN + IF (hold == mynode) THEN ! Translate indices of distribution blocks to indices of domain blocks ! Rows are AOs @@ -1120,7 +1120,7 @@ CONTAINS CALL dbcsr_put_block(almo_scf_env%quench_t(ispin), iblock_row, iblock_col, new_block) DEALLOCATE (new_block) - IF (domain_map_local_entries .GE. max_domain_neighbors*almo_scf_env%ndomains) THEN + IF (domain_map_local_entries >= max_domain_neighbors*almo_scf_env%ndomains) THEN CPABORT("weird... max_domain_neighbors is exceeded") END IF almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries + 1, 1) = iblock_row @@ -1185,25 +1185,25 @@ CONTAINS s0 = -LOG10(ABS(almo_scf_env%quencher_s0)) s1 = -LOG10(ABS(almo_scf_env%quencher_s1)) - IF (overlap .EQ. 0.0_dp) THEN + IF (overlap == 0.0_dp) THEN overlap = -LOG10(ABS(almo_scf_env%eps_filter)) + 100.0_dp ELSE overlap = -LOG10(overlap) END IF - IF (s0 .LT. 0.0_dp) THEN + IF (s0 < 0.0_dp) THEN CPABORT("S0 is less than zero") END IF - IF (s1 .LE. 0.0_dp) THEN + IF (s1 <= 0.0_dp) THEN CPABORT("S1 is less than or equal to zero") END IF - IF (s0 .GE. s1) THEN + IF (s0 >= s1) THEN CPABORT("S0 is greater than or equal to S1") END IF ! Fill in non-zero blocks if AOs are close to the electron center - IF (overlap .LT. s1) THEN + IF (overlap < s1) THEN ALLOCATE (new_block(row_blk_size(iblock_row), col_blk_size(iblock_col))) - IF (overlap .LE. s0) THEN + IF (overlap <= s0) THEN new_block(:, :) = 1.0_dp !WRITE(*,'(A15,2I7,3F8.3,E11.3)') "INTRA-BLOCKS: ",& ! iblock_col, iblock_row, s0, s1, overlap, new_block(1,1) @@ -1213,8 +1213,8 @@ CONTAINS ! iblock_col, iblock_row, s0, s1, overlap, new_block(1,1) END IF - IF (ABS(new_block(1, 1)) .GT. ABS(almo_scf_env%eps_filter)) THEN - IF (domain_map_local_entries .GE. max_domain_neighbors*almo_scf_env%ndomains) THEN + IF (ABS(new_block(1, 1)) > ABS(almo_scf_env%eps_filter)) THEN + IF (domain_map_local_entries >= max_domain_neighbors*almo_scf_env%ndomains) THEN CPABORT("weird... max_domain_neighbors is exceeded") END IF almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries + 1, 1) = iblock_row @@ -1252,14 +1252,14 @@ CONTAINS DO jatom = first_atom_of_molecule(domain_col), last_atom_of_molecule(domain_col) rab(:) = pbc(particle_set(iatom)%r(:), particle_set(jatom)%r(:), cell) trial_distance_squared = rab(1)*rab(1) + rab(2)*rab(2) + rab(3)*rab(3) - IF (trial_distance_squared .LT. distance_squared) THEN + IF (trial_distance_squared < distance_squared) THEN distance_squared = trial_distance_squared contact_atom_1 = iatom contact_atom_2 = jatom END IF END DO ! jatom END DO ! iatom - CPASSERT(contact_atom_1 .GT. 0) + CPASSERT(contact_atom_1 > 0) distance = SQRT(distance_squared) END IF @@ -1320,20 +1320,20 @@ CONTAINS r1 = almo_scf_env%quencher_r1_factor*(contact1_radius + contact2_radius) !+almo_scf_env%quencher_r1_shift - IF (r0 .LT. 0.0_dp) THEN + IF (r0 < 0.0_dp) THEN CPABORT("R0 is less than zero") END IF - IF (r1 .LE. 0.0_dp) THEN + IF (r1 <= 0.0_dp) THEN CPABORT("R1 is less than or equal to zero") END IF - IF (r0 .GT. r1) THEN + IF (r0 > r1) THEN CPABORT("R0 is greater than or equal to R1") END IF ! Fill in non-zero blocks if AOs are close to the electron center - IF (distance .LT. r1) THEN + IF (distance < r1) THEN ALLOCATE (new_block(row_blk_size(iblock_row), col_blk_size(iblock_col))) - IF (distance .LE. r0) THEN + IF (distance <= r0) THEN new_block(:, :) = 1.0_dp !WRITE(*,'(A15,2I7,5F8.3,E11.3)') "INTRA-BLOCKS: ",& ! iblock_col, iblock_row, contact1_radius,& @@ -1347,8 +1347,8 @@ CONTAINS ! contact2_radius, r0, r1, distance, new_block(1,1) END IF - IF (ABS(new_block(1, 1)) .GT. ABS(almo_scf_env%eps_filter)) THEN - IF (domain_map_local_entries .GE. max_domain_neighbors*almo_scf_env%ndomains) THEN + IF (ABS(new_block(1, 1)) > ABS(almo_scf_env%eps_filter)) THEN + IF (domain_map_local_entries >= max_domain_neighbors*almo_scf_env%ndomains) THEN CPABORT("weird... max_domain_neighbors is exceeded") END IF almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries + 1, 1) = iblock_row @@ -1380,7 +1380,7 @@ CONTAINS ! check that both domain_map and quench_t have the same number of entries nblks = dbcsr_get_num_blocks(almo_scf_env%quench_t(ispin)) - IF (nblks .NE. domain_map_local_entries) THEN + IF (nblks /= domain_map_local_entries) THEN CPABORT("number of blocks is wrong") END IF @@ -1434,7 +1434,7 @@ CONTAINS ! get the neighbor ineig = domain_map_global(2*(ientry - 1) + 1) ! check boundaries - IF (domain_grid(grid1, 0) .GT. max_neig) THEN + IF (domain_grid(grid1, 0) > max_neig) THEN ! this neighbor will overstep the boundaries ! stop the trial and increase the max number of neighbors DEALLOCATE (domain_grid) @@ -1446,14 +1446,14 @@ CONTAINS delayed_increment = .FALSE. DO igrid = 1, domain_grid(grid1, 0) ! compare the current neighbor with that already in the 'book' - IF (ineig .LT. domain_grid(grid1, igrid)) THEN + IF (ineig < domain_grid(grid1, igrid)) THEN ! if this one is smaller then insert it here and pick up the one ! from the book to continue inserting neig_temp = ineig ineig = domain_grid(grid1, igrid) domain_grid(grid1, igrid) = neig_temp ELSE - IF (domain_grid(grid1, igrid) .EQ. 0) THEN + IF (domain_grid(grid1, igrid) == 0) THEN ! got the empty slot now - insert the record domain_grid(grid1, igrid) = ineig ! increase the record counter but do it outside the loop @@ -1484,7 +1484,7 @@ CONTAINS DEALLOCATE (domain_grid) !ENDDO ! ispin - IF (almo_scf_env%nspins .EQ. 2) THEN + IF (almo_scf_env%nspins == 2) THEN CALL dbcsr_copy(almo_scf_env%quench_t(2), & almo_scf_env%quench_t(1)) almo_scf_env%domain_map(2)%pairs(:, :) = & diff --git a/src/almo_scf_types.F b/src/almo_scf_types.F index 5183be4ad1..6cd5d926b0 100644 --- a/src/almo_scf_types.F +++ b/src/almo_scf_types.F @@ -440,7 +440,7 @@ CONTAINS CHARACTER(33) :: conj_string, prec_string, type_string - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN SELECT CASE (optimizer%optimizer_type) CASE (optimizer_diis) @@ -455,14 +455,14 @@ CONTAINS WRITE (unit_nr, '(T4,A,T48,I33)') "maximum iterations:", optimizer%max_iter WRITE (unit_nr, '(T4,A,T48,E33.3)') "target error:", optimizer%eps_error - IF (optimizer%optimizer_type .EQ. optimizer_diis) THEN + IF (optimizer%optimizer_type == optimizer_diis) THEN WRITE (unit_nr, '(T4,A,T48,I33)') "maximum DIIS history:", optimizer%ndiis END IF - IF (optimizer%optimizer_type .EQ. optimizer_trustr .OR. & - optimizer%optimizer_type .EQ. optimizer_pcg) THEN + IF (optimizer%optimizer_type == optimizer_trustr .OR. & + optimizer%optimizer_type == optimizer_pcg) THEN WRITE (unit_nr, '(T4,A,T48,I33)') "maximum outer loop iterations:", & optimizer%max_iter_outer_loop @@ -499,20 +499,20 @@ CONTAINS END IF - IF (optimizer%optimizer_type .EQ. optimizer_pcg) THEN + IF (optimizer%optimizer_type == optimizer_pcg) THEN WRITE (unit_nr, '(T4,A,T48,E33.3)') "line search step size guess:", & optimizer%lin_search_step_size_guess WRITE (unit_nr, '(T4,A,T48,E33.3)') "line search target error:", & optimizer%lin_search_eps_error - IF (optimizer%neglect_threshold .GT. 0.0_dp) THEN + IF (optimizer%neglect_threshold > 0.0_dp) THEN WRITE (unit_nr, '(T4,A,T48,E33.3)') "low-curvature threshold:", & optimizer%neglect_threshold END IF END IF - IF (optimizer%optimizer_type .EQ. optimizer_trustr) THEN + IF (optimizer%optimizer_type == optimizer_trustr) THEN SELECT CASE (optimizer%trustr_algorithm) CASE (trustr_steihaug) @@ -560,7 +560,7 @@ 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 .GT. 0) & + IF (almo_scf_env%almo_history%istore > 0) & CALL dbcsr_release(almo_scf_env%almo_history%matrix_t(ispin)) END DO DEALLOCATE (almo_scf_env%almo_history%matrix_p_up_down) @@ -571,7 +571,7 @@ 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 .GT. 0) & + IF (almo_scf_env%xalmo_history%istore > 0) & CALL dbcsr_release(almo_scf_env%xalmo_history%matrix_t(ispin)) END DO DEALLOCATE (almo_scf_env%xalmo_history%matrix_p_up_down) diff --git a/src/aobasis/ai_elec_field.F b/src/aobasis/ai_elec_field.F index f577cabcec..6b6cbd67ea 100644 --- a/src/aobasis/ai_elec_field.F +++ b/src/aobasis/ai_elec_field.F @@ -215,84 +215,84 @@ CONTAINS dum = 4.0_dp*(za**2*rr(0, coap2x, cob) + zb**2*rr(0, coa, cobp2x) & & + 2.0_dp*za*zb*rr(0, coap1x, cobp1x)) & - 2.0_dp*rr(0, coa, cob)*(za*REAL(2*ax + 1, dp) + zb*REAL(2*bx + 1, dp)) - IF (ax .GT. 1) dum = dum + REAL(ax*(ax - 1), dp)*rr(0, coam2x, cob) - IF (bx .GT. 1) dum = dum + REAL(bx*(bx - 1), dp)*rr(0, coa, cobm2x) - IF (ax .GT. 0) dum = dum - 4.0_dp*zb*REAL(ax, dp)*rr(0, coam1x, cobp1x) - IF (bx .GT. 0) dum = dum - 4.0_dp*za*REAL(bx, dp)*rr(0, coap1x, cobm1x) - IF (ax .GT. 0 .AND. bx .GT. 0) dum = dum + 2.0_dp*REAL(ax*bx, dp)*rr(0, coam1x, cobm1x) + IF (ax > 1) dum = dum + REAL(ax*(ax - 1), dp)*rr(0, coam2x, cob) + IF (bx > 1) dum = dum + REAL(bx*(bx - 1), dp)*rr(0, coa, cobm2x) + IF (ax > 0) dum = dum - 4.0_dp*zb*REAL(ax, dp)*rr(0, coam1x, cobp1x) + IF (bx > 0) dum = dum - 4.0_dp*za*REAL(bx, dp)*rr(0, coap1x, cobm1x) + IF (ax > 0 .AND. bx > 0) dum = dum + 2.0_dp*REAL(ax*bx, dp)*rr(0, coam1x, cobm1x) dumxx = f0*dum ! ! (a|yy|b) dum = 4.0_dp*(za**2*rr(0, coap2y, cob) + zb**2*rr(0, coa, cobp2y) & & + 2.0_dp*za*zb*rr(0, coap1y, cobp1y)) & - 2.0_dp*rr(0, coa, cob)*(za*REAL(2*ay + 1, dp) + zb*REAL(2*by + 1, dp)) - IF (ay .GT. 1) dum = dum + REAL(ay*(ay - 1), dp)*rr(0, coam2y, cob) - IF (by .GT. 1) dum = dum + REAL(by*(by - 1), dp)*rr(0, coa, cobm2y) - IF (ay .GT. 0) dum = dum - 4.0_dp*zb*REAL(ay, dp)*rr(0, coam1y, cobp1y) - IF (by .GT. 0) dum = dum - 4.0_dp*za*REAL(by, dp)*rr(0, coap1y, cobm1y) - IF (ay .GT. 0 .AND. by .GT. 0) dum = dum + 2.0_dp*REAL(ay*by, dp)*rr(0, coam1y, cobm1y) + IF (ay > 1) dum = dum + REAL(ay*(ay - 1), dp)*rr(0, coam2y, cob) + IF (by > 1) dum = dum + REAL(by*(by - 1), dp)*rr(0, coa, cobm2y) + IF (ay > 0) dum = dum - 4.0_dp*zb*REAL(ay, dp)*rr(0, coam1y, cobp1y) + IF (by > 0) dum = dum - 4.0_dp*za*REAL(by, dp)*rr(0, coap1y, cobm1y) + IF (ay > 0 .AND. by > 0) dum = dum + 2.0_dp*REAL(ay*by, dp)*rr(0, coam1y, cobm1y) dumyy = f0*dum ! ! (a|zz|b) dum = 4.0_dp*(za**2*rr(0, coap2z, cob) + zb**2*rr(0, coa, cobp2z) & & + 2.0_dp*za*zb*rr(0, coap1z, cobp1z)) & - 2.0_dp*rr(0, coa, cob)*(za*REAL(2*az + 1, dp) + zb*REAL(2*bz + 1, dp)) - IF (az .GT. 1) dum = dum + REAL(az*(az - 1), dp)*rr(0, coam2z, cob) - IF (bz .GT. 1) dum = dum + REAL(bz*(bz - 1), dp)*rr(0, coa, cobm2z) - IF (az .GT. 0) dum = dum - 4.0_dp*zb*REAL(az, dp)*rr(0, coam1z, cobp1z) - IF (bz .GT. 0) dum = dum - 4.0_dp*za*REAL(bz, dp)*rr(0, coap1z, cobm1z) - IF (az .GT. 0 .AND. bz .GT. 0) dum = dum + 2.0_dp*REAL(az*bz, dp)*rr(0, coam1z, cobm1z) + IF (az > 1) dum = dum + REAL(az*(az - 1), dp)*rr(0, coam2z, cob) + IF (bz > 1) dum = dum + REAL(bz*(bz - 1), dp)*rr(0, coa, cobm2z) + IF (az > 0) dum = dum - 4.0_dp*zb*REAL(az, dp)*rr(0, coam1z, cobp1z) + IF (bz > 0) dum = dum - 4.0_dp*za*REAL(bz, dp)*rr(0, coap1z, cobm1z) + IF (az > 0 .AND. bz > 0) dum = dum + 2.0_dp*REAL(az*bz, dp)*rr(0, coam1z, cobm1z) dumzz = f0*dum ! ! (a|xy|b) dum = 4.0_dp*(za**2*rr(0, coapxy, cob) + zb**2*rr(0, coa, cobpxy) & & + za*zb*(rr(0, coap1x, cobp1y) + rr(0, coap1y, cobp1x))) - IF (ax .GT. 0) dum = dum - 2.0_dp*REAL(ax, dp)* & + IF (ax > 0) dum = dum - 2.0_dp*REAL(ax, dp)* & & (za*rr(0, coamxpy, cob) + zb*rr(0, coam1x, cobp1y)) - IF (ay .GT. 0) dum = dum - 2.0_dp*REAL(ay, dp)* & + IF (ay > 0) dum = dum - 2.0_dp*REAL(ay, dp)* & & (za*rr(0, coamypx, cob) + zb*rr(0, coam1y, cobp1x)) - IF (ax .GT. 0 .AND. ay .GT. 0) dum = dum + REAL(ax*ay, dp)*rr(0, coamxy, cob) - IF (bx .GT. 0) dum = dum - 2.0_dp*REAL(bx, dp)* & + IF (ax > 0 .AND. ay > 0) dum = dum + REAL(ax*ay, dp)*rr(0, coamxy, cob) + IF (bx > 0) dum = dum - 2.0_dp*REAL(bx, dp)* & & (zb*rr(0, coa, cobmxpy) + za*rr(0, coap1y, cobm1x)) - IF (by .GT. 0) dum = dum - 2.0_dp*REAL(by, dp)* & + IF (by > 0) dum = dum - 2.0_dp*REAL(by, dp)* & & (zb*rr(0, coa, cobmypx) + za*rr(0, coap1x, cobm1y)) - IF (bx .GT. 0 .AND. by .GT. 0) dum = dum + REAL(bx*by, dp)*rr(0, coa, cobmxy) - IF (ax .GT. 0 .AND. by .GT. 0) dum = dum + REAL(ax*by, dp)*rr(0, coam1x, cobm1y) - IF (ay .GT. 0 .AND. bx .GT. 0) dum = dum + REAL(ay*bx, dp)*rr(0, coam1y, cobm1x) + IF (bx > 0 .AND. by > 0) dum = dum + REAL(bx*by, dp)*rr(0, coa, cobmxy) + IF (ax > 0 .AND. by > 0) dum = dum + REAL(ax*by, dp)*rr(0, coam1x, cobm1y) + IF (ay > 0 .AND. bx > 0) dum = dum + REAL(ay*bx, dp)*rr(0, coam1y, cobm1x) dumxy = f0*dum ! ! (a|xz|b) dum = 4.0_dp*(za**2*rr(0, coapxz, cob) + zb**2*rr(0, coa, cobpxz) & & + za*zb*(rr(0, coap1x, cobp1z) + rr(0, coap1z, cobp1x))) - IF (ax .GT. 0) dum = dum - 2.0_dp*REAL(ax, dp)* & + IF (ax > 0) dum = dum - 2.0_dp*REAL(ax, dp)* & & (za*rr(0, coamxpz, cob) + zb*rr(0, coam1x, cobp1z)) - IF (az .GT. 0) dum = dum - 2.0_dp*REAL(az, dp)* & + IF (az > 0) dum = dum - 2.0_dp*REAL(az, dp)* & & (za*rr(0, coamzpx, cob) + zb*rr(0, coam1z, cobp1x)) - IF (ax .GT. 0 .AND. az .GT. 0) dum = dum + REAL(ax*az, dp)*rr(0, coamxz, cob) - IF (bx .GT. 0) dum = dum - 2.0_dp*REAL(bx, dp)* & + IF (ax > 0 .AND. az > 0) dum = dum + REAL(ax*az, dp)*rr(0, coamxz, cob) + IF (bx > 0) dum = dum - 2.0_dp*REAL(bx, dp)* & & (zb*rr(0, coa, cobmxpz) + za*rr(0, coap1z, cobm1x)) - IF (bz .GT. 0) dum = dum - 2.0_dp*REAL(bz, dp)* & + IF (bz > 0) dum = dum - 2.0_dp*REAL(bz, dp)* & & (zb*rr(0, coa, cobmzpx) + za*rr(0, coap1x, cobm1z)) - IF (bx .GT. 0 .AND. bz .GT. 0) dum = dum + REAL(bx*bz, dp)*rr(0, coa, cobmxz) - IF (ax .GT. 0 .AND. bz .GT. 0) dum = dum + REAL(ax*bz, dp)*rr(0, coam1x, cobm1z) - IF (az .GT. 0 .AND. bx .GT. 0) dum = dum + REAL(az*bx, dp)*rr(0, coam1z, cobm1x) + IF (bx > 0 .AND. bz > 0) dum = dum + REAL(bx*bz, dp)*rr(0, coa, cobmxz) + IF (ax > 0 .AND. bz > 0) dum = dum + REAL(ax*bz, dp)*rr(0, coam1x, cobm1z) + IF (az > 0 .AND. bx > 0) dum = dum + REAL(az*bx, dp)*rr(0, coam1z, cobm1x) dumxz = f0*dum ! ! (a|yz|b) dum = 4.0_dp*(za**2*rr(0, coapyz, cob) + zb**2*rr(0, coa, cobpyz) & & + za*zb*(rr(0, coap1y, cobp1z) + rr(0, coap1z, cobp1y))) - IF (ay .GT. 0) dum = dum - 2.0_dp*REAL(ay, dp)* & + IF (ay > 0) dum = dum - 2.0_dp*REAL(ay, dp)* & & (za*rr(0, coamypz, cob) + zb*rr(0, coam1y, cobp1z)) - IF (az .GT. 0) dum = dum - 2.0_dp*REAL(az, dp)* & + IF (az > 0) dum = dum - 2.0_dp*REAL(az, dp)* & & (za*rr(0, coamzpy, cob) + zb*rr(0, coam1z, cobp1y)) - IF (ay .GT. 0 .AND. az .GT. 0) dum = dum + REAL(ay*az, dp)*rr(0, coamyz, cob) - IF (by .GT. 0) dum = dum - 2.0_dp*REAL(by, dp)* & + IF (ay > 0 .AND. az > 0) dum = dum + REAL(ay*az, dp)*rr(0, coamyz, cob) + IF (by > 0) dum = dum - 2.0_dp*REAL(by, dp)* & & (zb*rr(0, coa, cobmypz) + za*rr(0, coap1z, cobm1y)) - IF (bz .GT. 0) dum = dum - 2.0_dp*REAL(bz, dp)* & + IF (bz > 0) dum = dum - 2.0_dp*REAL(bz, dp)* & & (zb*rr(0, coa, cobmzpy) + za*rr(0, coap1y, cobm1z)) - IF (by .GT. 0 .AND. bz .GT. 0) dum = dum + REAL(by*bz, dp)*rr(0, coa, cobmyz) - IF (ay .GT. 0 .AND. bz .GT. 0) dum = dum + REAL(ay*bz, dp)*rr(0, coam1y, cobm1z) - IF (az .GT. 0 .AND. by .GT. 0) dum = dum + REAL(az*by, dp)*rr(0, coam1z, cobm1y) + IF (by > 0 .AND. bz > 0) dum = dum + REAL(by*bz, dp)*rr(0, coa, cobmyz) + IF (ay > 0 .AND. bz > 0) dum = dum + REAL(ay*bz, dp)*rr(0, coam1y, cobm1z) + IF (az > 0 .AND. by > 0) dum = dum + REAL(az*by, dp)*rr(0, coam1z, cobm1y) dumyz = f0*dum ! ! diff --git a/src/aobasis/ai_fermi_contact.F b/src/aobasis/ai_fermi_contact.F index 21c0e6e6a5..3182e8a35b 100644 --- a/src/aobasis/ai_fermi_contact.F +++ b/src/aobasis/ai_fermi_contact.F @@ -120,27 +120,27 @@ CONTAINS DO lb = lb_min, lb_max DO bx = 0, lb fbx = 1.0_dp - IF (bx .GT. 0) fbx = (rbc(1))**bx + IF (bx > 0) fbx = (rbc(1))**bx DO by = 0, lb - bx bz = lb - bx - by cob = coset(bx, by, bz) mb = nb + cob fby = 1.0_dp - IF (by .GT. 0) fby = (rbc(2))**by + IF (by > 0) fby = (rbc(2))**by fbz = 1.0_dp - IF (bz .GT. 0) fbz = (rbc(3))**bz + IF (bz > 0) fbz = (rbc(3))**bz DO la = la_min, la_max DO ax = 0, la fax = fbx - IF (ax .GT. 0) fax = fbx*(rac(1))**ax + IF (ax > 0) fax = fbx*(rac(1))**ax DO ay = 0, la - ax az = la - ax - ay coa = coset(ax, ay, az) ma = na + coa fay = fby - IF (ay .GT. 0) fay = fby*(rac(2))**ay + IF (ay > 0) fay = fby*(rac(2))**ay faz = fbz - IF (az .GT. 0) faz = fbz*(rac(3))**az + IF (az > 0) faz = fbz*(rac(3))**az fcab(ma, mb) = f0*fax*fay*faz diff --git a/src/aobasis/ai_operators_r12.F b/src/aobasis/ai_operators_r12.F index be42292048..4a2c0aeb77 100644 --- a/src/aobasis/ai_operators_r12.F +++ b/src/aobasis/ai_operators_r12.F @@ -695,7 +695,7 @@ CONTAINS f0 = 2.0_dp*SQRT(pi**5*zetw)*zetp*zetq !check that the operator has been init from file - CPASSERT(get_lmax_init() .GE. nmax) + CPASSERT(get_lmax_init() >= nmax) CALL t_c_g0_n(f, use_gamma, r, t, nmax) IF (use_gamma) CALL fgamma(nmax, t, f) diff --git a/src/aobasis/ai_os_rr.F b/src/aobasis/ai_os_rr.F index 0139c9e0b3..e7ef5913bb 100644 --- a/src/aobasis/ai_os_rr.F +++ b/src/aobasis/ai_os_rr.F @@ -54,7 +54,7 @@ CONTAINS ! ! recursion along la for lb=0 ! - IF (la_max .GT. 0) THEN + IF (la_max > 0) THEN rr(1, 0, 1) = rap(1) rr(1, 0, 2) = rap(2) rr(1, 0, 3) = rap(3) @@ -70,7 +70,7 @@ CONTAINS ! ! recursion along lb for all la ! - IF (lb_max .GT. 0) THEN + IF (lb_max > 0) THEN rr(0, 1, 1) = rbp(1) rr(0, 1, 2) = rbp(2) rr(0, 1, 3) = rbp(3) @@ -153,29 +153,29 @@ CONTAINS coa2x = coset(MAX(ax - 2, 0), ay, az) coa2y = coset(ax, MAX(ay - 2, 0), az) coa2z = coset(ax, ay, MAX(az - 2, 0)) - IF (az .GT. 0) THEN + IF (az > 0) THEN DO m = 0, mmax - la rr(m, coa, 1) = rap(3)*rr(m, coa1z, 1) - rcp(3)*rr(m + 1, coa1z, 1) END DO - IF (az .GT. 1) THEN + IF (az > 1) THEN DO m = 0, mmax - la rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(az - 1, dp)*(rr(m, coa2z, 1) - rr(m + 1, coa2z, 1)) END DO END IF - ELSEIF (ay .GT. 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 - IF (ay .GT. 1) THEN + IF (ay > 1) THEN DO m = 0, mmax - la rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(ay - 1, dp)*(rr(m, coa2y, 1) - rr(m + 1, coa2y, 1)) END DO END IF - ELSEIF (ax .GT. 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 - IF (ax .GT. 1) THEN + IF (ax > 1) THEN DO m = 0, mmax - la rr(m, coa, 1) = rr(m, coa, 1) + g*REAL(ax - 1, dp)*(rr(m, coa2x, 1) - rr(m + 1, coa2x, 1)) END DO @@ -211,44 +211,44 @@ CONTAINS cob2x = coset(MAX(bx - 2, 0), by, bz) cob2y = coset(bx, MAX(by - 2, 0), bz) cob2z = coset(bx, by, MAX(bz - 2, 0)) - IF (bz .GT. 0) THEN + IF (bz > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rbp(3)*rr(m, coa, cob1z) - rcp(3)*rr(m + 1, coa, cob1z) END DO - IF (bz .GT. 1) THEN + IF (bz > 1) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(bz - 1, dp)*(rr(m, coa, cob2z) - rr(m + 1, coa, cob2z)) END DO END IF - IF (az .GT. 0) THEN + IF (az > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(az, dp)*(rr(m, coa1z, cob1z) - rr(m + 1, coa1z, cob1z)) END DO END IF - ELSEIF (by .GT. 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 - IF (by .GT. 1) THEN + IF (by > 1) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(by - 1, dp)*(rr(m, coa, cob2y) - rr(m + 1, coa, cob2y)) END DO END IF - IF (ay .GT. 0) THEN + IF (ay > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(ay, dp)*(rr(m, coa1y, cob1y) - rr(m + 1, coa1y, cob1y)) END DO END IF - ELSEIF (bx .GT. 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 - IF (bx .GT. 1) THEN + IF (bx > 1) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(bx - 1, dp)*(rr(m, coa, cob2x) - rr(m + 1, coa, cob2x)) END DO END IF - IF (ax .GT. 0) THEN + IF (ax > 0) THEN DO m = 0, mmax - la - lb rr(m, coa, cob) = rr(m, coa, cob) + g*REAL(ax, dp)*(rr(m, coa1x, cob1x) - rr(m + 1, coa1x, cob1x)) END DO diff --git a/src/aobasis/ai_spin_orbit.F b/src/aobasis/ai_spin_orbit.F index 7f992a353f..68d7cad5f7 100644 --- a/src/aobasis/ai_spin_orbit.F +++ b/src/aobasis/ai_spin_orbit.F @@ -173,14 +173,14 @@ CONTAINS ! -2*zeta*Ny(b)*(a+z||b-y)-2*zetb*Nz(a)*(a-z||b+y) ! +Nz(a)*Ny(b)*(a-z||b-y)) dum1 = 4.0_dp*zeta(ipgf)*zetb(jpgf)*rr(0, coap1y, cobp1z) - IF (bz .GT. 0) dum1 = dum1 - 2.0_dp*zeta(ipgf)*REAL(bz, dp)*rr(0, coap1y, cobm1z) - IF (ay .GT. 0) dum1 = dum1 - 2.0_dp*zetb(jpgf)*REAL(ay, dp)*rr(0, coam1y, cobp1z) - IF (ay .GT. 0 .AND. bz .GT. 0) dum1 = dum1 + REAL(ay, dp)*REAL(bz, dp)*rr(0, coam1y, cobm1z) + IF (bz > 0) dum1 = dum1 - 2.0_dp*zeta(ipgf)*REAL(bz, dp)*rr(0, coap1y, cobm1z) + IF (ay > 0) dum1 = dum1 - 2.0_dp*zetb(jpgf)*REAL(ay, dp)*rr(0, coam1y, cobp1z) + IF (ay > 0 .AND. bz > 0) dum1 = dum1 + REAL(ay, dp)*REAL(bz, dp)*rr(0, coam1y, cobm1z) ! dum2 = 4.0_dp*zeta(ipgf)*zetb(jpgf)*rr(0, coap1z, cobp1y) - IF (by .GT. 0) dum2 = dum2 - 2.0_dp*zeta(ipgf)*REAL(by, dp)*rr(0, coap1z, cobm1y) - IF (az .GT. 0) dum2 = dum2 - 2.0_dp*zetb(jpgf)*REAL(az, dp)*rr(0, coam1z, cobp1y) - IF (az .GT. 0 .AND. by .GT. 0) dum2 = dum2 + REAL(az, dp)*REAL(by, dp)*rr(0, coam1z, cobm1y) + IF (by > 0) dum2 = dum2 - 2.0_dp*zeta(ipgf)*REAL(by, dp)*rr(0, coap1z, cobm1y) + IF (az > 0) dum2 = dum2 - 2.0_dp*zetb(jpgf)*REAL(az, dp)*rr(0, coam1z, cobp1y) + IF (az > 0 .AND. by > 0) dum2 = dum2 + REAL(az, dp)*REAL(by, dp)*rr(0, coam1z, cobm1y) vab(ma, mb, 1) = f0*(dum1 - dum2) ! ! @@ -191,14 +191,14 @@ CONTAINS ! -2*zeta*Nz(b)*(a+x||b-z)-2*zetb*Nx(a)*(a-x||b+z) ! +Nx(a)*Nz(b)*(a-x||b-z)) dum1 = 4.0_dp*zeta(ipgf)*zetb(jpgf)*rr(0, coap1z, cobp1x) - IF (bx .GT. 0) dum1 = dum1 - 2.0_dp*zeta(ipgf)*REAL(bx, dp)*rr(0, coap1z, cobm1x) - IF (az .GT. 0) dum1 = dum1 - 2.0_dp*zetb(jpgf)*REAL(az, dp)*rr(0, coam1z, cobp1x) - IF (az .GT. 0 .AND. bx .GT. 0) dum1 = dum1 + REAL(az, dp)*REAL(bx, dp)*rr(0, coam1z, cobm1x) + IF (bx > 0) dum1 = dum1 - 2.0_dp*zeta(ipgf)*REAL(bx, dp)*rr(0, coap1z, cobm1x) + IF (az > 0) dum1 = dum1 - 2.0_dp*zetb(jpgf)*REAL(az, dp)*rr(0, coam1z, cobp1x) + IF (az > 0 .AND. bx > 0) dum1 = dum1 + REAL(az, dp)*REAL(bx, dp)*rr(0, coam1z, cobm1x) ! dum2 = 4.0_dp*zeta(ipgf)*zetb(jpgf)*rr(0, coap1x, cobp1z) - IF (bz .GT. 0) dum2 = dum2 - 2.0_dp*zeta(ipgf)*REAL(bz, dp)*rr(0, coap1x, cobm1z) - IF (ax .GT. 0) dum2 = dum2 - 2.0_dp*zetb(jpgf)*REAL(ax, dp)*rr(0, coam1x, cobp1z) - IF (ax .GT. 0 .AND. bz .GT. 0) dum2 = dum2 + REAL(ax, dp)*REAL(bz, dp)*rr(0, coam1x, cobm1z) + IF (bz > 0) dum2 = dum2 - 2.0_dp*zeta(ipgf)*REAL(bz, dp)*rr(0, coap1x, cobm1z) + IF (ax > 0) dum2 = dum2 - 2.0_dp*zetb(jpgf)*REAL(ax, dp)*rr(0, coam1x, cobp1z) + IF (ax > 0 .AND. bz > 0) dum2 = dum2 + REAL(ax, dp)*REAL(bz, dp)*rr(0, coam1x, cobm1z) vab(ma, mb, 2) = f0*(dum1 - dum2) ! ! @@ -209,14 +209,14 @@ CONTAINS ! -2*zeta*Nx(b)*(a+y||b-x)-2*zetb*Ny(a)*(a-y||b+x) ! +Ny(a)*Nx(b)*(a-y||b-x)) dum1 = 4.0_dp*zeta(ipgf)*zetb(jpgf)*rr(0, coap1x, cobp1y) - IF (by .GT. 0) dum1 = dum1 - 2.0_dp*zeta(ipgf)*REAL(by, dp)*rr(0, coap1x, cobm1y) - IF (ax .GT. 0) dum1 = dum1 - 2.0_dp*zetb(jpgf)*REAL(ax, dp)*rr(0, coam1x, cobp1y) - IF (ax .GT. 0 .AND. by .GT. 0) dum1 = dum1 + REAL(ax, dp)*REAL(by, dp)*rr(0, coam1x, cobm1y) + IF (by > 0) dum1 = dum1 - 2.0_dp*zeta(ipgf)*REAL(by, dp)*rr(0, coap1x, cobm1y) + IF (ax > 0) dum1 = dum1 - 2.0_dp*zetb(jpgf)*REAL(ax, dp)*rr(0, coam1x, cobp1y) + IF (ax > 0 .AND. by > 0) dum1 = dum1 + REAL(ax, dp)*REAL(by, dp)*rr(0, coam1x, cobm1y) ! dum2 = 4.0_dp*zeta(ipgf)*zetb(jpgf)*rr(0, coap1y, cobp1x) - IF (bx .GT. 0) dum2 = dum2 - 2.0_dp*zeta(ipgf)*REAL(bx, dp)*rr(0, coap1y, cobm1x) - IF (ay .GT. 0) dum2 = dum2 - 2.0_dp*zetb(jpgf)*REAL(ay, dp)*rr(0, coam1y, cobp1x) - IF (ay .GT. 0 .AND. bx .GT. 0) dum2 = dum2 + REAL(ay, dp)*REAL(bx, dp)*rr(0, coam1y, cobm1x) + IF (bx > 0) dum2 = dum2 - 2.0_dp*zeta(ipgf)*REAL(bx, dp)*rr(0, coap1y, cobm1x) + IF (ay > 0) dum2 = dum2 - 2.0_dp*zetb(jpgf)*REAL(ay, dp)*rr(0, coam1y, cobp1x) + IF (ay > 0 .AND. bx > 0) dum2 = dum2 + REAL(ay, dp)*REAL(bx, dp)*rr(0, coam1y, cobm1x) vab(ma, mb, 3) = f0*(dum1 - dum2) ! END DO diff --git a/src/aobasis/ao_util.F b/src/aobasis/ao_util.F index 53d89c21bd..5134746f69 100644 --- a/src/aobasis/ao_util.F +++ b/src/aobasis/ao_util.F @@ -107,17 +107,17 @@ CONTAINS REAL(KIND=dp) :: a, d, dr, eps, r, rd, t REAL(KIND=dp), DIMENSION(SIZE(contract)) :: g, s - IF (l .LT. 0) THEN + IF (l < 0) THEN CPABORT("The angular momentum quantum number is negative") END IF - IF (alpha .EQ. 0.0_dp) THEN + IF (alpha == 0.0_dp) THEN CPABORT("The Gaussian function exponent is zero") ELSE a = ABS(alpha) END IF - IF (threshold .NE. 0.0_dp) THEN + IF (threshold /= 0.0_dp) THEN t = ABS(threshold) ELSE CPABORT("The requested threshold is zero") @@ -125,24 +125,24 @@ CONTAINS radius = 0.0_dp IF (PRESENT(rlow)) radius = rlow - IF (prefactor .EQ. 0.0_dp) RETURN + IF (prefactor == 0.0_dp) RETURN ! MAX: facilitate early exit r = MAX(SQRT(0.5_dp*REAL(l, dp)/a), radius) d = ABS(prefactor); g(1) = d - IF (l .NE. 0) THEN + IF (l /= 0) THEN g(1) = g(1)*EXP(REAL(-a*r*r, KIND=prec_exp))*r**l END IF ! original approach may return radius=0 ! with g(r) != g(radius) !radius = r - IF (g(1) .LT. t) RETURN ! early exit + IF (g(1) < t) RETURN ! early exit radius = r*next + step DO i = 1, itermax g(1) = d*EXP(REAL(-a*radius*radius, KIND=prec_exp))*radius**l - IF (g(1) .LT. t) EXIT + IF (g(1) < t) EXIT r = radius; radius = r*next + step END DO @@ -160,11 +160,11 @@ CONTAINS DO i = i + 1, itermax rd = radius - r ! check if finished or no further progress - IF ((rd .LT. eps) .OR. (rd .EQ. dr)) RETURN + IF ((rd < eps) .OR. (rd == dr)) RETURN s = r + rd*contract ! interval contraction g = d*EXP(REAL(-a*s*s, KIND=prec_exp))*s**l DO j = 1, SIZE(contract) - IF (g(j) .LT. t) THEN + IF (g(j) < t) THEN radius = s(j) ! interval [r, sj) EXIT ELSE @@ -173,7 +173,7 @@ CONTAINS END DO dr = rd END DO - IF (i .GE. itermax) THEN + IF (i >= itermax) THEN CPABORT("Maximum number of iterations reached") END IF diff --git a/src/aobasis/aux_basis_set.F b/src/aobasis/aux_basis_set.F index 4b8e50dcf0..6c699622bc 100644 --- a/src/aobasis/aux_basis_set.F +++ b/src/aobasis/aux_basis_set.F @@ -117,7 +117,7 @@ CONTAINS zb = (2.0_dp*zet(j, iset))**(0.25_dp*(2*l + 3)) zetab = zet(i, iset) + zet(j, iset) so(i, j) = za*zb/zetab**(l + 1.5_dp) - IF (i .NE. j) so(j, i) = so(i, j) + IF (i /= j) so(j, i) = so(i, j) END DO END DO info = 0 diff --git a/src/aobasis/basis_set_types.F b/src/aobasis/basis_set_types.F index 02a67c6d88..39293faecb 100644 --- a/src/aobasis/basis_set_types.F +++ b/src/aobasis/basis_set_types.F @@ -844,7 +844,7 @@ CONTAINS n = SIZE(gto_basis_set%cphi, 1) gto_basis_set%sphi = 0.0_dp - IF (n .GT. 0) THEN + IF (n > 0) THEN lmax = -1 ! Ensure proper setup of orbtramat DO iset = 1, gto_basis_set%nset @@ -876,7 +876,7 @@ CONTAINS n = SIZE(gto_basis_set%scon, 1) gto_basis_set%scon = 0.0_dp - IF (n .GT. 0) THEN + IF (n > 0) THEN DO iset = 1, gto_basis_set%nset lmin = gto_basis_set%lmin(iset) lmax = gto_basis_set%lmax(iset) @@ -1207,7 +1207,7 @@ CONTAINS basis_set_file_name = cbasis(ibasis) tmp = basis_set_file_name CALL uppercase(tmp) - IF (INDEX(tmp, "MOLOPT") .NE. 0) CALL cite_reference(VandeVondele2007) + IF (INDEX(tmp, "MOLOPT") /= 0) CALL cite_reference(VandeVondele2007) END DO ! Search for the requested basis set in the basis set file @@ -1225,7 +1225,7 @@ CONTAINS tmp = basis_set_name CALL uppercase(tmp) - IF (INDEX(tmp, "MOLOPT") .NE. 0) CALL cite_reference(VandeVondele2007) + IF (INDEX(tmp, "MOLOPT") /= 0) CALL cite_reference(VandeVondele2007) nset = 0 maxshell = 0 @@ -1261,7 +1261,7 @@ CONTAINS CALL reallocate(gto_basis_set%m, 1, nsgf) CALL reallocate(gto_basis_set%norm_cgf, 1, ncgf) - IF (tmp .NE. "NONE") THEN + IF (tmp /= "NONE") THEN search_loop: DO CALL parser_search_string(parser, TRIM(bsname), .TRUE., found, line) @@ -1463,7 +1463,7 @@ CONTAINS END DO basis_loop - IF (tmp .NE. "NONE") THEN + IF (tmp /= "NONE") THEN IF (.NOT. basis_found) THEN basis_set_file_name = "" DO ibasis = 1, nbasis @@ -2259,7 +2259,7 @@ CONTAINS tmp = basis_set_name CALL uppercase(tmp) - IF (tmp .NE. "NONE") THEN + IF (tmp /= "NONE") THEN search_loop: DO CALL parser_search_string(parser, TRIM(bsname), .TRUE., found, line) @@ -2339,7 +2339,7 @@ CONTAINS END DO basis_loop - IF (tmp .NE. "NONE") THEN + IF (tmp /= "NONE") THEN IF (.NOT. basis_found) THEN basis_set_file_name = "" DO ibasis = 1, nbasis diff --git a/src/arnoldi/arnoldi_data_methods.F b/src/arnoldi/arnoldi_data_methods.F index 33d4dbc0b1..6da6e54d96 100644 --- a/src/arnoldi/arnoldi_data_methods.F +++ b/src/arnoldi/arnoldi_data_methods.F @@ -166,13 +166,13 @@ CONTAINS IF (control%generalized_ev .AND. selection_crit == 1) & CALL cp_abort(__LOCATION__, & 'generalized ev can only highest OR lowest EV') - IF (control%generalized_ev .AND. nval_request .NE. 1) & + IF (control%generalized_ev .AND. nval_request /= 1) & CALL cp_abort(__LOCATION__, & 'generalized ev can only compute one EV at the time') IF (control%generalized_ev .AND. control%nrestart == 0) & CALL cp_abort(__LOCATION__, & 'outer loops are mandatory for generalized EV, set nrestart appropriatly') - IF (SIZE(matrix) .NE. 2 .AND. control%generalized_ev) & + IF (SIZE(matrix) /= 2 .AND. control%generalized_ev) & CALL cp_abort(__LOCATION__, & 'generalized ev needs exactly two matrices as input (2nd is the metric)') @@ -288,7 +288,7 @@ CONTAINS convergence = MAX(convergence, & ABS(ar_data%revec(last_el, my_ind)*ar_data%Hessenberg(last_el + 1, last_el))) END DO - control%converged = convergence .LT. control%threshold + control%converged = convergence < control%threshold END SUBROUTINE select_evals @@ -386,7 +386,7 @@ CONTAINS INTEGER :: ev_ind INTEGER, DIMENSION(:), POINTER :: selected_ind - IF (ind .GT. get_nval_out(arnoldi_env)) & + IF (ind > get_nval_out(arnoldi_env)) & CPABORT('outside range of indexed evals') selected_ind => get_sel_ind(arnoldi_env) @@ -411,7 +411,7 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: selected_ind NULLIFY (evals) - IF (SIZE(eval_out) .LT. get_nval_out(arnoldi_env)) & + IF (SIZE(eval_out) < get_nval_out(arnoldi_env)) & CPABORT('array for eval output too small') selected_ind => get_sel_ind(arnoldi_env) diff --git a/src/arnoldi/arnoldi_geev.F b/src/arnoldi/arnoldi_geev.F index d98f38992b..09b5e3ef25 100644 --- a/src/arnoldi/arnoldi_geev.F +++ b/src/arnoldi/arnoldi_geev.F @@ -142,13 +142,13 @@ CONTAINS ! if eval is complex, then the complex conj pair of evec can be constructed from the i and i+1st evec ! Unfortunately dtrevc computes the ev such that the largest is set to one and not normalized i = 1 - DO WHILE (i .LE. ndim) - IF (ABS(eval2(i)) .LT. EPSILON(REAL(0.0, dp))) THEN + DO WHILE (i <= ndim) + IF (ABS(eval2(i)) < EPSILON(REAL(0.0, dp))) THEN evec_r(:, i) = evec_r(:, i)/SQRT(DOT_PRODUCT(evec_r(:, i), evec_r(:, i))) 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 - ELSE IF (eval2(i) .GT. EPSILON(REAL(0.0, dp))) THEN + ELSE IF (eval2(i) > EPSILON(REAL(0.0, dp))) THEN norm = SQRT(SUM(evec_r(:, i)**2.0_dp) + SUM(evec_r(:, i + 1)**2.0_dp)) revec(:, i) = CMPLX(evec_r(:, i), evec_r(:, i + 1), dp)/norm revec(:, i + 1) = CMPLX(evec_r(:, i), -evec_r(:, i + 1), dp)/norm diff --git a/src/arnoldi/arnoldi_methods.F b/src/arnoldi/arnoldi_methods.F index 1028f324cf..f2a7bf2862 100644 --- a/src/arnoldi/arnoldi_methods.F +++ b/src/arnoldi/arnoldi_methods.F @@ -98,7 +98,7 @@ CONTAINS CALL zgeqrf(msize, msize, tmp_mat, msize, tau, work_measure, lwork, info) lwork = INT(work_measure(1)) IF (ALLOCATED(work)) THEN - IF (SIZE(work) .LT. lwork) THEN + IF (SIZE(work) < lwork) THEN DEALLOCATE (work) END IF END IF @@ -414,7 +414,7 @@ CONTAINS CALL compute_norms(ar_data%f_vec, norm, rnorm, control%pcol_group) ! check convergence and inform everybody about it, a bit annoying to talk to everybody because of that - IF (control%myproc == 0) control%converged = rnorm .LT. REAL(control%threshold, dp) + IF (control%myproc == 0) control%converged = rnorm < REAL(control%threshold, dp) CALL control%mp_group%bcast(control%converged, 0) IF (control%converged) EXIT @@ -538,7 +538,7 @@ CONTAINS norm = DOT_PRODUCT(ar_data%f_vec, v_vec) CALL pcol_group%sum(norm) - IF (control%myproc == 0) control%converged = REAL(norm, dp) .LT. EPSILON(REAL(1.0, dp)) + IF (control%myproc == 0) control%converged = REAL(norm, dp) < EPSILON(REAL(1.0, dp)) CALL control%mp_group%bcast(control%converged, 0) IF (control%converged) EXIT IF (j == control%max_iter - 1) EXIT @@ -632,7 +632,7 @@ CONTAINS IF (ncol_local > 0) THEN CALL compute_norms(v_vec, norm, rnorm, control%pcol_group) ! check convergence - control%converged = rnorm .LT. control%threshold + control%converged = rnorm < control%threshold DEALLOCATE (v_vec) END IF ! and broadcast the real eigenvalue diff --git a/src/arnoldi/arnoldi_vector.F b/src/arnoldi/arnoldi_vector.F index d063f3966a..5a2a9c1742 100644 --- a/src/arnoldi/arnoldi_vector.F +++ b/src/arnoldi/arnoldi_vector.F @@ -267,7 +267,7 @@ CONTAINS ALLOCATE (fast_vec_access%blk_map(0:nblk_local)) CALL dbcsr_get_info(matrix=vec, nblkcols_local=col) - IF (col .GT. 1) CPABORT("BUG") + IF (col > 1) CPABORT("BUG") ! go through the blocks of the vector iblock = 0 @@ -318,7 +318,7 @@ CONTAINS ! sanity check CALL dbcsr_get_info(matrix=vec, nblkrows_local=row) - IF (row .GT. 1) CPABORT("BUG") + IF (row > 1) CPABORT("BUG") ! go through the blocks of the vector iblock = 0 @@ -448,7 +448,7 @@ CONTAINS CALL hash_table_release(hash_table) CALL hash_table_create(hash_table, INT((UBOUND(tmp_hash, 1) + 8)*hash_table_expand)) DO i = LBOUND(tmp_hash, 1), UBOUND(tmp_hash, 1) - IF (tmp_hash(i)%c .NE. 0) THEN + IF (tmp_hash(i)%c /= 0) THEN CALL hash_table_add(hash_table, tmp_hash(i)%c, tmp_hash(i)%p) END IF END DO @@ -606,12 +606,12 @@ CONTAINS DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, row, col, data_d) prow = hash_table_get(fast_vec_col%hash_table, row) - IF (fast_vec_col%blk_map(prow)%assigned_thread .NE. ithread) CYCLE + IF (fast_vec_col%blk_map(prow)%assigned_thread /= ithread) CYCLE m = SIZE(fast_vec_col%blk_map(prow)%ptr, 1) n = SIZE(fast_vec_col%blk_map(prow)%ptr, 2) k = SIZE(data_d, 2) - IF ((m .EQ. 0) .OR. (n .EQ. 0) .OR. (k .EQ. 0)) CYCLE - CPASSERT(n .EQ. 1) + IF ((m == 0) .OR. (n == 0) .OR. (k == 0)) CYCLE + CPASSERT(n == 1) pcol = hash_table_get(fast_vec_row%hash_table, col) CALL dgemm('N', 'T', m, n, k, & 1.0_dp, data_d, m, & @@ -722,13 +722,13 @@ CONTAINS pcol = hash_table_get(fast_vec_row%hash_table, col) IF (ASSOCIATED(fast_vec_row%blk_map(pcol)%ptr) .AND. & ASSOCIATED(fast_vec_col%blk_map(prow)%ptr)) THEN - IF (fast_vec_row%blk_map(pcol)%assigned_thread .NE. ithread) CYCLE + IF (fast_vec_row%blk_map(pcol)%assigned_thread /= ithread) CYCLE fast_vec_row%blk_map(pcol)%ptr = fast_vec_row%blk_map(pcol)%ptr + & MATMUL(TRANSPOSE(fast_vec_col%blk_map(prow)%ptr), data_d) ELSE prow = hash_table_get(fast_vec_row%hash_table, row) pcol = hash_table_get(fast_vec_col%hash_table, col) - IF (fast_vec_row%blk_map(prow)%assigned_thread .NE. ithread) CYCLE + IF (fast_vec_row%blk_map(prow)%assigned_thread /= ithread) CYCLE fast_vec_row%blk_map(prow)%ptr = fast_vec_row%blk_map(prow)%ptr + & MATMUL(TRANSPOSE(fast_vec_col%blk_map(pcol)%ptr), TRANSPOSE(data_d)) END IF @@ -969,26 +969,26 @@ CONTAINS rprow = hash_table_get(res_fast_vec_col%hash_table, row) IF (ASSOCIATED(fast_vec_row%blk_map(pcol)%ptr) .AND. & ASSOCIATED(res_fast_vec_col%blk_map(rprow)%ptr)) THEN - IF (res_fast_vec_col%blk_map(rprow)%assigned_thread .EQ. ithread) THEN + IF (res_fast_vec_col%blk_map(rprow)%assigned_thread == ithread) THEN res_fast_vec_col%blk_map(rprow)%ptr = res_fast_vec_col%blk_map(rprow)%ptr + & MATMUL(data_d, TRANSPOSE(fast_vec_row%blk_map(pcol)%ptr)) END IF prow = hash_table_get(fast_vec_col%hash_table, row) rpcol = hash_table_get(res_fast_vec_row%hash_table, col) - IF (res_fast_vec_row%blk_map(rpcol)%assigned_thread .EQ. ithread .AND. row .NE. col) THEN + IF (res_fast_vec_row%blk_map(rpcol)%assigned_thread == ithread .AND. row /= col) THEN res_fast_vec_row%blk_map(rpcol)%ptr = res_fast_vec_row%blk_map(rpcol)%ptr + & MATMUL(TRANSPOSE(fast_vec_col%blk_map(prow)%ptr), data_d) END IF ELSE rpcol = hash_table_get(res_fast_vec_col%hash_table, col) prow = hash_table_get(fast_vec_row%hash_table, row) - IF (res_fast_vec_col%blk_map(rpcol)%assigned_thread .EQ. ithread) THEN + IF (res_fast_vec_col%blk_map(rpcol)%assigned_thread == ithread) THEN res_fast_vec_col%blk_map(rpcol)%ptr = res_fast_vec_col%blk_map(rpcol)%ptr + & TRANSPOSE(MATMUL(fast_vec_row%blk_map(prow)%ptr, data_d)) END IF rprow = hash_table_get(res_fast_vec_row%hash_table, row) pcol = hash_table_get(fast_vec_col%hash_table, col) - IF (res_fast_vec_row%blk_map(rprow)%assigned_thread .EQ. ithread .AND. row .NE. col) THEN + IF (res_fast_vec_row%blk_map(rprow)%assigned_thread == ithread .AND. row /= col) THEN res_fast_vec_row%blk_map(rprow)%ptr = res_fast_vec_row%blk_map(rprow)%ptr + & TRANSPOSE(MATMUL(data_d, fast_vec_col%blk_map(pcol)%ptr)) END IF diff --git a/src/atom_grb.F b/src/atom_grb.F index 3ba8af07ea..d85fb5a60c 100644 --- a/src/atom_grb.F +++ b/src/atom_grb.F @@ -734,7 +734,7 @@ CONTAINS IF (PRESENT(header)) THEN DO i = 1, SIZE(header, 1) - IF (header(i) .NE. "") THEN + IF (header(i) /= "") THEN WRITE (iunit, "(A)") TRIM(header(i)) END IF END DO diff --git a/src/atom_utils.F b/src/atom_utils.F index e28aa42366..194f778fca 100644 --- a/src/atom_utils.F +++ b/src/atom_utils.F @@ -472,12 +472,12 @@ CONTAINS READ (extunit, *, IOSTAT=er) nbas - IF (er .NE. 0) THEN + IF (er /= 0) THEN WRITE (iw, fmt="(' ZMP | ERROR! Restart file unreadable')") WRITE (iw, fmt="(' ZMP | ERROR! Starting ZMP calculation form initial atomic guess')") doguess = .TRUE. atom%doread = .FALSE. - ELSE IF (nbas(1) .NE. atom%basis%nbas(1)) THEN + ELSE IF (nbas(1) /= atom%basis%nbas(1)) THEN WRITE (iw, fmt="(' ZMP | ERROR! Restart file contains a different basis set')") WRITE (iw, fmt="(' ZMP | ERROR! Starting ZMP calculation form initial atomic guess')") doguess = .TRUE. @@ -535,7 +535,7 @@ CONTAINS IF (.NOT. ldm) THEN READ (extunit, *) nr - IF (nr .NE. atom%basis%grid%nr) THEN + IF (nr /= atom%basis%grid%nr) THEN IF (iw > 0) WRITE (iw, fmt="(' ZMP | ERROR! External grid dimension ',I4,' differs from internal grid ',I4)") & nr, atom%basis%grid%nr IF (iw > 0) WRITE (iw, fmt="(' ZMP | ERROR! Stopping ZMP calculation')") @@ -544,7 +544,7 @@ CONTAINS DO ir = 1, nr READ (extunit, *) rr, density(ir) - IF (ABS(rr - atom%basis%grid%rad(ir)) .GT. atom%zmpgrid_tol) THEN + IF (ABS(rr - atom%basis%grid%rad(ir)) > atom%zmpgrid_tol) THEN IF (iw > 0) WRITE (iw, fmt="(' ZMP | ERROR! Grid points do not coincide: ')") IF (iw > 0) WRITE (iw, fmt='(" ZMP |",T20,"R_out[bohr]",T36,"R_in[bohr]",T61,"R_diff[bohr]")') IF (iw > 0) WRITE (iw, fmt='(" ZMP |",T14,E24.15,T39,E24.15,T64,E24.15)') & @@ -622,7 +622,7 @@ CONTAINS READ (extunit, *) READ (extunit, *) adum, nr - IF (nr .NE. atom%basis%grid%nr) THEN + IF (nr /= atom%basis%grid%nr) THEN IF (iw > 0) WRITE (iw, fmt="(' ZMP | ERROR! External grid dimension ',I4,' differs from internal grid ',I4)") & nr, atom%basis%grid%nr IF (iw > 0) WRITE (iw, fmt="(' ZMP | ERROR! Stopping ZMP calculation')") @@ -630,7 +630,7 @@ CONTAINS END IF DO ir = 1, nr READ (extunit, *) rr, vxc(ir) - IF (ABS(rr - atom%basis%grid%rad(ir)) .GT. atom%zmpvxcgrid_tol) THEN + IF (ABS(rr - atom%basis%grid%rad(ir)) > atom%zmpvxcgrid_tol) THEN IF (iw > 0) WRITE (iw, fmt="(' ZMP | ERROR! Grid points do not coincide: ')") IF (iw > 0) WRITE (iw, fmt='(" ZMP |",T20,"R_out[bohr]",T36,"R_in[bohr]",T61,"R_diff[bohr]")') IF (iw > 0) WRITE (iw, fmt='(" ZMP |",T14,E24.15,T39,E24.15,T64,E24.15)') & diff --git a/src/base/machine.F b/src/base/machine.F index 91e400a715..f90b177463 100644 --- a/src/base/machine.F +++ b/src/base/machine.F @@ -373,7 +373,7 @@ CONTAINS 999 CLOSE (121245) DATA(I:80) = "" READ (DATA, *, IOSTAT=iostat) raw - IF (iostat .NE. 0) THEN + IF (iostat /= 0) THEN wt = 0.0_dp ELSE ! convert from J to kJ @@ -489,7 +489,7 @@ CONTAINS ! m2 = resident ! m3 = shared READ (DATA, *, IOSTAT=iostat) m1, m2, m3 - IF (iostat .NE. 0) THEN + IF (iostat /= 0) THEN mem_local = 0 ELSE mem_local = m2 @@ -576,9 +576,9 @@ CONTAINS get_field_value_in_bytes = 0 start = INDEX(meminfo, field) - IF (start .NE. 0) THEN + IF (start /= 0) THEN start = start + LEN_TRIM(field) - IF (start .LT. Nbuffer) THEN + IF (start < Nbuffer) THEN READ (meminfo(start:), *, ERR=999, END=999) value ! XXXXXXX convert from Kb to bytes XXXXXXXX get_field_value_in_bytes = value*1024 @@ -738,7 +738,7 @@ CONTAINS ! now move istat = rename(TRIM(source)//c_null_char, TRIM(TARGET)//c_null_char) - IF (istat .NE. 0) THEN + IF (istat /= 0) THEN WRITE (*, *) "Trying to move "//TRIM(source)//" to "//TRIM(TARGET)//"." WRITE (*, *) "rename returned status: ", istat WRITE (*, *) "Problem moving file" diff --git a/src/beta_gamma_psi.F b/src/beta_gamma_psi.F index 13f5038356..a63227480c 100644 --- a/src/beta_gamma_psi.F +++ b/src/beta_gamma_psi.F @@ -39,7 +39,7 @@ CONTAINS ! SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) -! WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. +! WHERE 0 <= X(I) < A FOR I=0,...,N-1. ! IPMPAR(1) = A, THE BASE (radix). @@ -56,7 +56,7 @@ CONTAINS ! SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) ! WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, -! X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. +! X(1) >= 1, AND EMIN <= E <= EMAX. ! IPMPAR(4) = B, THE BASE. @@ -678,7 +678,7 @@ CONTAINS ! ************************************************************************************************** FUNCTION gamln1(a) RESULT(fn_val) !----------------------------------------------------------------------- -! EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25 +! EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 <= A <= 1.25 !----------------------------------------------------------------------- REAL(dp), INTENT(IN) :: a REAL(dp) :: fn_val @@ -781,7 +781,7 @@ CONTAINS aug = 0.0e0_dp IF (x < 0.5e0_dp) THEN !--------------------------------------------------------------------- -! X .LT. 0.5, USE REFLECTION FORMULA +! X < 0.5, USE REFLECTION FORMULA ! PSI(1-X) = PSI(X) + PI * COTAN(PI*X) !--------------------------------------------------------------------- IF (ABS(x) <= xsmall) THEN @@ -791,7 +791,7 @@ CONTAINS RETURN END IF !--------------------------------------------------------------------- -! 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE +! 0 < ABS(X) <= XSMALL. USE 1/X AS A SUBSTITUTE ! FOR PI*COTAN(PI*X) !--------------------------------------------------------------------- aug = -1.0e0_dp/x @@ -807,7 +807,7 @@ CONTAINS sgn = -sgn END IF !--------------------------------------------------------------------- -! MAKE AN ERROR EXIT IF X .LE. -XMAX1 +! MAKE AN ERROR EXIT IF X <= -XMAX1 !--------------------------------------------------------------------- IF (w >= xmax1) THEN ! ERROR RETURN @@ -856,7 +856,7 @@ CONTAINS END IF IF (x <= 3.0e0_dp) THEN !--------------------------------------------------------------------- -! 0.5 .LE. X .LE. 3.0 +! 0.5 <= X <= 3.0 !--------------------------------------------------------------------- den = x upper = p1(1)*x @@ -872,11 +872,11 @@ CONTAINS RETURN END IF !--------------------------------------------------------------------- -! IF X .GE. XMAX1, PSI = LN(X) +! IF X >= XMAX1, PSI = LN(X) !--------------------------------------------------------------------- IF (x < xmax1) THEN !--------------------------------------------------------------------- -! 3.0 .LT. X .LT. XMAX1 +! 3.0 < X < XMAX1 !--------------------------------------------------------------------- w = 1.0e0_dp/(x*x) den = w @@ -918,7 +918,7 @@ CONTAINS a = MIN(a0, b0) b = MAX(a0, b0) !----------------------------------------------------------------------- -! PROCEDURE WHEN A .GE. 8 +! PROCEDURE WHEN A >= 8 !----------------------------------------------------------------------- IF (a >= 8.0e0_dp) THEN w = bcorr(a, b) @@ -932,7 +932,7 @@ CONTAINS fn_val = (((-0.5e0_dp*LOG(b) + e) + w) - u) - v END IF !----------------------------------------------------------------------- -! PROCEDURE WHEN A .LT. 1 +! PROCEDURE WHEN A < 1 !----------------------------------------------------------------------- ELSEIF (a < 1.0e0_dp) THEN IF (b < 8.0e0_dp) THEN @@ -941,7 +941,7 @@ CONTAINS fn_val = LOG_GAMMA(a) + algdiv(a, b) END IF !----------------------------------------------------------------------- -! PROCEDURE WHEN 1 .LE. A .LT. 8 +! PROCEDURE WHEN 1 <= A < 8 !----------------------------------------------------------------------- ELSEIF (a <= 2.0e0_dp) THEN IF (b <= 2.0e0_dp) THEN @@ -950,7 +950,7 @@ CONTAINS END IF w = 0.0e0_dp IF (b < 8.0e0_dp) THEN - ! REDUCTION OF B WHEN B .LT. 8 + ! REDUCTION OF B WHEN B < 8 n = INT(b - 1.0e0_dp) z = 1.0e0_dp @@ -962,7 +962,7 @@ CONTAINS RETURN END IF fn_val = LOG_GAMMA(a) + algdiv(a, b) -! REDUCTION OF A WHEN B .LE. 1000 +! REDUCTION OF A WHEN B <= 1000 ELSEIF (b <= 1000.0e0_dp) THEN n = INT(a - 1.0e0_dp) w = 1.0e0_dp @@ -977,7 +977,7 @@ CONTAINS RETURN END IF - ! REDUCTION OF B WHEN B .LT. 8 + ! REDUCTION OF B WHEN B < 8 n = INT(b - 1.0e0_dp) z = 1.0e0_dp @@ -987,7 +987,7 @@ CONTAINS END DO fn_val = w + LOG(z) + (LOG_GAMMA(a) + (LOG_GAMMA(b) - gsumln(a, b))) ELSE -! REDUCTION OF A WHEN B .GT. 1000 +! REDUCTION OF A WHEN B > 1000 n = INT(a - 1.0e0_dp) w = 1.0e0_dp @@ -1009,7 +1009,7 @@ CONTAINS FUNCTION gsumln(a, b) RESULT(fn_val) !----------------------------------------------------------------------- ! EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) -! FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 +! FOR 1 <= A <= 2 AND 1 <= B <= 2 !----------------------------------------------------------------------- REAL(dp), INTENT(IN) :: a, b REAL(dp) :: fn_val @@ -1037,7 +1037,7 @@ CONTAINS ! EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE ! LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A). -! IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8. +! IT IS ASSUMED THAT A0 >= 8 AND B0 >= 8. !----------------------------------------------------------------------- REAL(dp), INTENT(IN) :: a0, b0 @@ -1110,9 +1110,9 @@ CONTAINS ! IERR = 1 IF A OR B IS NEGATIVE ! IERR = 2 IF A = B = 0 -! IERR = 3 IF X .LT. 0 OR X .GT. 1 -! IERR = 4 IF Y .LT. 0 OR Y .GT. 1 -! IERR = 5 IF X + Y .NE. 1 +! IERR = 3 IF X < 0 OR X > 1 +! IERR = 4 IF Y < 0 OR Y > 1 +! IERR = 5 IF X + Y /= 1 ! IERR = 6 IF X = A = 0 ! IERR = 7 IF Y = B = 0 @@ -1131,7 +1131,7 @@ CONTAINS !----------------------------------------------------------------------- ! ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST -! FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0 +! FLOATING POINT NUMBER FOR WHICH 1.0 + EPS > 1.0 eps = dpmpar(1) @@ -1183,7 +1183,7 @@ CONTAINS eps = MAX(eps, 1.e-15_dp) IF (MAX(a, b) < 1.e-3_dp*eps) THEN -! PROCEDURE FOR A AND B .LT. 1.E-3*EPS +! PROCEDURE FOR A AND B < 1.E-3*EPS w = b/(a + b) w1 = a/(a + b) RETURN @@ -1196,7 +1196,7 @@ CONTAINS y0 = y IF (MIN(a0, b0) > 1.0e0_dp) GO TO 30 -! PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1 +! PROCEDURE FOR A0 <= 1 OR B0 <= 1 IF (x > 0.5e0_dp) THEN ind = 1 @@ -1222,7 +1222,7 @@ CONTAINS n = 20 GO TO 130 -! PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1 +! PROCEDURE FOR A0 > 1 AND B0 > 1 30 IF (a > b) THEN lambda = (a + b)*y - b @@ -1324,7 +1324,7 @@ CONTAINS ! EVALUATION OF I (A,B) ! X -! FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5. +! FOR B < MIN(EPS,EPS*A) AND X <= 0.5. !----------------------------------------------------------------------- REAL(dp), INTENT(IN) :: a, b, x, eps @@ -1375,7 +1375,7 @@ CONTAINS FUNCTION apser(a, b, x, eps) RESULT(fn_val) !----------------------------------------------------------------------- ! APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR -! A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN +! A <= MIN(EPS,EPS*B), B*X <= 1, AND X <= 0.5. USED WHEN ! A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED. !----------------------------------------------------------------------- REAL(dp), INTENT(IN) :: a, b, x, eps @@ -1420,8 +1420,8 @@ CONTAINS ! ************************************************************************************************** FUNCTION bpser(a, b, x, eps) RESULT(fn_val) !----------------------------------------------------------------------- -! POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1 -! OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED. +! POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B <= 1 +! OR B*X <= 0.7. EPS IS THE TOLERANCE USED. !----------------------------------------------------------------------- REAL(dp), INTENT(IN) :: a, b, x, eps REAL(dp) :: fn_val @@ -1444,7 +1444,7 @@ CONTAINS z = a*LOG(x) - u fn_val = (a0/a)*EXP(z) ELSEIF (b0 > 1.0e0_dp) THEN -! PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 +! PROCEDURE FOR A0 < 1 AND 1 < B0 < 8 u = gamln1(a0) m = INT(b0 - 1.0e0_dp) @@ -1469,7 +1469,7 @@ CONTAINS fn_val = EXP(z)*(a0/a)*(1.0e0_dp + gam1(b0))/t ELSE - ! PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1 + ! PROCEDURE FOR A0 < 1 AND B0 <= 1 fn_val = x**a IF (fn_val == 0.0e0_dp) RETURN @@ -1486,7 +1486,7 @@ CONTAINS fn_val = fn_val*c*(b/apb) END IF -! PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 +! PROCEDURE FOR A0 < 1 AND B0 >= 8 IF (fn_val == 0.0e0_dp .OR. a <= 0.1e0_dp*eps) RETURN !----------------------------------------------------------------------- @@ -1618,7 +1618,7 @@ CONTAINS ! ************************************************************************************************** FUNCTION bfrac(a, b, x, y, lambda, eps) RESULT(fn_val) !----------------------------------------------------------------------- -! CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1. +! CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B > 1. ! IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B. !----------------------------------------------------------------------- REAL(dp), INTENT(IN) :: a, b, x, y, lambda, eps @@ -1718,7 +1718,7 @@ CONTAINS a0 = MIN(a, b) IF (a0 >= 8.0e0_dp) THEN !----------------------------------------------------------------------- -! PROCEDURE FOR A .GE. 8 AND B .GE. 8 +! PROCEDURE FOR A >= 8 AND B >= 8 !----------------------------------------------------------------------- IF (a > b) THEN h = b/a @@ -1771,17 +1771,17 @@ CONTAINS RETURN END IF !----------------------------------------------------------------------- -! PROCEDURE FOR A .LT. 1 OR B .LT. 1 +! PROCEDURE FOR A < 1 OR B < 1 !----------------------------------------------------------------------- b0 = MAX(a, b) IF (b0 >= 8.0e0_dp) THEN -! ALGORITHM FOR B0 .GE. 8 +! ALGORITHM FOR B0 >= 8 u = gamln1(a0) + algdiv(a0, b0) fn_val = a0*EXP(z - u) END IF IF (b0 <= 1.0e0_dp) THEN -! ALGORITHM FOR B0 .LE. 1 +! ALGORITHM FOR B0 <= 1 fn_val = EXP(z) IF (fn_val == 0.0e0_dp) RETURN @@ -1799,7 +1799,7 @@ CONTAINS RETURN END IF -! ALGORITHM FOR 1 .LT. B0 .LT. 8 +! ALGORITHM FOR 1 < B0 < 8 u = gamln1(a0) n = INT(b0 - 1.0e0_dp) @@ -1855,7 +1855,7 @@ CONTAINS a0 = MIN(a, b) IF (a0 >= 8.0e0_dp) THEN !----------------------------------------------------------------------- -! PROCEDURE FOR A .GE. 8 AND B .GE. 8 +! PROCEDURE FOR A >= 8 AND B >= 8 !----------------------------------------------------------------------- IF (a > b) THEN h = b/a @@ -1905,11 +1905,11 @@ CONTAINS RETURN END IF !----------------------------------------------------------------------- -! PROCEDURE FOR A .LT. 1 OR B .LT. 1 +! PROCEDURE FOR A < 1 OR B < 1 !----------------------------------------------------------------------- b0 = MAX(a, b) IF (b0 >= 8.0e0_dp) THEN -! ALGORITHM FOR B0 .GE. 8 +! ALGORITHM FOR B0 >= 8 u = gamln1(a0) + algdiv(a0, b0) fn_val = a0*esum(mu, z - u) @@ -1917,7 +1917,7 @@ CONTAINS END IF IF (b0 <= 1.0e0_dp) THEN -! ALGORITHM FOR B0 .LE. 1 +! ALGORITHM FOR B0 <= 1 fn_val = esum(mu, z) IF (fn_val == 0.0e0_dp) RETURN @@ -1935,7 +1935,7 @@ CONTAINS RETURN END IF -! ALGORITHM FOR 1 .LT. B0 .LT. 8 +! ALGORITHM FOR 1 < B0 < 8 u = gamln1(a0) n = INT(b0 - 1.0e0_dp) diff --git a/src/bse_iterative.F b/src/bse_iterative.F index d08702a951..37c2ffbc51 100644 --- a/src/bse_iterative.F +++ b/src/bse_iterative.F @@ -137,7 +137,7 @@ CONTAINS CALL cp_abort(__LOCATION__, "Initial dimension was too large and could not be corrected. "// & "Choose another num_exc_en and num_add_start_z_space or adapt your basis set.") END IF - IF (num_max_z_space .GE. homo*virtual) THEN + IF (num_max_z_space >= homo*virtual) THEN fac_max_z_space = homo*virtual/num_Z_vectors_init num_max_z_space = num_Z_vectors_init*fac_max_z_space @@ -336,7 +336,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (num_Z_vectors + num_new_t .LE. num_max_z_space) THEN + IF (num_Z_vectors + num_new_t <= num_max_z_space) THEN W_vectors(:, :, :num_Z_vectors) = Z_vectors(:, :, :) W_vectors(:, :, num_Z_vectors + 1:) = Subspace_add_dir num_Z_vectors = num_Z_vectors + num_new_t diff --git a/src/bse_util.F b/src/bse_util.F index b99caef3ae..4a45514a00 100644 --- a/src/bse_util.F +++ b/src/bse_util.F @@ -547,13 +547,13 @@ CONTAINS ! due to their reversed indexing IF (correct_nrow) THEN idx_col_first = idx_col_first - nrow_offset + 1 - IF (idx_col_first .LE. 0) CYCLE + IF (idx_col_first <= 0) CYCLE ELSE IF (idx_col_first > nrow_out) EXIT END IF IF (correct_ncol) THEN idx_col_sec = idx_col_sec - ncol_offset + 1 - IF (idx_col_sec .LE. 0) CYCLE + IF (idx_col_sec <= 0) CYCLE ELSE IF (idx_col_sec > ncol_out) CYCLE END IF @@ -643,13 +643,13 @@ CONTAINS ! due to their reversed indexing IF (correct_nrow) THEN idx_col_first = idx_col_first - nrow_offset + 1 - IF (idx_col_first .LE. 0) CYCLE + IF (idx_col_first <= 0) CYCLE ELSE IF (idx_col_first > nrow_out) EXIT END IF IF (correct_ncol) THEN idx_col_sec = idx_col_sec - ncol_offset + 1 - IF (idx_col_sec .LE. 0) CYCLE + IF (idx_col_sec <= 0) CYCLE ELSE IF (idx_col_sec > ncol_out) CYCLE END IF @@ -1141,14 +1141,14 @@ CONTAINS ! Determine index in homo and virtual for truncation ! Uses indices of outermost orbitals within energy range (-mp2_env%bse%bse_cutoff_occ,mp2_env%bse%bse_cutoff_empty) IF (mp2_env%bse%bse_cutoff_occ > 0 .OR. mp2_env%bse%bse_cutoff_empty > 0) THEN - IF (-mp2_env%bse%bse_cutoff_occ .LT. Eigenval(1) - Eigenval(homo) & + IF (-mp2_env%bse%bse_cutoff_occ < Eigenval(1) - Eigenval(homo) & .OR. mp2_env%bse%bse_cutoff_occ < 0) THEN homo_red = homo homo_incl = 1 ELSE homo_incl = 1 DO i_homo = 1, homo - IF (Eigenval(i_homo) - Eigenval(homo) .GT. -mp2_env%bse%bse_cutoff_occ) THEN + IF (Eigenval(i_homo) - Eigenval(homo) > -mp2_env%bse%bse_cutoff_occ) THEN homo_incl = i_homo EXIT END IF @@ -1156,14 +1156,14 @@ CONTAINS homo_red = homo - homo_incl + 1 END IF - IF (mp2_env%bse%bse_cutoff_empty .GT. Eigenval(homo + virtual) - Eigenval(homo + 1) & + IF (mp2_env%bse%bse_cutoff_empty > Eigenval(homo + virtual) - Eigenval(homo + 1) & .OR. mp2_env%bse%bse_cutoff_empty < 0) THEN virt_red = virtual virt_incl = virtual ELSE virt_incl = homo + 1 DO j_virt = 1, virtual - IF (Eigenval(homo + j_virt) - Eigenval(homo + 1) .GT. mp2_env%bse%bse_cutoff_empty) THEN + IF (Eigenval(homo + j_virt) - Eigenval(homo + 1) > mp2_env%bse%bse_cutoff_empty) THEN virt_incl = j_virt - 1 EXIT END IF diff --git a/src/bsse.F b/src/bsse.F index dbf7f10dd7..b0401579f8 100644 --- a/src/bsse.F +++ b/src/bsse.F @@ -374,10 +374,10 @@ CONTAINS extension=".log") IF (iw > 0) THEN WRITE (conf_s, fmt="(1000I0)", iostat=istat) conf; - IF (istat .NE. 0) conf_s = "exceeded" + IF (istat /= 0) conf_s = "exceeded" CALL compress(conf_s, full=.TRUE.) WRITE (conf_loc_s, fmt="(1000I0)", iostat=istat) conf_loc; - IF (istat .NE. 0) conf_loc_s = "exceeded" + IF (istat /= 0) conf_loc_s = "exceeded" CALL compress(conf_loc_s, full=.TRUE.) WRITE (UNIT=iw, FMT="(/,T2,A)") REPEAT("-", 79) @@ -487,7 +487,7 @@ CONTAINS WRITE (UNIT=iw, FMT="(T2,A,T20,A,F16.6,T80,A)") "-", "CP-corrected Total energy:", SUM(Em), "-" WRITE (UNIT=iw, FMT="(T2,A,T80,A)") "-", "-" DO i = 1, SIZE(conf, 1) - IF (i .GT. 1) THEN + IF (i > 1) THEN IF (SUM(conf(i - 1, :)) == 1 .AND. SUM(conf(i, :)) /= 1) THEN WRITE (UNIT=iw, FMT="(T2,A,T80,A)") "-", "-" END IF diff --git a/src/colvar_methods.F b/src/colvar_methods.F index 58065fbb1a..153d40f09c 100644 --- a/src/colvar_methods.F +++ b/src/colvar_methods.F @@ -2507,7 +2507,7 @@ CONTAINS t = MIN(1.0_dp, ABS(t))*SIGN(1.0_dp, t) colvar%ss = ACOS(t) - IF ((ABS(colvar%ss) .LT. tolerance_acos) .OR. (ABS(colvar%ss - pi) .LT. tolerance_acos)) THEN + IF ((ABS(colvar%ss) < tolerance_acos) .OR. (ABS(colvar%ss - pi) < tolerance_acos)) THEN fmod = 0.0_dp ELSE fmod = -1.0_dp/SIN(colvar%ss) @@ -2675,7 +2675,7 @@ CONTAINS t2 = 1.0_dp/(a*b**3.0_dp) t3 = DOT_PRODUCT(xij, xkj) colvar%ss = ACOS(t3*t0) - IF ((ABS(colvar%ss) .LT. tolerance_acos) .OR. (ABS(colvar%ss - pi) .LT. tolerance_acos)) THEN + IF ((ABS(colvar%ss) < tolerance_acos) .OR. (ABS(colvar%ss - pi) < tolerance_acos)) THEN fmod = 0.0_dp ELSE fmod = -1.0_dp/SIN(colvar%ss) @@ -2826,7 +2826,7 @@ CONTAINS t2 = 1.0_dp/(a*b**3.0_dp) t3 = DOT_PRODUCT(xij, xkj) colvar%ss = ACOS(t3*t0) - IF ((ABS(colvar%ss) .LT. tolerance_acos) .OR. (ABS(colvar%ss - pi) .LT. tolerance_acos)) THEN + IF ((ABS(colvar%ss) < tolerance_acos) .OR. (ABS(colvar%ss - pi) < tolerance_acos)) THEN fmod = 0.0_dp ELSE fmod = -1.0_dp/SIN(colvar%ss) @@ -3005,17 +3005,17 @@ CONTAINS rt2 = xt*xt + yt*yt + zt*zt ru2 = xu*xu + yu*yu + zu*zu rtru = SQRT(rt2*ru2) - IF (rtru .NE. 0.0_dp) THEN + IF (rtru /= 0.0_dp) THEN rcb = SQRT(xcb*xcb + ycb*ycb + zcb*zcb) cosine = (xt*xu + yt*yu + zt*zu)/rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu)/(rcb*rtru) cosine = MIN(1.0_dp, MAX(-1.0_dp, cosine)) angle = ACOS(cosine) - IF (sine .LT. 0.0_dp) angle = -angle + IF (sine < 0.0_dp) angle = -angle ! dt = angle ! [rad] dt = MOD(2.0E4_dp*pi + dt - o0, 2.0_dp*pi) - IF (dt .GT. pi) dt = dt - 2.0_dp*pi + IF (dt > pi) dt = dt - 2.0_dp*pi dt = o0 + dt colvar%torsion_param%o0 = dt ! @@ -3141,7 +3141,7 @@ CONTAINS CALL cp_subsys_get(subsys, particles=particles_i) my_particles => particles_i%els END IF - CPASSERT(r1cut .LT. rcut) + CPASSERT(r1cut < rcut) denominator_tolerance = 1.0E-8_dp !ri_step=0.1 @@ -3195,16 +3195,16 @@ CONTAINS DO bb = -ncells(2), ncells(2) DO cc = -ncells(3), ncells(3) ! do not include the central atom - IF (i == j .AND. aa .EQ. 0 .AND. bb .EQ. 0 .AND. cc .EQ. 0) CYCLE + IF (i == j .AND. aa == 0 .AND. bb == 0 .AND. cc == 0) CYCLE shift(1) = REAL(aa, KIND=dp) shift(2) = REAL(bb, KIND=dp) shift(3) = REAL(cc, KIND=dp) xij = MATMUL(cell%hmat, ss0(:) + shift(:)) rij = SQRT(DOT_PRODUCT(xij, xij)) !IF (rij > rcut) THEN - ! IF (mm.EQ.0) WRITE(*,'(A8,4F10.5)') " --", shift, rij + ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " --", shift, rij !ELSE - ! IF (mm.EQ.0) WRITE(*,'(A8,4F10.5)') " ++", shift, rij + ! IF (mm==0) WRITE(*,'(A8,4F10.5)') " ++", shift, rij !ENDIF IF (rij > rcut) CYCLE @@ -3236,13 +3236,13 @@ 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) .GT. 0) THEN + !IF (ABS(mm) > 0) THEN ! fact = 2.0_dp !ELSE ! fact = 1.0_dp !ENDIF - IF (nbond .LT. denominator_tolerance) THEN + IF (nbond < denominator_tolerance) THEN CPWARN("QPARM: number of neighbors is very close to zero!") END IF @@ -3311,12 +3311,12 @@ CONTAINS !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 .GT. rcut) THEN + IF (rij > rcut) THEN !bond = 0.0_dp !exp_fac = 0.0_dp RETURN ELSE - IF (rij .LT. r1cut) THEN + IF (rij < r1cut) THEN bond = 1.0_dp exp_fac = 0.0_dp ELSE @@ -3330,8 +3330,8 @@ CONTAINS END IF ! compute continuous bond order nbond = nbond + bond - IF (ABS(xij(1)) .LT. denominator_tolerance & - .AND. ABS(xij(2)) .LT. denominator_tolerance) THEN + IF (ABS(xij(1)) < denominator_tolerance & + .AND. ABS(xij(2)) < denominator_tolerance) THEN fi = 0.0_dp ELSE fi = ATAN2(xij(2), xij(1)) @@ -4225,7 +4225,7 @@ CONTAINS j = colvar%coord_param%i_at_to(jj) CALL get_coordinates(colvar, j, xpj, my_particles) ! define coordination of atom A with itself to be 0. also fixes rij==0 for the force calculation - IF (i .EQ. j) CYCLE + IF (i == j) CYCLE ss = MATMUL(cell%h_inv, xpi(:) - xpj(:)) ss = ss - NINT(ss) xij = MATMUL(cell%hmat, ss) @@ -4252,7 +4252,7 @@ CONTAINS func_k = 0.0_dp DO kk = 1, n_atoms_to_b k = colvar%coord_param%i_at_to_b(kk) - IF (k .EQ. j) CYCLE + IF (k == j) CYCLE CALL get_coordinates(colvar, k, xpk, my_particles) ss = MATMUL(cell%h_inv, xpj(:) - xpk(:)) ss = ss - NINT(ss) @@ -5756,7 +5756,7 @@ CONTAINS INTEGER :: count1, i k = 1 - IF (v_count .LT. ncol) THEN + IF (v_count < ncol) THEN count1 = v_count + 1 DO i = p_bounds(1, count1), p_bounds(2, count1) gp(count1) = REAL(i, KIND=dp)*grid_sp(count1) diff --git a/src/common/cp_array_utils.F b/src/common/cp_array_utils.F index 679f3310f3..fdb2afd6ce 100644 --- a/src/common/cp_array_utils.F +++ b/src/common/cp_array_utils.F @@ -146,7 +146,7 @@ CONTAINS IF (PRESENT(el_format)) THEN DO i = 1, SIZE(array) - 1 WRITE (unit=unit_nr, fmt=el_format, advance="no") array(i) - IF (MOD(i, 5) .EQ. 0) THEN ! only a few elements per line + IF (MOD(i, 5) == 0) THEN ! only a few elements per line WRITE (unit=unit_nr, fmt="(',')") ELSE WRITE (unit=unit_nr, fmt="(',')", advance="no") @@ -157,7 +157,7 @@ CONTAINS ELSE DO i = 1, SIZE(array) - 1 WRITE (unit=unit_nr, fmt=defaultFormat, advance="no") array(i) - IF (MOD(i, 5) .EQ. 0) THEN ! only a few elements per line + IF (MOD(i, 5) == 0) THEN ! only a few elements per line WRITE (unit=unit_nr, fmt="(',')") ELSE WRITE (unit=unit_nr, fmt="(',')", advance="no") diff --git a/src/common/cp_min_heap.F b/src/common/cp_min_heap.F index 1cf96cb025..25611a12ed 100644 --- a/src/common/cp_min_heap.F +++ b/src/common/cp_min_heap.F @@ -176,7 +176,7 @@ CONTAINS INTEGER(KIND=valt), INTENT(OUT) :: value LOGICAL, INTENT(OUT) :: found - IF (heap%n .LT. 1) THEN + IF (heap%n < 1) THEN found = .FALSE. ELSE found = .TRUE. @@ -203,7 +203,7 @@ CONTAINS CALL cp_heap_get_first(heap, key, value, found) IF (found) THEN - IF (heap%n .GT. 1) THEN + IF (heap%n > 1) THEN CALL cp_heap_copy_node(heap, 1, heap%n) heap%n = heap%n - 1 CALL bubble_down(heap, 1) @@ -316,30 +316,30 @@ CONTAINS all_done = .FALSE. ! Check whether we are finished, i.e,. whether the element to ! bubble down is childless. - DO WHILE (e .LE. get_parent(heap%n) .AND. .NOT. all_done) + DO WHILE (e <= get_parent(heap%n) .AND. .NOT. all_done) ! Determines which node (current, left, or right child) has the ! smallest value. smallest = e min_value = get_value(heap, e) left_child = get_left_child(e) - IF (left_child .LE. heap%n) THEN + IF (left_child <= heap%n) THEN left_child_value = get_value(heap, left_child) - IF (left_child_value .LT. min_value) THEN + IF (left_child_value < min_value) THEN min_value = left_child_value smallest = left_child END IF END IF right_child = left_child + 1 - IF (right_child .LE. heap%n) THEN + IF (right_child <= heap%n) THEN right_child_value = get_value(heap, right_child) - IF (right_child_value .LT. min_value) THEN + IF (right_child_value < min_value) THEN min_value = right_child_value smallest = right_child END IF END IF ! CALL cp_heap_swap(heap, e, smallest) - IF (smallest .EQ. e) THEN + IF (smallest == e) THEN all_done = .TRUE. ELSE e = smallest @@ -366,18 +366,18 @@ CONTAINS e = first all_done = .FALSE. - IF (e .GT. 1) THEN + IF (e > 1) THEN my_value = get_value(heap, e) END IF ! Check whether we are finished, i.e,. whether the element to ! bubble up is an orphan. new_pos = e - DO WHILE (e .GT. 1 .AND. .NOT. all_done) + DO WHILE (e > 1 .AND. .NOT. all_done) ! Switches the parent and the current element if the current ! element's value is greater than the parent's value. parent = get_parent(e) parent_value = get_value(heap, parent) - IF (my_value .LT. parent_value) THEN + IF (my_value < parent_value) THEN CALL cp_heap_swap(heap, e, parent) e = parent ELSE diff --git a/src/common/cp_result_methods.F b/src/common/cp_result_methods.F index 9943b78d4b..ceedebf18f 100644 --- a/src/common/cp_result_methods.F +++ b/src/common/cp_result_methods.F @@ -178,7 +178,7 @@ CONTAINS n_rep = nrep END IF - IF (nrep .LE. 0) & + IF (nrep <= 0) & CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") @@ -251,7 +251,7 @@ CONTAINS n_rep = nrep END IF - IF (nrep .LE. 0) & + IF (nrep <= 0) & CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)//") which was never stored!") @@ -377,7 +377,7 @@ CONTAINS DO i = 1, nlist IF (TRIM(results%result_label(i)) == TRIM(description)) nrep = nrep + 1 END DO - IF (nrep .NE. 0) THEN + IF (nrep /= 0) THEN k = 0 entry_deleted = 0 DO i = 1, nlist diff --git a/src/common/erf_complex.F b/src/common/erf_complex.F index a979af04ac..3c4e99f854 100644 --- a/src/common/erf_complex.F +++ b/src/common/erf_complex.F @@ -114,7 +114,7 @@ CONTAINS ! For purely imaginary z, use intrinsic scaled complement of ! the error function, erfc_scaled (F2008 and beyond). ! Return immediately. - IF (ABS(x) .EQ. zero) THEN + IF (ABS(x) == zero) THEN faddeyeva_accurate = erfc_scaled(y) RETURN END IF @@ -152,7 +152,7 @@ CONTAINS n3 = CEILING(x/a) n3_3 = n3 - 1 - outer: IF ((sqrt_log_rmin - x) .GT. 0) THEN + outer: IF ((sqrt_log_rmin - x) > 0) THEN sigma1 = rmin sigma2 = rmin sigma4 = rmin @@ -165,14 +165,14 @@ CONTAINS del3_3_tmp = EXP(a_sqr - (two_a_sqr*n3 - two_a_x)) loop1: DO - IF (delta3 .LT. myerr .AND. delta5 .LT. myerr .AND. & - n .GT. 50) EXIT loop1 + IF (delta3 < myerr .AND. delta5 < myerr .AND. & + n > 50) EXIT loop1 n = n + 1 den1 = a_sqr*n**2 + y_sqr exp_del1 = EXP(-(a_sqr*n**2))/den1 del2_tmp = del2_tmp*exp1 - minor: IF (n3_3 .GE. 1) THEN + minor: IF (n3_3 >= 1) THEN del3_tmp = del3_tmp*exp3 exp3_den = del3_tmp*exp_del1* & (den1/(a_sqr*n3**2 + y_sqr)) @@ -197,7 +197,7 @@ CONTAINS sigma4 = sigma4 + n*del2_tmp*exp_x_sqr*exp_del1 sigma5 = sigma5 + del5 - IF (x .GE. 5.0e-4_dp) THEN + IF (x >= 5.0e-4_dp) THEN sigma4_5 = -sigma4 + sigma5 ELSE sigma4_5 = sigma4_5 + 2*n**2*two_a_x*exp_x_sqr & @@ -214,11 +214,11 @@ CONTAINS ! Second line of Eqn (13) aux13 = y*two_a_pi* & (-cos_2yx*exp_x_sqr*sigma1 + half*(sigma2 + sigma3)) - mumu: IF (y .LE. 5.0_dp .AND. two_yx .GT. rmin) THEN + mumu: IF (y <= 5.0_dp .AND. two_yx > rmin) THEN faddeyeva_accurate = v_old + aux13 + cmplxj*xsign & *(sin_2yx*exp_x_sqr*(l_old + two_a_pi*y*sigma1) & + two_a_pi*half_a*sigma4_5) - ELSE IF (y .LE. 5.0_dp .AND. two_yx .LE. rmin) THEN + ELSE IF (y <= 5.0_dp .AND. two_yx <= rmin) THEN faddeyeva_accurate = v_old + aux13 + cmplxj*xsign & *(two*y*exp_x_sqr*(x*l_old + x*two_a_pi*y & *sigma1) + two_a_pi*half_a*sigma4_5) @@ -229,16 +229,16 @@ CONTAINS *sigma4_5) END IF mumu - ELSE IF (x .GE. sqrt_log_rmin .AND. x .LT. 1.0e15_dp) THEN + ELSE IF (x >= sqrt_log_rmin .AND. x < 1.0e15_dp) THEN exp2 = EXP(four_a_sqr*n3 - 2*two_a_x - two_a_sqr) del3_3_tmp = EXP(a_sqr + two_a_x - two_a_sqr*n3) loop2: DO - IF (delta3 .LT. myerr .AND. delta5 .LT. myerr .AND. & - n .GT. 50) EXIT loop2 + IF (delta3 < myerr .AND. delta5 < myerr .AND. & + n > 50) EXIT loop2 n = n + 1 - IF (n3_3 .GE. 1) THEN + IF (n3_3 >= 1) THEN exp3_den = EXP(-(a*n3 - x)*(a*n3 - x)) & /(a_sqr*n3**2 + y_sqr) del3_3_tmp = del3_3_tmp*exp2 @@ -267,7 +267,7 @@ CONTAINS faddeyeva_accurate = one_sqrt_pi*((y + cmplxj*xsign*x)/(x_sqr + y_sqr)) END IF outer - IF (ysign .LT. zero) THEN + IF (ysign < zero) THEN two_exp_x_sqr_ysqr = two*EXP(-x_sqr + y_sqr) faddeyeva_accurate = two_exp_x_sqr_ysqr*cos_2yx - REAL(faddeyeva_accurate) - cmplxj & *(-xsign*two_exp_x_sqr_ysqr*sin_2yx - AIMAG(faddeyeva_accurate)) @@ -341,7 +341,7 @@ CONTAINS xquad = xabsq - yabs**2 yquad = 2*xabs*yabs - a = qrho .LT. 0.085264_dp + a = qrho < 0.085264_dp branch1: IF (a) THEN @@ -372,7 +372,7 @@ CONTAINS v = u1*v2 + v1*u2 ELSE - bran2: IF (qrho .GT. one) THEN + bran2: IF (qrho > one) THEN ! If ( qrho .gt. 1) then w(z) is evaluated using the laplace ! continued fraction. nu is the minimum number of terms needed @@ -402,7 +402,7 @@ CONTAINS END IF bran2 - b = h .GT. zero + b = h > zero ! To avoid uninitialise compiler warning. qlambda is used ! only if (b), so can define to any value otherwise. @@ -421,7 +421,7 @@ CONTAINS c = half/(tx**2 + ty**2) rx = c*tx ry = c*ty - IF (b .AND. n .LE. kapn) THEN + IF (b .AND. n <= kapn) THEN tx = qlambda + sx sx = rx*tx - ry*sy sy = ry*tx + rx*sy @@ -429,7 +429,7 @@ CONTAINS END IF END DO - IF (h .EQ. zero) THEN + IF (h == zero) THEN u = factor*rx v = factor*ry ELSE @@ -437,13 +437,13 @@ CONTAINS v = factor*sy END IF - IF (yabs .EQ. zero) u = EXP(-xabs**2) + IF (yabs == zero) u = EXP(-xabs**2) END IF branch1 ! Evaluation of w(z) in the other quadrants - IF (yi .LT. zero) THEN + IF (yi < zero) THEN IF (a) THEN u2 = two*u2 @@ -457,9 +457,9 @@ CONTAINS u = u2 - u v = v2 - v - IF (xi .GT. zero) v = -v + IF (xi > zero) v = -v ELSE - IF (xi .LT. zero) v = -v + IF (xi < zero) v = -v END IF faddeyeva_fast = CMPLX(u, v, kind=dp) diff --git a/src/common/fparser.F b/src/common/fparser.F index 1f540ae9cf..37837f1139 100644 --- a/src/common/fparser.F +++ b/src/common/fparser.F @@ -1009,12 +1009,12 @@ CONTAINS a(j, i) = (a(j - 1, i)*fac - a(j - 1, i - 1))/(fac - 1.0_rn) fac = con2*fac errt = MAX(ABS(a(j, i) - a(j - 1, i)), ABS(a(j, i) - a(j - 1, i - 1))) - IF (errt .LE. err) THEN + IF (errt <= err) THEN err = errt derivative = a(j, i) END IF END DO - IF (ABS(a(i, i) - a(i - 1, i - 1)) .GE. safe*err) RETURN + IF (ABS(a(i, i) - a(i - 1, i - 1)) >= safe*err) RETURN END DO ELSE CPABORT("DX provided equals zero!") diff --git a/src/common/kahan_sum.F b/src/common/kahan_sum.F index f5c2da1a14..9ea1bb234b 100644 --- a/src/common/kahan_sum.F +++ b/src/common/kahan_sum.F @@ -614,7 +614,7 @@ CONTAINS DO i3 = LBOUND(mask, 3), UBOUND(mask, 3) DO i2 = LBOUND(mask, 2), UBOUND(mask, 2) DO i1 = LBOUND(mask, 1), UBOUND(mask, 1) - IF (mask(i1, i2, i3) .GT. th) THEN + IF (mask(i1, i2, i3) > th) THEN y = array1(i1, i2, i3)*array2(i1, i2, i3) - c t = ks + y c = (t - ks) - y diff --git a/src/common/mathlib.F b/src/common/mathlib.F index 481cbee317..bc81b8b59f 100644 --- a/src/common/mathlib.F +++ b/src/common/mathlib.F @@ -158,7 +158,7 @@ CONTAINS ! which the compiler uses to optimize the function to .FALSE. if based on the IEEE module ! therefore, pass this to the Fortran runtime/printf, if things are NaN or Inf, error out. WRITE (buffer, *) a - IF (INDEX(buffer, "N") .NE. 0 .OR. INDEX(buffer, "n") .NE. 0) abnormal_value = .TRUE. + IF (INDEX(buffer, "N") /= 0 .OR. INDEX(buffer, "n") /= 0) abnormal_value = .TRUE. END FUNCTION abnormal_value @@ -1291,7 +1291,7 @@ CONTAINS s = ab l = aa END IF - IF (s .NE. 0) THEN + IF (s /= 0) THEN DO rem = MOD(l, s) IF (rem == 0) EXIT @@ -1403,13 +1403,13 @@ CONTAINS nm1 = n - 1 - IF (n .LT. 0 .OR. x .LT. 0.0_dp .OR. (x .EQ. 0.0_dp .AND. (n .EQ. 0 .OR. n .EQ. 1))) THEN + IF (n < 0 .OR. x < 0.0_dp .OR. (x == 0.0_dp .AND. (n == 0 .OR. n == 1))) THEN CPABORT("Invalid argument") - ELSE IF (n .EQ. 0) THEN !Special case. + ELSE IF (n == 0) THEN !Special case. expint = EXP(-x)/x - ELSE IF (x .EQ. 0.0_dp) THEN !Another special case. + ELSE IF (x == 0.0_dp) THEN !Another special case. expint = 1.0_dp/nm1 - ELSE IF (x .GT. 1.0_dp) THEN !Lentz's algorithm (5.2). + ELSE IF (x > 1.0_dp) THEN !Lentz's algorithm (5.2). b = x + n c = 1.0_dp/FPMIN d = 1.0_dp/b @@ -1421,14 +1421,14 @@ CONTAINS c = b + a/c del = c*d h = h*del - IF (ABS(del - 1.0_dp) .LT. EPS) THEN + IF (ABS(del - 1.0_dp) < EPS) THEN expint = h*EXP(-x) RETURN END IF END DO CPABORT("continued fraction failed in expint") ELSE !Evaluate series. - IF (nm1 .NE. 0) THEN !Set first term. + IF (nm1 /= 0) THEN !Set first term. expint = 1.0_dp/nm1 ELSE expint = -LOG(x) - euler @@ -1436,7 +1436,7 @@ CONTAINS fact = 1.0_dp DO i = 1, MAXIT fact = -fact*x/i - IF (i .NE. nm1) THEN + IF (i /= nm1) THEN del = -fact/(i - nm1) ELSE psi = -euler !Compute I(n). @@ -1446,7 +1446,7 @@ CONTAINS del = fact*(-LOG(x) + psi) END IF expint = expint + del - IF (ABS(del) .LT. ABS(expint)*EPS) RETURN + IF (ABS(del) < ABS(expint)*EPS) RETURN END DO CPABORT("series failed in expint") END IF @@ -1535,7 +1535,7 @@ CONTAINS g = 100.0_dp*ABS(apq) IF (tresh < ABS(apq)) THEN h = diq - dip - IF ((ABS(h) + g) .NE. ABS(h)) THEN + IF ((ABS(h) + g) /= ABS(h)) THEN theta = 0.5_dp*h/apq t = 1.0_dp/(ABS(theta) + SQRT(1.0_dp + theta**2)) IF (theta < 0.0_dp) t = -t @@ -1705,7 +1705,7 @@ CONTAINS delta_r = f0/fprime0 r0 = r0 - delta_r CALL eval_transc_func(r0, eps, omg, f0, fprime0) - IF (ABS(delta_r) .LT. abstol .OR. ABS(f0) .LT. soltol) EXIT + IF (ABS(delta_r) < abstol .OR. ABS(f0) < soltol) EXIT END DO CPASSERT(iter <= itermax) r_cutoff = r0 diff --git a/src/common/parallel_rng_types.F b/src/common/parallel_rng_types.F index d22e23d1ff..e16f4b24f3 100644 --- a/src/common/parallel_rng_types.F +++ b/src/common/parallel_rng_types.F @@ -512,7 +512,7 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: antithetic, extended_precision TYPE(rng_stream_type) :: rng_stream - IF (LEN_TRIM(name) .GT. rng_name_length) & + IF (LEN_TRIM(name) > rng_name_length) & CPABORT("given random number generator name is too long") rng_stream%name = TRIM(name) diff --git a/src/common/parallel_rng_types_unittest.F b/src/common/parallel_rng_types_unittest.F index a8175ea496..b91c372acb 100644 --- a/src/common/parallel_rng_types_unittest.F +++ b/src/common/parallel_rng_types_unittest.F @@ -32,7 +32,7 @@ PROGRAM parallel_rng_types_TEST nsamples = 1000 nargs = command_argument_count() - IF (nargs .GT. 1) & + IF (nargs > 1) & ERROR STOP "Usage: parallel_rng_types_TEST []" IF (nargs == 1) THEN diff --git a/src/common/powell.F b/src/common/powell.F index 9ce59efbfb..5e4956aa23 100644 --- a/src/common/powell.F +++ b/src/common/powell.F @@ -1461,7 +1461,7 @@ CONTAINS ! HCOL, GC, GD, S and W will be used for working space. ! ! The step D is calculated in a way that attempts to maximize the mo -! of LFUNC(XOPT+D), subject to the bound ||D|| .LE. DELTA, where LFU +! of LFUNC(XOPT+D), subject to the bound ||D|| <= DELTA, where LFU ! the KNEW-th Lagrange function. ! diff --git a/src/common/reference_manager.F b/src/common/reference_manager.F index 995bc0492a..36fd322267 100644 --- a/src/common/reference_manager.F +++ b/src/common/reference_manager.F @@ -179,7 +179,7 @@ CONTAINS mylen = LEN_TRIM(citation_key) ires = 0 DO I = 1, mylen - IF (INDEX("0123456789thequickbrownfoxjumpsoverthelazydogTHEQUICKBROWNFOXJUMPSOVERTHELAZYDOG", citation_key(i:i)) .NE. 0) THEN + IF (INDEX("0123456789thequickbrownfoxjumpsoverthelazydogTHEQUICKBROWNFOXJUMPSOVERTHELAZYDOG", citation_key(i:i)) /= 0) THEN ires = ires + 1 tmp = citation_key(i:i) citation_key(ires:ires) = tmp diff --git a/src/common/string_table.F b/src/common/string_table.F index bd324f6f61..88e7799722 100644 --- a/src/common/string_table.F +++ b/src/common/string_table.F @@ -9,7 +9,7 @@ !> \brief generates a unique id number for a string (str2id) that can be used !> two compare two strings. I.e. !> if (str1==str2) => str2id(str1)==str2id(str2) -!> if (str1.NE.str2) => str2id(str1).NE.str2id(str2) +!> if (str1/=str2) => str2id(str1)/=str2id(str2) !> and the other way around. Given an id, the string can be retrieved. !> \note !> the purpose of this routine is to speed up string handling, diff --git a/src/common/string_utilities.F b/src/common/string_utilities.F index 7976e0f7bd..d95b14bfc6 100644 --- a/src/common/string_utilities.F +++ b/src/common/string_utilities.F @@ -151,7 +151,7 @@ CONTAINS !> 11.2004 created [Joost VandeVondele ] !> \note !> can be used instead of the illegal (/"12","1234"/) generating -!> s2a("12","1234").EQ.(/"12 ","1234"/) +!> s2a("12","1234")==(/"12 ","1234"/) ! ************************************************************************************************** PURE FUNCTION s2a_1(s1) RESULT(a) CHARACTER(LEN=*), INTENT(IN) :: s1 diff --git a/src/common/timings.F b/src/common/timings.F index 1607b9b700..9cae931fbb 100644 --- a/src/common/timings.F +++ b/src/common/timings.F @@ -236,7 +236,7 @@ CONTAINS routine_id = routine_name2id(routine_name_dsl) ! ! Take timings when the timings_level is appropriated - IF (global_timings_level .NE. 0 .OR. routine_id .EQ. root_cp2k_id) THEN + IF (global_timings_level /= 0 .OR. routine_id == root_cp2k_id) THEN cs_entry%walltime_start = m_walltime() cs_entry%energy_start = m_energy() END IF @@ -320,7 +320,7 @@ CONTAINS wt_elapsed = 0 en_elapsed = 0 ! Take timings only when the start time is >=0, i.e. the timings_level is appropriated - IF (cs_entry%walltime_start .GE. 0) THEN + IF (cs_entry%walltime_start >= 0) THEN wt_now = m_walltime() en_now = m_energy() ! add the elapsed time for this timeset/timestop to the time accumulator diff --git a/src/commutator_rpnl.F b/src/commutator_rpnl.F index 297e2a43af..a594ea747d 100644 --- a/src/commutator_rpnl.F +++ b/src/commutator_rpnl.F @@ -531,7 +531,7 @@ CONTAINS rf = ref_point my_ref = .TRUE. ELSE ! use my_ref = False in periodic case, corresponds to distributed ref point - IF (order .GT. 1) THEN + IF (order > 1) THEN CPWARN("Not clear how to define reference point for order > 1 in periodic cells.") END IF END IF diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index d4775a3e3a..b38a4a1472 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -1928,7 +1928,7 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T2,A,T76,I5)") & "DFT| Charge", dft_control%charge - IF (dft_control%sic_method_id .NE. sic_none) CALL cite_reference(VandeVondele2005b) + IF (dft_control%sic_method_id /= sic_none) CALL cite_reference(VandeVondele2005b) SELECT CASE (dft_control%sic_method_id) CASE (sic_none) tmpstr = "NO" @@ -2522,7 +2522,7 @@ 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) .GT. 1) & + IF (SIZE(qs_control%ddapc_restraint_control) > 1) & WRITE (UNIT=output_unit, FMT="(T2,A,T3,I8)") & "QS| parameters for DDAPC restraint number", i WRITE (UNIT=output_unit, FMT="(T2,A,T73,ES8.1)") & @@ -2595,7 +2595,7 @@ CONTAINS IF (PRESENT(ddapc_restraint_section)) THEN IF (ASSOCIATED(qs_control%ddapc_restraint_control)) THEN - IF (SIZE(qs_control%ddapc_restraint_control) .GE. 2) & + IF (SIZE(qs_control%ddapc_restraint_control) >= 2) & CPABORT("ET_COUPLING cannot be used in combination with a normal restraint") ELSE ddapc_section => ddapc_restraint_section @@ -2666,7 +2666,7 @@ CONTAINS ddapc_restraint_control%coeff(jj) = rtmplist(j) END DO END DO - IF (jj < ddapc_restraint_control%natoms .AND. jj .NE. 0) & + IF (jj < ddapc_restraint_control%natoms .AND. jj /= 0) & CPABORT("Need no or the same number of coeff as there are atoms.") END DO k = 0 diff --git a/src/cp_dbcsr_cp2k_link.F b/src/cp_dbcsr_cp2k_link.F index a2884ae40c..a7cb05ccaf 100644 --- a/src/cp_dbcsr_cp2k_link.F +++ b/src/cp_dbcsr_cp2k_link.F @@ -489,7 +489,7 @@ CONTAINS new_atom_b = .FALSE. CYCLE END IF - IF (blk_cnt + nadd .GT. SIZE(rows)) THEN + IF (blk_cnt + nadd > SIZE(rows)) THEN ALLOCATE (tmp(blk_cnt + nadd)) tmp(1:blk_cnt) = rows(1:blk_cnt) DEALLOCATE (rows) @@ -674,7 +674,7 @@ CONTAINS DO jshell = 1, nshell_b(jset) gto_loop: DO ipgf = 1, npgf_a(iset) DO jpgf = 1, npgf_b(jset) - IF (rpgfa(ipgf, iset) + rpgfb(jpgf, jset) .GE. dab) THEN + IF (rpgfa(ipgf, iset) + rpgfb(jpgf, jset) >= dab) THEN ! more selective screening with radius calculated for each primitive GTO r_a = exp_radius(l_a(ishell, iset), & zet_a(ipgf, iset), & @@ -684,8 +684,8 @@ CONTAINS zet_b(jpgf, jset), & eps_pgf_orb, & gcc_b(jpgf, jshell, jset)) - IF (r_a + r_b .GE. dab) THEN - IF (irow .EQ. iatom) THEN + IF (r_a + r_b >= dab) THEN + IF (irow == iatom) THEN screen_blk(isgf + 1:isgf + nso(l_a(ishell, iset)), & jsgf + 1:jsgf + nso(l_b(jshell, jset))) = 1.0_dp ELSE diff --git a/src/cp_dbcsr_operations.F b/src/cp_dbcsr_operations.F index e5188beed4..a4a9dfeef1 100644 --- a/src/cp_dbcsr_operations.F +++ b/src/cp_dbcsr_operations.F @@ -336,7 +336,7 @@ CONTAINS ! calculate first_row and last_row ALLOCATE (local_row_sizes(nblkrows_total)) local_row_sizes(:) = 0 - IF (nblkrows_local .GE. 1) THEN + IF (nblkrows_local >= 1) THEN DO row = 1, nblkrows_local local_row_sizes(local_rows(row)) = row_blk_size(local_rows(row)) END DO @@ -348,7 +348,7 @@ CONTAINS ! calculate first_col and last_col ALLOCATE (local_col_sizes(nblkcols_total)) local_col_sizes(:) = 0 - IF (nblkcols_local .GE. 1) THEN + IF (nblkcols_local >= 1) THEN DO col = 1, nblkcols_local local_col_sizes(local_cols(col)) = col_blk_size(local_cols(col)) END DO @@ -480,18 +480,18 @@ CONTAINS IF (PRESENT(ncol)) my_ncol = ncol my_alpha2 = 0.0_dp - IF (dbcsr_get_matrix_type(matrix_a) .EQ. dbcsr_type_symmetric) my_alpha2 = my_alpha - IF (dbcsr_get_matrix_type(matrix_a) .EQ. dbcsr_type_antisymmetric) my_alpha2 = -my_alpha + IF (dbcsr_get_matrix_type(matrix_a) == dbcsr_type_symmetric) my_alpha2 = my_alpha + IF (dbcsr_get_matrix_type(matrix_a) == dbcsr_type_antisymmetric) my_alpha2 = -my_alpha - has_symm = (dbcsr_get_matrix_type(matrix_a) .EQ. dbcsr_type_symmetric .OR. & - dbcsr_get_matrix_type(matrix_a) .EQ. dbcsr_type_antisymmetric) + has_symm = (dbcsr_get_matrix_type(matrix_a) == dbcsr_type_symmetric .OR. & + dbcsr_get_matrix_type(matrix_a) == dbcsr_type_antisymmetric) !$OMP PARALLEL DEFAULT(NONE) SHARED(matrix_a,vec_b,vec_c,ncol,my_alpha2,my_alpha,my_ncol,has_symm) & !$OMP PRIVATE(iter,row,col,data_d,rowoff,coloff) CALL dbcsr_iterator_readonly_start(iter, matrix_a, dynamic=.TRUE., dynamic_byrows=.TRUE.) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, row, col, data_d, row_offset=rowoff, col_offset=coloff) - IF (my_ncol .NE. 1) THEN + IF (my_ncol /= 1) THEN CALL dgemm('N', 'N', & SIZE(data_d, 1), my_ncol, SIZE(data_d, 2), & my_alpha, data_d(1, 1), SIZE(data_d, 1), & @@ -513,8 +513,8 @@ CONTAINS CALL dbcsr_iterator_readonly_start(iter, matrix_a) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, row, col, data_d, row_offset=rowoff, col_offset=coloff) - IF (row .NE. col) THEN - IF (my_ncol .NE. 1) THEN + IF (row /= col) THEN + IF (my_ncol /= 1) THEN CALL dgemm('T', 'N', & SIZE(data_d, 2), my_ncol, SIZE(data_d, 1), & my_alpha2, data_d(1, 1), SIZE(data_d, 1), & @@ -586,12 +586,12 @@ CONTAINS CALL cp_fm_get_info(fm_in, ncol_global=k_in) !write(*,*)routineN//" -----------------------------------" - !IF (k_in .NE. k_out) & + !IF (k_in /= k_out) & ! WRITE(*,'(3(A,I5,1X),2(A,F5.2,1X))')& ! routineN//" ncol", ncol,'k_in',k_in,'k_out',k_out,& ! 'alpha',my_alpha,'beta',my_beta - IF (ncol .GT. 0 .AND. k_out .GT. 0 .AND. k_in .GT. 0) THEN + IF (ncol > 0 .AND. k_out > 0 .AND. k_in > 0) THEN CALL dbcsr_get_info(matrix, row_blk_size=row_blk_size, col_blk_size=col_blk_size, distribution=dist) CALL dbcsr_create_dist_r_unrot(dist_right_in, dist, k_in, col_blk_size_right_in) @@ -615,7 +615,7 @@ CONTAINS row_blk_size, col_blk_size_right_out) CALL copy_fm_to_dbcsr(fm_in, in) - IF (ncol .NE. k_out .OR. my_beta .NE. 0.0_dp) & + IF (ncol /= k_out .OR. my_beta /= 0.0_dp) & CALL copy_fm_to_dbcsr(fm_out, out) CALL timeset(routineN//'_core', timing_handle_mult) @@ -652,19 +652,19 @@ CONTAINS n1 = SIZE(sizes1) n2 = SIZE(sizes2) - IF (n1 .NE. n2) & + IF (n1 /= n2) & CPABORT("distributions must be equal!") sizes1(1:n1) = sizes2(1:n1) used = SUM(sizes1(1:n1)) ! If sizes1 does not cover everything, then we increase the ! size of the last block; otherwise we reduce the blocks ! (from the end) until it is small enough. - IF (used .LT. full_num) THEN + IF (used < full_num) THEN sizes1(n1) = sizes1(n1) + full_num - used ELSE left = used - full_num p = n1 - DO WHILE (left .GT. 0 .AND. p .GT. 0) + DO WHILE (left > 0 .AND. p > 0) rm = MIN(left, sizes1(p)) sizes1(p) = sizes1(p) - rm left = left - rm @@ -726,7 +726,7 @@ CONTAINS NULLIFY (col_dist_left) - IF (ncol .GT. 0) THEN + IF (ncol > 0) THEN IF (.NOT. dbcsr_valid_index(sparse_matrix)) & CPABORT("sparse_matrix must pre-exist") ! @@ -834,7 +834,7 @@ 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) .GT. 1e-12_dp) THEN + 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) @@ -1011,7 +1011,7 @@ CONTAINS NULLIFY (block_distribution) NULLIFY (block_size) ! Define the sizes on which we build the distribution. - IF (nelements .GT. 0) THEN + IF (nelements > 0) THEN nblocks = CEILING(REAL(nelements, KIND=dp)/REAL(max_elements_per_block, KIND=dp)) max_blocks_per_bin = CEILING(REAL(nblocks, KIND=dp)/REAL(nbins, KIND=dp)) @@ -1039,7 +1039,7 @@ CONTAINS DO blk_layer = 1, max_blocks_per_bin DO bin = 0, nbins - 1 els = MIN(max_elements_per_block, nelements - element_stack) - IF (els .GT. 0) THEN + IF (els > 0) THEN element_stack = element_stack + els nblks = nblks + 1 blk_dist(nblks) = bin @@ -1050,7 +1050,7 @@ CONTAINS END DO END DO ! Create the output arrays. - IF (nblks .EQ. estimated_blocks) THEN + IF (nblks == estimated_blocks) THEN block_distribution => blk_dist block_size => blk_sizes ELSE @@ -1174,14 +1174,14 @@ CONTAINS ! --------------------------------------------------------------------------- - IF (MOD(nbins*nimages, multiplicity) .NE. 0) THEN + IF (MOD(nbins*nimages, multiplicity) /= 0) THEN CPWARN("mulitplicity is not divisor of new process grid coordinate") END IF old_nbins = (nbins*nimages)/multiplicity ALLOCATE (bin_multiplier(0:old_nbins - 1)) bin_multiplier(:) = 0 DO i = 1, SIZE(new_bins) - IF (i .LE. SIZE(source_bins)) THEN + IF (i <= SIZE(source_bins)) THEN bin = source_bins(i) ELSE ! Fill remainder with a cyclic distribution @@ -1191,7 +1191,7 @@ CONTAINS new_bins(i) = virtual_bin/nimages images(i) = 1 + MOD(virtual_bin, nimages) bin_multiplier(bin) = bin_multiplier(bin) + 1 - IF (bin_multiplier(bin) .GE. multiplicity) THEN + IF (bin_multiplier(bin) >= multiplicity) THEN bin_multiplier(bin) = 0 END IF END DO @@ -1227,30 +1227,30 @@ CONTAINS INTEGER, DIMENSION(:), POINTER :: cd_data, rd_data ! Row sizes - IF (nrow_block .EQ. 0) THEN + IF (nrow_block == 0) THEN nblkrows = 0 sz = 0 ELSE nblkrows = nrows/nrow_block sz = MOD(nrows, nrow_block) END IF - IF (sz .GT. 0) nblkrows = nblkrows + 1 + IF (sz > 0) nblkrows = nblkrows + 1 ALLOCATE (row_blk_sizes(nblkrows), rd_data(nblkrows)) row_blk_sizes = nrow_block - IF (sz .NE. 0) row_blk_sizes(nblkrows) = sz + IF (sz /= 0) row_blk_sizes(nblkrows) = sz ! Column sizes - IF (ncol_block .EQ. 0) THEN + IF (ncol_block == 0) THEN nblkcols = 0 sz = 0 ELSE nblkcols = ncolumns/ncol_block sz = MOD(ncolumns, ncol_block) END IF - IF (sz .GT. 0) nblkcols = nblkcols + 1 + IF (sz > 0) nblkcols = nblkcols + 1 ALLOCATE (col_blk_sizes(nblkcols), cd_data(nblkcols)) col_blk_sizes = ncol_block - IF (sz .NE. 0) col_blk_sizes(nblkcols) = sz + IF (sz /= 0) col_blk_sizes(nblkcols) = sz ! IF (debug_mod) THEN WRITE (*, *) routineN//" nrows,nrow_block,nblkrows=", & diff --git a/src/cp_dbcsr_output.F b/src/cp_dbcsr_output.F index ee7e379997..8148166538 100644 --- a/src/cp_dbcsr_output.F +++ b/src/cp_dbcsr_output.F @@ -653,7 +653,7 @@ CONTAINS END IF occupation = -1.0_dp - IF (nblock_tot .NE. 0) occupation = 100.0_dp*REAL(nblock_sum, dp)/REAL(nblock_tot, dp) + IF (nblock_tot /= 0) occupation = 100.0_dp*REAL(nblock_sum, dp)/REAL(nblock_tot, dp) IF (ionode) THEN WRITE (UNIT=output_unit, FMT="(/,/,T2,A)") & diff --git a/src/cp_ddapc.F b/src/cp_ddapc.F index 4b3ba64b46..3e98083aa5 100644 --- a/src/cp_ddapc.F +++ b/src/cp_ddapc.F @@ -118,7 +118,7 @@ CONTAINS IF (dft_control%qs_control%ddapc_restraint) THEN ddapc_size = SIZE(dft_control%qs_control%ddapc_restraint_control) - IF (SIZE(energy%ddapc_restraint) .NE. ddapc_size) THEN + IF (SIZE(energy%ddapc_restraint) /= ddapc_size) THEN DEALLOCATE (energy%ddapc_restraint) ALLOCATE (energy%ddapc_restraint(ddapc_size)) END IF diff --git a/src/cp_ddapc_methods.F b/src/cp_ddapc_methods.F index 96a5d40741..bc72d81693 100644 --- a/src/cp_ddapc_methods.F +++ b/src/cp_ddapc_methods.F @@ -137,7 +137,7 @@ CONTAINS IF (g2 > gcut2) EXIT igmax = ig END DO - IF (igmax .GE. s_dim) THEN + IF (igmax >= s_dim) THEN ALLOCATE (my_bv(s_dim:igmax)) ALLOCATE (my_bvw(s_dim:igmax)) ! @@ -218,7 +218,7 @@ CONTAINS IF (g2 > gcut2) EXIT igmax = ig END DO - IF (igmax .GE. s_dim) THEN + IF (igmax >= s_dim) THEN ALLOCATE (my_Am(s_dim:igmax)) ALLOCATE (my_Amw(s_dim:igmax)) ALLOCATE (gfunc_sq(s_dim:igmax, SIZE(radii), SIZE(radii))) @@ -303,7 +303,7 @@ CONTAINS IF (g2 > gcut2) EXIT igmax = ig END DO - IF (igmax .GE. s_dim) THEN + IF (igmax >= s_dim) THEN ALLOCATE (my_dbv(3, s_dim:igmax)) ALLOCATE (my_dbvw(s_dim:igmax)) DO iparticle = 1, SIZE(particle_set) @@ -403,7 +403,7 @@ CONTAINS Nr = SIZE(radii) Np = SIZE(particle_set) Ng = igmax - s_dim + 1 - IF (igmax .GE. s_dim) THEN + IF (igmax >= s_dim) THEN ALLOCATE (lhs(nparticles*Nr, Ng)) ALLOCATE (rhs(Ng, Np*Nr)) @@ -507,7 +507,7 @@ CONTAINS igmax = ig END DO - IF (igmax .GE. s_dim) THEN + IF (igmax >= s_dim) THEN ALLOCATE (g_dot_rvec_sin(1:igmax - s_dim + 1, SIZE(particle_set))) ALLOCATE (g_dot_rvec_cos(1:igmax - s_dim + 1, SIZE(particle_set))) diff --git a/src/cp_ddapc_util.F b/src/cp_ddapc_util.F index ba3e423681..14d885fc50 100644 --- a/src/cp_ddapc_util.F +++ b/src/cp_ddapc_util.F @@ -726,10 +726,10 @@ CONTAINS CALL rho_tot_g%pw_grid%para%group%sum(bv2) ddbv(:) = (bv1(:) - bv2(:))/(2.0_dp*dx) DO kk = 1, SIZE(ddbv) - IF (ddbv(kk) .GT. 1.0E-8_dp) THEN + IF (ddbv(kk) > 1.0E-8_dp) THEN v0 = ABS(dbv(kk, i) - ddbv(kk))/ddbv(kk)*100.0_dp WRITE (*, *) "Error % on B ::", v0 - IF (v0 .GT. 0.1_dp) THEN + IF (v0 > 0.1_dp) THEN WRITE (*, '(A,2I5,2F15.9)') "ERROR IN DERIVATIVE OF B VECTOR, IPARTICLE, ICOORD:", iparticle, i, & dbv(kk, i), ddbv(kk) CPABORT("") @@ -806,10 +806,10 @@ CONTAINS ddAm(:, :) = (Am1 - Am2)/(2.0_dp*dx) DO kk = 1, SIZE(ddAm, 1) DO ll = 1, SIZE(ddAm, 2) - IF (ddAm(kk, ll) .GT. 1.0E-8_dp) THEN + IF (ddAm(kk, ll) > 1.0E-8_dp) THEN v0 = ABS(dAm(kk, ll, i) - ddAm(kk, ll))/ddAm(kk, ll)*100.0_dp WRITE (*, *) "Error % on A ::", v0, Am1(kk, ll), Am2(kk, ll), iparticle, i, kk, ll - IF (v0 .GT. 0.1_dp) THEN + IF (v0 > 0.1_dp) THEN WRITE (*, '(A,4I5,2F15.9)') "ERROR IN DERIVATIVE OF A MATRIX, IPARTICLE, ICOORD:", iparticle, i, kk, ll, & dAm(kk, ll, i), ddAm(kk, ll) CPABORT("") @@ -876,7 +876,7 @@ CONTAINS ext_rho_tot_g=rho_tot_g, Itype_of_density=type_of_density) ddqv(:) = (qtot1 - qtot2)/(2.0_dp*dx) DO kk = 1, SIZE(qtot1) - 1, SIZE(radii) - IF (ANY(ddqv(kk:kk + 2) .GT. 1.0E-8_dp)) THEN + IF (ANY(ddqv(kk:kk + 2) > 1.0E-8_dp)) THEN WRITE (*, '(A,2F12.6,F12.2)') "Error :", SUM(dqv(kk:kk + 2, iparticle, i)), SUM(ddqv(kk:kk + 2)), & ABS((SUM(ddqv(kk:kk + 2)) - SUM(dqv(kk:kk + 2, iparticle, i)))/SUM(ddqv(kk:kk + 2))*100.0_dp) END IF diff --git a/src/cp_eri_mme_interface.F b/src/cp_eri_mme_interface.F index f6ee3bc6c8..fe200fd4ec 100644 --- a/src/cp_eri_mme_interface.F +++ b/src/cp_eri_mme_interface.F @@ -311,14 +311,14 @@ CONTAINS unit_nr = param%par%unit_nr IF (unit_nr > 0) THEN - IF (count_2c .GT. 0) THEN + IF (count_2c > 0) THEN WRITE (unit_nr, '(/T2, A)') "ERI_MME| Percentage of 2-center integrals evaluated in" WRITE (unit_nr, '(T2, A, T76, F5.1)') "ERI_MME| G space:", & 100.0_dp*param%G_count_2c/count_2c WRITE (unit_nr, '(T2, A, T76, F5.1/)') "ERI_MME| R space:", & 100.0_dp*param%R_count_2c/count_2c END IF - IF (count_3c .GT. 0) THEN + IF (count_3c > 0) THEN WRITE (unit_nr, '(/T2, A)') "ERI_MME| Percentage of 3-center integrals evaluated in" WRITE (unit_nr, '(T2, A, T76, F5.1)') "ERI_MME| G/G space:", & 100.0_dp*param%GG_count_3c/count_3c @@ -468,7 +468,7 @@ CONTAINS ! (and min zet for minimax error) DO ikind = 1, nkind DO ibasis = 1, nbasis - IF (ibasis .EQ. 1) THEN + IF (ibasis == 1) THEN basis_type = basis_type_1 ELSE basis_type = basis_type_2 @@ -481,7 +481,7 @@ CONTAINS l_m = MAX(l_m, MAXVAL(basis_set%lmax(:))) DO iset = 1, nset zet_m = MAX(zet_m, MAXVAL(basis_set%zet(1:npgf(iset), iset))) - IF (zet_min .LT. 0.0_dp) THEN + IF (zet_min < 0.0_dp) THEN zet_min = MINVAL(basis_set%zet(1:npgf(iset), iset)) ELSE zet_min = MIN(zet_min, MINVAL(basis_set%zet(1:npgf(iset), iset))) @@ -493,7 +493,7 @@ CONTAINS ! 2) get largest zet for max l and largest l for max zet DO ikind = 1, nkind DO ibasis = 1, nbasis - IF (ibasis .EQ. 1) THEN + IF (ibasis == 1) THEN basis_type = basis_type_1 ELSE basis_type = basis_type_2 @@ -502,8 +502,8 @@ CONTAINS basis_type=basis_type) DO iset = 1, basis_set%nset DO ipgf = 1, basis_set%npgf(iset) - IF (ABS(zet_m - basis_set%zet(ipgf, iset)) .LE. (zet_m*1.0E-12_dp) & - .AND. (basis_set%lmax(iset) .GT. l_zet)) THEN + IF (ABS(zet_m - basis_set%zet(ipgf, iset)) <= (zet_m*1.0E-12_dp) & + .AND. (basis_set%lmax(iset) > l_zet)) THEN l_zet = basis_set%lmax(iset) END IF END DO @@ -511,7 +511,7 @@ CONTAINS END DO END DO - CPASSERT(l_zet .GE. 0) + CPASSERT(l_zet >= 0) zet_max = zet_m @@ -786,7 +786,7 @@ 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 .LE. 0) & + IF (nzet <= 0) & CPABORT("Number of exponents NZET must be greater than 0.") CALL init_orbital_pointers(l_max) @@ -795,7 +795,7 @@ CONTAINS ALLOCATE (zet(nzet)) zet(1) = zetmin - IF (nzet .GT. 1) THEN + IF (nzet > 1) THEN zet_fac = (zetmax/zetmin)**(1.0_dp/(nzet - 1)) DO i = 1, nzet - 1 zet(i + 1) = zet(i)*zet_fac diff --git a/src/cp_external_control.F b/src/cp_external_control.F index daa9e61403..c9a41b655c 100644 --- a/src/cp_external_control.F +++ b/src/cp_external_control.F @@ -58,7 +58,7 @@ CONTAINS INTEGER, INTENT(IN) :: in_external_master_id INTEGER, INTENT(IN), OPTIONAL :: in_scf_energy_message_tag, in_exit_tag - CPASSERT(in_external_master_id .GE. 0) + CPASSERT(in_external_master_id >= 0) external_comm = comm external_master_id = in_external_master_id @@ -67,7 +67,7 @@ CONTAINS scf_energy_message_tag = in_scf_energy_message_tag IF (PRESENT(in_exit_tag)) THEN ! the exit tag should be different from the mpi_probe tag default - CPASSERT(in_exit_tag .NE. -1) + CPASSERT(in_exit_tag /= -1) exit_tag = in_exit_tag END IF END SUBROUTINE set_external_comm @@ -123,10 +123,10 @@ CONTAINS exit_fname_level = TRIM(logger%iter_info%project_name)//"."//TRIM(exit_gname_level) ! check for incomming messages and if it is tagged with the exit tag - IF (exit_tag .NE. -1) THEN + IF (exit_tag /= -1) THEN i = external_master_id CALL external_comm%probe(source=i, tag=tag) - IF (tag .EQ. exit_tag) should_stop = .TRUE. + IF (tag == exit_tag) should_stop = .TRUE. END IF IF (logger%para_env%is_source()) THEN @@ -214,7 +214,7 @@ CONTAINS IF ((.NOT. should_stop) .AND. (my_target_time > 0.0_dp)) THEN ! Check for execution time time_check = m_walltime() - my_start_time - IF (time_check .GT. my_target_time) THEN + IF (time_check > my_target_time) THEN should_stop = .TRUE. WRITE (UNIT=cp_logger_get_default_unit_nr(logger), FMT="(/,T2,A,f12.3,A)") & "*** "//TRIM(flag)//" run terminated - exceeded requested execution time:", & diff --git a/src/ct_methods.F b/src/ct_methods.F index 1465137626..9623fdae06 100644 --- a/src/ct_methods.F +++ b/src/ct_methods.F @@ -95,7 +95,7 @@ CONTAINS CPABORT("q-update is possible only with p-update") END IF - IF (cts_env%tensor_type .EQ. tensor_up_down) THEN + IF (cts_env%tensor_type == tensor_up_down) THEN CPABORT("riccati is not implemented for biorthogonal basis") END IF @@ -129,8 +129,8 @@ CONTAINS END IF END IF - IF (cts_env%tensor_type .NE. tensor_up_down .AND. & - cts_env%tensor_type .NE. tensor_orthogonal) THEN + IF (cts_env%tensor_type /= tensor_up_down .AND. & + cts_env%tensor_type /= tensor_orthogonal) THEN CPABORT("illegal tensor flag") END IF @@ -176,7 +176,7 @@ CONTAINS IF (ASSOCIATED(cts_env%matrix_x_guess)) THEN CALL dbcsr_copy(cts_env%matrix_x, & cts_env%matrix_x_guess) - IF (cts_env%tensor_type .EQ. tensor_orthogonal) THEN + IF (cts_env%tensor_type == tensor_orthogonal) THEN ! bring x from contravariant-covariant representation ! to the orthogonal/cholesky representation ! use res as temporary storage @@ -241,7 +241,7 @@ CONTAINS CALL matrix_forward_transform(cts_env%matrix_x, u_qq, u_pp, & cts_env%eps_filter) - IF (cts_env%max_iter .GE. 0) THEN + IF (cts_env%max_iter >= 0) THEN CALL solve_riccati_equation( & pp=matrix_pp, & @@ -355,7 +355,7 @@ CONTAINS !CALL dbcsr_print(matrix_qp) !CALL dbcsr_print(matrix_pp) - IF (cts_env%max_iter .GE. 0) THEN + IF (cts_env%max_iter >= 0) THEN CALL solve_riccati_equation( & pp=matrix_pp, & @@ -407,7 +407,7 @@ CONTAINS IF (cts_env%update_p) THEN - IF (cts_env%tensor_type .EQ. tensor_up_down) THEN + IF (cts_env%tensor_type == tensor_up_down) THEN CPABORT("orbital update is NYI for this tensor type") END IF @@ -481,7 +481,7 @@ CONTAINS ELSE ! do not update p - IF (cts_env%tensor_type .EQ. tensor_orthogonal) THEN + IF (cts_env%tensor_type == tensor_orthogonal) THEN ! bring x to contravariant-covariant representation CALL dbcsr_create(matrix_qp, & template=cts_env%matrix_qp_template, & @@ -828,7 +828,7 @@ CONTAINS DO ! (re)-compute the residuals - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN CALL dbcsr_copy(res, qp) IF (present_oo) THEN CALL dbcsr_multiply("N", "N", +1.0_dp, qq, x, 0.0_dp, res_trial, & @@ -876,8 +876,8 @@ CONTAINS END IF ! check convergence and other exit criteria - converged = (best_norm .LT. eps_convergence) - IF (converged .OR. (iteration .GE. max_iter)) THEN + converged = (best_norm < eps_convergence) + IF (converged .OR. (iteration >= max_iter)) THEN prepare_to_exit = .TRUE. END IF @@ -885,7 +885,7 @@ CONTAINS ! update aux1=-pp-pq.x.oo and aux2=qq-vv.x.pq IF (quadratic_term) THEN - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN IF (present_oo) THEN CALL dbcsr_multiply("N", "N", -1.0_dp, pq, x, 0.0_dp, oo1, & filter_eps=eps_filter) @@ -946,7 +946,7 @@ CONTAINS ! compute preconditioner !IF (iteration.eq.0.OR.(mod(iteration,update_prec_freq).eq.0)) THEN - IF (iteration .EQ. 0) THEN + IF (iteration == 0) THEN CALL create_preconditioner(prec, aux1, aux2, eps_filter) !restart_conjugator=.TRUE. !CALL dbcsr_set(prec,1.0_dp) @@ -954,7 +954,7 @@ CONTAINS END IF ! compute the conjugation coefficient - beta - IF ((iteration .EQ. 0) .OR. restart_conjugator) THEN + IF ((iteration == 0) .OR. restart_conjugator) THEN beta = 0.0_dp ELSE restart_conjugator = .FALSE. @@ -1107,7 +1107,7 @@ CONTAINS ! find step size CALL analytic_line_search(c0, c1, c2, c3, step_size, nsteps) - IF (nsteps .EQ. 0) THEN + IF (nsteps == 0) THEN CPABORT("no step sizes!") END IF ! if we have several possible step sizes @@ -1124,7 +1124,7 @@ CONTAINS ! tensor_up_down !obj_function=0.5_dp*(dbcsr_frobenius_norm(res_trial))**2 obj_function = dbcsr_maxabs(res_trial) - IF (obj_function .LT. best_norm) THEN + IF (obj_function < best_norm) THEN best_norm = obj_function best_step_size = step_size(istep) END IF @@ -1142,8 +1142,8 @@ CONTAINS !change_ecorr=ecorr-change_ecorr ! check convergence and other exit criteria - converged = (best_norm .LT. eps_convergence) - IF (converged .OR. (iteration .GE. max_iter)) THEN + converged = (best_norm < eps_convergence) + IF (converged .OR. (iteration >= max_iter)) THEN prepare_to_exit = .TRUE. END IF @@ -1387,9 +1387,9 @@ CONTAINS pi = ACOS(-1.0_dp) ! Step 0: Check coefficients and find the true order of the eq - IF (a .EQ. 0.0_dp) THEN - IF (b .EQ. 0.0_dp) THEN - IF (c .EQ. 0.0_dp) THEN + IF (a == 0.0_dp) THEN + IF (b == 0.0_dp) THEN + IF (c == 0.0_dp) THEN ! Non-equation, no valid solutions nroots = 0 ELSE @@ -1400,11 +1400,11 @@ CONTAINS ELSE ! Quadratic equation with max two roots. DD = c*c - 4.0_dp*b*d - IF (DD .GT. 0.0_dp) THEN + IF (DD > 0.0_dp) THEN nroots = 2 x(1) = (-c + SQRT(DD))/2.0_dp/b x(2) = (-c - SQRT(DD))/2.0_dp/b - ELSE IF (DD .LT. 0.0_dp) THEN + ELSE IF (DD < 0.0_dp) THEN nroots = 0 ELSE nroots = 1 @@ -1420,7 +1420,7 @@ CONTAINS ! Calculate DD DD = p*p*p/27.0_dp + q*q/4.0_dp - IF (DD .LT. 0.0_dp) THEN + IF (DD < 0.0_dp) THEN ! three real unequal roots -- use the trigonometric formulation phi = ACOS(-q/2.0_dp/SQRT(ABS(p*p*p)/27.0_dp)) temp1 = 2.0_dp*SQRT(ABS(p)/3.0_dp) @@ -1433,8 +1433,8 @@ CONTAINS temp2 = -q/2.0_dp - SQRT(DD) u = ABS(temp1)**(1.0_dp/3.0_dp) v = ABS(temp2)**(1.0_dp/3.0_dp) - IF (temp1 .LT. 0.0_dp) u = -u - IF (temp2 .LT. 0.0_dp) v = -v + IF (temp1 < 0.0_dp) u = -u + IF (temp2 < 0.0_dp) v = -v y1 = u + v y2r = -(u + v)/2.0_dp y2i = (u - v)*SQRT(3.0_dp)/2.0_dp @@ -1448,12 +1448,12 @@ CONTAINS y2r = y2r - temp1 ! Assign answers - IF (DD .LT. 0.0_dp) THEN + IF (DD < 0.0_dp) THEN nroots = 3 x(1) = y1 x(2) = y2 x(3) = y3 - ELSE IF (DD .EQ. 0.0_dp) THEN + ELSE IF (DD == 0.0_dp) THEN nroots = 2 x(1) = y1 x(2) = y2r @@ -1473,7 +1473,7 @@ CONTAINS ! maximum or minimum? use the derivative ! 3*a*x**2+2*b*x+c der = 3.0_dp*a*x(i)*x(i) + 2.0_dp*b*x(i) + c - IF (der .GT. 0.0_dp) THEN + IF (der > 0.0_dp) THEN nmins = nmins + 1 minima(nmins) = x(i) !write(*,'(a,i2,a,f10.5)') 'Minimum ', i, ', value: ', x(i) @@ -1549,7 +1549,7 @@ CONTAINS ! Allocate the workspace and solve the eigenproblem ALLOCATE (WORK(MAX(1, LWORK))) CALL dsyev('V', 'L', iblock_size, data_copy, iblock_size, eigenvalues, WORK, LWORK, INFO) - IF (INFO .NE. 0) CPABORT("DSYEV failed") + IF (INFO /= 0) CPABORT("DSYEV failed") ! copy eigenvectors into a cp_dbcsr matrix CALL dbcsr_put_block(c, iblock_row, iblock_col, block=data_copy) diff --git a/src/dbm/dbm_tests.F b/src/dbm/dbm_tests.F index 50bea73181..02600e6605 100644 --- a/src/dbm/dbm_tests.F +++ b/src/dbm/dbm_tests.F @@ -240,14 +240,14 @@ CONTAINS CALL group%sum(flop) duration = MAX(duration, EPSILON(duration)) ! avoid division by zero flops_all = REAL(flop, KIND=dp)/duration/numnodes/(1024*1024) - IF (io_unit .GT. 0) THEN + IF (io_unit > 0) THEN WRITE (io_unit, '(A,I5,A,I5,A,F12.3,A,I9,A)') & " loop ", loop_iter, " with ", numnodes, " MPI ranks: using ", & duration, "s ", INT(flops_all), " Mflops/rank" CALL m_flush(io_unit) END IF - IF (loop_iter .EQ. n_loops .OR. always_checksum) THEN + IF (loop_iter == n_loops .OR. always_checksum) THEN cs = dbm_checksum(matrix_c) IF (io_unit > 0) THEN WRITE (io_unit, *) "Final checksums", cs @@ -288,11 +288,11 @@ CONTAINS CALL timeset(routineN, handle) ! Check that the counter was initialised (or has not overflowed) - CPASSERT(randmat_counter .NE. 0) + CPASSERT(randmat_counter /= 0) ! the counter goes into the seed. Every new call gives a new random matrix randmat_counter = randmat_counter + 1 - IF (sparsity .GT. 1) THEN + IF (sparsity > 1) THEN my_sparsity = sparsity/100.0 ELSE my_sparsity = sparsity diff --git a/src/dbt/dbt_array_list_methods.F b/src/dbt/dbt_array_list_methods.F index 55399886d2..cff76c1d34 100644 --- a/src/dbt/dbt_array_list_methods.F +++ b/src/dbt/dbt_array_list_methods.F @@ -112,7 +112,7 @@ CONTAINS size_all = 0 #:for dim in range(1, maxdim+1) - IF (ndata .GE. ${dim}$) THEN + IF (ndata >= ${dim}$) THEN CPASSERT(PRESENT(data_${dim}$)) size_all = size_all + SIZE(data_${dim}$) END IF @@ -125,7 +125,7 @@ CONTAINS list%ptr(1) = ptr #:for dim in range(1, maxdim+1) - IF (ndata .GE. ${dim}$) THEN + IF (ndata >= ${dim}$) THEN list%col_data(ptr:ptr + SIZE(data_${dim}$) - 1) = data_${dim}$ (:) ptr = ptr + SIZE(data_${dim}$) list%ptr(${dim+1}$) = ptr @@ -339,7 +339,7 @@ CONTAINS array_eq_i = .NOT. libxsmm_diff(arr1, arr2) #else array_eq_i = .FALSE. - IF (SIZE(arr1) .EQ. SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) + IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif END FUNCTION diff --git a/src/dbt/dbt_block.F b/src/dbt/dbt_block.F index 8f2552b1bc..2ce10237e5 100644 --- a/src/dbt/dbt_block.F +++ b/src/dbt/dbt_block.F @@ -449,7 +449,7 @@ CONTAINS INTEGER, INTENT(IN) :: row, column LOGICAL :: transpose - transpose = BTEST(column + row, 0) .EQV. column .GE. row + transpose = BTEST(column + row, 0) .EQV. column >= row END FUNCTION checker_tr diff --git a/src/dbt/dbt_io.F b/src/dbt/dbt_io.F index f784bee62d..f3f0dc548f 100644 --- a/src/dbt/dbt_io.F +++ b/src/dbt/dbt_io.F @@ -148,7 +148,7 @@ CONTAINS nblock_tot = PRODUCT(INT(bdims, KIND=int_8)) occupation = -1.0_dp - IF (nblock_tot .NE. 0) occupation = 100.0_dp*REAL(nblock_sum, dp)/REAL(nblock_tot, dp) + IF (nblock_tot /= 0) occupation = 100.0_dp*REAL(nblock_sum, dp)/REAL(nblock_tot, dp) IF (unit_nr_prv > 0) THEN WRITE (unit_nr_prv, "(T2,A)") & @@ -191,7 +191,7 @@ CONTAINS CALL dbt_iterator_next_block(iterator, blk_index, blk_size=blk_size) CALL dbt_get_stored_coordinates(tensor, blk_index, proc) mynode = tensor%pgrid%mp_comm_2d%mepos - CPASSERT(proc .EQ. mynode) + CPASSERT(proc == mynode) #:for ndim in ndims IF (ndims_tensor(tensor) == ${ndim}$) THEN CALL dbt_get_block(tensor, blk_index, blk_values_${ndim}$, found) @@ -285,7 +285,7 @@ CONTAINS CALL dbt_iterator_next_block(iterator, blk_index, blk_size=blk_size) CALL dbt_get_stored_coordinates(tensor, blk_index, proc) mynode = tensor%pgrid%mp_comm_2d%mepos - CPASSERT(proc .EQ. mynode) + CPASSERT(proc == mynode) #:for ndim in ndims IF (ndims_tensor(tensor) == ${ndim}$) THEN WRITE (io_unit_all, '(T7,A,T16,A,${ndim}$I3,1X,A,1X,I3,A2,${ndim}$I3)') & diff --git a/src/dbt/dbt_methods.F b/src/dbt/dbt_methods.F index 60f347c93d..e7d89d5497 100644 --- a/src/dbt/dbt_methods.F +++ b/src/dbt/dbt_methods.F @@ -642,22 +642,22 @@ CONTAINS CPASSERT(tensor_2%valid) CPASSERT(tensor_3%valid) - assert_stmt = SIZE(contract_1) .EQ. SIZE(contract_2) + assert_stmt = SIZE(contract_1) == SIZE(contract_2) CPASSERT(assert_stmt) - assert_stmt = SIZE(map_1) .EQ. SIZE(notcontract_1) + assert_stmt = SIZE(map_1) == SIZE(notcontract_1) CPASSERT(assert_stmt) - assert_stmt = SIZE(map_2) .EQ. SIZE(notcontract_2) + assert_stmt = SIZE(map_2) == SIZE(notcontract_2) CPASSERT(assert_stmt) - assert_stmt = SIZE(notcontract_1) + SIZE(contract_1) .EQ. ndims_tensor(tensor_1) + assert_stmt = SIZE(notcontract_1) + SIZE(contract_1) == ndims_tensor(tensor_1) CPASSERT(assert_stmt) - assert_stmt = SIZE(notcontract_2) + SIZE(contract_2) .EQ. ndims_tensor(tensor_2) + assert_stmt = SIZE(notcontract_2) + SIZE(contract_2) == ndims_tensor(tensor_2) CPASSERT(assert_stmt) - assert_stmt = SIZE(map_1) + SIZE(map_2) .EQ. ndims_tensor(tensor_3) + assert_stmt = SIZE(map_1) + SIZE(map_2) == ndims_tensor(tensor_3) CPASSERT(assert_stmt) unit_nr_prv = prep_output_unit(unit_nr) @@ -1197,7 +1197,7 @@ CONTAINS CALL blk_dims_tensor(tensor1, dims1) CALL blk_dims_tensor(tensor2, dims2) - IF (PRODUCT(int(dims1, int_8)) .GE. PRODUCT(int(dims2, int_8))) THEN + IF (PRODUCT(int(dims1, int_8)) >= PRODUCT(int(dims2, int_8))) THEN ref_tensor = 1 ELSE ref_tensor = 2 @@ -1350,7 +1350,7 @@ CONTAINS END SELECT IF (unit_nr_prv > 0) THEN - IF (compat1 .NE. compat1_old) THEN + IF (compat1 /= compat1_old) THEN WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor1_out%name), ":" SELECT CASE (compat1) CASE (0) @@ -1361,7 +1361,7 @@ CONTAINS WRITE (unit_nr_prv, '(A)') "Transposed" END SELECT END IF - IF (compat2 .NE. compat2_old) THEN + IF (compat2 /= compat2_old) THEN WRITE (unit_nr_prv, '(T2,A,1X,A,A,1X)', advance='no') "compatibility of", TRIM(tensor2_out%name), ":" SELECT CASE (compat2) CASE (0) @@ -1449,7 +1449,7 @@ CONTAINS END IF IF (unit_nr_prv > 0) THEN - IF (compat1_old .NE. compat1 .OR. compat2_old .NE. compat2) THEN + IF (compat1_old /= compat1 .OR. compat2_old /= compat2) THEN 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" diff --git a/src/dbt/dbt_split.F b/src/dbt/dbt_split.F index 76a29c34ac..0ad9103c3d 100644 --- a/src/dbt/dbt_split.F +++ b/src/dbt/dbt_split.F @@ -391,7 +391,7 @@ CONTAINS isplit_sum = 0 DO iblk = 1, SIZE(blk_size_d) splitsum = 0 - IF (iblk .GT. 1) first_split_d(iblk) = last_split_d(iblk - 1) + 1 + IF (iblk > 1) first_split_d(iblk) = last_split_d(iblk - 1) + 1 DO WHILE (splitsum < blk_size_d(iblk)) isplit_sum = isplit_sum + 1 #:for idim in range(1, maxdim+1) diff --git a/src/dbt/dbt_test.F b/src/dbt/dbt_test.F index 2a0362bd68..3948e35031 100644 --- a/src/dbt/dbt_test.F +++ b/src/dbt/dbt_test.F @@ -114,7 +114,7 @@ CONTAINS TYPE(block_nd), INTENT(IN) :: block1, block2 LOGICAL :: blocks_equal - blocks_equal = MAXVAL(ABS(block1%blk - block2%blk)) .LT. 1.0E-12_dp + blocks_equal = MAXVAL(ABS(block1%blk - block2%blk)) < 1.0E-12_dp END FUNCTION @@ -203,7 +203,7 @@ CONTAINS mynode = mp_comm%mepos io_unit = 0 - IF (mynode .EQ. 0) io_unit = unit_nr + IF (mynode == 0) io_unit = unit_nr CALL permute(ndims, perm) ALLOCATE (map1_ref, source=perm(1:ndims/2, 1)) @@ -389,7 +389,7 @@ CONTAINS mynode = mp_comm%mepos IF (.NOT. enumerate) THEN - CPASSERT(randmat_counter .NE. 0) + CPASSERT(randmat_counter /= 0) randmat_counter = randmat_counter + 1 END IF @@ -530,7 +530,7 @@ CONTAINS INTEGER, DIMENSION(ndims_tensor(tensor)) :: blk_start, blk_end LOGICAL :: found - CPASSERT(ndims_tensor(tensor) .EQ. ${ndim}$) + CPASSERT(ndims_tensor(tensor) == ${ndim}$) CALL dbt_get_info(tensor, nfull_total=dims_nd) CALL allocate_any(array, shape_spec=dims_nd) array(${shape_colon(ndim)}$) = 0.0_dp @@ -620,7 +620,7 @@ CONTAINS mp_comm = tensor_1%pgrid%mp_comm_2d mynode = mp_comm%mepos io_unit = -1 - IF (mynode .EQ. 0) io_unit = unit_nr + IF (mynode == 0) io_unit = unit_nr cs_1 = dbt_checksum(tensor_1) cs_2 = dbt_checksum(tensor_2) @@ -762,9 +762,9 @@ CONTAINS END ASSOCIATE eql_diff = MAXVAL(ABS(array_3_test_mm(:, :) - array_3_mm(:, :))) - notzero = MAXVAL(ABS(array_3_test_mm(:, :))) .GT. 1.0E-12_dp + notzero = MAXVAL(ABS(array_3_test_mm(:, :))) > 1.0E-12_dp - eql = eql_diff .LT. 1.0E-11_dp + eql = eql_diff < 1.0E-11_dp IF (.NOT. eql .OR. .NOT. notzero) THEN IF (io_unit > 0) WRITE (io_unit, *) 'Test failed!', eql_diff diff --git a/src/dbt/dbt_types.F b/src/dbt/dbt_types.F index 7e69910e5b..0b5ffb7541 100644 --- a/src/dbt/dbt_types.F +++ b/src/dbt/dbt_types.F @@ -268,7 +268,7 @@ CONTAINS #:endfor #:for idim in range(1, maxdim+1) - IF (SIZE(t%dims) .GE. ${idim}$) THEN + IF (SIZE(t%dims) >= ${idim}$) THEN nblks = SIZE(dist_${idim}$) ALLOCATE (blks_tmp(nblks)) iblk_count = 0 @@ -452,7 +452,7 @@ CONTAINS dims(idim) = pdim pdims_rem = pdims_rem/dims(idim) - IF (idim .NE. SIZE(tensor_dims_sorted)) THEN + IF (idim /= SIZE(tensor_dims_sorted)) THEN dims(idim + 1:) = 0 CALL mp_dims_create(pdims_rem, dims(idim + 1:)) ELSEIF (lb_ratio_prv < 0.5_dp) THEN @@ -719,7 +719,7 @@ CONTAINS CALL timeset(routineN, handle) ndims = SIZE(map1_2d) + SIZE(map2_2d) - CPASSERT(ndims .GE. 2 .AND. ndims .LE. ${maxdim}$) + CPASSERT(ndims >= 2 .AND. ndims <= ${maxdim}$) CALL create_array_list(nd_dist, ndims, ${varlist("nd_dist")}$) @@ -756,7 +756,7 @@ CONTAINS comm_2d = pgrid_prv%mp_comm_2d pdims_2d_check = comm_2d%num_pe_cart - IF (ANY(pdims_2d_check .NE. pdims_2d)) THEN + IF (ANY(pdims_2d_check /= pdims_2d)) THEN CPABORT("inconsistent process grid dimensions") END IF @@ -982,7 +982,7 @@ CONTAINS ALLOCATE (nfull_local(ndims)) nfull_local(:) = 0 #:for idim in range(1, maxdim+1) - IF (ndims .GE. ${idim}$) THEN + IF (ndims >= ${idim}$) THEN nblks_local(${idim}$) = COUNT(dist_${idim}$ == task_coor(${idim}$)) ALLOCATE (blks_local_${idim}$ (nblks_local(${idim}$))) iblk_count = 0 diff --git a/src/dbt/dbt_unittest.F b/src/dbt/dbt_unittest.F index 54beac0994..fca7d93cee 100644 --- a/src/dbt/dbt_unittest.F +++ b/src/dbt/dbt_unittest.F @@ -70,7 +70,7 @@ PROGRAM dbt_unittest ! set standard output parameters io_unit = -1 - IF (mynode .EQ. 0) io_unit = default_output_unit + IF (mynode == 0) io_unit = default_output_unit CALL dbcsr_init_lib(mp_comm%get_handle(), io_unit) ! Needed for DBM_VALIDATE_AGAINST_DBCSR. CALL dbm_library_init() diff --git a/src/dbt/tas/dbt_tas_io.F b/src/dbt/tas/dbt_tas_io.F index 1575203b97..533b6725c4 100644 --- a/src/dbt/tas/dbt_tas_io.F +++ b/src/dbt/tas/dbt_tas_io.F @@ -166,7 +166,7 @@ CONTAINS ndbt_tot = dbt_tas_nblkrows_total(matrix)*dbt_tas_nblkcols_total(matrix) occupation = -1.0_dp - IF (ndbt_tot .NE. 0) occupation = 100.0_dp*REAL(ndbt_p_sum, dp)/REAL(ndbt_tot, dp) + IF (ndbt_tot /= 0) occupation = 100.0_dp*REAL(ndbt_p_sum, dp)/REAL(ndbt_tot, dp) dist = dbm_get_distribution(matrix%matrix) rowdist => dbm_distribution_row_dist(dist) diff --git a/src/dbt/tas/dbt_tas_mm.F b/src/dbt/tas/dbt_tas_mm.F index be9f3df87a..081ce20ec9 100644 --- a/src/dbt/tas/dbt_tas_mm.F +++ b/src/dbt/tas/dbt_tas_mm.F @@ -241,7 +241,7 @@ CONTAINS dims_c = [dims_a(1), dims_b(2)] - IF (.NOT. (dims_a(2) .EQ. dims_b(1))) THEN + IF (.NOT. (dims_a(2) == dims_b(1))) THEN CPABORT("inconsistent matrix dimensions") END IF @@ -1344,7 +1344,7 @@ CONTAINS dim_split_template = info_template%split_rowcol dim_split_matrix = split_rc - transposed = dim_split_template .NE. dim_split_matrix + transposed = dim_split_template /= dim_split_matrix IF (transposed) trans = .NOT. trans pdims = info_template%mp_comm%num_pe_cart diff --git a/src/dbt/tas/dbt_tas_reshape_ops.F b/src/dbt/tas/dbt_tas_reshape_ops.F index 3412283a9d..af86bd3cc2 100644 --- a/src/dbt/tas/dbt_tas_reshape_ops.F +++ b/src/dbt/tas/dbt_tas_reshape_ops.F @@ -693,7 +693,7 @@ CONTAINS TYPE(dbt_buffer_type), INTENT(IN) :: buffer LOGICAL :: dbt_buffer_blocks_left - dbt_buffer_blocks_left = buffer%endpos .LT. buffer%nblock + dbt_buffer_blocks_left = buffer%endpos < buffer%nblock END FUNCTION ! ************************************************************************************************** @@ -758,7 +758,7 @@ CONTAINS ndata = PRODUCT(SHAPE(block)) p = buffer%endpos - IF (p .EQ. 0) THEN + IF (p == 0) THEN p_data = 0 ELSE p_data = INT(buffer%indx(p, 3)) @@ -806,7 +806,7 @@ CONTAINS END IF p = buffer%endpos - IF (p .EQ. 0) THEN + IF (p == 0) THEN p_data = 0 ELSE p_data = INT(buffer%indx(p, 3)) diff --git a/src/dbt/tas/dbt_tas_split.F b/src/dbt/tas/dbt_tas_split.F index cc4e868fbc..7d10ae7908 100644 --- a/src/dbt/tas/dbt_tas_split.F +++ b/src/dbt/tas/dbt_tas_split.F @@ -123,7 +123,7 @@ CONTAINS CALL world_to_group_proc_map(iproc, pdims, split_rowcol, split_info%pgrid_split_size, igroup_check, pdims_group, iproc_group) - IF (igroup_check .NE. split_info%igroup) THEN + IF (igroup_check /= split_info%igroup) THEN CPABORT('inconsistent subgroups') END IF @@ -131,7 +131,7 @@ CONTAINS iproc_group_check = split_info%mp_comm_group%mepos - CPASSERT(iproc_group_check .EQ. iproc_group) + CPASSERT(iproc_group_check == iproc_group) CALL mp_comm_group%free() @@ -285,7 +285,7 @@ CONTAINS get_opt_nsplit = nsplit_list(minpos) ELSE get_opt_nsplit = nsplit - DO WHILE (MOD(numproc, get_opt_nsplit) .NE. 0) + DO WHILE (MOD(numproc, get_opt_nsplit) /= 0) get_opt_nsplit = get_opt_nsplit - 1 END DO END IF @@ -368,7 +368,7 @@ CONTAINS IF (opt_nsplit_prv) THEN nsplit_opt = get_opt_nsplit(pdim_split, nsplit, split_pgrid=.TRUE., pdim_nonsplit=pdim_nonsplit) ELSE - IF (MOD(pdims(split_rowcol), nsplit) .NE. 0) THEN + IF (MOD(pdims(split_rowcol), nsplit) /= 0) THEN CPABORT("Split factor does not divide process grid dimension") END IF nsplit_opt = nsplit @@ -406,9 +406,9 @@ CONTAINS IF (relative) THEN dims_opt = 0 CALL mp_dims_create(PRODUCT(dims), dims_opt) - accept_pgrid_dims = (MAXVAL(REAL(dims, dp))/MAXVAL(dims_opt) .LT. default_pdims_accept_ratio) + accept_pgrid_dims = (MAXVAL(REAL(dims, dp))/MAXVAL(dims_opt) < default_pdims_accept_ratio) ELSE - accept_pgrid_dims = (MAXVAL(REAL(dims, dp))/MINVAL(dims) .LT. default_pdims_accept_ratio**2) + accept_pgrid_dims = (MAXVAL(REAL(dims, dp))/MINVAL(dims) < default_pdims_accept_ratio**2) END IF END FUNCTION diff --git a/src/dbt/tas/dbt_tas_test.F b/src/dbt/tas/dbt_tas_test.F index 191b4dff1d..516fb23a99 100644 --- a/src/dbt/tas/dbt_tas_test.F +++ b/src/dbt/tas/dbt_tas_test.F @@ -99,7 +99,7 @@ CONTAINS CALL timeset(routineN, handle) ! Check that the counter was initialised (or has not overflowed) - CPASSERT(randmat_counter .NE. 0) + CPASSERT(randmat_counter /= 0) ! the counter goes into the seed. Every new call gives a new random matrix randmat_counter = randmat_counter + 1 @@ -142,12 +142,12 @@ CONTAINS DO row = 1, dbt_tas_nblkrows_total(matrix) DO col = 1, dbt_tas_nblkcols_total(matrix) CALL dlarnv(1, jseed, 1, rn) - IF (rn(1) .LT. sparsity) THEN + IF (rn(1) < sparsity) THEN tr = .FALSE. row_s = row; col_s = col CALL dbt_tas_get_stored_coordinates(matrix, row_s, col_s, node_holds_blk) - IF (node_holds_blk .EQ. mynode) THEN + IF (node_holds_blk == mynode) THEN row_size = rbsize_obj%data(row_s) col_size = cbsize_obj%data(col_s) nze = row_size*col_size @@ -346,7 +346,7 @@ CONTAINS mynode = mp_comm%mepos abort = .FALSE. io_unit = -1 - IF (mynode .EQ. 0) io_unit = unit_nr + IF (mynode == 0) io_unit = unit_nr CALL dbt_tas_multiply(transa, transb, transc, 1.0_dp, matrix_a, matrix_b, & 0.0_dp, matrix_c, & diff --git a/src/dbt/tas/dbt_tas_unittest.F b/src/dbt/tas/dbt_tas_unittest.F index 98dff6ef13..e48684fb8a 100644 --- a/src/dbt/tas/dbt_tas_unittest.F +++ b/src/dbt/tas/dbt_tas_unittest.F @@ -61,7 +61,7 @@ PROGRAM dbt_tas_unittest END IF io_unit = -1 - IF (mynode .EQ. 0) io_unit = default_output_unit + IF (mynode == 0) io_unit = default_output_unit CALL dbcsr_init_lib(mp_comm%get_handle(), io_unit) ! Needed for DBM_VALIDATE_AGAINST_DBCSR. CALL dbm_library_init() diff --git a/src/dbt/tas/dbt_tas_util.F b/src/dbt/tas/dbt_tas_util.F index 4bac170575..3416f5985d 100644 --- a/src/dbt/tas/dbt_tas_util.F +++ b/src/dbt/tas/dbt_tas_util.F @@ -89,7 +89,7 @@ CONTAINS array_eq_i = .NOT. libxsmm_diff(arr1, arr2) #else array_eq_i = .FALSE. - IF (SIZE(arr1) .EQ. SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) + IF (SIZE(arr1) == SIZE(arr2)) array_eq_i = ALL(arr1 == arr2) #endif END FUNCTION @@ -108,7 +108,7 @@ CONTAINS array_eq_i8 = .NOT. libxsmm_diff(arr1, arr2) #else array_eq_i8 = .FALSE. - IF (SIZE(arr1) .EQ. SIZE(arr2)) array_eq_i8 = ALL(arr1 == arr2) + IF (SIZE(arr1) == SIZE(arr2)) array_eq_i8 = ALL(arr1 == arr2) #endif END FUNCTION diff --git a/src/distribution_2d_types.F b/src/distribution_2d_types.F index 8bc567d15c..7fca0b41dd 100644 --- a/src/distribution_2d_types.F +++ b/src/distribution_2d_types.F @@ -315,7 +315,7 @@ 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 .NE. SIZE(distribution_2d%row_distribution, 1)) & + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%row_distribution, 1)) & WRITE (unit=unit_nr, fmt='()') END DO WRITE (unit=unit_nr, fmt="('),')") @@ -336,7 +336,7 @@ 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 .NE. SIZE(distribution_2d%col_distribution, 1)) & + IF (MODULO(i, 8) == 0 .AND. i /= SIZE(distribution_2d%col_distribution, 1)) & WRITE (unit=unit_nr, fmt='()') END DO WRITE (unit=unit_nr, fmt="('),')") @@ -355,7 +355,7 @@ 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 .NE. SIZE(distribution_2d%n_local_rows)) & + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_rows)) & WRITE (unit=unit_nr, fmt='()') END DO WRITE (unit=unit_nr, fmt="('),')") @@ -395,7 +395,7 @@ 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 .NE. SIZE(distribution_2d%n_local_cols)) & + IF (MODULO(i, 10) == 0 .AND. i /= SIZE(distribution_2d%n_local_cols)) & WRITE (unit=unit_nr, fmt='()') END DO WRITE (unit=unit_nr, fmt="('),')") diff --git a/src/distribution_methods.F b/src/distribution_methods.F index 03c53fbac2..225fb6855e 100644 --- a/src/distribution_methods.F +++ b/src/distribution_methods.F @@ -275,7 +275,7 @@ CONTAINS END DO - IF (ANY(workload_fill .NE. workload_count)) & + IF (ANY(workload_fill /= workload_count)) & CPABORT("Inconsistent heaps encountered") CALL cp_heap_release(bin_heap_count) @@ -563,7 +563,7 @@ 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 .GT. nclusters) & + IF (iatom > nclusters) & CPABORT("Bounds error") CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) cluster_list(iatom) = iatom @@ -868,10 +868,10 @@ CONTAINS CPABORT("No topmost heap element found.") ! prow = INT((bin - 1)*pgrid_gcd/npcols) - IF (prow .GE. nprows) & + IF (prow >= nprows) & CPABORT("Invalid process row.") pcol = INT((bin - 1)*pgrid_gcd/nprows) - IF (pcol .GE. npcols) & + IF (pcol >= npcols) & CPABORT("Invalid process column.") row_distribution(cluster) = prow + 1 col_distribution(cluster) = pcol + 1 @@ -1171,7 +1171,7 @@ CONTAINS natoms = SIZE(coord, 2) ! This is a bit of an arbitrary choice, simply a try to avoid too many clusters on large systems and too few for balancing on ! small systems or subclusters - IF (natoms .LE. 1) THEN + IF (natoms <= 1) THEN nsplits = 1 ELSE nsplits = MIN(INT(MIN(INT(MAX(6, INT(60.00/LOG(REAL(natoms, KIND=dp)))), KIND=int_8), ncluster)), natoms) @@ -1189,13 +1189,13 @@ CONTAINS ! If the system is small enough try to do better in terms of balancing number of atoms per cluster ! by changing the seed for the initial guess - IF (natoms .LT. 1000 .AND. balance .GT. 1.1) THEN + IF (natoms < 1000 .AND. balance > 1.1) THEN found = .FALSE. DO i = 1, 5 - IF (balance .GT. 1.1) THEN + IF (balance > 1.1) THEN CALL kmeans(nsplits, coord, scaled_coord, cell, cluster_inds, nat_cluster, seed + i*40, conv) balance_new = MAXVAL(REAL(nat_cluster, KIND=dp))/MINVAL(REAL(nat_cluster, KIND=dp)) - IF (balance_new .LT. balance) THEN + IF (balance_new < balance) THEN balance = balance_new min_seed = seed + i*40; END IF @@ -1225,11 +1225,11 @@ CONTAINS END DO ! now comes the next part that the number of clusters will not match anymore, so try to correct in a meaningful way without ! introducing 0 sized blocks again - IF (nleft .NE. 0) THEN + IF (nleft /= 0) THEN DO i = 1, ABS(nleft) IF (nleft < 0) THEN maxv = MINLOC(cluster_cost/ncluster_new) - IF (ncluster_new(maxv(1)) .NE. 1) THEN + IF (ncluster_new(maxv(1)) /= 1) THEN ncluster_new(maxv) = ncluster_new(maxv) - 1 ELSE maxv = MAXLOC(ncluster_new) @@ -1315,10 +1315,10 @@ CONTAINS DO j = 1, i - 1 dvec = pbc(cent_coord(:, j), cent_coord(:, i), cell) dist = SQRT(DOT_PRODUCT(dvec, dvec)) - IF (dist .LT. devi) devi = dist + IF (dist < devi) devi = dist END DO rn = rng_stream%next() - IF (rn .LT. devi**2/169.0) EXIT + IF (rn < devi**2/169.0) EXIT END DO END DO @@ -1338,18 +1338,18 @@ CONTAINS devi = HUGE(1.0_dp); oldc = cluster(i) DO j = 1, ncent dist = dmat(j, i) + MAX(nat_cl(j)**2/nat*ncent, nat/ncent) - IF (dist .LT. devi) THEN + IF (dist < devi) THEN devi = dist; cluster(i) = j END IF END DO deviat(cluster(i)) = deviat(cluster(i)) + SQRT(devi) nat_cl(cluster(i)) = nat_cl(cluster(i)) + 1 tot_var = tot_var + devi - IF (oldc .NE. cluster(i)) changed = .TRUE. + IF (oldc /= cluster(i)) changed = .TRUE. END DO ! get the update of the centers done, add a new one in case one center lost all its atoms ! the algorithm would survive, but its nice to really create what you demand - IF (tot_var .GE. old_var) EXIT + IF (tot_var >= old_var) EXIT IF (changed) THEN ! Here misery of computing the center of geometry of the clusters in PBC. ! The mapping on the unit circle allows to circumvent all problems diff --git a/src/dkh_main.F b/src/dkh_main.F index 8841249652..73531469d3 100644 --- a/src/dkh_main.F +++ b/src/dkh_main.F @@ -226,7 +226,7 @@ CONTAINS ! Calculate even3 in T-basis, only if requested !----------------------------------------------------------------------- - IF (dkh_order .GE. 3) THEN + IF (dkh_order >= 3) THEN CALL peven1p(n, matrix_pe1p, matrix_v, matrix_pvp, matrix_aux, matrix_aux2, aa, rr, tt) CALL even3b(n, matrix_ev3, matrix_ev1, matrix_pe1p, matrix_v, matrix_pvp, aa, rr, tt, e, matrix_aux) @@ -241,7 +241,7 @@ CONTAINS ! Calculate even4 in T-basis, only if requested !----------------------------------------------------------------------- - IF (dkh_order .GE. 4) THEN + IF (dkh_order >= 4) THEN CPABORT("DKH order greater than 3 not yet available") ! CALL even4a(n,matrix_ev4%local_data,matrix_ev2%local_data,matrix_pe1p%local_data,matrix_v%local_data,& ! matrix_pvp%local_data,aa,rr,tt,e) @@ -277,9 +277,9 @@ CONTAINS CALL cp_fm_scale_and_add(1.0_dp, matrix_ev1, 1.0_dp, matrix_ev2) CALL cp_fm_uplo_to_full(matrix_ev1, matrix_aux) CALL cp_fm_to_fm(matrix_ev1, matrix_v) - IF (dkh_order .GE. 3) THEN + IF (dkh_order >= 3) THEN CALL cp_fm_scale_and_add(1.0_dp, matrix_v, 1.0_dp, matrix_ev3) - IF (dkh_order .GE. 4) THEN + IF (dkh_order >= 4) THEN CALL cp_fm_scale_and_add(1.0_dp, matrix_v, 1.0_dp, matrix_ev4) END IF END IF @@ -326,7 +326,7 @@ CONTAINS con = 1.0_dp/prea DO i = 1, n - IF (tt(i) .LT. 0.0_dp) THEN + IF (tt(i) < 0.0_dp) THEN WRITE (*, *) ' dkh_main.F | tt(', i, ') = ', tt(i) END IF @@ -335,7 +335,7 @@ CONTAINS ev0t(i) = tt(i) ratio = tt(i)/c_light_au - IF (ratio .LE. 0.02_dp) THEN + IF (ratio <= 0.02_dp) THEN tv1 = tt(i) tv2 = -tv1*tt(i)*prea*0.5_dp tv3 = -tv2*tt(i)*prea @@ -1384,7 +1384,7 @@ CONTAINS ! Calculate even1 in T-basis !----------------------------------------------------------------------- - IF (dkh_order .GE. 1) THEN + IF (dkh_order >= 1) THEN CALL even1_a(n, ev1t, vt, pvpt, aa, rr) !---------------------------------------------------------------------- @@ -1399,7 +1399,7 @@ CONTAINS ! Calculate even2 in T-basis !----------------------------------------------------------------------- - IF (dkh_order .GE. 2) THEN + IF (dkh_order >= 2) THEN CALL even2c_a(n, ev2t, vt, pvpt, aa, rr, tt, e) !----------------------------------------------------------------------- @@ -1415,7 +1415,7 @@ CONTAINS ! Calculate even3 in T-basis, only if requested !----------------------------------------------------------------------- - IF (dkh_order .GE. 3) THEN + IF (dkh_order >= 3) THEN CALL peven1p_a(n, pev1tp, vt, pvpt, aa, rr, tt) CALL even3b_a(n, ev3t, ev1t, pev1tp, vt, pvpt, aa, rr, tt, e) @@ -1430,7 +1430,7 @@ CONTAINS ! Calculate even4 in T-basis, only if requested !----------------------------------------------------------------------- - IF (dkh_order .GE. 4) THEN + IF (dkh_order >= 4) THEN CALL even4a_a(n, ev4t, ev1t, pev1tp, vt, pvpt, aa, rr, tt, e) !----------------------------------------------------------------------- @@ -1442,23 +1442,23 @@ CONTAINS END IF END IF - IF (dkh_order .GE. 4) THEN + IF (dkh_order >= 4) THEN CPABORT("DKH 4") END IF !----------------------------------------------------------------------- ! Calculate v in position space !----------------------------------------------------------------------- - IF (dkh_order .GE. 1) THEN + IF (dkh_order >= 1) THEN CALL mat_add2(v, 0.0_dp, 1.0_dp, ev1, n) END IF - IF (dkh_order .GE. 2) THEN + IF (dkh_order >= 2) THEN CALL mat_add2(v, 1.0_dp, 1.0_dp, ev2, n) END IF - IF (dkh_order .GE. 3) THEN + IF (dkh_order >= 3) THEN CALL mat_add2(v, 1.0_dp, 1.0_dp, ev3, n) END IF - IF (dkh_order .GE. 4) THEN + IF (dkh_order >= 4) THEN CALL mat_add2(v, 1.0_dp, 1.0_dp, ev4, n) END IF @@ -1488,7 +1488,7 @@ CONTAINS tv4 DO i = 1, n - IF (tt(i) .LT. 0.0_dp) THEN + IF (tt(i) < 0.0_dp) THEN WRITE (*, *) ' dkh_main.F | tt(', i, ') = ', tt(i) END IF @@ -1503,7 +1503,7 @@ CONTAINS ev0t(i) = tt(i) ratio = tt(i)/c_light_au - IF (ratio .LE. 0.02_dp) THEN + IF (ratio <= 0.02_dp) THEN tv1 = tt(i) tv2 = -tv1*tt(i)*prea/2.0_dp tv3 = -tv2*tt(i)*prea @@ -2541,7 +2541,7 @@ CONTAINS eigv(i, i) = 1.0_dp eigw(i) = sogt(i, i) DO j = 1, i - IF (i .NE. j) THEN + IF (i /= j) THEN eigv(i, j) = 0.0_dp eigv(j, i) = 0.0_dp ext_norm = ext_norm + sogt(i, j)*sogt(i, j) @@ -2549,7 +2549,7 @@ CONTAINS END DO END DO - IF (ext_norm .GT. 0.0_dp) THEN + IF (ext_norm > 0.0_dp) THEN ext_norm = SQRT(2.0_dp*ext_norm) thr_min = ext_norm*tol/u1 ind = 0 @@ -2562,14 +2562,14 @@ CONTAINS DO m = l + 1 DO - IF ((ABS(sogt(m, l)) - thr) .GE. 0.0_dp) THEN + IF ((ABS(sogt(m, l)) - thr) >= 0.0_dp) THEN ind = 1 x = 0.5_dp*(eigw(l) - eigw(m)) y = -sogt(m, l)/SQRT(sogt(m, l)*sogt(m, l) + x*x) - IF (x .LT. 0.0_dp) y = -y + IF (x < 0.0_dp) y = -y - IF (y .GT. 1.0_dp) y = 1.0_dp - IF (y .LT. -1.0_dp) y = -1.0_dp + IF (y > 1.0_dp) y = 1.0_dp + IF (y < -1.0_dp) y = -1.0_dp xy = 1.0_dp - y*y sint = y/SQRT(2.0_dp*(1.0_dp + SQRT(xy))) sint2 = sint*sint @@ -2578,16 +2578,16 @@ CONTAINS sincs = sint*cost DO i = 1, n - IF ((i - m) .NE. 0) THEN - IF ((i - m) .LT. 0) THEN + IF ((i - m) /= 0) THEN + IF ((i - m) < 0) THEN im = m mm = i ELSE im = i mm = m END IF - IF ((i - l) .NE. 0) THEN - IF ((i - l) .LT. 0) THEN + IF ((i - l) /= 0) THEN + IF ((i - l) < 0) THEN il = l ll = i ELSE @@ -2612,23 +2612,23 @@ CONTAINS eigw(l) = y eigw(m) = x END IF - IF ((m - n) .EQ. 0) EXIT + IF ((m - n) == 0) EXIT m = m + 1 END DO - IF ((l - m + 1) .EQ. 0) EXIT + IF ((l - m + 1) == 0) EXIT l = l + 1 END DO - IF ((ind - 1) .NE. 0.0_dp) EXIT + IF ((ind - 1) /= 0.0_dp) EXIT ind = 0 END DO - IF ((thr - thr_min) .LE. 0.0_dp) EXIT + IF ((thr - thr_min) <= 0.0_dp) EXIT END DO END IF - IF (ic .NE. 0) THEN + IF (ic /= 0) THEN DO i = 1, n DO j = 1, n - IF ((eigw(i) - eigw(j)) .GT. 0.0_dp) THEN + IF ((eigw(i) - eigw(j)) > 0.0_dp) THEN x = eigw(i) eigw(i) = eigw(j) eigw(j) = x @@ -2678,7 +2678,7 @@ CONTAINS diag_s = matrix_s_pgf(jn, jn) g(jn, jn) = 1.0_dp - IF (jn .NE. 1) THEN + IF (jn /= 1) THEN DO j = 1, jn - 1 scalar = 0.0_dp DO i = 1, j diff --git a/src/dm_ls_scf.F b/src/dm_ls_scf.F index 1952a38108..07be88ede8 100644 --- a/src/dm_ls_scf.F +++ b/src/dm_ls_scf.F @@ -542,7 +542,7 @@ CONTAINS IF (do_transport) THEN maxscf_reached = should_stop .OR. iscf >= ls_scf_env%max_scf ! one extra scf step for post-processing in transmission calculations - IF (transport_env%params%method .EQ. transport_transmission) THEN + IF (transport_env%params%method == transport_transmission) THEN IF (transm_maxscf_reached) THEN IF (unit_nr > 0) WRITE (unit_nr, '(T2,A)') "SCF not converged! " EXIT @@ -596,7 +596,7 @@ CONTAINS CALL dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) ELSE IF (ls_scf_env%ls_diis) THEN ! ------- IF-DIIS+MIX--- START - IF (diis_step .AND. (iscf - 1) .GE. ls_scf_env%iter_ini_diis) THEN + IF (diis_step .AND. (iscf - 1) >= ls_scf_env%iter_ini_diis) THEN IF (unit_nr > 0) THEN WRITE (unit_nr, '(A61)') & '*************************************************************' @@ -659,7 +659,7 @@ CONTAINS IF (do_transport) THEN IF (ls_scf_env%has_s_preconditioner) & CPABORT("NOT YET IMPLEMENTED with S preconditioner. ") - IF (ls_scf_env%ls_mstruct%cluster_type .NE. ls_cluster_atomic) & + IF (ls_scf_env%ls_mstruct%cluster_type /= ls_cluster_atomic) & CPABORT("NOT YET IMPLEMENTED with molecular clustering. ") extra_scf = maxscf_reached .OR. scf_converged @@ -693,7 +693,7 @@ CONTAINS CASE (ls_scf_pexsi) IF (ls_scf_env%has_s_preconditioner) & CPABORT("S preconditioning not implemented in combination with the PEXSI library. ") - IF (ls_scf_env%ls_mstruct%cluster_type .NE. ls_cluster_atomic) & + 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. ") CALL density_matrix_pexsi(ls_scf_env%pexsi, ls_scf_env%matrix_p(ispin), ls_scf_env%pexsi%matrix_w(ispin), & @@ -744,7 +744,7 @@ CONTAINS IF (do_transport) THEN scf_converged = check_convergence .AND. ABS(energy_diff) < ls_scf_env%eps_scf*ls_scf_env%nelectron_total ! one extra scf step for post-processing in transmission calculations - IF (transport_env%params%method .EQ. transport_transmission) THEN + IF (transport_env%params%method == transport_transmission) THEN IF (transm_scf_converged) EXIT transm_scf_converged = scf_converged ELSE @@ -779,7 +779,7 @@ CONTAINS CALL pexsi_set_convergence_tolerance(ls_scf_env%pexsi, energy_diff, & ls_scf_env%eps_scf*ls_scf_env%nelectron_total, & ! initialize in second scf step of first SCF cycle: - (iscf .EQ. 2) .AND. (ls_scf_env%scf_history%istore .EQ. 0), & + (iscf == 2) .AND. (ls_scf_env%scf_history%istore == 0), & check_convergence) END IF diff --git a/src/dm_ls_scf_create.F b/src/dm_ls_scf_create.F index 52fcb2fa60..0181cb8ff9 100644 --- a/src/dm_ls_scf_create.F +++ b/src/dm_ls_scf_create.F @@ -155,7 +155,7 @@ CONTAINS ! initialize PEXSI IF (ls_scf_env%do_pexsi) THEN - IF (dft_control%qs_control%eps_filter_matrix .NE. 0.0_dp) & + IF (dft_control%qs_control%eps_filter_matrix /= 0.0_dp) & CPABORT("EPS_FILTER_MATRIX must be set to 0 for PEXSI.") CALL lib_pexsi_init(ls_scf_env%pexsi, ls_scf_env%para_env, ls_scf_env%nspins) END IF @@ -269,7 +269,7 @@ CONTAINS pexsi_section => section_vals_get_subs_vals(input, "DFT%LS_SCF%PEXSI") CALL section_vals_get(pexsi_section) - ls_scf_env%do_pexsi = ls_scf_env%purification_method .EQ. ls_scf_pexsi & + ls_scf_env%do_pexsi = ls_scf_env%purification_method == ls_scf_pexsi & .AND. .NOT. ls_scf_env%do_transport IF (ls_scf_env%do_pexsi) THEN CALL pexsi_init_read_input(pexsi_section, ls_scf_env%pexsi) @@ -323,16 +323,16 @@ CONTAINS CPABORT("CURVY_STEPS requires the use of the sqrt inversion.") ! verify requirements for direct submatrix sign methods - IF (ls_scf_env%sign_method .EQ. ls_scf_sign_submatrix & + IF (ls_scf_env%sign_method == ls_scf_sign_submatrix & .AND. ( & - ls_scf_env%submatrix_sign_method .EQ. ls_scf_submatrix_sign_direct & - .OR. ls_scf_env%submatrix_sign_method .EQ. ls_scf_submatrix_sign_direct_muadj & - .OR. ls_scf_env%submatrix_sign_method .EQ. ls_scf_submatrix_sign_direct_muadj_lowmem & + 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) & CPABORT("DIRECT submatrix sign methods require SIGN_SYMMETRIC being set.") IF (ls_scf_env%fixed_mu .AND. ( & - ls_scf_env%submatrix_sign_method .EQ. ls_scf_submatrix_sign_direct_muadj & - .OR. ls_scf_env%submatrix_sign_method .EQ. ls_scf_submatrix_sign_direct_muadj_lowmem & + 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 & )) CPABORT("Invalid submatrix sign method for FIXED_MU.") ! sign_symmetric requires computation of s_sqrt diff --git a/src/dm_ls_scf_curvy.F b/src/dm_ls_scf_curvy.F index 8083fdc349..943f078940 100644 --- a/src/dm_ls_scf_curvy.F +++ b/src/dm_ls_scf_curvy.F @@ -101,10 +101,10 @@ CONTAINS ! 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 - IF (lsstep .NE. 1) energy = ls_scf_env%curvy_data%energies(1) + IF (lsstep /= 1) energy = ls_scf_env%curvy_data%energies(1) ! start the optimization by calling the driver routine or simply combine saved P(2D line search) - IF (lsstep .LE. 2) THEN + IF (lsstep <= 2) THEN CALL optimization_step(ls_scf_env%curvy_data, ls_scf_env) ELSE IF (lsstep == ls_scf_env%curvy_data%line_search_type) THEN ! line_search type has the value appropriate to the number of energy calculations needed @@ -125,7 +125,7 @@ CONTAINS IF (ls_scf_env%nspins == 1) CALL dbcsr_scale(ls_scf_env%matrix_p(1), 2.0_dp) ! P-matrices only need to be stored in case of 2D line search - IF (lsstep .LE. 3 .AND. ls_scf_env%curvy_data%line_search_type == ls_scf_line_search_3point_2d) THEN + IF (lsstep <= 3 .AND. ls_scf_env%curvy_data%line_search_type == ls_scf_line_search_3point_2d) THEN DO i = 1, ls_scf_env%nspins CALL dbcsr_copy(ls_scf_env%curvy_data%matrix_psave(i, lsstep), & ls_scf_env%matrix_p(i)) @@ -175,7 +175,7 @@ CONTAINS curvy_data%BCH_saved = 0 ELSE IF (curvy_data%line_search_step == 2) THEN step_size = curvy_data%step_size - IF (curvy_data%energies(1) - curvy_data%energies(2) .GT. 0.0_dp) THEN + IF (curvy_data%energies(1) - curvy_data%energies(2) > 0.0_dp) THEN curvy_data%step_size = curvy_data%step_size*2.0_dp curvy_data%double_step_size = .TRUE. ELSE @@ -225,7 +225,7 @@ CONTAINS TYPE(cp_logger_type), POINTER :: logger logger => cp_get_default_logger() - IF (energies(1) - energies(2) .LT. 0._dp) THEN + IF (energies(1) - energies(2) < 0._dp) THEN tmp_e = energies(2); energies(2) = energies(3); energies(3) = tmp_e step_size = step_size*2.0_dp END IF @@ -248,13 +248,13 @@ CONTAINS v2 = -(param(2)**2)/(2.0_dp*param(1)) + 2.0_dp*param(3) step_size(2) = v1/v2 step_size(1) = (-param(2)*step_size(2) - param(4))/(2.0_dp*param(1)) - IF (step_size(1) .LT. 0.0_dp) step_size(1) = 1.0_dp - IF (step_size(2) .LT. 0.0_dp) step_size(2) = 1.0_dp + IF (step_size(1) < 0.0_dp) step_size(1) = 1.0_dp + IF (step_size(2) < 0.0_dp) step_size(2) = 1.0_dp ! step_size(1)=MIN(step_size(1),2.0_dp) ! step_size(2)=MIN(step_size(2),2.0_dp) e_pred = param(1)*step_size(1)**2 + param(2)*step_size(1)*step_size(2) + & param(3)*step_size(2)**2 + param(4)*step_size(1) + param(5)*step_size(2) + param(6) - IF (unit_nr .GT. 0) WRITE (unit_nr, "(t3,a,F10.5,F10.5,A,F20.9)") & + IF (unit_nr > 0) WRITE (unit_nr, "(t3,a,F10.5,F10.5,A,F20.9)") & " Line Search: Step Size", step_size, " Predicted energy", e_pred e_pred = param(1)*s1**2 + param(2)*s2*s1*0.0_dp + & param(3)*s1**2*0.0_dp + param(4)*s1 + param(5)*s1*0.0_dp + param(6) @@ -279,7 +279,7 @@ CONTAINS TYPE(cp_logger_type), POINTER :: logger logger => cp_get_default_logger() - IF (energies(1) - energies(2) .LT. 0._dp) THEN + IF (energies(1) - energies(2) < 0._dp) THEN tmp_e = energies(2); energies(2) = energies(3); energies(3) = tmp_e step_size = step_size*2.0_dp END IF @@ -292,18 +292,18 @@ CONTAINS c = energies(1) a = (energies(3) + c - 2.0_dp*energies(2))/(2.0_dp*step1**2) b = (energies(2) - c - a*step1**2)/step1 - IF (a .LT. 1.0E-12_dp) a = -1.0E-12_dp + IF (a < 1.0E-12_dp) a = -1.0E-12_dp min_val = -b/(2.0_dp*a) e_pred = a*min_val**2 + b*min_val + c tmp = step_size(1) - IF (e_pred .LT. energies(1) .AND. e_pred .LT. energies(2)) THEN + IF (e_pred < energies(1) .AND. e_pred < energies(2)) THEN step_size = MAX(-1.0_dp, & MIN(min_val, 10_dp*step_size)) ELSE step_size = 1.0_dp END IF e_pred = a*(step_size(1))**2 + b*(step_size(1)) + c - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, "(t3,a,f16.8,a,F20.9)") "Line Search: Step Size", step_size(1), " Predicted energy", e_pred CALL m_flush(unit_nr) END IF @@ -414,17 +414,17 @@ CONTAINS ! check for convergence of the newton step maxel = dbcsr_frobenius_norm(matrix_res) - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, "(T3,A,F12.6)") "Convergence of Newton iteration ", maxel CALL m_flush(unit_nr) END IF - at_limit = at_limit .OR. (old_conv/maxel .LT. 1.01_dp) + at_limit = at_limit .OR. (old_conv/maxel < 1.01_dp) old_conv = maxel - IF (i == ncyc .AND. maxel/conv_val .GT. 5.0_dp) THEN + IF (i == ncyc .AND. maxel/conv_val > 5.0_dp) THEN fix_shift(ispin) = .TRUE. curvy_shift(ispin) = 4.0_dp*shift END IF - IF (maxel .LT. conv_val .OR. at_limit) EXIT + IF (maxel < conv_val .OR. at_limit) EXIT END DO ! Refine the Newton like search direction with a preconditioned cg update @@ -435,11 +435,11 @@ CONTAINS cg_denom(ispin) = cg_numer(ispin) CALL dbcsr_dot(matrix_cg, matrix_dp(ispin), cg_numer(ispin)) beta = cg_numer(ispin)/MAX(cg_denom(ispin), 1.0E-6_dp) - IF (beta .LT. 1.0_dp) THEN + IF (beta < 1.0_dp) THEN beta = MAX(0.0_dp, beta) CALL dbcsr_add(matrix_dp(ispin), matrix_dp_old, 1.0_dp, beta) END IF - IF (unit_nr .GT. 0) WRITE (unit_nr, "(A)") " " + IF (unit_nr > 0) WRITE (unit_nr, "(A)") " " END DO CALL dbcsr_release(matrix_PKs) @@ -452,7 +452,7 @@ CONTAINS CALL dbcsr_release(matrix_res) CALL dbcsr_release(matrix_cg) - IF (unit_nr .GT. 0) CALL m_flush(unit_nr) + IF (unit_nr > 0) CALL m_flush(unit_nr) CALL timestop(handle) END SUBROUTINE compute_direction_newton @@ -508,7 +508,7 @@ CONTAINS alpha = norm_rr/norm_cA CALL dbcsr_add(res, Ax, 1.0_dp, -alpha) CALL dbcsr_dot(res, res, new_norm) - IF (norm_rr .LT. eps_filter*0.001_dp .OR. new_norm .LT. eps_filter*0.001_dp) THEN + IF (norm_rr < eps_filter*0.001_dp .OR. new_norm < eps_filter*0.001_dp) THEN beta = 0.0_dp at_limit = .TRUE. ELSE @@ -659,13 +659,13 @@ CONTAINS CALL dbcsr_add(matrix_p_out(ispin), matrix_BCH(ispin, i), 1.0_dp, ifac(i)*step_fac) CALL dbcsr_add(matrix_tmp, matrix_p_out(ispin), 1.0_dp, -1.0_dp) frob_norm = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr .GT. 0) WRITE (unit_nr, "(t3,a,i3,a,f16.8)") "BCH: step", i, " Norm of P_old-Pnew:", frob_norm - IF (frob_norm .LT. threshold) EXIT + IF (unit_nr > 0) WRITE (unit_nr, "(t3,a,i3,a,f16.8)") "BCH: step", i, " Norm of P_old-Pnew:", frob_norm + IF (frob_norm < threshold) EXIT END DO - IF (frob_norm .LT. threshold) CYCLE + IF (frob_norm < threshold) CYCLE ! If the copy and scale isn't enough compute a few more BCH steps. 20 seems high but except of the first step it will never be close - save_BCH = BCH_saved(ispin) == 0 .AND. n_bch_hist .GT. 0 + save_BCH = BCH_saved(ispin) == 0 .AND. n_bch_hist > 0 DO i = BCH_saved(ispin) + 1, 20 step_fac = step_fac*step_size(ispin) !allow for a bit of matrix magic here by exploiting matrix and matrix_tmp @@ -681,7 +681,7 @@ CONTAINS !Finally, add the new BCH order to P, but store the previous one for a convergence check CALL dbcsr_copy(matrix_tmp, matrix_p_out(ispin)) CALL dbcsr_add(matrix_p_out(ispin), matrix, 1.0_dp, ifac(i)*step_fac) - IF (save_BCH .AND. i .LE. n_bch_hist) THEN + IF (save_BCH .AND. i <= n_bch_hist) THEN CALL dbcsr_copy(matrix_BCH(ispin, i), matrix) nsave = i END IF @@ -690,19 +690,19 @@ CONTAINS !Stop the BCH-series if two successive P's differ by less the threshold frob_norm = dbcsr_frobenius_norm(matrix_tmp) - IF (unit_nr .GT. 0) WRITE (unit_nr, "(t3,a,i3,a,f16.8)") "BCH: step", i, " Norm of P_old-Pnew:", frob_norm - IF (frob_norm .LT. threshold) EXIT + IF (unit_nr > 0) WRITE (unit_nr, "(t3,a,i3,a,f16.8)") "BCH: step", i, " Norm of P_old-Pnew:", frob_norm + IF (frob_norm < threshold) EXIT !Copy the latest BCH-matrix on matrix tmp, so we can cycle with all matrices in place CALL dbcsr_copy(matrix_tmp, matrix) CALL dbcsr_filter(matrix_tmp, threshold) END DO BCH_saved(ispin) = nsave - IF (unit_nr .GT. 0) WRITE (unit_nr, "(A)") " " + IF (unit_nr > 0) WRITE (unit_nr, "(A)") " " END DO CALL purify_mcweeny(matrix_p_out, threshold, 1) - IF (unit_nr .GT. 0) CALL m_flush(unit_nr) + IF (unit_nr > 0) CALL m_flush(unit_nr) CALL dbcsr_release(matrix_tmp) CALL dbcsr_release(matrix) CALL timestop(handle) @@ -836,7 +836,7 @@ CONTAINS END DO END DO END IF - IF (curvy_data%n_bch_hist .GT. 0) THEN + IF (curvy_data%n_bch_hist > 0) THEN ALLOCATE (curvy_data%matrix_BCH(nspins, curvy_data%n_bch_hist)) DO ispin = 1, nspins DO j = 1, curvy_data%n_bch_hist diff --git a/src/dm_ls_scf_methods.F b/src/dm_ls_scf_methods.F index 954f2952ab..b5e9bcfc89 100644 --- a/src/dm_ls_scf_methods.F +++ b/src/dm_ls_scf_methods.F @@ -411,9 +411,9 @@ CONTAINS used_submatrix_sign_method = ls_scf_submatrix_sign_ns IF (PRESENT(submatrix_sign_method)) used_submatrix_sign_method = submatrix_sign_method - internal_mu_adjust = ((sign_method .EQ. ls_scf_sign_submatrix) .AND. & - (used_submatrix_sign_method .EQ. ls_scf_submatrix_sign_direct_muadj .OR. & - used_submatrix_sign_method .EQ. ls_scf_submatrix_sign_direct_muadj_lowmem)) + internal_mu_adjust = ((sign_method == ls_scf_sign_submatrix) .AND. & + (used_submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj .OR. & + used_submatrix_sign_method == ls_scf_submatrix_sign_direct_muadj_lowmem)) IF (internal_mu_adjust) THEN CALL density_matrix_sign_internal_mu(matrix_p, trace, mu, sign_method, & diff --git a/src/dm_ls_scf_qs.F b/src/dm_ls_scf_qs.F index baf38593f5..b088f4e588 100644 --- a/src/dm_ls_scf_qs.F +++ b/src/dm_ls_scf_qs.F @@ -580,10 +580,10 @@ 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 .EQ. direct_mixing_nr) & + IF (ls_scf_env%density_mixing_method == direct_mixing_nr) & CPABORT("Direct P mixing not implemented in linear scaling SCF. ") IF (ls_scf_env%density_mixing_method >= gspace_mixing_nr) THEN - IF (iscf .GT. MAX(ls_scf_env%mixing_store%nskip_mixing, 1)) THEN + IF (iscf > MAX(ls_scf_env%mixing_store%nskip_mixing, 1)) THEN CALL gspace_mixing(qs_env, ls_scf_env%density_mixing_method, & ls_scf_env%mixing_store, rho, para_env, & iscf - 1) diff --git a/src/domain_submatrix_methods.F b/src/domain_submatrix_methods.F index 3eeaa607bc..4728d4c118 100644 --- a/src/domain_submatrix_methods.F +++ b/src/domain_submatrix_methods.F @@ -154,11 +154,11 @@ CONTAINS ndomains = SIZE(original) ndomainsB = SIZE(copy) - CPASSERT(ndomains .EQ. ndomainsB) + CPASSERT(ndomains == ndomainsB) copy(:)%nnodes = original(:)%nnodes copy(:)%group = original(:)%group DO idomain = 1, ndomains - IF (original(idomain)%domain .GT. 0) THEN + IF (original(idomain)%domain > 0) THEN CALL copy_submatrix(original(idomain), copy(idomain), copy_data) END IF END DO ! loop over domains @@ -189,7 +189,7 @@ CONTAINS copy%nnodes = original%nnodes copy%group = original%group - IF (original%domain .GT. 0) THEN + IF (original%domain > 0) THEN copy%nbrows = original%nbrows copy%nbcols = original%nbcols @@ -199,7 +199,7 @@ CONTAINS IF (.NOT. ALLOCATED(copy%dbcsr_row)) THEN ALLOCATE (copy%dbcsr_row(original%nbrows)) ELSE - IF (SIZE(copy%dbcsr_row) .NE. SIZE(original%dbcsr_row)) THEN + IF (SIZE(copy%dbcsr_row) /= SIZE(original%dbcsr_row)) THEN DEALLOCATE (copy%dbcsr_row) ALLOCATE (copy%dbcsr_row(original%nbrows)) END IF @@ -207,7 +207,7 @@ CONTAINS IF (.NOT. ALLOCATED(copy%dbcsr_col)) THEN ALLOCATE (copy%dbcsr_col(original%nbcols)) ELSE - IF (SIZE(copy%dbcsr_col) .NE. SIZE(original%dbcsr_col)) THEN + IF (SIZE(copy%dbcsr_col) /= SIZE(original%dbcsr_col)) THEN DEALLOCATE (copy%dbcsr_col) ALLOCATE (copy%dbcsr_col(original%nbcols)) END IF @@ -215,7 +215,7 @@ CONTAINS IF (.NOT. ALLOCATED(copy%size_brow)) THEN ALLOCATE (copy%size_brow(original%nbrows)) ELSE - IF (SIZE(copy%size_brow) .NE. SIZE(original%size_brow)) THEN + IF (SIZE(copy%size_brow) /= SIZE(original%size_brow)) THEN DEALLOCATE (copy%size_brow) ALLOCATE (copy%size_brow(original%nbrows)) END IF @@ -223,7 +223,7 @@ CONTAINS IF (.NOT. ALLOCATED(copy%size_bcol)) THEN ALLOCATE (copy%size_bcol(original%nbcols)) ELSE - IF (SIZE(copy%size_bcol) .NE. SIZE(original%size_bcol)) THEN + IF (SIZE(copy%size_bcol) /= SIZE(original%size_bcol)) THEN DEALLOCATE (copy%size_bcol) ALLOCATE (copy%size_bcol(original%nbcols)) END IF @@ -265,7 +265,7 @@ CONTAINS CALL timeset(routineN, handle) - CPASSERT(copy%domain .GT. 0) + CPASSERT(copy%domain > 0) ds1 = SIZE(array, 1) ds2 = SIZE(array, 2) @@ -275,7 +275,7 @@ CONTAINS ELSE ms1 = SIZE(copy%mdata, 1) ms2 = SIZE(copy%mdata, 2) - IF ((ds1 .NE. ms1) .OR. (ds2 .NE. ms2)) THEN + IF ((ds1 /= ms1) .OR. (ds2 /= ms2)) THEN DEALLOCATE (copy%mdata) ALLOCATE (copy%mdata(ds1, ds2)) END IF @@ -306,7 +306,7 @@ CONTAINS ndomains = SIZE(submatrices) DO idomain = 1, ndomains - IF (submatrices(idomain)%domain .GT. 0) THEN + IF (submatrices(idomain)%domain > 0) THEN CALL set_submatrix(submatrices(idomain), scalar) END IF END DO ! loop over domains @@ -331,9 +331,9 @@ CONTAINS CALL timeset(routineN, handle) - CPASSERT(submatrix%domain .GT. 0) - CPASSERT(submatrix%nrows .GT. 0) - CPASSERT(submatrix%ncols .GT. 0) + CPASSERT(submatrix%domain > 0) + CPASSERT(submatrix%nrows > 0) + CPASSERT(submatrix%ncols > 0) ds1 = submatrix%nrows ds2 = submatrix%ncols @@ -343,7 +343,7 @@ CONTAINS ELSE ms1 = SIZE(submatrix%mdata, 1) ms2 = SIZE(submatrix%mdata, 2) - IF ((ds1 .NE. ms1) .OR. (ds2 .NE. ms2)) THEN + IF ((ds1 /= ms1) .OR. (ds2 /= ms2)) THEN DEALLOCATE (submatrix%mdata) ALLOCATE (submatrix%mdata(ds1, ds2)) END IF @@ -448,15 +448,15 @@ CONTAINS CALL timeset(routineN, handle) - CPASSERT(A%domain .GT. 0) - CPASSERT(B%domain .GT. 0) - CPASSERT(C%domain .GT. 0) + CPASSERT(A%domain > 0) + CPASSERT(B%domain > 0) + CPASSERT(C%domain > 0) LDA = SIZE(A%mdata, 1) LDB = SIZE(B%mdata, 1) - NOTA = (transA .EQ. 'N') .OR. (transA .EQ. 'n') - NOTB = (transB .EQ. 'N') .OR. (transB .EQ. 'n') + NOTA = (transA == 'N') .OR. (transA == 'n') + NOTB = (transB == 'N') .OR. (transB == 'n') IF (NOTA) THEN M = A%nrows @@ -479,7 +479,7 @@ CONTAINS END IF ! these checks are for debugging only - CPASSERT(K .EQ. K1) + CPASSERT(K == K1) ! conform C matrix C%nrows = M @@ -525,14 +525,14 @@ CONTAINS IF (.NOT. ALLOCATED(C%mdata)) THEN !!! cannot use non-zero beta if C is not allocated - CPASSERT(beta .EQ. 0.0_dp) + CPASSERT(beta == 0.0_dp) ALLOCATE (C%mdata(C%nrows, C%ncols)) ELSE cs1 = SIZE(C%mdata, 1) cs2 = SIZE(C%mdata, 2) - IF ((C%nrows .NE. cs1) .OR. (C%ncols .NE. cs2)) THEN + IF ((C%nrows /= cs1) .OR. (C%ncols /= cs2)) THEN !!! cannot deallocate data if beta is non-zero - CPASSERT(beta .EQ. 0.0_dp) + CPASSERT(beta == 0.0_dp) DEALLOCATE (C%mdata) ALLOCATE (C%mdata(C%nrows, C%ncols)) END IF @@ -580,20 +580,20 @@ CONTAINS ndomainsB = SIZE(B) ndomainsC = SIZE(C) - CPASSERT(ndomains .EQ. ndomainsB) - CPASSERT(ndomainsB .EQ. ndomainsC) + CPASSERT(ndomains == ndomainsB) + CPASSERT(ndomainsB == ndomainsC) DO idomain = 1, ndomains idomainA = A(idomain)%domain idomainB = B(idomain)%domain - CPASSERT(idomainA .EQ. idomainB) + CPASSERT(idomainA == idomainB) C(idomain)%domain = idomainA ! check if the submatrix exists - IF (idomainA .GT. 0) THEN + IF (idomainA > 0) THEN CALL multiply_submatrices_once(transA, transB, alpha, A(idomain), B(idomain), beta, C(idomain)) END IF ! submatrix for the domain exists @@ -627,13 +627,13 @@ CONTAINS CALL timeset(routineN, handle) - CPASSERT(A%domain .GT. 0) - CPASSERT(B%domain .GT. 0) + CPASSERT(A%domain > 0) + CPASSERT(B%domain > 0) R1 = A%nrows C1 = A%ncols - NOTB = (transB .EQ. 'N') .OR. (transB .EQ. 'n') + NOTB = (transB == 'N') .OR. (transB == 'n') IF (NOTB) THEN R2 = B%nrows @@ -644,8 +644,8 @@ CONTAINS END IF ! these checks are for debugging only - CPASSERT(C1 .EQ. C2) - CPASSERT(R1 .EQ. R2) + CPASSERT(C1 == C2) + CPASSERT(R1 == R2) IF (NOTB) THEN DO icol = 1, C1 @@ -689,17 +689,17 @@ CONTAINS ndomains = SIZE(A) ndomainsB = SIZE(B) - CPASSERT(ndomains .EQ. ndomainsB) + CPASSERT(ndomains == ndomainsB) DO idomain = 1, ndomains idomainA = A(idomain)%domain idomainB = B(idomain)%domain - CPASSERT(idomainA .EQ. idomainB) + CPASSERT(idomainA == idomainB) ! check if the submatrix exists - IF (idomainA .GT. 0) THEN + IF (idomainA > 0) THEN CALL add_submatrices_once(alpha, A(idomain), beta, B(idomain), transB) END IF ! submatrix for the domain exists @@ -738,9 +738,9 @@ CONTAINS DO idomain = 1, ndomains ! check if the submatrix is local - IF (submatrices(idomain)%domain .GT. 0) THEN + IF (submatrices(idomain)%domain > 0) THEN curr_norm = MAXVAL(ABS(submatrices(idomain)%mdata)) - IF (curr_norm .GT. send_norm) send_norm = curr_norm + IF (curr_norm > send_norm) send_norm = curr_norm END IF END DO ! loop over domains @@ -786,20 +786,20 @@ CONTAINS ndomainsA = SIZE(A) ndomainsB = SIZE(B) - CPASSERT(ndomainsA .EQ. ndomainsB) + CPASSERT(ndomainsA == ndomainsB) DO idomain = 1, ndomainsA domainA = A(idomain)%domain domainB = B(idomain)%domain - CPASSERT(domainA .EQ. domainB) + CPASSERT(domainA == domainB) ! check if the submatrix is local - IF (domainA .GT. 0) THEN + IF (domainA > 0) THEN - CPASSERT(A(idomain)%nrows .EQ. B(idomain)%nrows) - CPASSERT(A(idomain)%ncols .EQ. B(idomain)%ncols) + CPASSERT(A(idomain)%nrows == B(idomain)%nrows) + CPASSERT(A(idomain)%ncols == B(idomain)%ncols) curr_trace = SUM(A(idomain)%mdata(:, :)*B(idomain)%mdata(:, :)) send_trace = send_trace + curr_trace @@ -893,7 +893,7 @@ CONTAINS ! loop over those rows that have non-zero quencher index_sr = 1 ! index start row - IF (idomain .GT. 1) index_sr = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sr = domain_map%index1(idomain - 1) index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er @@ -903,7 +903,7 @@ CONTAINS IF (job_type == select_row_col) THEN ! loop over those columns that have non-zero quencher index_sc = 1 ! index start col - IF (idomain .GT. 1) index_sc = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sc = domain_map%index1(idomain - 1) index_ec = domain_map%index1(idomain) - 1 ! index end col ELSE ! fake loop @@ -922,7 +922,7 @@ CONTAINS transp = .FALSE. CALL dbcsr_get_stored_coordinates(matrix, & row, col, block_node) - IF (block_node .EQ. myNode) THEN + IF (block_node == myNode) THEN CALL dbcsr_get_block_p(matrix, row, col, block_p, found, row_size, col_size) IF (found) THEN send_descriptor(1, dest_node + 1) = send_descriptor(1, dest_node + 1) + 1 @@ -1026,7 +1026,7 @@ CONTAINS ! loop over those rows that have non-zero quencher index_sr = 1 ! index start row - IF (idomain .GT. 1) index_sr = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sr = domain_map%index1(idomain - 1) index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er @@ -1036,7 +1036,7 @@ CONTAINS IF (job_type == select_row_col) THEN ! loop over those columns that have non-zero quencher index_sc = 1 ! index start col - IF (idomain .GT. 1) index_sc = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sc = domain_map%index1(idomain - 1) index_ec = domain_map%index1(idomain) - 1 ! index end col ELSE ! fake loop @@ -1055,7 +1055,7 @@ CONTAINS transp = .FALSE. CALL dbcsr_get_stored_coordinates(matrix, & row, col, block_node) - IF (block_node .EQ. myNode) THEN + 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 @@ -1146,7 +1146,7 @@ CONTAINS ! subm_row_size(:)=0 ! subm_col_size(:)=0 ndomains2 = SIZE(submatrix) - IF (ndomains2 .NE. ndomains) THEN + IF (ndomains2 /= ndomains) THEN CPABORT("wrong submatrix size") END IF CALL release_submatrices(submatrix) @@ -1162,7 +1162,7 @@ CONTAINS !transp=.FALSE. !CALL dbcsr_get_stored_coordinates(distr_pattern,& ! idomain, idomain, transp, dest_node) - IF (dest_node .EQ. mynode) THEN + IF (dest_node == mynode) THEN submatrix(idomain)%domain = idomain submatrix(idomain)%nbrows = 0 submatrix(idomain)%nbcols = 0 @@ -1170,7 +1170,7 @@ CONTAINS ! loop over those rows that have non-zero quencher first_row(:) = -1 index_sr = 1 ! index start row - IF (idomain .GT. 1) index_sr = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sr = domain_map%index1(idomain - 1) index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) @@ -1186,7 +1186,7 @@ CONTAINS smrow = 1 ! again loop over those rows that have non-zero quencher index_sr = 1 ! index start row - IF (idomain .GT. 1) index_sr = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sr = domain_map%index1(idomain - 1) index_er = domain_map%index1(idomain) - 1 ! index end row DO index_row = index_sr, index_er row = domain_map%pairs(index_row, 1) @@ -1203,7 +1203,7 @@ CONTAINS IF (job_type == select_row_col) THEN ! loop over those columns that have non-zero quencher index_sc = 1 ! index start col - IF (idomain .GT. 1) index_sc = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sc = domain_map%index1(idomain - 1) index_ec = domain_map%index1(idomain) - 1 ! index end col ELSE ! fake loop @@ -1237,7 +1237,7 @@ CONTAINS IF (job_type == select_row_col) THEN ! loop over those columns that have non-zero quencher index_sc = 1 ! index start col - IF (idomain .GT. 1) index_sc = domain_map%index1(idomain - 1) + IF (idomain > 1) index_sc = domain_map%index1(idomain - 1) index_ec = domain_map%index1(idomain) - 1 ! index end col ELSE ! fake loop @@ -1269,7 +1269,7 @@ CONTAINS row = recv_data2(recv_offset2_cpu(iNode) + (iBlock - 1)*2 + 1) col = recv_data2(recv_offset2_cpu(iNode) + (iBlock - 1)*2 + 2) ! check if this block should be in the submatrix of this domain - IF ((first_col(col) .NE. -1) .AND. (first_row(row) .NE. -1)) THEN + IF ((first_col(col) /= -1) .AND. (first_row(row) /= -1)) THEN ! copy data from the received array into submatrix start_data = recv_offset_cpu(iNode) + block_offset + 1 DO icol = 0, col_blk_size(col) - 1 @@ -1370,7 +1370,7 @@ CONTAINS ndomains = nblkcols_tot ! RZK-warning not true for atomic distributions ndomains2 = SIZE(submatrix) - IF (ndomains .NE. ndomains2) THEN + IF (ndomains /= ndomains2) THEN CPABORT("domain mismatch") END IF @@ -1380,7 +1380,7 @@ CONTAINS CALL group%set_handle(GroupID) matrix_type = dbcsr_get_matrix_type(matrix) - IF (matrix_type .NE. dbcsr_type_no_symmetry) THEN + IF (matrix_type /= dbcsr_type_no_symmetry) THEN CPABORT("only non-symmetric matrices so far") END IF @@ -1403,18 +1403,18 @@ CONTAINS ! loop over domains - find how much data to send DO idomain = 1, ndomains - IF (submatrix(idomain)%domain .GT. 0) THEN + IF (submatrix(idomain)%domain > 0) THEN DO irow_subm = 1, submatrix(idomain)%nbrows - IF (submatrix(idomain)%nbcols .NE. 1) THEN + IF (submatrix(idomain)%nbcols /= 1) THEN CPABORT("corrupt submatrix structure") END IF row = submatrix(idomain)%dbcsr_row(irow_subm) col = submatrix(idomain)%dbcsr_col(1) - IF (col .NE. idomain) THEN + IF (col /= idomain) THEN CPABORT("corrupt submatrix structure") END IF @@ -1491,7 +1491,7 @@ CONTAINS ! loop over domains - collect data to send DO idomain = 1, ndomains - IF (submatrix(idomain)%domain .GT. 0) THEN + IF (submatrix(idomain)%domain > 0) THEN smroff = 0 DO irow_subm = 1, submatrix(idomain)%nbrows @@ -1605,7 +1605,7 @@ CONTAINS ncols = SIZE(submatrices(i)%mdata, 2) WRITE (colstr, *) ncols formatstr = '('//TRIM(ADJUSTL(colstr))//'F16.9)' - IF (submatrices(i)%domain .GT. 0) THEN + IF (submatrices(i)%domain > 0) THEN WRITE (*, *) "SUBMATRIX: ", i, nrows, 'x', ncols nrows = SIZE(submatrices(i)%mdata, 1) DO irow = 1, nrows @@ -1642,17 +1642,17 @@ CONTAINS ndomains = SIZE(map%index1) qblk_exists = .FALSE. - IF (col .LT. 1 .OR. col .GT. ndomains) RETURN + IF (col < 1 .OR. col > ndomains) RETURN first = 1 - IF (col .GT. 1) first = map%index1(col - 1) + IF (col > 1) first = map%index1(col - 1) last = map%index1(col) - 1 ! perform binary search within first-last - DO WHILE (last .GE. first) + DO WHILE (last >= first) mid = first + (last - first)/2 - IF (map%pairs(mid, 1) .GT. row) THEN + IF (map%pairs(mid, 1) > row) THEN last = mid - 1 - ELSE IF (map%pairs(mid, 1) .LT. row) THEN + ELSE IF (map%pairs(mid, 1) < row) THEN first = mid + 1 ELSE qblk_exists = .TRUE. ! SUCCESS!! diff --git a/src/ec_environment.F b/src/ec_environment.F index 959b60f494..67e7b92aa9 100644 --- a/src/ec_environment.F +++ b/src/ec_environment.F @@ -300,7 +300,7 @@ CONTAINS ! Basis sets of energy correction CALL get_qs_kind(qs_kind=qs_kind, basis_set=harris_basis, basis_type="HARRIS") - IF (basis_set%name .NE. harris_basis%name) THEN + IF (basis_set%name /= harris_basis%name) THEN ec_env%basis_inconsistent = .TRUE. END IF END DO @@ -374,9 +374,9 @@ CONTAINS ! Initialize Harris LS solver environment ec_env%use_ls_solver = .FALSE. - ec_env%use_ls_solver = (ec_env%ks_solver .EQ. ec_matrix_sign) & - .OR. (ec_env%ks_solver .EQ. ec_matrix_trs4) & - .OR. (ec_env%ks_solver .EQ. ec_matrix_tc2) + ec_env%use_ls_solver = (ec_env%ks_solver == ec_matrix_sign) & + .OR. (ec_env%ks_solver == ec_matrix_trs4) & + .OR. (ec_env%ks_solver == ec_matrix_tc2) IF (ec_env%use_ls_solver) THEN CALL ec_ls_create(qs_env, ec_env) diff --git a/src/ec_orth_solver.F b/src/ec_orth_solver.F index ac529b24d5..70739d1940 100644 --- a/src/ec_orth_solver.F +++ b/src/ec_orth_solver.F @@ -239,14 +239,14 @@ CONTAINS IF (abnormal_value(norm_rr(ispin))) & CPABORT("Preconditioner: Tr[r_j*r_j] is an abnormal value (NaN/Inf)") - IF (norm_rr(ispin) .LT. 0.0_dp) CPABORT("norm_rr < 0") + IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0") norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp))) ! norm_cA = tr(Ap_j * p_j) CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin)) ! Determine step-size - IF (norm_cA(ispin) .LT. linres_control%eps) THEN + IF (norm_cA(ispin) < linres_control%eps) THEN alpha(ispin) = 1.0_dp ELSE alpha(ispin) = norm_rr(ispin)/norm_cA(ispin) @@ -266,13 +266,13 @@ CONTAINS DO ispin = 1, nspins ! 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) .LT. 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") + IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") IF (abnormal_value(new_norm(ispin))) & CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) - IF (norm_rr(ispin) .LT. linres_control%eps*0.001_dp & - .OR. new_norm(ispin) .LT. linres_control%eps*0.001_dp) THEN + IF (norm_rr(ispin) < linres_control%eps*0.001_dp & + .OR. new_norm(ispin) < linres_control%eps*0.001_dp) THEN beta(ispin) = 0.0_dp converged = .TRUE. ELSE @@ -288,12 +288,12 @@ CONTAINS END DO ! Convergence criteria - IF (norm_res .LT. linres_control%eps) THEN + IF (norm_res < linres_control%eps) THEN converged = .TRUE. END IF t2 = m_walltime() - IF (i .EQ. 1 .OR. MOD(i, 1) .EQ. 0 .OR. converged) THEN + IF (i == 1 .OR. MOD(i, 1) == 0 .OR. converged) THEN IF (iounit > 0) THEN WRITE (iounit, "(T10,I5,T25,1E8.2,T33,F25.14,T58,F8.2)") & i, MAXVAL(alpha), norm_res, t2 - t1 @@ -583,7 +583,7 @@ CONTAINS ! Tr(r_0 * z_0) CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_cg(ispin)%matrix, norm_rr(ispin)) - IF (norm_rr(ispin) .LT. 0.0_dp) CPABORT("norm_rr < 0") + IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0") norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp))) END DO @@ -610,12 +610,12 @@ CONTAINS ! Convergence criteria ! default for eps 10E-6 in MO_linres - IF (norm_res .LT. linres_control%eps) THEN + IF (norm_res < linres_control%eps) THEN linres_control%converged = .TRUE. END IF t2 = m_walltime() - IF (i .EQ. 1 .OR. MOD(i, 1) .EQ. 0 .OR. linres_control%converged & + IF (i == 1 .OR. MOD(i, 1) == 0 .OR. linres_control%converged & .OR. restart .OR. should_stop) THEN IF (iounit > 0) THEN WRITE (iounit, "(T5,I5,T18,A3,T28,L1,T38,1E8.2,T48,F16.10,T68,F8.2)") & @@ -666,7 +666,7 @@ CONTAINS ! norm_cA = tr(Ap_j * p_j) CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin)) - IF (norm_cA(ispin) .LT. 0.0_dp) THEN + IF (norm_cA(ispin) < 0.0_dp) THEN ! Recalculate w/o preconditioner IF (i > 1) THEN @@ -707,7 +707,7 @@ CONTAINS DO ispin = 1, nspins ! Determine step-size - IF (norm_cA(ispin) .LT. linres_control%eps) THEN + IF (norm_cA(ispin) < linres_control%eps) THEN alpha(ispin) = 1.0_dp ELSE alpha(ispin) = norm_rr(ispin)/norm_cA(ispin) @@ -720,7 +720,7 @@ CONTAINS ! need to recompute the residue restart = .FALSE. - IF (MOD(i, linres_control%restart_every) .EQ. 0) THEN + IF (MOD(i, linres_control%restart_every) == 0) THEN ! ! r_j+1 = b - A * x_j+1 CALL build_hessian_op(qs_env=qs_env, & @@ -777,12 +777,12 @@ CONTAINS DO ispin = 1, nspins ! 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) .LT. 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") + IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0") IF (abnormal_value(new_norm(ispin))) & CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)") norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp)) - IF (norm_rr(ispin) .LT. linres_control%eps .OR. new_norm(ispin) .LT. linres_control%eps) THEN + IF (norm_rr(ispin) < linres_control%eps .OR. new_norm(ispin) < linres_control%eps) THEN beta(ispin) = 0.0_dp linres_control%converged = .TRUE. ELSE @@ -1057,7 +1057,7 @@ CONTAINS END DO ! skip the kernel if the DM is very small - IF (chksum .GT. 1.0E-14_dp) THEN + IF (chksum > 1.0E-14_dp) THEN ! Bring matrix B as density on grid diff --git a/src/efield_utils.F b/src/efield_utils.F index 0854f40138..dba2301f2c 100644 --- a/src/efield_utils.F +++ b/src/efield_utils.F @@ -139,18 +139,18 @@ CONTAINS pol(:) = efield%polarisation(:)/(SQRT(DOT_PRODUCT(efield%polarisation, efield%polarisation))) END IF IF (efield%envelop_id == constant_env) THEN - IF (sim_step .GE. efield%envelop_i_vars(1) .AND. & - (sim_step .LE. efield%envelop_i_vars(2) .OR. efield%envelop_i_vars(2) .LT. 0)) THEN + IF (sim_step >= efield%envelop_i_vars(1) .AND. & + (sim_step <= efield%envelop_i_vars(2) .OR. efield%envelop_i_vars(2) < 0)) THEN field = field + strength*COS(sim_time*nu*2.0_dp*pi + & efield%phase_offset*pi)*pol(:) END IF ELSE IF (efield%envelop_id == ramp_env) THEN - IF (sim_step .GE. efield%envelop_i_vars(1) .AND. sim_step .LE. efield%envelop_i_vars(2)) & + IF (sim_step >= efield%envelop_i_vars(1) .AND. sim_step <= efield%envelop_i_vars(2)) & strength = strength*(sim_step - efield%envelop_i_vars(1))/(efield%envelop_i_vars(2) - efield%envelop_i_vars(1)) - IF (sim_step .GE. efield%envelop_i_vars(3) .AND. sim_step .LE. efield%envelop_i_vars(4)) & + IF (sim_step >= efield%envelop_i_vars(3) .AND. sim_step <= efield%envelop_i_vars(4)) & strength = strength*(efield%envelop_i_vars(4) - sim_step)/(efield%envelop_i_vars(4) - efield%envelop_i_vars(3)) - IF (sim_step .GT. efield%envelop_i_vars(4) .AND. efield%envelop_i_vars(4) .GT. 0) strength = 0.0_dp - IF (sim_step .LE. efield%envelop_i_vars(1)) strength = 0.0_dp + 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*2.0_dp*pi + & efield%phase_offset*pi)*pol(:) ELSE IF (efield%envelop_id == gaussian_env) THEN @@ -159,7 +159,7 @@ CONTAINS efield%phase_offset*pi)*pol(:) ELSE IF (efield%envelop_id == custom_env) THEN dt = efield%envelop_r_vars(1) - IF (sim_time .LT. (SIZE(efield%envelop_r_vars) - 2)*dt) THEN + IF (sim_time < (SIZE(efield%envelop_r_vars) - 2)*dt) THEN !make a linear interpolation between the two next points lower = FLOOR(sim_time/dt) upper = lower + 1 diff --git a/src/eip_silicon.F b/src/eip_silicon.F index 7e70963a5c..5b2bb762f4 100644 --- a/src/eip_silicon.F +++ b/src/eip_silicon.F @@ -628,16 +628,16 @@ CONTAINS ! cut=par_a cut = 3.1213820e0_dp + 1.e-14_dp - IF (count .EQ. 0) OPEN (unit=10, file='bazant.mon', status='unknown') + IF (count == 0) OPEN (unit=10, file='bazant.mon', status='unknown') count = count + 1.e0_dp ! linear scaling calculation of verlet list ll1 = INT(alat(1)/cut) - IF (ll1 .LT. 1) CPABORT("alat(1) too small") + IF (ll1 < 1) CPABORT("alat(1) too small") ll2 = INT(alat(2)/cut) - IF (ll2 .LT. 1) CPABORT("alat(2) too small") + IF (ll2 < 1) CPABORT("alat(2) too small") ll3 = INT(alat(3)/cut) - IF (ll3 .LT. 1) CPABORT("alat(3) too small") + IF (ll3 < 1) CPABORT("alat(3) too small") ! determine number of threads npr = 1 @@ -648,7 +648,7 @@ CONTAINS ! linear scaling calculation of verlet list - IF (npr .LE. 1) THEN !serial if too few processors to gain by parallelizing + IF (npr <= 1) THEN !serial if too few processors to gain by parallelizing ! set ncx for serial case, ncx for parallel case set below ncx = 16 @@ -670,7 +670,7 @@ CONTAINS ii = icell(0, l1, l2, l3) ii = ii + 1 icell(0, l1, l2, l3) = ii - IF (ii .GT. ncx) THEN + IF (ii > ncx) THEN WRITE (10, *) count, 'NCX too small', ncx DEALLOCATE (icell) ncx = ncx*2 @@ -710,7 +710,7 @@ CONTAINS ii = icell(0, l1, l2, l3) ii = ii + 1 icell(0, l1, l2, l3) = ii - IF (ii .GT. ncx) THEN + IF (ii > ncx) THEN WRITE (10, *) count, 'NCX too small', ncx DEALLOCATE (icell) ncx = ncx*2 @@ -743,7 +743,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, l2, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, l2, ll3) = il rxyz(1, il) = rxyz(1, i) @@ -756,7 +756,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, l2, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, l2, -1) = il rxyz(1, il) = rxyz(1, i) @@ -776,7 +776,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, l2, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, l2, l3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -789,7 +789,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, l2, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, l2, l3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -809,7 +809,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, 0, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, ll2, l3) = il rxyz(1, il) = rxyz(1, i) @@ -822,7 +822,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, ll2 - 1, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, -1, l3) = il rxyz(1, il) = rxyz(1, i) @@ -841,7 +841,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, 0, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, ll2, ll3) = il rxyz(1, il) = rxyz(1, i) @@ -854,7 +854,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, 0, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, ll2, -1) = il rxyz(1, il) = rxyz(1, i) @@ -867,7 +867,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, ll2 - 1, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, -1, ll3) = il rxyz(1, il) = rxyz(1, i) @@ -880,7 +880,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, ll2 - 1, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, -1, -1) = il rxyz(1, il) = rxyz(1, i) @@ -898,7 +898,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, l2, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, l2, ll3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -911,7 +911,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, l2, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, l2, -1) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -924,7 +924,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, l2, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, l2, ll3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -937,7 +937,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, l2, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, l2, -1) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -955,7 +955,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, 0, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, ll2, l3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -968,7 +968,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, 0, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, ll2, l3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -981,7 +981,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, ll2 - 1, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, -1, l3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -994,7 +994,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, ll2 - 1, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, -1, l3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -1010,7 +1010,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, 0, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, ll2, ll3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -1023,7 +1023,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, 0, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, ll2, ll3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -1036,7 +1036,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, ll2 - 1, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, -1, ll3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -1049,7 +1049,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, ll2 - 1, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, -1, ll3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -1062,7 +1062,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, 0, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, ll2, -1) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -1075,7 +1075,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, 0, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, ll2, -1) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -1088,7 +1088,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, ll2 - 1, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, -1, -1) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -1101,7 +1101,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, ll2 - 1, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, -1, -1) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -1129,7 +1129,7 @@ CONTAINS cut2 = cut**2 ! assign contiguous portions of the arrays lstb and rel to the threads myspace = (nat*nnbrx)/npr - IF (iam .EQ. 0) myspaceout = myspace + IF (iam == 0) myspaceout = myspace ! Verlet list, relative positions indlst = 0 loop_l3: DO l3 = 0, ll3 - 1 @@ -1137,7 +1137,7 @@ CONTAINS loop_l1: DO l1 = 0, ll1 - 1 loop_ii: DO ii = 1, icell(0, l1, l2, l3) iat = icell(ii, l1, l2, l3) - IF (((iat - 1)*npr)/nat .EQ. iam) THEN + IF (((iat - 1)*npr)/nat == iam) THEN ! write(*,*) 'sublstiat:iam,iat',iam,iat lsta(1, iat) = iam*myspace + indlst + 1 CALL sublstiat_b(iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, myspace, & @@ -1157,7 +1157,7 @@ CONTAINS !$OMP END CRITICAL !$OMP END PARALLEL - IF (indlstx .GE. myspaceout) THEN + IF (indlstx >= myspaceout) THEN WRITE (10, *) count, 'NNBRX too small', nnbrx DEALLOCATE (lstb, rel) nnbrx = 3*nnbrx/2 @@ -1180,7 +1180,7 @@ CONTAINS max_nbrs = 30 - IF (npr .NE. 1) THEN + IF (npr /= 1) THEN ! PARALLEL CASE ! create temporary private scalars for reduction sum on energies and ! temporary private array for reduction sum on forces @@ -1188,7 +1188,7 @@ CONTAINS ALLOCATE (txyz(3, nat), s2(max_nbrs, 8), s3(max_nbrs, 7), sz(max_nbrs, 6), & num2(max_nbrs), num3(max_nbrs), numz(max_nbrs)) !$OMP END CRITICAL - IF (iam .EQ. 0) THEN + IF (iam == 0) THEN ener = 0.e0_dp ener2 = 0.e0_dp coord = 0.e0_dp @@ -1245,7 +1245,7 @@ CONTAINS ! write(*,*) 'ener,norm force', & ! ener,DNRM2(3*nat,fxyz,1) - IF (istopg .GT. 0) CPABORT("DIMENSION ERROR (see WARNING above)") + IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat coord_var = coord2/nat - coord**2 @@ -1424,7 +1424,7 @@ CONTAINS s2_dz(n2) = dz s2_r(n2) = r n2 = n2 + 1 - IF (n2 .GT. max_nbrs) THEN + IF (n2 > max_nbrs) THEN WRITE (*, *) 'WARNING enlarge max_nbrs' istop = 1 RETURN @@ -1432,9 +1432,9 @@ CONTAINS ! coordination number calculated with soft cutoff between first ! nearest neighbor and midpoint of first and second nearest neighbor - IF (r .LE. 2.36e0_dp) THEN + IF (r <= 2.36e0_dp) THEN coord_iat = coord_iat + 1.e0_dp - ELSE IF (r .GE. 3.12e0_dp) THEN + ELSE IF (r >= 3.12e0_dp) THEN ELSE xarg = (r - 2.36e0_dp)*(1.e0_dp/(3.12e0_dp - 2.36e0_dp)) coord_iat = coord_iat + (2*xarg + 1.e0_dp)*(xarg - 1.e0_dp)**2 @@ -1442,7 +1442,7 @@ CONTAINS ! RADIAL PARTS OF THREE-BODY INTERACTION r max_nbrs) THEN WRITE (*, *) 'WARNING enlarge max_nbrs' istop = 1 RETURN @@ -1464,8 +1464,8 @@ CONTAINS ! COORDINATION AND NEIGHBOR FUNCTION par_c max_nbrs) THEN WRITE (*, *) 'WARNING enlarge max_nbrs' istop = 1 RETURN @@ -1716,12 +1716,12 @@ CONTAINS DO k1 = l1 - 1, l1 + 1 DO jj = 1, icell(0, k1, k2, k3) jat = icell(jj, k1, k2, k3) - IF (jat .EQ. iat) CYCLE + IF (jat == iat) CYCLE xrel = rxyz(1, iat) - rxyz(1, jat) yrel = rxyz(2, iat) - rxyz(2, jat) zrel = rxyz(3, iat) - rxyz(3, jat) rr2 = xrel**2 + yrel**2 + zrel**2 - IF (rr2 .LE. cut2) THEN + IF (rr2 <= cut2) THEN indlst = MIN(indlst, myspace - 1) lstb(indlst) = lay(jat) ! write(*,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) @@ -1794,16 +1794,16 @@ CONTAINS ! cut=tmax_phi cut = 0.4500000e+01_dp - IF (count .EQ. 0) OPEN (unit=10, file='lenosky.mon', status='unknown') + IF (count == 0) OPEN (unit=10, file='lenosky.mon', status='unknown') count = count + 1.e0_dp ! linear scaling calculation of verlet list ll1 = INT(alat(1)/cut) - IF (ll1 .LT. 1) CPABORT("alat(1) too small") + IF (ll1 < 1) CPABORT("alat(1) too small") ll2 = INT(alat(2)/cut) - IF (ll2 .LT. 1) CPABORT("alat(2) too small") + IF (ll2 < 1) CPABORT("alat(2) too small") ll3 = INT(alat(3)/cut) - IF (ll3 .LT. 1) CPABORT("alat(3) too small") + IF (ll3 < 1) CPABORT("alat(3) too small") ! determine number of threads npr = 1 @@ -1814,7 +1814,7 @@ CONTAINS ! linear scaling calculation of verlet list - IF (npr .LE. 1) THEN !serial if too few processors to gain by parallelizing + IF (npr <= 1) THEN !serial if too few processors to gain by parallelizing ! set ncx for serial case, ncx for parallel case set below ncx = 16 @@ -1836,7 +1836,7 @@ CONTAINS ii = icell(0, l1, l2, l3) ii = ii + 1 icell(0, l1, l2, l3) = ii - IF (ii .GT. ncx) THEN + IF (ii > ncx) THEN WRITE (10, *) count, 'NCX too small', ncx DEALLOCATE (icell) ncx = ncx*2 @@ -1875,7 +1875,7 @@ CONTAINS ii = icell(0, l1, l2, l3) ii = ii + 1 icell(0, l1, l2, l3) = ii - IF (ii .GT. ncx) THEN + IF (ii > ncx) THEN WRITE (10, *) count, 'NCX too small', ncx DEALLOCATE (icell) ncx = ncx*2 @@ -1908,7 +1908,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, l2, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, l2, ll3) = il rxyz(1, il) = rxyz(1, i) @@ -1921,7 +1921,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, l2, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, l2, -1) = il rxyz(1, il) = rxyz(1, i) @@ -1941,7 +1941,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, l2, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, l2, l3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -1954,7 +1954,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, l2, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, l2, l3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -1974,7 +1974,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, 0, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, ll2, l3) = il rxyz(1, il) = rxyz(1, i) @@ -1987,7 +1987,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, ll2 - 1, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, -1, l3) = il rxyz(1, il) = rxyz(1, i) @@ -2006,7 +2006,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, 0, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, ll2, ll3) = il rxyz(1, il) = rxyz(1, i) @@ -2019,7 +2019,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, 0, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, ll2, -1) = il rxyz(1, il) = rxyz(1, i) @@ -2032,7 +2032,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, ll2 - 1, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, -1, ll3) = il rxyz(1, il) = rxyz(1, i) @@ -2045,7 +2045,7 @@ CONTAINS DO ii = 1, in i = icell(ii, l1, ll2 - 1, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, l1, -1, -1) = il rxyz(1, il) = rxyz(1, i) @@ -2063,7 +2063,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, l2, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, l2, ll3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2076,7 +2076,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, l2, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, l2, -1) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2089,7 +2089,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, l2, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, l2, ll3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2102,7 +2102,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, l2, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, l2, -1) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2120,7 +2120,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, 0, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, ll2, l3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2133,7 +2133,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, 0, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, ll2, l3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2146,7 +2146,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, ll2 - 1, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, -1, l3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2159,7 +2159,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, ll2 - 1, l3) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, -1, l3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2175,7 +2175,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, 0, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, ll2, ll3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2188,7 +2188,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, 0, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, ll2, ll3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2201,7 +2201,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, ll2 - 1, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, -1, ll3) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2214,7 +2214,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, ll2 - 1, 0) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, -1, ll3) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2227,7 +2227,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, 0, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, ll2, -1) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2240,7 +2240,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, 0, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, ll2, -1) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2253,7 +2253,7 @@ CONTAINS DO ii = 1, in i = icell(ii, 0, ll2 - 1, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, ll1, -1, -1) = il rxyz(1, il) = rxyz(1, i) + alat(1) @@ -2266,7 +2266,7 @@ CONTAINS DO ii = 1, in i = icell(ii, ll1 - 1, ll2 - 1, ll3 - 1) il = il + 1 - IF (il .GT. nn) CPABORT("enlarge laymx") + IF (il > nn) CPABORT("enlarge laymx") lay(il) = i icell(ii, -1, -1, -1) = il rxyz(1, il) = rxyz(1, i) - alat(1) @@ -2294,7 +2294,7 @@ CONTAINS cut2 = cut**2 ! assign contiguous portions of the arrays lstb and rel to the threads myspace = (nat*nnbrx)/npr - IF (iam .EQ. 0) myspaceout = myspace + IF (iam == 0) myspaceout = myspace ! Verlet list, relative positions indlst = 0 loop_l3: DO l3 = 0, ll3 - 1 @@ -2302,7 +2302,7 @@ CONTAINS loop_l1: DO l1 = 0, ll1 - 1 loop_ii: DO ii = 1, icell(0, l1, l2, l3) iat = icell(ii, l1, l2, l3) - IF (((iat - 1)*npr)/nat .EQ. iam) THEN + IF (((iat - 1)*npr)/nat == iam) THEN ! write(*,*) 'sublstiat:iam,iat',iam,iat lsta(1, iat) = iam*myspace + indlst + 1 CALL sublstiat_l(iat, nn, ncx, ll1, ll2, ll3, l1, l2, l3, myspace, & @@ -2323,7 +2323,7 @@ CONTAINS !$OMP END CRITICAL !$OMP END PARALLEL - IF (indlstx .GE. myspaceout) THEN + IF (indlstx >= myspaceout) THEN WRITE (10, *) count, 'NNBRX too small', nnbrx DEALLOCATE (lstb, rel) nnbrx = 3*nnbrx/2 @@ -2345,14 +2345,14 @@ CONTAINS npjx = 300; npjkx = 6000 - IF (npr .NE. 1) THEN + IF (npr /= 1) THEN ! PARALLEL CASE ! create temporary private scalars for reduction sum on energies and ! temporary private array for reduction sum on forces !$OMP CRITICAL ALLOCATE (txyz(3, nat), f2ij(3, npjx), f3ij(3, npjkx), f3ik(3, npjkx)) !$OMP END CRITICAL - IF (iam .EQ. 0) THEN + IF (iam == 0) THEN ener = 0.e0_dp ener2 = 0.e0_dp coord = 0.e0_dp @@ -2401,7 +2401,7 @@ CONTAINS ! write(*,*) 'ener,norm force', & ! ener,DNRM2(3*nat,fxyz,1) - IF (istopg .GT. 0) CPABORT("DIMENSION ERROR (see WARNING above)") + IF (istopg > 0) CPABORT("DIMENSION ERROR (see WARNING above)") ener_var = ener2/nat - (ener/nat)**2 coord = coord/nat coord_var = coord2/nat - coord**2 @@ -2574,7 +2574,7 @@ CONTAINS calculate: DO jbr = lsta(1, iat), lsta(2, iat) jat = lstb(jbr) jcnt = jcnt + 1 - IF (jcnt .GT. npjx) THEN + IF (jcnt > npjx) THEN WRITE (*, *) 'WARNING: enlarge npjx' istop = 1 RETURN @@ -2588,9 +2588,9 @@ CONTAINS ! coordination number calculated with soft cutoff between first ! nearest neighbor and midpoint of first and second nearest neighbor - IF (rij .LE. 2.36e0_dp) THEN + IF (rij <= 2.36e0_dp) THEN coord_iat = coord_iat + 1.e0_dp - ELSE IF (rij .GE. 3.12e0_dp) THEN + ELSE IF (rij >= 3.12e0_dp) THEN ELSE xarg = (rij - 2.36e0_dp)*(1.e0_dp/(3.12e0_dp - 2.36e0_dp)) coord_iat = coord_iat + (2*xarg + 1.e0_dp)*(xarg - 1.e0_dp)**2 @@ -2621,9 +2621,9 @@ CONTAINS embed_3body: DO kbr = lsta(1, iat), lsta(2, iat) kat = lstb(kbr) - IF (kat .LT. jat) THEN + IF (kat < jat) THEN jkcnt = jkcnt + 1 - IF (jkcnt .GT. npjkx) THEN + IF (jkcnt > npjkx) THEN WRITE (*, *) 'WARNING: enlarge npjkx', npjkx istop = 1 RETURN @@ -2645,11 +2645,11 @@ CONTAINS ! begin optimized version rik = rel(4, kbr) - IF (rik .GT. tmax_fff) THEN + IF (rik > tmax_fff) THEN fikp = 0.e0_dp; fik = 0.e0_dp gjik = 0.e0_dp; gjikp = 0.e0_dp; sik = 0.e0_dp costheta = 0.e0_dp; fxik = 0.e0_dp; fyik = 0.e0_dp; fzik = 0.e0_dp - ELSE IF (rik .LT. tmin_fff) THEN + ELSE IF (rik < tmin_fff) THEN fxik = rel(1, kbr) fyik = rel(2, kbr) fzik = rel(3, kbr) @@ -2659,7 +2659,7 @@ CONTAINS (dof_fff(1) + 2.e0_dp*dof_fff(0))*hsixth_fff fik = cof_fff(0) + (rik - tmin_fff)*fikp tt_ggg = (costheta - tmin_ggg)*hi_ggg - IF (costheta .GT. tmax_ggg) THEN + IF (costheta > tmax_ggg) THEN gjikp = hi_ggg*(cof_ggg(8 - 1) - cof_ggg(8 - 2)) + & (2.e0_dp*dof_ggg(8 - 1) + dof_ggg(8 - 2))*hsixth_ggg gjik = cof_ggg(8 - 1) + (costheta - tmax_ggg)*gjikp @@ -2705,7 +2705,7 @@ CONTAINS costheta = costheta + fzij*fzik sik = rel(5, kbr) tt_ggg = (costheta - tmin_ggg)*hi_ggg - IF (costheta .GT. tmax_ggg) THEN + IF (costheta > tmax_ggg) THEN gjikp = hi_ggg*(cof_ggg(8 - 1) - cof_ggg(8 - 2)) + & (2.e0_dp*dof_ggg(8 - 1) + dof_ggg(8 - 2))*hsixth_ggg gjik = cof_ggg(8 - 1) + (costheta - tmax_ggg)*gjikp @@ -2836,7 +2836,7 @@ CONTAINS ! 3 body embedding term DO kbr = lsta(1, iat), lsta(2, iat) kat = lstb(kbr) - IF (kat .LT. jat) THEN + IF (kat < jat) THEN jkcnt = jkcnt + 1 txyz(1, iat) = txyz(1, iat) - ep_uuu*(f3ij(1, jkcnt) + f3ik(1, jkcnt)) @@ -2906,12 +2906,12 @@ CONTAINS loop_k1: DO k1 = l1 - 1, l1 + 1 loop_jj: DO jj = 1, icell(0, k1, k2, k3) jat = icell(jj, k1, k2, k3) - IF (jat .EQ. iat) CYCLE loop_k3 + IF (jat == iat) CYCLE loop_k3 xrel = rxyz(1, iat) - rxyz(1, jat) yrel = rxyz(2, iat) - rxyz(2, jat) zrel = rxyz(3, iat) - rxyz(3, jat) rr2 = xrel**2 + yrel**2 + zrel**2 - IF (rr2 .LE. cut2) THEN + IF (rr2 <= cut2) THEN indlst = MIN(indlst, myspace - 1) lstb(indlst) = lay(jat) ! write(*,*) 'iat,indlst,lay(jat)',iat,indlst,lay(jat) @@ -2958,11 +2958,11 @@ CONTAINS ! interpolate if the argument is outside the cubic spline interval [tmin,tmax] tt = (x - tmin)*hi - IF (x .LT. tmin) THEN + IF (x < tmin) THEN yp = hi*(ya(1) - ya(0)) - & (y2a(1) + 2.e0_dp*y2a(0))*hsixth y = ya(0) + (x - tmin)*yp - ELSE IF (x .GT. tmax) THEN + ELSE IF (x > tmax) THEN yp = hi*(ya(n - 1) - ya(n - 2)) + & (2.e0_dp*y2a(n - 1) + y2a(n - 2))*hsixth y = ya(n - 1) + (x - tmax)*yp diff --git a/src/embed_main.F b/src/embed_main.F index 2b307128e2..500910cd81 100644 --- a/src/embed_main.F +++ b/src/embed_main.F @@ -93,7 +93,7 @@ CONTAINS CALL section_vals_val_get(force_env_section, "EMBED%NGROUPS", n_rep_val=n_rep_val) IF (n_rep_val > 0) THEN CALL section_vals_val_get(force_env_section, "EMBED%NGROUPS", i_val=ngroup_wish) - IF (ngroup_wish .NE. 1) CPABORT("Embedding runs with NGROUP=1 and no group partitioning") + IF (ngroup_wish /= 1) CPABORT("Embedding runs with NGROUP=1 and no group partitioning") ELSE ngroup_wish = n_subforce_eval END IF diff --git a/src/emd/rt_delta_pulse.F b/src/emd/rt_delta_pulse.F index 3e22774449..049f68fa20 100644 --- a/src/emd/rt_delta_pulse.F +++ b/src/emd/rt_delta_pulse.F @@ -357,7 +357,7 @@ CONTAINS DO idir = 1, 3 factor = kvec(idir) - IF (factor .NE. 0.0_dp) THEN + IF (factor /= 0.0_dp) THEN IF (.NOT. len_rep) THEN CALL cp_dbcsr_sm_fm_multiply(matrix_s(idir + 1)%matrix, mos_old(2*ispin - 1), & mos_old(2*ispin), ncol=nmo) @@ -633,7 +633,7 @@ CONTAINS DO idir = 1, 3 factor = kvec(idir) - IF (factor .NE. 0.0_dp) THEN + IF (factor /= 0.0_dp) THEN CALL cp_dbcsr_sm_fm_multiply(matrix_mag(idir)%matrix, mos_old(2*ispin - 1), & mos_old(2*ispin), ncol=nmo) CALL cp_fm_scale_and_add(1.0_dp, mos_new(2*ispin - 1), factor, mos_old(2*ispin)) diff --git a/src/emd/rt_propagation_methods.F b/src/emd/rt_propagation_methods.F index 6ccc19393d..df2ae59516 100644 --- a/src/emd/rt_propagation_methods.F +++ b/src/emd/rt_propagation_methods.F @@ -306,19 +306,19 @@ CONTAINS matrix_ks=matrix_ks, matrix_ks_im=matrix_ks_im, energy=energy) CALL get_rtp(rtp=rtp, exp_H_old=exp_H_old, exp_H_new=exp_H_new) - IF (rtp_control%sc_check_start .LT. rtp%iter) THEN + IF (rtp_control%sc_check_start < rtp%iter) THEN rtp%delta_iter_old = rtp%delta_iter IF (rtp%linear_scaling) THEN CALL rt_convergence_density(rtp, delta_P, rtp%delta_iter) ELSE CALL rt_convergence(rtp, s_mat(1)%matrix, delta_mos, rtp%delta_iter) END IF - rtp%converged = (rtp%delta_iter .LT. rtp_control%eps_ener) + rtp%converged = (rtp%delta_iter < rtp_control%eps_ener) !Apply mixing if scf loop is not converging !It would be better to redo the current step with mixixng, !but currently the decision is made to use mixing from the next step on - IF (rtp_control%sc_check_start .LT. rtp%iter + 1) THEN + IF (rtp_control%sc_check_start < rtp%iter + 1) THEN IF (rtp%delta_iter/rtp%delta_iter_old > 0.9) THEN rtp%mixing_factor = MAX(rtp%mixing_factor/2.0_dp, 0.125_dp) rtp%mixing = .TRUE. @@ -639,8 +639,8 @@ CONTAINS CALL dbcsr_add(tmp(re)%matrix, P(re)%matrix, 1.0_dp, -1.0_dp) CALL dbcsr_add(tmp(im)%matrix, P(im)%matrix, 1.0_dp, -1.0_dp) CALL complex_frobenius_norm(frob_norm, tmp(re)%matrix, tmp(im)%matrix) - IF (unit_nr .GT. 0) WRITE (unit_nr, '(t3,a,2f16.8)') "Deviation from idempotency: ", frob_norm - IF (frob_norm .GT. threshold .AND. max_iter > 0) THEN + IF (unit_nr > 0) WRITE (unit_nr, '(t3,a,2f16.8)') "Deviation from idempotency: ", frob_norm + IF (frob_norm > threshold .AND. max_iter > 0) THEN CALL dbcsr_copy(P(re)%matrix, PSP(re)%matrix) CALL dbcsr_copy(P(im)%matrix, PSP(im)%matrix) CALL cp_complex_dbcsr_gemm_3("N", "N", -2.0_dp, PS(re)%matrix, PS(im)%matrix, & diff --git a/src/emd/rt_propagation_output.F b/src/emd/rt_propagation_output.F index 9674684bda..2e463c6783 100644 --- a/src/emd/rt_propagation_output.F +++ b/src/emd/rt_propagation_output.F @@ -420,7 +420,7 @@ CONTAINS DO i = 1, nrow_local DO j = 1, ncol_local alpha = overlap_re%local_data(i, j) - IF (row_indices(i) .EQ. col_indices(j)) alpha = alpha - 1.0_dp + IF (row_indices(i) == col_indices(j)) alpha = alpha - 1.0_dp max_alpha = MAX(max_alpha, ABS(alpha)) END DO END DO diff --git a/src/energy_corrections.F b/src/energy_corrections.F index 0d8493da66..5de6848227 100644 --- a/src/energy_corrections.F +++ b/src/energy_corrections.F @@ -3894,7 +3894,7 @@ CONTAINS ! Basis sets of energy correction CALL get_qs_kind(qs_kind=qs_kind, basis_set=harris_basis, basis_type="HARRIS") - IF (basis_set%name .NE. harris_basis%name) THEN + IF (basis_set%name /= harris_basis%name) THEN CPABORT("OT-Diag initial guess: Harris and ground state need to use the same basis") END IF END DO diff --git a/src/environment.F b/src/environment.F index d2ee161198..d1eaba74e7 100644 --- a/src/environment.F +++ b/src/environment.F @@ -300,7 +300,7 @@ CONTAINS ALLOCATE (all_host(30, para_env%num_pe), SOURCE=0) ALLOCATE (all_pid(para_env%num_pe), SOURCE=0) - IF (m_procrun(r_pid) .EQ. 1) THEN + IF (m_procrun(r_pid) == 1) THEN CALL string_to_ascii(r_host_name, all_host(:, para_env%mepos + 1)) CALL para_env%sum(all_host) END IF @@ -309,11 +309,11 @@ CONTAINS IF (output_unit > 0) WRITE (UNIT=output_unit, FMT="(T2,A)") "" DO ipe = 1, para_env%num_pe nr_occu = 0 - IF (all_pid(ipe) .NE. -1) THEN + IF (all_pid(ipe) /= -1) THEN CALL ascii_to_string(all_host(:, ipe), string) DO jpe = 1, para_env%num_pe CALL ascii_to_string(all_host(:, jpe), string_sec) - IF (string .EQ. string_sec) THEN + IF (string == string_sec) THEN nr_occu = nr_occu + 1 all_pid(jpe) = -1 END IF @@ -330,7 +330,7 @@ CONTAINS DEALLOCATE (all_pid) DEALLOCATE (all_host) - CPASSERT(0 .LT. nr_dist) + CPASSERT(0 < nr_dist) IF (PRESENT(node_count)) node_count = nr_dist END SUBROUTINE echo_all_process_host @@ -1218,7 +1218,7 @@ 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 .NE. ":" .OR. c2 .NE. ":") & + IF (n /= 8 .OR. ierr /= 0 .OR. c1 /= ":" .OR. c2 /= ":") & CPABORT('Could not parse WALLTIME: "'//txt(1:n)//'"') walltime = 3600.0_dp*REAL(hours, dp) + 60.0_dp*REAL(minutes, dp) + REAL(seconds, dp) END IF @@ -1308,7 +1308,7 @@ CONTAINS r_timings = section_get_rval(root_section, "GLOBAL%TIMINGS%THRESHOLD") sort_by_self_time = section_get_lval(root_section, "GLOBAL%TIMINGS%SORT_BY_SELF_TIME") report_maxloc = section_get_lval(root_section, "GLOBAL%TIMINGS%REPORT_MAXLOC") - IF (m_energy() .NE. 0.0_dp) THEN + IF (m_energy() /= 0.0_dp) THEN CALL timings_report_print(iw, r_timings, sort_by_self_time, cost_type_energy, report_maxloc, para_env) END IF CALL timings_report_print(iw, r_timings, sort_by_self_time, cost_type_time, report_maxloc, para_env) diff --git a/src/eri_mme/eri_mme_error_control.F b/src/eri_mme/eri_mme_error_control.F index a4f899a2fe..cb9c0f717c 100644 --- a/src/eri_mme/eri_mme_error_control.F +++ b/src/eri_mme/eri_mme_error_control.F @@ -92,11 +92,11 @@ CONTAINS max_iter = 100 - IF ((cutoff_r - cutoff_l)/(0.5_dp*(cutoff_r + cutoff_l)) .LE. tol) & + 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.") - IF ((delta .GE. 1.0_dp) .OR. (delta .LE. 0.0_dp)) & + 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)") @@ -113,7 +113,7 @@ CONTAINS ! 1) find valid initial values for bisection DO iter1 = 1, max_iter + 1 - IF (iter1 .GT. max_iter) & + IF (iter1 > max_iter) & CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine initial "// & "cutoff interval has been exceeded.") @@ -127,11 +127,11 @@ CONTAINS END DO valid_initial = .TRUE. - IF ((delta_mm(1) - delta_c(1)) .GT. 0) THEN + IF ((delta_mm(1) - delta_c(1)) > 0) THEN cutoff_lr(1) = cutoff_lr(1)*(1.0_dp - ABS(delta)) valid_initial = .FALSE. END IF - IF ((delta_mm(2) - delta_c(2)) .LT. 0) THEN + IF ((delta_mm(2) - delta_c(2)) < 0) THEN cutoff_lr(2) = cutoff_lr(2)*(1.0_dp + ABS(delta)) valid_initial = .FALSE. END IF @@ -144,7 +144,7 @@ CONTAINS "ERI_MME| Step, cutoff (min, max, mid), err(minimax), err(cutoff), err diff" DO iter2 = 1, max_iter + 1 - IF (iter2 .GT. max_iter) & + IF (iter2 > max_iter) & CALL cp_abort(__LOCATION__, & "Maximum number of iterations in bisection to determine cutoff has been exceeded") @@ -155,8 +155,8 @@ CONTAINS iter2, cutoff_lr(1), cutoff_lr(2), cutoff_mid, & delta_mm_mid, delta_c_mid, delta_mm_mid - delta_c_mid - IF ((cutoff_lr(2) - cutoff_lr(1))/cutoff_mid .LT. tol) EXIT - IF (delta_mm_mid - delta_c_mid .GT. 0) THEN + IF ((cutoff_lr(2) - cutoff_lr(1))/cutoff_mid < tol) EXIT + IF (delta_mm_mid - delta_c_mid > 0) THEN cutoff_lr(2) = cutoff_mid delta_mm(2) = delta_mm_mid delta_c(2) = delta_c_mid @@ -257,7 +257,7 @@ CONTAINS prod_mm_k = 1.0_dp DO i_xyz = 1, 3 prod_mm_k = prod_mm_k*(ABS(hmat(i_xyz, i_xyz))/twopi + & - MERGE(SQRT(2.0_dp/(zet_min*pi))*EXP(-1.0_dp), 0.0_dp, l_mm .GT. 0)) + MERGE(SQRT(2.0_dp/(zet_min*pi))*EXP(-1.0_dp), 0.0_dp, l_mm > 0)) END DO err_mm = 32*pi**4/vol*delta_mm*prod_mm_k @@ -313,7 +313,7 @@ CONTAINS G_1 = SQRT(1.0_dp/(3.0_dp*MINVAL(minimax_aw(1:n_minimax)))) C_mm = 0.0_dp - IF (G_1 .GT. G_c) THEN + IF (G_1 > G_c) THEN nG = 1000 dG = (G_1 - G_c)/nG G = G_c @@ -337,12 +337,12 @@ 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 .GT. max_iter) & + IF (iter > max_iter) & CALL cp_abort(__LOCATION__, "Maximum number of iterations for finding "// & "exponent maximizing cutoff error has been exceeded.") 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 .GE. err_ctff_curr) THEN + IF (err_ctff_prev >= err_ctff_curr) THEN zet_a = zet_max_tmp zet_b = MIN(zet_max_tmp*zet_div**2, zet_max) EXIT @@ -356,7 +356,7 @@ CONTAINS zet_c = zet_b - gr*(zet_b - zet_a) zet_d = zet_a + gr*(zet_b - zet_a) DO iter = 1, max_iter + 1 - IF (ABS(zet_c - zet_d) .LT. eps_zet*(zet_a + zet_b)) THEN + IF (ABS(zet_c - zet_d) < eps_zet*(zet_a + zet_b)) THEN CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_a, C, err0, para_env) CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_b, C, err1, para_env) err_ctff_curr = MAX(err0, err1) @@ -364,7 +364,7 @@ CONTAINS END IF CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_c, C, err_c, para_env) CALL cutoff_error_fixed_exp(cutoff, h_inv, G_min, l_max_zet, zet_d, C, err_d, para_env) - IF (err_c .GT. err_d) THEN + IF (err_c > err_d) THEN zet_b = zet_d zet_d = zet_c zet_c = zet_b - gr*(zet_b - zet_a) @@ -432,7 +432,7 @@ CONTAINS G_l = FLOOR(G_c/(inv_lgth*twopi)) G_u = FLOOR(G_rad/(inv_lgth*twopi)) - IF (G_u .LT. G_l) G_u = G_l + IF (G_u < G_l) G_u = G_l ! Serial code: ! !Sum |G| <= G_c @@ -450,7 +450,7 @@ CONTAINS n_Gu_left = MOD(n_Gu, n_p) n_Gl_left = MOD(n_Gl, n_p) - IF (my_p .LT. n_Gu_left) THEN + IF (my_p < n_Gu_left) THEN Gu_first = G_l + 1 + (n_Gu_p + 1)*my_p Gu_last = G_l + 1 + (n_Gu_p + 1)*(my_p + 1) - 1 ELSE @@ -458,7 +458,7 @@ CONTAINS Gu_last = G_l + 1 + n_Gu_left + n_Gu_p*(my_p + 1) - 1 END IF - IF (my_p .LT. n_Gl_left) THEN + IF (my_p < n_Gl_left) THEN Gl_first = -G_l + (n_Gl_p + 1)*my_p Gl_last = -G_l + (n_Gl_p + 1)*(my_p + 1) - 1 ELSE diff --git a/src/eri_mme/eri_mme_gaussian.F b/src/eri_mme/eri_mme_gaussian.F index 2494e90a9a..1216a0459d 100644 --- a/src/eri_mme/eri_mme_gaussian.F +++ b/src/eri_mme/eri_mme_gaussian.F @@ -130,7 +130,7 @@ CONTAINS ! 1) compute minimax coefficients G_max = SQRT(3.0_dp*2.0_dp*cutoff) - CPASSERT(G_max .GT. G_min) + CPASSERT(G_max > G_min) IF (potential_prv == eri_mme_coulomb .OR. potential_prv == eri_mme_longrange) THEN minimax_Rc = (G_max/G_min)**2 ELSEIF (potential_prv == eri_mme_yukawa) THEN @@ -207,16 +207,16 @@ CONTAINS c2 = (b/(a + b))*(R2 - R1) c3 = (a/(a + b))*(R1 - R2) - IF (H_or_C_product .EQ. 1) THEN ! Cartesian overlap dist + IF (H_or_C_product == 1) THEN ! Cartesian overlap dist DO mm = 0, m DO ll = 0, l DO t = 0, ll + mm + 1 - IF (ll .LT. l) THEN + IF (ll < l) THEN E(t, ll + 1, mm) = c1*E(t - 1, ll, mm) + & ! cost: 8 flops c2*E(t, ll, mm) + & (t + 1)*E(t + 1, ll, mm) END IF - IF (mm .LT. m) THEN + IF (mm < m) THEN E(t, ll, mm + 1) = c1*E(t - 1, ll, mm) + & ! cost: 8 flops c3*E(t, ll, mm) + & (t + 1)*E(t + 1, ll, mm) @@ -228,13 +228,13 @@ CONTAINS DO mm = 0, m DO ll = 0, l DO t = 0, ll + mm + 1 - IF (ll .LT. l) THEN + IF (ll < l) THEN E(t, ll + 1, mm) = a*(2*c1*E(t - 1, ll, mm) + & ! cost: 16 flops 2*c2*E(t, ll, mm) + & 2*(t + 1)*E(t + 1, ll, mm) - & 2*ll*E(t, ll - 1, mm)) END IF - IF (mm .LT. m) THEN + IF (mm < m) THEN E(t, ll, mm + 1) = b*(2*c1*E(t - 1, ll, mm) + & ! cost: 16 flops 2*c3*E(t, ll, mm) + & 2*(t + 1)*E(t + 1, ll, mm) - & diff --git a/src/eri_mme/eri_mme_integrate.F b/src/eri_mme/eri_mme_integrate.F index e94f51bae9..bfc805901a 100644 --- a/src/eri_mme/eri_mme_integrate.F +++ b/src/eri_mme/eri_mme_integrate.F @@ -103,7 +103,7 @@ CONTAINS cutoff = G_rad**2/2 CALL get_minimax_from_cutoff(param%minimax_grid, cutoff, n_aw, aw, grid) - CPASSERT(grid .GT. 0) + CPASSERT(grid > 0) ! cell info h_inv = param%h_inv @@ -187,13 +187,13 @@ CONTAINS CALL pgf_sum_2c_rspace_1d(S_G_2, -rab(i_xyz), alpha_R, lgth, R_bounds(i_xyz)) max_error = MAXVAL(ABS(S_G_1 - S_G_2)/(0.5_dp*(ABS(S_G_1) + ABS(S_G_2)) + 1.0_dp)) - CPASSERT(max_error .LE. param%debug_delta) + CPASSERT(max_error <= param%debug_delta) END IF END DO ELSE ! general cell - do_g_sum = n_sum_3d(1) < n_sum_3d(2) !PRODUCT(2*R_bounds+1) .GT. PRODUCT(2*G_bounds+1) + do_g_sum = n_sum_3d(1) < n_sum_3d(2) !PRODUCT(2*R_bounds+1) > PRODUCT(2*G_bounds+1) IF (do_g_sum) THEN CALL pgf_sum_2c_gspace_3d(S_G_no_H, l_max, -rab, alpha_G, h_inv, G_bounds, G_rad, vol) @@ -229,7 +229,7 @@ CONTAINS ELSE Imm = S_G_no(coset(ax + bx, ay + by, az + bz))*prefac**3 END IF - IF (la + lb .EQ. 0 .AND. .NOT. exact) THEN + IF (la + lb == 0 .AND. .NOT. exact) THEN Imm = Imm - SUM(aw(n_aw + 1:2*n_aw))*prefac**3/vol ! subtracting G = 0 term END IF IF (.NOT. norm) THEN @@ -347,7 +347,7 @@ CONTAINS CALL get_minimax_from_cutoff(param%minimax_grid, cutoff, n_aw, aw, grid) - CPASSERT(grid .GT. 0) + CPASSERT(grid > 0) ! minimax coeffs n_aw = param%minimax_grid(grid)%n_minimax @@ -473,7 +473,7 @@ CONTAINS CALL get_minimax_from_cutoff(param%minimax_grid, cutoff, n_aw, aw, grid) - CPASSERT(grid .GT. 0) + CPASSERT(grid > 0) ! minimax coeffs n_aw = param%minimax_grid(grid)%n_minimax @@ -518,7 +518,7 @@ CONTAINS R_rad_0 = exp_radius(lmax_0, alpha_R_0, param%sum_precision, 1.0_dp, epsabs=R_res) G_bound_0 = ellipsoid_bounds(G_rad_0, TRANSPOSE(hmat)/(2.0_dp*pi)) R_bound_0 = ellipsoid_bounds(R_rad_0, h_inv) - do_g_sum_0 = PRODUCT(2*R_bound_0 + 1) .GT. PRODUCT(2*G_bound_0 + 1) + do_g_sum_0 = PRODUCT(2*R_bound_0 + 1) > PRODUCT(2*G_bound_0 + 1) IF (do_g_sum_0) THEN CALL pgf_sum_2c_gspace_3d(S_G_0_no, lmax_0, R_0, alpha_G_0, h_inv, G_bound_0, G_rad_0, vol) ELSE @@ -554,9 +554,9 @@ CONTAINS nresults = 0 ! check consistency of summation methods - db_sum1 = (n_sum_3d(1)) .LT. INT(param%debug_nsum, KIND=int_8) - db_sum2 = (n_sum_3d(2)) .LT. INT(param%debug_nsum, KIND=int_8) - db_sum3 = (n_sum_3d(3)) .LT. INT(param%debug_nsum, KIND=int_8) + db_sum1 = (n_sum_3d(1)) < INT(param%debug_nsum, KIND=int_8) + db_sum2 = (n_sum_3d(2)) < INT(param%debug_nsum, KIND=int_8) + db_sum3 = (n_sum_3d(3)) < INT(param%debug_nsum, KIND=int_8) IF (param%unit_nr > 0) THEN WRITE (param%unit_nr, *) "ERI_MME DEBUG | number of summands (GG / GR / RR)", n_sum_3d @@ -629,7 +629,7 @@ CONTAINS END DO END DO - CPASSERT(max_error .LE. param%debug_delta) + CPASSERT(max_error <= param%debug_delta) DEALLOCATE (results_no) END IF END DO @@ -801,7 +801,7 @@ CONTAINS CALL get_l(ico, la, ax, ay, az) IF (la_prev < la) resc_a = resc_a*(2.0_dp*zeta) - IF (lc .GT. 0) THEN + IF (lc > 0) THEN Imm = S_G(ico, jco, kco) ELSE ijco = coset(ax + bx, ay + by, az + bz) diff --git a/src/eri_mme/eri_mme_lattice_summation.F b/src/eri_mme/eri_mme_lattice_summation.F index 9e6055899e..80f6a9329a 100644 --- a/src/eri_mme/eri_mme_lattice_summation.F +++ b/src/eri_mme/eri_mme_lattice_summation.F @@ -445,10 +445,10 @@ CONTAINS G = G_x + G_y + G_z G_sq = G(1)**2 + G(2)**2 + G(3)**2 - IF (G_sq .GT. G_rads_sq) CYCLE + IF (G_sq > G_rads_sq) CYCLE IF (PRESENT(potential)) THEN - IF (gx .EQ. 0 .AND. gy .EQ. 0 .AND. gz .EQ. 0) CYCLE + IF (gx == 0 .AND. gy == 0 .AND. gz == 0) CYCLE END IF exp_tot = EXP(-alpha*G_sq)*EXP(gaussi*DOT_PRODUCT(G, R)) ! cost: 2 exp_w flops @@ -601,7 +601,7 @@ CONTAINS Rz = hmat(:, 3)*sz Rp = Rx + Ry + Rz R_sq = (Rp(1) + R(1))**2 + (Rp(2) + R(2))**2 + (Rp(3) + R(3))**2 - IF (R_sq .GT. R_rad_sq) CYCLE + IF (R_sq > R_rad_sq) CYCLE exp_tot = EXP(-alpha*R_sq) ! cost: exp_w flops DO k = 1, 3 R_pow_l(k, 0) = 1.0_dp @@ -667,16 +667,16 @@ CONTAINS l_max = UBOUND(S_G, 1) S_G(:) = 0.0_dp - IF (0 .LT. G_min) THEN + IF (0 < G_min) THEN k0 = G_min; k1 = 0 - ELSE IF (G_c .LT. 0) THEN + ELSE IF (G_c < 0) THEN k0 = 0; k1 = G_c ELSE ! Gmin <= 0 /\ 0 <= Gc S_G(0) = prefac k0 = 1; k1 = -1 END IF ! positive range - IF (0 .LT. k0) THEN + IF (0 < k0) THEN DO k = k0, G_c G = k*dG; exp_tot = EXP(-alpha*G**2)*prefac DO l = 0, l_max @@ -685,7 +685,7 @@ CONTAINS END DO END IF ! negative range - IF (k1 .LT. 0) THEN + IF (k1 < 0) THEN DO k = G_min, k1 G = k*dG; exp_tot = EXP(-alpha*G**2)*prefac DO l = 0, l_max @@ -755,7 +755,7 @@ CONTAINS prop_exp = 0 END IF - IF (MAXVAL([l_max, m_max, n_max]) .GT. ${lmax_unroll}$) THEN + IF (MAXVAL([l_max, m_max, n_max]) > ${lmax_unroll}$) THEN CALL pgf_sum_3c_rspace_1d_generic(S_G, RA, RB, RC, zeta, zetb, zetc, a_mm, lgth, R_bounds_3) ELSE #:for l_max in range(0,lmax_unroll+1) @@ -1198,7 +1198,7 @@ CONTAINS SELECT CASE (sum_method) CASE (1) ! sum_G sum_G' C(G) C(G,G') C(G') - IF (sum_order .EQ. 0) THEN + IF (sum_order == 0) THEN sum_order = MAXLOC(G_bounds_1(:, 1), DIM=1) assert_stm = MINLOC(G_bounds_1(:, 1), DIM=1) == & MINLOC(G_bounds_1(:, 2), DIM=1) .AND. & @@ -1210,7 +1210,7 @@ CONTAINS CALL pgf_sum_3c_gspace_3d(S_G, l_max, m_max, n_max, R1, R2, alpha, beta, gamma, ht, vol, G_bounds_1, G_rads_1, sum_order) CASE (2) ! sum_G sum_R C(G) C(R) - IF (sum_order .EQ. 0) THEN + IF (sum_order == 0) THEN sum_order = MINLOC(G_bounds_1(:, 1), DIM=1) assert_stm = MINLOC(G_bounds_1(:, 1), DIM=1) == & MINLOC(G_bounds_1(:, 2), DIM=1) .AND. & @@ -1334,7 +1334,7 @@ CONTAINS G2_z = ht(:, 3)*g2z G2 = G2_x + G2_y + G2_z G2_sq = G2(1)**2 + G2(2)**2 + G2(3)**2 - IF (G2_sq .GT. G_rads_sq(2)) CYCLE + IF (G2_sq > G_rads_sq(2)) CYCLE DO g3x = -G3c(1), G3c(1) G3_x = ht(:, 1)*g3x DO g3y = -G3c(2), G3c(2) @@ -1343,10 +1343,10 @@ CONTAINS G3_z = ht(:, 3)*g3z G3 = G3_x + G3_y + G3_z G3_sq = G3(1)**2 + G3(2)**2 + G3(3)**2 - IF (G3_sq .GT. G_rads_sq(3)) CYCLE + IF (G3_sq > G_rads_sq(3)) CYCLE G1 = G3 - G2 G1_sq = G1(1)**2 + G1(2)**2 + G1(3)**2 - IF (G1_sq .GT. G_rads_sq(1)) CYCLE + IF (G1_sq > G_rads_sq(1)) CYCLE IF (use_coulomb) THEN IF (g3x == 0 .AND. g3y == 0 .AND. g3z == 0) CYCLE END IF @@ -1367,7 +1367,7 @@ CONTAINS G1_z = ht(:, 3)*g1z G1 = G1_x + G1_y + G1_z G1_sq = G1(1)**2 + G1(2)**2 + G1(3)**2 - IF (G1_sq .GT. G_rads_sq(1)) CYCLE + IF (G1_sq > G_rads_sq(1)) CYCLE DO g3x = -G3c(1), G3c(1) G3_x = ht(:, 1)*g3x DO g3y = -G3c(2), G3c(2) @@ -1376,10 +1376,10 @@ CONTAINS G3_z = ht(:, 3)*g3z G3 = G3_x + G3_y + G3_z G3_sq = G3(1)**2 + G3(2)**2 + G3(3)**2 - IF (G3_sq .GT. G_rads_sq(3)) CYCLE + IF (G3_sq > G_rads_sq(3)) CYCLE G2 = G3 - G1 G2_sq = G2(1)**2 + G2(2)**2 + G2(3)**2 - IF (G2_sq .GT. G_rads_sq(2)) CYCLE + IF (G2_sq > G_rads_sq(2)) CYCLE IF (use_coulomb) THEN IF (g3x == 0 .AND. g3y == 0 .AND. g3z == 0) CYCLE END IF @@ -1400,7 +1400,7 @@ CONTAINS G1_z = ht(:, 3)*g1z G1 = G1_x + G1_y + G1_z G1_sq = G1(1)**2 + G1(2)**2 + G1(3)**2 - IF (G1_sq .GT. G_rads_sq(1)) CYCLE + IF (G1_sq > G_rads_sq(1)) CYCLE DO g2x = -G2c(1), G2c(1) G2_x = ht(:, 1)*g2x DO g2y = -G2c(2), G2c(2) @@ -1409,10 +1409,10 @@ CONTAINS G2_z = ht(:, 3)*g2z G2 = G2_x + G2_y + G2_z G2_sq = G2(1)**2 + G2(2)**2 + G2(3)**2 - IF (G2_sq .GT. G_rads_sq(2)) CYCLE + IF (G2_sq > G_rads_sq(2)) CYCLE G3 = G1 + G2 G3_sq = G3(1)**2 + G3(2)**2 + G3(3)**2 - IF (G3_sq .GT. G_rads_sq(3)) CYCLE + IF (G3_sq > G_rads_sq(3)) CYCLE IF (use_coulomb) THEN IF (g1x + g2x == 0 .AND. g1y + g2y == 0 .AND. g1z + g2z == 0) CYCLE END IF @@ -1604,7 +1604,7 @@ CONTAINS G_z = ht(:, 3)*gz G = G_x + G_y + G_z G_sq = G(1)**2 + G(2)**2 + G(3)**2 - IF (G_sq .GT. G_rad_sq) CYCLE + IF (G_sq > G_rad_sq) CYCLE exp_tot = EXP(-alpha*G_sq)*EXP(gaussi*DOT_PRODUCT(G, R1)) ! cost: exp_w*2 flops @@ -1695,7 +1695,7 @@ CONTAINS Rz = hmat(:, 3)*sz Rp = Rx + Ry + Rz - R Rp_sq = Rp(1)**2 + Rp(2)**2 + Rp(3)**2 - IF (Rp_sq .GT. R_rad_sq) CYCLE + IF (Rp_sq > R_rad_sq) CYCLE exp_tot = EXP(-c1*Rp_sq)*EXP(-gaussi*c2*DOT_PRODUCT(Rp, G)) ! cost: exp_w*2 flops DO k = 1, 3 @@ -1853,7 +1853,7 @@ CONTAINS R1_tmp = R1 - (RA - RB) R1_sq = R1_tmp(1)**2 + R1_tmp(2)**2 + R1_tmp(3)**2 - IF (R1_sq .GT. R_rad_sq(1)) CYCLE + IF (R1_sq > R_rad_sq(1)) CYCLE R_tmp = R_offset + R1*zeta/(zeta + zetb) s2_shift = -MATMUL(h_inv, R_tmp) @@ -1868,7 +1868,7 @@ CONTAINS R = R_tmp + R2x + R2y + R2z R_sq = R(1)**2 + R(2)**2 + R(3)**2 - IF (R_sq .GT. R_rad_sq(2)) CYCLE + IF (R_sq > R_rad_sq(2)) CYCLE exp_tot = EXP(-alpha*R_sq) ! cost: exp_w flops DO k = 1, 3 @@ -1957,7 +1957,7 @@ CONTAINS nsum_gaussian_overlap = exp_w loop = (m + 1)*(l + 1)*(m + l + 2) - IF (H_or_C_product .EQ. 1) THEN + IF (H_or_C_product == 1) THEN nsum_gaussian_overlap = nsum_gaussian_overlap + loop*16 ELSE nsum_gaussian_overlap = nsum_gaussian_overlap + loop*32 diff --git a/src/eri_mme/eri_mme_test.F b/src/eri_mme/eri_mme_test.F index 88db10cb52..f892a1f793 100644 --- a/src/eri_mme/eri_mme_test.F +++ b/src/eri_mme/eri_mme_test.F @@ -153,7 +153,7 @@ CONTAINS MAXVAL(I_diff) IF (param%is_ortho) THEN - acc_check = param%err_mm + param%err_c .GE. MAXVAL(I_diff) + acc_check = param%err_mm + param%err_c >= MAXVAL(I_diff) ELSE acc_check = .TRUE. END IF @@ -259,7 +259,7 @@ CONTAINS DO izetb = 1, nzet DO izetc = 1, nzet nintg = nintg + 1 - IF (MOD(nintg, ns) .EQ. 0) THEN + IF (MOD(nintg, ns) == 0) THEN I_test(:, :, :) = 0.0_dp CALL CPU_TIME(t0) DO irep = 1, nrep @@ -365,8 +365,8 @@ CONTAINS C_prod_err = MAXVAL(ABS(C_prod_test - C_prod_ref)/(0.5_dp*(ABS(C_prod_test) + ABS(C_prod_ref)) + 1.0_dp)) H_prod_err = MAXVAL(ABS(H_prod_test - H_prod_ref)/(0.5_dp*(ABS(C_prod_test) + ABS(C_prod_ref)) + 1.0_dp)) - CPASSERT(C_prod_err .LE. tolerance) - CPASSERT(H_prod_err .LE. tolerance) + CPASSERT(C_prod_err <= tolerance) + CPASSERT(H_prod_err <= tolerance) MARK_USED(tolerance) END SUBROUTINE overlap_dist_expansion_test diff --git a/src/eri_mme/eri_mme_types.F b/src/eri_mme/eri_mme_types.F index 0703792f7f..813c970fe4 100644 --- a/src/eri_mme/eri_mme_types.F +++ b/src/eri_mme/eri_mme_types.F @@ -127,7 +127,7 @@ CONTAINS CHARACTER(len=2) :: string WRITE (string, '(I2)') n_minimax_max - IF (n_minimax .GT. n_minimax_max) & + IF (n_minimax > n_minimax_max) & CPABORT("The maximum allowed number of minimax points N_MINIMAX is "//TRIM(string)) param%n_minimax = n_minimax @@ -191,7 +191,7 @@ CONTAINS CALL timeset(routineN, handle) ! Note: in MP2 default logger hacked and does not use global default print level - s_only = l_max .EQ. 0 + s_only = l_max == 0 CALL init_orbital_pointers(3*l_max) ! allow for orbital pointers of combined index @@ -287,8 +287,8 @@ CONTAINS DEALLOCATE (minimax_aw) - CPASSERT(param%zet_max + 1.0E-12 .GT. param%zet_min) - CPASSERT(param%n_grids .GE. 1) + CPASSERT(param%zet_max + 1.0E-12 > param%zet_min) + CPASSERT(param%n_grids >= 1) cutoff_max = param%cutoff cutoff_rel = param%cutoff/param%zet_max @@ -338,7 +338,7 @@ CONTAINS ! for first grid (for max. cutoff) always use default n_minimax CALL get_minimax_coeff_v_gspace(n_minimax, cutoff, G_min, minimax_aw, err_minimax=err_mm, & potential=potential, pot_par=pot_par) - CPASSERT(err_mm .LT. 1.1_dp*target_error + 1.0E-12) + CPASSERT(err_mm < 1.1_dp*target_error + 1.0E-12) CALL create_minimax_grid(minimax_grids(n_grids), cutoff, n_minimax, minimax_aw, err_mm) DEALLOCATE (minimax_aw) @@ -348,8 +348,8 @@ CONTAINS CALL get_minimax_coeff_v_gspace(n_mm, cutoff, G_min, minimax_aw, err_minimax=err_mm, & potential=potential, pot_par=pot_par) - IF (err_mm .GT. 1.1_dp*target_error) THEN - CPASSERT(n_mm .NE. n_minimax) + IF (err_mm > 1.1_dp*target_error) THEN + CPASSERT(n_mm /= n_minimax) CALL create_minimax_grid(minimax_grids(i_grid), cutoff, n_mm + 1, minimax_aw_prev, err_mm_prev) DEALLOCATE (minimax_aw) @@ -428,7 +428,7 @@ CONTAINS grid_no = 0 DO igrid = 1, SIZE(grids) - IF (grids(igrid)%cutoff .GE. cutoff/2) THEN + IF (grids(igrid)%cutoff >= cutoff/2) THEN n_minimax = grids(igrid)%n_minimax minimax_aw => grids(igrid)%minimax_aw grid_no = igrid diff --git a/src/f77_interface.F b/src/f77_interface.F index 38e656e250..b98387517f 100644 --- a/src/f77_interface.F +++ b/src/f77_interface.F @@ -754,7 +754,7 @@ CONTAINS "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. ") - IF (method_name_id .EQ. do_mixed) THEN + IF (method_name_id == do_mixed) THEN check = ASSOCIATED(force_env%mixed_env%sub_para_env) CPASSERT(check) ngroups = force_env%mixed_env%ngroups @@ -767,7 +767,7 @@ CONTAINS CALL cp_rm_default_logger() CALL cp_add_default_logger(my_logger) END IF - IF (method_name_id .EQ. do_embed) THEN + IF (method_name_id == do_embed) THEN check = ASSOCIATED(force_env%embed_env%sub_para_env) CPASSERT(check) ngroups = force_env%embed_env%ngroups diff --git a/src/farming_methods.F b/src/farming_methods.F index b841bc9cc9..fc790022db 100644 --- a/src/farming_methods.F +++ b/src/farming_methods.F @@ -78,7 +78,7 @@ CONTAINS dep_ok = .TRUE. dep: DO idep = 1, ndep DO icheck = start, END - IF (farming_env%job(icheck)%status .NE. job_finished) THEN + IF (farming_env%job(icheck)%status /= job_finished) THEN IF (farming_env%job(icheck)%id == farming_env%job(itry)%dependencies(idep)) THEN dep_ok = .FALSE. EXIT dep @@ -102,7 +102,7 @@ CONTAINS IF (todo == do_wait) THEN dep_OK = .FALSE. DO itry = start, END - IF (farming_env%job(itry)%status .EQ. job_running) dep_OK = .TRUE. + IF (farming_env%job(itry)%status == job_running) dep_OK = .TRUE. END DO IF (.NOT. dep_OK) todo = do_deadlock END IF @@ -225,7 +225,7 @@ CONTAINS keyword_name="DEPENDENCIES", i_vals=dependencies) ALLOCATE (farming_env%Job(i)%dependencies(SIZE(dependencies, 1))) farming_env%Job(i)%dependencies = dependencies - IF (SIZE(dependencies, 1) .NE. 0) has_dep = .TRUE. + IF (SIZE(dependencies, 1) /= 0) has_dep = .TRUE. END IF END DO @@ -259,7 +259,7 @@ CONTAINS WRITE (output_unit, FMT='(I4)', ADVANCE="NO") farming_env%group_partition(i) END DO WRITE (output_unit, *) - IF (SUM(farming_env%group_partition) .NE. num_minions) THEN + IF (SUM(farming_env%group_partition) /= num_minions) THEN WRITE (output_unit, FMT="(T2,A,T61,I10,T71,I10)") & "FARMING| WARNING : group partition CPUs not equal to the available number (ignoring Captain) ", & num_minions, SUM(farming_env%group_partition) diff --git a/src/fm/cp_blacs_env.F b/src/fm/cp_blacs_env.F index e6efcf4073..6f5f271b38 100644 --- a/src/fm/cp_blacs_env.F +++ b/src/fm/cp_blacs_env.F @@ -172,7 +172,7 @@ CONTAINS npcol = grid_2d(2) END IF - IF (nprow*npcol .NE. npe) THEN + IF (nprow*npcol /= npe) THEN ! hard code for the time being the grid layout my_blacs_grid_layout = BLACS_GRID_SQUARE IF (PRESENT(blacs_grid_layout)) my_blacs_grid_layout = blacs_grid_layout @@ -184,7 +184,7 @@ CONTAINS gcd_max = -1 DO ipe = 1, CEILING(SQRT(REAL(npe, dp))) jpe = npe/ipe - IF (ipe*jpe .NE. npe) CYCLE + IF (ipe*jpe /= npe) CYCLE IF (gcd(ipe, jpe) >= gcd_max) THEN nprow = ipe npcol = jpe diff --git a/src/fm/cp_cfm_basic_linalg.F b/src/fm/cp_cfm_basic_linalg.F index 6565bd3a1c..30361ad2fb 100644 --- a/src/fm/cp_cfm_basic_linalg.F +++ b/src/fm/cp_cfm_basic_linalg.F @@ -487,7 +487,7 @@ CONTAINS counter = 0 DO irow = 1, nrow_local - IF (ipivot(irow) .NE. row_indices(irow)) counter = counter + 1 + IF (ipivot(irow) /= row_indices(irow)) counter = counter + 1 END DO IF (MOD(counter, 2) == 0) THEN @@ -517,7 +517,7 @@ CONTAINS counter = 0 determinant = z_one DO irow = 1, nrow_global - IF (ipivot(irow) .NE. irow) counter = counter + 1 + IF (ipivot(irow) /= irow) counter = counter + 1 determinant = determinant*a(irow, irow) END DO IF (MOD(counter, 2) == 1) determinant = -1.0_dp*determinant @@ -764,7 +764,7 @@ CONTAINS counter = 0 DO irow = 1, nrow_local - IF (ipivot(irow) .NE. row_indices(irow)) counter = counter + 1 + IF (ipivot(irow) /= row_indices(irow)) counter = counter + 1 END DO IF (MOD(counter, 2) == 0) THEN @@ -800,7 +800,7 @@ CONTAINS counter = 0 determinant = z_one DO irow = 1, nrow_global - IF (ipivot(irow) .NE. irow) counter = counter + 1 + IF (ipivot(irow) /= irow) counter = counter + 1 determinant = determinant*a(irow, irow) END DO IF (MOD(counter, 2) == 1) determinant = -1.0_dp*determinant @@ -846,7 +846,7 @@ CONTAINS mat => matrix%local_data nrows_global = matrix%matrix_struct%nrow_global - CPASSERT(nrows_global .EQ. matrix%matrix_struct%ncol_global) + CPASSERT(nrows_global == matrix%matrix_struct%ncol_global) ALLOCATE (ipivot(nrows_global)) ! do LU decomposition diff --git a/src/fm/cp_cfm_cholesky.F b/src/fm/cp_cfm_cholesky.F index 574ce8fe75..b7ef861a76 100644 --- a/src/fm/cp_cfm_cholesky.F +++ b/src/fm/cp_cfm_cholesky.F @@ -78,7 +78,7 @@ CONTAINS #if defined(__parallel) desca(:) = matrix%matrix_struct%descriptor(:) #if defined(__DLAF) - IF (cholesky_type == FM_CHOLESKY_TYPE_DLAF .AND. matrix%matrix_struct%nrow_global .GE. dlaf_cholesky_n_min) THEN + IF (cholesky_type == FM_CHOLESKY_TYPE_DLAF .AND. matrix%matrix_struct%nrow_global >= dlaf_cholesky_n_min) THEN ! Initialize DLA-Future on-demand; if already initialized, does nothing CALL cp_dlaf_initialize() @@ -147,7 +147,7 @@ CONTAINS #if defined(__parallel) desca = matrix%matrix_struct%descriptor #if defined(__DLAF) - IF (cholesky_type == FM_CHOLESKY_TYPE_DLAF .AND. matrix%matrix_struct%nrow_global .GE. dlaf_cholesky_n_min) THEN + IF (cholesky_type == FM_CHOLESKY_TYPE_DLAF .AND. matrix%matrix_struct%nrow_global >= dlaf_cholesky_n_min) THEN ! Initialize DLA-Future on-demand; if already initialized, does nothing CALL cp_dlaf_initialize() diff --git a/src/fm/cp_cfm_types.F b/src/fm/cp_cfm_types.F index 6cbeb1dc08..193f05eb6e 100644 --- a/src/fm/cp_cfm_types.F +++ b/src/fm/cp_cfm_types.F @@ -774,8 +774,8 @@ CONTAINS IF (PRESENT(mtargetr)) THEN rmat => mtargetr%local_data IF ((.NOT. cp_fm_struct_equivalent(mtargetr%matrix_struct, msource%matrix_struct)) .OR. & - (SIZE(rmat, 1) .NE. SIZE(zmat, 1)) .OR. & - (SIZE(rmat, 2) .NE. SIZE(zmat, 2))) THEN + (SIZE(rmat, 1) /= SIZE(zmat, 1)) .OR. & + (SIZE(rmat, 2) /= SIZE(zmat, 2))) THEN CPABORT("size of local_data of mtargetr differ to msource") END IF ! copy local data @@ -786,8 +786,8 @@ CONTAINS IF (PRESENT(mtargeti)) THEN imat => mtargeti%local_data IF ((.NOT. cp_fm_struct_equivalent(mtargeti%matrix_struct, msource%matrix_struct)) .OR. & - (SIZE(imat, 1) .NE. SIZE(zmat, 1)) .OR. & - (SIZE(imat, 2) .NE. SIZE(zmat, 2))) THEN + (SIZE(imat, 1) /= SIZE(zmat, 1)) .OR. & + (SIZE(imat, 2) /= SIZE(zmat, 2))) THEN CPABORT("size of local_data of mtargeti differ to msource") END IF ! copy local data @@ -826,8 +826,8 @@ CONTAINS IF (PRESENT(msourcer)) THEN rmat => msourcer%local_data IF ((.NOT. cp_fm_struct_equivalent(msourcer%matrix_struct, mtarget%matrix_struct)) .OR. & - (SIZE(rmat, 1) .NE. SIZE(zmat, 1)) .OR. & - (SIZE(rmat, 2) .NE. SIZE(zmat, 2))) THEN + (SIZE(rmat, 1) /= SIZE(zmat, 1)) .OR. & + (SIZE(rmat, 2) /= SIZE(zmat, 2))) THEN CPABORT("size of local_data of msourcer differ to mtarget") END IF mode = mode + 1 @@ -837,8 +837,8 @@ CONTAINS IF (PRESENT(msourcei)) THEN imat => msourcei%local_data IF ((.NOT. cp_fm_struct_equivalent(msourcei%matrix_struct, mtarget%matrix_struct)) .OR. & - (SIZE(imat, 1) .NE. SIZE(zmat, 1)) .OR. & - (SIZE(imat, 2) .NE. SIZE(zmat, 2))) THEN + (SIZE(imat, 1) /= SIZE(zmat, 1)) .OR. & + (SIZE(imat, 2) /= SIZE(zmat, 2))) THEN CPABORT("size of local_data of msourcei differ to mtarget") END IF mode = mode + 2 @@ -938,9 +938,9 @@ CONTAINS CALL para_env%allgather(send_rank, all_ranks) IF (ASSOCIATED(destination%matrix_struct)) THEN - ALLOCATE (source2global(0:COUNT(all_ranks .NE. mp_proc_null) - 1)) + ALLOCATE (source2global(0:COUNT(all_ranks /= mp_proc_null) - 1)) DO i = 0, global_size - 1 - IF (all_ranks(i) .NE. mp_proc_null) THEN + IF (all_ranks(i) /= mp_proc_null) THEN source2global(all_ranks(i)) = i END IF END DO @@ -948,9 +948,9 @@ CONTAINS CALL para_env%allgather(recv_rank, all_ranks) IF (ASSOCIATED(source%matrix_struct)) THEN - ALLOCATE (dest2global(0:COUNT(all_ranks .NE. mp_proc_null) - 1)) + ALLOCATE (dest2global(0:COUNT(all_ranks /= mp_proc_null) - 1)) DO i = 0, global_size - 1 - IF (all_ranks(i) .NE. mp_proc_null) THEN + IF (all_ranks(i) /= mp_proc_null) THEN dest2global(all_ranks(i)) = i END IF END DO @@ -1074,9 +1074,9 @@ CONTAINS ! src_p/q now contains the process row/column ID that will send data to that row/column DO q = 0, src_num_pe(2) - 1 - ncols = COUNT(src_q .EQ. q) + ncols = COUNT(src_q == q) DO p = 0, src_num_pe(1) - 1 - nrows = COUNT(src_p .EQ. p) + nrows = COUNT(src_p == p) ! Use the send_dist here as we are looking up the processes where the data comes from recv_count(info%src_blacs2mpi(p, q)) = nrows*ncols END DO @@ -1093,7 +1093,7 @@ CONTAINS ! Issue receive calls on ranks which expect data DO k = 0, send_size - 1 - IF (recv_count(k) .GT. 0) THEN + IF (recv_count(k) > 0) THEN CALL para_env%irecv(info%recv_buf(info%recv_disp(k) + 1:info%recv_disp(k) + recv_count(k)), & source2global(k), info%recv_request(k)) ELSE @@ -1129,9 +1129,9 @@ CONTAINS ! dest_p/q now contain the process row/column ID that will receive data from that row/column DO q = 0, dest_num_pe(2) - 1 - ncols = COUNT(dest_q .EQ. q) + ncols = COUNT(dest_q == q) DO p = 0, dest_num_pe(1) - 1 - nrows = COUNT(dest_p .EQ. p) + nrows = COUNT(dest_p == p) send_count(dest_blacs2mpi(p, q)) = nrows*ncols END DO END DO @@ -1159,7 +1159,7 @@ CONTAINS ! For each non-zero send_count, call mpi_isend DO k = 0, recv_size - 1 - IF (send_count(k) .GT. 0) THEN + IF (send_count(k) > 0) THEN CALL para_env%isend(info%send_buf(send_disp(k) + 1:send_disp(k) + send_count(k)), & dest2global(k), info%send_request(k)) ELSE diff --git a/src/fm/cp_fm_basic_linalg.F b/src/fm/cp_fm_basic_linalg.F index 1f2fd19779..6185a2c3c3 100644 --- a/src/fm/cp_fm_basic_linalg.F +++ b/src/fm/cp_fm_basic_linalg.F @@ -202,15 +202,15 @@ CONTAINS size_a = SIZE(a, 1)*SIZE(a, 2) END IF - IF (alpha .NE. 1.0_dp) THEN + IF (alpha /= 1.0_dp) THEN IF (matrix_a%use_sp) THEN CALL sscal(size_a, REAL(alpha, sp), a_sp, 1) ELSE CALL dscal(size_a, alpha, a, 1) END IF END IF - IF (my_beta .NE. 0.0_dp) THEN - IF (matrix_a%matrix_struct%context .NE. matrix_b%matrix_struct%context) & + IF (my_beta /= 0.0_dp) THEN + IF (matrix_a%matrix_struct%context /= matrix_b%matrix_struct%context) & CPABORT("Matrices must be in the same blacs context") IF (cp_fm_struct_equivalent(matrix_a%matrix_struct, & @@ -223,7 +223,7 @@ CONTAINS ELSE size_b = SIZE(b, 1)*SIZE(b, 2) END IF - IF (size_a .NE. size_b) & + IF (size_a /= size_b) & CPABORT("Matrices must have same local sizes") IF (matrix_a%use_sp .AND. matrix_b%use_sp) THEN @@ -285,8 +285,8 @@ CONTAINS nrow_global = matrix_a%matrix_struct%nrow_global ncol_global = matrix_a%matrix_struct%ncol_global - CPASSERT(nrow_global .EQ. matrix_b%matrix_struct%nrow_global) - CPASSERT(ncol_global .EQ. matrix_b%matrix_struct%ncol_global) + CPASSERT(nrow_global == matrix_b%matrix_struct%nrow_global) + CPASSERT(ncol_global == matrix_b%matrix_struct%ncol_global) aa => matrix_a%local_data bb => matrix_b%local_data @@ -391,7 +391,7 @@ CONTAINS determinant = 1.0_dp IF (correct_sign) THEN DO i = 1, n - IF (ipivot(i) .NE. i) THEN + IF (ipivot(i) /= i) THEN determinant = -determinant*a(i, i) ELSE determinant = determinant*a(i, i) @@ -1125,7 +1125,7 @@ CONTAINS al = 1.0_dp CALL cp_fm_get_info(matrix_b, nrow_global=m, ncol_global=n) IF (PRESENT(side)) side_char = side - mdim = MERGE(1, 2, 'L' .EQ. side_char) + mdim = MERGE(1, 2, 'L' == side_char) IF (PRESENT(invert_tr)) invert = invert_tr IF (PRESENT(uplo_tr)) uplo = uplo_tr IF (PRESENT(unit_diag_tr)) THEN @@ -1582,7 +1582,7 @@ CONTAINS ALLOCATE (ipivot(n + matrix_a%matrix_struct%nrow_block)) ipivot(:) = 0 #if defined(__parallel) - IF (my_eps_svd .EQ. 0.0_dp) THEN + IF (my_eps_svd == 0.0_dp) THEN ! Use LU decomposition lwork = 3*n liwork = 3*n @@ -1599,7 +1599,7 @@ CONTAINS determinant = 1.0_dp DO i = 1, n determinant = determinant*diag(i) - IF (ipivot(i) .NE. i) THEN + IF (ipivot(i) /= i) THEN exponent_of_minus_one = exponent_of_minus_one + 1 END IF END DO @@ -1695,7 +1695,7 @@ CONTAINS CALL cp_fm_release(inv_sigma_ut) END IF #else - IF (my_eps_svd .EQ. 0.0_dp) THEN + IF (my_eps_svd == 0.0_dp) THEN sign = .TRUE. CALL invert_matrix(matrix_a%local_data, matrix_inverse%local_data, & eval_error=eps1) @@ -2013,7 +2013,7 @@ CONTAINS mat => matrix%local_data mat_sp => matrix%local_data_sp nrows_global = matrix%matrix_struct%nrow_global - CPASSERT(nrows_global .EQ. matrix%matrix_struct%ncol_global) + CPASSERT(nrows_global == matrix%matrix_struct%ncol_global) ALLOCATE (ipivot(nrows_global)) ! do LU decomposition #if defined(__parallel) @@ -2227,7 +2227,7 @@ CONTAINS nrows = matrix%matrix_struct%nrow_global ncols = matrix%matrix_struct%ncol_global - CPASSERT(nrows .EQ. ncols) + CPASSERT(nrows == ncols) aa => matrix%local_data aa_sp => matrix%local_data_sp diff --git a/src/fm/cp_fm_cholesky.F b/src/fm/cp_fm_cholesky.F index fd3bafdf58..96c9d79d2b 100644 --- a/src/fm/cp_fm_cholesky.F +++ b/src/fm/cp_fm_cholesky.F @@ -326,7 +326,7 @@ CONTAINS b_sp => fm_matrixb%local_data_sp outm_sp => fm_matrixout%local_data_sp n = fm_matrix%matrix_struct%nrow_global - mdim = MERGE(1, 2, 'L' .EQ. chol_pos) + mdim = MERGE(1, 2, 'L' == chol_pos) alpha = 1.0_dp #if defined(__parallel) @@ -340,7 +340,7 @@ CONTAINS CALL pdcopy(n, a(1, 1), 1, i, desca, 1, outm(1, 1), 1, i, descout, 1) END IF END DO - IF (op .EQ. "SOLVE") THEN + IF (op == "SOLVE") THEN IF (fm_matrix%use_sp) THEN CALL pstrsm(chol_pos, 'U', chol_transa, 'N', n, neig, REAL(alpha, sp), b_sp(1, 1), 1, 1, descb, & outm_sp(1, 1), 1, 1, descout) @@ -357,7 +357,7 @@ CONTAINS END IF #elif defined(__MKL) && (2025 <= __INTEL_MKL__) beta = 0.0_dp - IF (op .EQ. "SOLVE") THEN + IF (op == "SOLVE") THEN IF (fm_matrix%use_sp) THEN CALL strsm_oop(chol_pos, 'U', chol_transa, 'N', n, neig, REAL(alpha, sp), b_sp(1, 1), SIZE(b_sp, mdim), a_sp(1, 1), n, REAL(beta, sp), outm_sp(1, 1), n) ELSE @@ -376,7 +376,7 @@ CONTAINS ELSE CALL dcopy(neig*n, a(1, 1), 1, outm(1, 1), 1) END IF - IF (op .EQ. "SOLVE") THEN + IF (op == "SOLVE") THEN IF (fm_matrix%use_sp) THEN CALL strsm(chol_pos, 'U', chol_transa, 'N', n, neig, REAL(alpha, sp), b_sp(1, 1), SIZE(b_sp, mdim), outm_sp(1, 1), n) ELSE diff --git a/src/fm/cp_fm_diag.F b/src/fm/cp_fm_diag.F index c1c79da5c3..4af59b6c2c 100644 --- a/src/fm/cp_fm_diag.F +++ b/src/fm/cp_fm_diag.F @@ -342,7 +342,7 @@ CONTAINS DO i = 1, ncol CALL infog2l(i, j, desca, nprow, npcol, myprow, mypcol, il, jl, iprow, ipcol) IF ((iprow == myprow) .AND. (ipcol == mypcol)) THEN - gold = MERGE(0.0_dp, 1.0_dp, i .NE. j) + gold = MERGE(0.0_dp, 1.0_dp, i /= j) test = matrix%local_data(il, jl) eps = ABS(test - gold) IF (eps > eps_warning) EXIT outer @@ -358,7 +358,7 @@ CONTAINS 0.0_dp, matrix%local_data(1, 1), nrow) outer: DO j = 1, ncol DO i = 1, ncol - gold = MERGE(0.0_dp, 1.0_dp, i .NE. j) + gold = MERGE(0.0_dp, 1.0_dp, i /= j) test = matrix%local_data(i, j) eps = ABS(test - gold) IF (eps > eps_warning) EXIT outer @@ -601,14 +601,14 @@ CONTAINS CALL cp_fm_error("ERROR in PDORMTR: Work space query failed", myinfo, PRESENT(info)) END IF - IF (lwork .LT. (work(1) + 2*n)) THEN + IF (lwork < (work(1) + 2*n)) THEN lwork = NINT(work(1)) + 2*n ! still wrong by 2*N END IF #endif ALLOCATE (work(lwork)) ! Initial/documented amount of liwork is exceeded (slightly worrisome too). - IF (liwork .LT. iwork(1)) THEN + IF (liwork < iwork(1)) THEN liwork = iwork(1) DEALLOCATE (iwork) ALLOCATE (iwork(liwork)) diff --git a/src/fm/cp_fm_diag_utils.F b/src/fm/cp_fm_diag_utils.F index 2dfb3ae790..d58d2226d2 100644 --- a/src/fm/cp_fm_diag_utils.F +++ b/src/fm/cp_fm_diag_utils.F @@ -216,7 +216,7 @@ CONTAINS gcd_max = -1 DO ipe = 1, CEILING(SQRT(REAL(ncpu, dp))) jpe = ncpu/ipe - IF (ipe*jpe .NE. ncpu) & + IF (ipe*jpe /= ncpu) & CYCLE IF (gcd(ipe, jpe) >= gcd_max) THEN npcol = jpe diff --git a/src/fm/cp_fm_elpa.F b/src/fm/cp_fm_elpa.F index 0e7c6ef6a8..f70b71a9b4 100644 --- a/src/fm/cp_fm_elpa.F +++ b/src/fm/cp_fm_elpa.F @@ -208,7 +208,7 @@ CONTAINS ! Resolve AUTO kernel. IF (elpa_kernel == ELPA_2STAGE_REAL_INVALID) THEN cpuid = m_cpuid() - IF ((MACHINE_CPU_GENERIC .LT. cpuid) .AND. (cpuid .LE. MACHINE_X86)) THEN + IF ((MACHINE_CPU_GENERIC < cpuid) .AND. (cpuid <= MACHINE_X86)) THEN SELECT CASE (cpuid) CASE (MACHINE_X86_SSE4) elpa_kernel = ELPA_2STAGE_REAL_SSE_BLOCK4 @@ -386,10 +386,10 @@ CONTAINS ! - Proper block size: test/Fortran/test.F90 ! Note that the names of these files might change in different ELPA versions ! Matrix order must be even - use_qr = elpa_qr .AND. (MODULO(n, 2) .EQ. 0) + 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) & - use_qr = use_qr .AND. (n .GE. 64) .AND. (nblk .GE. 64) + use_qr = use_qr .AND. (n >= 64) .AND. (nblk >= 64) ! Check if eigenvalues computed with ELPA_QR_UNSAFE should be verified IF (use_qr .AND. elpa_qr_unsafe .AND. elpa_should_print) & @@ -544,7 +544,7 @@ CONTAINS IF (success /= elpa_ok) & CPABORT("ELPA failed to diagonalize a matrix even without QR decomposition") - IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) .GT. th)) & + IF (ANY(ABS(eval(1:neig) - eval_noqr(1:neig)) > th)) & CPABORT("Eigenvalues calculated with QR decomp. in ELPA are wrong. Disable ELPA_QR_UNSAFE.") DEALLOCATE (eval_noqr) diff --git a/src/fm/cp_fm_struct.F b/src/fm/cp_fm_struct.F index ed01d29443..a9670b4ccd 100644 --- a/src/fm/cp_fm_struct.F +++ b/src/fm/cp_fm_struct.F @@ -252,8 +252,8 @@ CONTAINS fmstruct%nrow_locals(:) = fmstruct%nrow_locals(:)/fmstruct%context%num_pe(2) fmstruct%ncol_locals(:) = fmstruct%ncol_locals(:)/fmstruct%context%num_pe(1) - IF (SUM(fmstruct%ncol_locals) .NE. fmstruct%ncol_global .OR. & - SUM(fmstruct%nrow_locals) .NE. fmstruct%nrow_global) THEN + IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global .OR. & + SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) THEN ! try to collect some output if this is going to happen again ! this seems to trigger on blanc, but should really never happen logger => cp_get_default_logger() @@ -266,9 +266,9 @@ CONTAINS CALL m_flush(iunit) END IF - IF (SUM(fmstruct%ncol_locals) .NE. fmstruct%ncol_global) & + IF (SUM(fmstruct%ncol_locals) /= fmstruct%ncol_global) & CPABORT("sum of local cols not equal global cols") - IF (SUM(fmstruct%nrow_locals) .NE. fmstruct%nrow_global) & + IF (SUM(fmstruct%nrow_locals) /= fmstruct%nrow_global) & CPABORT("sum of local row not equal global rows") #else ! block = full matrix diff --git a/src/fm/cp_fm_types.F b/src/fm/cp_fm_types.F index 79ecfbd2dd..97a667ca75 100644 --- a/src/fm/cp_fm_types.F +++ b/src/fm/cp_fm_types.F @@ -805,7 +805,7 @@ CONTAINS IF (al == 1.0 .AND. be == 0.0) THEN DO j = 1, ncol_local this_col = col_indices(j) - j0 + 1 - IF (this_col .GE. 1 .AND. this_col .LE. ncol) THEN + IF (this_col >= 1 .AND. this_col <= ncol) THEN IF (tr_a) THEN IF (i0 == 1 .AND. nrow_global == nrow) THEN DO i = 1, nrow_local @@ -838,7 +838,7 @@ CONTAINS ELSE DO j = 1, ncol_local this_col = col_indices(j) - j0 + 1 - IF (this_col .GE. 1 .AND. this_col .LE. ncol) THEN + IF (this_col >= 1 .AND. this_col <= ncol) THEN IF (tr_a) THEN DO i = 1, nrow_local this_row = row_indices(i) - i0 + 1 @@ -942,7 +942,7 @@ CONTAINS DO j = 1, ncol_local this_col = col_indices(j) - j0 + 1 - IF (this_col .GE. 1 .AND. this_col .LE. ncol) THEN + IF (this_col >= 1 .AND. this_col <= ncol) THEN IF (tr_a) THEN IF (i0 == 1 .AND. nrow_global == nrow) THEN DO i = 1, nrow_local @@ -1634,9 +1634,9 @@ CONTAINS CALL para_env%allgather(send_rank, all_ranks) IF (ASSOCIATED(recv_dist)) THEN - ALLOCATE (source2global(0:COUNT(all_ranks .NE. mp_proc_null) - 1)) + ALLOCATE (source2global(0:COUNT(all_ranks /= mp_proc_null) - 1)) DO i = 0, global_size - 1 - IF (all_ranks(i) .NE. mp_proc_null) THEN + IF (all_ranks(i) /= mp_proc_null) THEN source2global(all_ranks(i)) = i END IF END DO @@ -1644,9 +1644,9 @@ CONTAINS CALL para_env%allgather(recv_rank, all_ranks) IF (ASSOCIATED(send_dist)) THEN - ALLOCATE (dest2global(0:COUNT(all_ranks .NE. mp_proc_null) - 1)) + ALLOCATE (dest2global(0:COUNT(all_ranks /= mp_proc_null) - 1)) DO i = 0, global_size - 1 - IF (all_ranks(i) .NE. mp_proc_null) THEN + IF (all_ranks(i) /= mp_proc_null) THEN dest2global(all_ranks(i)) = i END IF END DO @@ -1667,7 +1667,7 @@ CONTAINS END IF IF (ASSOCIATED(send_dist)) THEN - IF ((send_rank .EQ. 0)) THEN + IF ((send_rank == 0)) THEN ! need to use separate buffers here in case this is actually global rank 0 src_block_tmp = [send_dist%nrow_block, send_dist%ncol_block] CALL para_env%isend(src_block_tmp, 0, send_req(1), tag=src_tag) @@ -1676,7 +1676,7 @@ CONTAINS END IF IF (ASSOCIATED(recv_dist)) THEN - IF ((recv_rank .EQ. 0)) THEN + IF ((recv_rank == 0)) THEN dest_block_tmp = [recv_dist%nrow_block, recv_dist%ncol_block] CALL para_env%isend(dest_block_tmp, 0, send_req(3), tag=dest_tag) CALL para_env%isend(recv_dist%context%num_pe, 0, send_req(4), tag=dest_tag) @@ -1694,13 +1694,13 @@ CONTAINS END IF IF (ASSOCIATED(send_dist)) THEN - IF ((send_rank .EQ. 0)) THEN + IF ((send_rank == 0)) THEN CALL para_env%isend(send_dist%context%blacs2mpi(:, :), 0, send_req(5), tag=src_tag) END IF END IF IF (ASSOCIATED(recv_dist)) THEN - IF ((recv_rank .EQ. 0)) THEN + IF ((recv_rank == 0)) THEN CALL para_env%isend(recv_dist%context%blacs2mpi(:, :), 0, send_req(6), tag=dest_tag) END IF END IF @@ -1716,7 +1716,7 @@ CONTAINS CALL para_env%bcast(dest_num_pe, 0) info%src_num_pe(1:2) = src_num_pe(1:2) info%nblock_src(1:2) = src_block(1:2) - IF (global_rank .NE. 0) THEN + IF (global_rank /= 0) THEN ALLOCATE (info%src_blacs2mpi(0:src_num_pe(1) - 1, 0:src_num_pe(2) - 1), & dest_blacs2mpi(0:dest_num_pe(1) - 1, 0:dest_num_pe(2) - 1) & ) @@ -1773,9 +1773,9 @@ CONTAINS ! src_p/q now contains the process row/column ID that will send data to that row/column DO q = 0, src_num_pe(2) - 1 - ncols = COUNT(src_q .EQ. q) + ncols = COUNT(src_q == q) DO p = 0, src_num_pe(1) - 1 - nrows = COUNT(src_p .EQ. p) + nrows = COUNT(src_p == p) ! Use the send_dist here as we are looking up the processes where the data comes from recv_count(info%src_blacs2mpi(p, q)) = nrows*ncols END DO @@ -1792,7 +1792,7 @@ CONTAINS ! Issue receive calls on ranks which expect data DO k = 0, send_size - 1 - IF (recv_count(k) .GT. 0) THEN + IF (recv_count(k) > 0) THEN CALL para_env%irecv(info%recv_buf(info%recv_disp(k) + 1:info%recv_disp(k) + recv_count(k)), & source2global(k), info%recv_request(k)) END IF @@ -1827,9 +1827,9 @@ CONTAINS ! dest_p/q now contain the process row/column ID that will receive data from that row/column DO q = 0, dest_num_pe(2) - 1 - ncols = COUNT(dest_q .EQ. q) + ncols = COUNT(dest_q == q) DO p = 0, dest_num_pe(1) - 1 - nrows = COUNT(dest_p .EQ. p) + nrows = COUNT(dest_p == p) send_count(dest_blacs2mpi(p, q)) = nrows*ncols END DO END DO @@ -1857,7 +1857,7 @@ CONTAINS ! For each non-zero send_count, call mpi_isend DO k = 0, recv_size - 1 - IF (send_count(k) .GT. 0) THEN + IF (send_count(k) > 0) THEN CALL para_env%isend(info%send_buf(send_disp(k) + 1:send_disp(k) + send_count(k)), & dest2global(k), info%send_request(k)) END IF @@ -2036,9 +2036,9 @@ CONTAINS IF (ASSOCIATED(source%matrix_struct)) THEN desca = source%matrix_struct%descriptor IF (source%use_sp) CPABORT("only DP kind implemented") - IF (nrows .GT. source%matrix_struct%nrow_global) & + IF (nrows > source%matrix_struct%nrow_global) & CPABORT("nrows is greater than nrow_global of source") - IF (ncols .GT. source%matrix_struct%ncol_global) & + IF (ncols > source%matrix_struct%ncol_global) & CPABORT("ncols is greater than ncol_global of source") smat => source%local_data ELSE @@ -2049,9 +2049,9 @@ CONTAINS IF (ASSOCIATED(destination%matrix_struct)) THEN descb = destination%matrix_struct%descriptor IF (destination%use_sp) CPABORT("only DP kind implemented") - IF (nrows .GT. destination%matrix_struct%nrow_global) & + IF (nrows > destination%matrix_struct%nrow_global) & CPABORT("nrows is greater than nrow_global of destination") - IF (ncols .GT. destination%matrix_struct%ncol_global) & + IF (ncols > destination%matrix_struct%ncol_global) & CPABORT("ncols is greater than ncol_global of destination") dmat => destination%local_data ELSE diff --git a/src/force_env_methods.F b/src/force_env_methods.F index 9597562a8c..a498fedf42 100644 --- a/src/force_env_methods.F +++ b/src/force_env_methods.F @@ -1138,7 +1138,7 @@ CONTAINS IF (SIZE(itmplist) /= 2) & CALL cp_abort(__LOCATION__, & "Keyword FORCE_STATES takes exactly two input values.") - IF (ANY(itmplist .LT. 0)) & + IF (ANY(itmplist < 0)) & CPABORT("Invalid force_eval index.") istate = itmplist IF (istate(1) > nforce_eval .OR. istate(2) > nforce_eval) & @@ -1277,7 +1277,7 @@ CONTAINS DO iforce_eval = 1, nforce_eval IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE ! From this point on the error is the sub_error - IF (force_env%mixed_env%cdft_control%run_type == mixed_cdft_serial .AND. iforce_eval .GE. 2) THEN + IF (force_env%mixed_env%cdft_control%run_type == mixed_cdft_serial .AND. iforce_eval >= 2) THEN my_logger => force_env%mixed_env%cdft_control%sub_logger(iforce_eval - 1)%p ELSE my_group = force_env%mixed_env%group_distribution(force_env%para_env%mepos) @@ -1436,7 +1436,7 @@ CONTAINS NULLIFY (dft_control) CALL get_qs_env(force_env%sub_force_env(iforce_eval)%force_env%qs_env, dft_control=dft_control) IF (dft_control%qs_control%ref_embed_subsys) THEN - IF (iforce_eval .EQ. 2) CPABORT("Density importing force_eval can't be the first.") + IF (iforce_eval == 2) CPABORT("Density importing force_eval can't be the first.") END IF END IF @@ -1665,7 +1665,7 @@ CONTAINS CALL pw_axpy(rho_r_ref(i_spin), diff_rho_r, -1.0_dp) END DO IF (opt_embed%open_shell_embed) THEN ! Spin part - IF (nspins .EQ. 2) THEN ! Reference systems has an open shell, else the reference diff_rho_spin is zero + IF (nspins == 2) THEN ! Reference systems has an open shell, else the reference diff_rho_spin is zero CALL pw_axpy(rho_r_ref(1), diff_rho_spin, -1.0_dp) CALL pw_axpy(rho_r_ref(2), diff_rho_spin, 1.0_dp) END IF @@ -1682,9 +1682,9 @@ CONTAINS CALL pw_axpy(rho_r_subsys(i_spin), diff_rho_r, allow_noncompatible_grids=.TRUE.) END DO IF (opt_embed%open_shell_embed) THEN ! Spin part - IF (nspins_subsys .EQ. 2) THEN ! The subsystem makes contribution if it is spin-polarized + IF (nspins_subsys == 2) THEN ! The subsystem makes contribution if it is spin-polarized ! We may need to change spin ONLY FOR THE SECOND SUBSYSTEM: that's the internal convention - IF ((i_force_eval .EQ. 2) .AND. (opt_embed%change_spin)) THEN + IF ((i_force_eval == 2) .AND. (opt_embed%change_spin)) THEN CALL pw_axpy(rho_r_subsys(1), diff_rho_spin, -1.0_dp, allow_noncompatible_grids=.TRUE.) CALL pw_axpy(rho_r_subsys(2), diff_rho_spin, 1.0_dp, allow_noncompatible_grids=.TRUE.) ELSE @@ -1715,7 +1715,7 @@ CONTAINS mapping_section => section_vals_get_subs_vals(embed_section, "MAPPING") DO i_force_eval = 1, ref_subsys_number - 1 - IF (i_force_eval .EQ. 1) THEN + IF (i_force_eval == 1) THEN CALL Coulomb_guess(embed_pot, rhs, mapping_section, & force_env%sub_force_env(i_force_eval)%force_env%qs_env, nforce_eval, i_force_eval, opt_embed%eta) ELSE @@ -1749,7 +1749,7 @@ CONTAINS END DO IF (opt_embed%open_shell_embed) THEN ! Spin part CALL pw_zero(diff_rho_spin) - IF (nspins .EQ. 2) THEN ! Reference systems has an open shell, else the reference diff_rho_spin is zero + IF (nspins == 2) THEN ! Reference systems has an open shell, else the reference diff_rho_spin is zero CALL pw_axpy(rho_r_ref(1), diff_rho_spin, -1.0_dp) CALL pw_axpy(rho_r_ref(2), diff_rho_spin, 1.0_dp) END IF @@ -1760,7 +1760,7 @@ CONTAINS CALL get_qs_env(force_env%sub_force_env(i_force_eval)%force_env%qs_env, dft_control=dft_control) nspins_subsys = dft_control%nspins - IF ((i_force_eval .EQ. 2) .AND. (opt_embed%change_spin)) THEN + IF ((i_force_eval == 2) .AND. (opt_embed%change_spin)) THEN ! Here we change the sign of the spin embedding potential due to spin change: ! only in spin_embed_subsys CALL make_subsys_embed_pot(force_env%sub_force_env(i_force_eval)%force_env%qs_env, & @@ -1777,7 +1777,7 @@ CONTAINS ! Add the embedding potential CALL set_qs_env(force_env%sub_force_env(i_force_eval)%force_env%qs_env, embed_pot=embed_pot_subsys) - IF ((opt_embed%open_shell_embed) .AND. (nspins_subsys .EQ. 2)) THEN ! Spin part + IF ((opt_embed%open_shell_embed) .AND. (nspins_subsys == 2)) THEN ! Spin part CALL set_qs_env(force_env%sub_force_env(i_force_eval)%force_env%qs_env, & spin_embed_pot=spin_embed_pot_subsys) END IF @@ -1811,9 +1811,9 @@ CONTAINS CALL pw_axpy(rho_r_subsys(i_spin), diff_rho_r, allow_noncompatible_grids=.TRUE.) END DO IF (opt_embed%open_shell_embed) THEN ! Spin part - IF (nspins_subsys .EQ. 2) THEN ! The subsystem makes contribution if it is spin-polarized + IF (nspins_subsys == 2) THEN ! The subsystem makes contribution if it is spin-polarized ! We may need to change spin ONLY FOR THE SECOND SUBSYSTEM: that's the internal convention - IF ((i_force_eval .EQ. 2) .AND. (opt_embed%change_spin)) THEN + IF ((i_force_eval == 2) .AND. (opt_embed%change_spin)) THEN CALL pw_axpy(rho_r_subsys(1), diff_rho_spin, -1.0_dp, allow_noncompatible_grids=.TRUE.) CALL pw_axpy(rho_r_subsys(2), diff_rho_spin, 1.0_dp, allow_noncompatible_grids=.TRUE.) ELSE @@ -1849,7 +1849,7 @@ CONTAINS ! Spin part IF (opt_embed%open_shell_embed) THEN ! If reference system is not spin-polarized then it does not make a contribution to W functional - IF (nspins .EQ. 2) THEN + IF (nspins == 2) THEN opt_embed%w_func(i_iter) = opt_embed%w_func(i_iter) & - pw_integral_ab(spin_embed_pot, rho_r_ref(1)) & + pw_integral_ab(spin_embed_pot, rho_r_ref(2)) @@ -1864,7 +1864,7 @@ CONTAINS IF (opt_embed%converged) EXIT ! Update the trust radius and control the step - IF ((i_iter .GT. 1) .AND. (.NOT. opt_embed%steep_desc)) CALL step_control(opt_embed) + IF ((i_iter > 1) .AND. (.NOT. opt_embed%steep_desc)) CALL step_control(opt_embed) ! Print density difference CALL print_rho_diff(diff_rho_r, i_iter, force_env%sub_force_env(ref_subsys_number)%force_env%qs_env, .FALSE.) @@ -1923,7 +1923,7 @@ CONTAINS CALL set_qs_env(force_env%sub_force_env(ref_subsys_number + 1)%force_env%qs_env, embed_pot=embed_pot_subsys) - IF ((opt_embed%open_shell_embed) .AND. (nspins_subsys .EQ. 2)) THEN + IF ((opt_embed%open_shell_embed) .AND. (nspins_subsys == 2)) THEN CALL set_qs_env(force_env%sub_force_env(ref_subsys_number + 1)%force_env%qs_env, & spin_embed_pot=spin_embed_pot_subsys) END IF @@ -2078,7 +2078,7 @@ CONTAINS IF (opt_dmfet%open_shell_embed) THEN ! Open-shell embedding ! We may need to change spin ONLY FOR THE SECOND SUBSYSTEM: that's the internal convention - IF ((i_force_eval .EQ. 2) .AND. (opt_dmfet%change_spin)) THEN + IF ((i_force_eval == 2) .AND. (opt_dmfet%change_spin)) THEN CALL cp_fm_scale_and_add(-1.0_dp, opt_dmfet%dm_diff_beta, 1.0_dp, opt_dmfet%dm_subsys) CALL cp_fm_scale_and_add(-1.0_dp, opt_dmfet%dm_diff, 1.0_dp, opt_dmfet%dm_subsys_beta) ELSE diff --git a/src/force_fields_input.F b/src/force_fields_input.F index 4ecc3d4a19..02ffd06f83 100644 --- a/src/force_fields_input.F +++ b/src/force_fields_input.F @@ -2320,12 +2320,12 @@ CONTAINS CALL section_vals_val_get(section, "PHI0", i_rep_section=isec, r_val=torsion_phi0(start + isec)) CALL section_vals_val_get(section, "M", i_rep_section=isec, i_val=torsion_m(start + isec)) ! Modify parameterisation for OPLS case - IF (torsion_kind(start + isec) .EQ. do_ff_opls) THEN - IF (torsion_phi0(start + isec) .NE. 0.0_dp) THEN + IF (torsion_kind(start + isec) == do_ff_opls) THEN + IF (torsion_phi0(start + isec) /= 0.0_dp) THEN CALL cp_warn(__LOCATION__, "PHI0 parameter was non-zero "// & "for an OPLS-type TORSION. It will be ignored.") END IF - IF (MODULO(torsion_m(start + isec), 2) .EQ. 0) THEN + IF (MODULO(torsion_m(start + isec), 2) == 0) THEN ! For even M, negate the cosine using a Pi phase factor torsion_phi0(start + isec) = pi END IF diff --git a/src/graphcon.F b/src/graphcon.F index 262c02d031..741099066d 100644 --- a/src/graphcon.F +++ b/src/graphcon.F @@ -100,7 +100,7 @@ CONTAINS Nclasses = 1 old_class = kind_new(1) DO i = 2, N - IF (kind_new(I) .NE. old_class) THEN + IF (kind_new(I) /= old_class) THEN Nclasses = Nclasses + 1 old_class = kind_new(I) END IF @@ -151,7 +151,7 @@ CONTAINS ! molecules with no symmetry e.g. JAC need less than 500 tries ! catch the cases where the molecules are trivially different - IF (SIZE(reference) .NE. SIZE(unordered)) THEN + IF (SIZE(reference) /= SIZE(unordered)) THEN matches = .FALSE. RETURN END IF @@ -170,7 +170,7 @@ CONTAINS class_of_atom(N), superclass_of_atom(N)) CALL hash_molecule(reference, kind_ref, hash_re) CALL hash_molecule(unordered, kind_un, hash_un) - IF (hash_re .NE. hash_un) THEN + IF (hash_re /= hash_un) THEN matches = .FALSE. RETURN END IF @@ -180,7 +180,7 @@ CONTAINS CALL sort(kind_ref_ordered, N, index_ref) kind_un_ordered(:) = kind_un CALL sort(kind_un_ordered, N, index_un) - IF (ANY(kind_ref_ordered .NE. kind_un_ordered)) THEN + IF (ANY(kind_ref_ordered /= kind_un_ordered)) THEN matches = .FALSE. RETURN END IF @@ -189,7 +189,7 @@ CONTAINS Nclasses = 1 old_class = kind_ref_ordered(1) DO i = 2, N - IF (kind_ref_ordered(I) .NE. old_class) THEN + IF (kind_ref_ordered(I) /= old_class) THEN Nclasses = Nclasses + 1 old_class = kind_ref_ordered(I) END IF @@ -199,7 +199,7 @@ CONTAINS Nclasses = 1 classes(1)%Nele = 1 DO i = 2, N - IF (kind_ref_ordered(I) .NE. classes(Nclasses)%kind) THEN + IF (kind_ref_ordered(I) /= classes(Nclasses)%kind) THEN Nclasses = Nclasses + 1 classes(Nclasses)%kind = kind_ref_ordered(I) classes(Nclasses)%Nele = 1 @@ -234,7 +234,7 @@ CONTAINS isuperclass = 0 DO I = 1, N ! this atom belongs to a class with several equivalent atoms, and has not yet been found - IF (superclass_of_atom(I) .EQ. -1 .AND. classes(class_of_atom(I))%Nele > 1) THEN + IF (superclass_of_atom(I) == -1 .AND. classes(class_of_atom(I))%Nele > 1) THEN isuperclass = isuperclass + 1 CALL spread_superclass(I, isuperclass, superclass_of_atom, class_of_atom, classes, reference) END IF @@ -298,7 +298,7 @@ CONTAINS END DO ! we are back at the original permutation so we're unable to match this superclass. - IF (iclass .EQ. superclasses(I)%Nele .AND. & + IF (iclass == superclasses(I)%Nele .AND. & classes(superclasses(I)%classes(superclasses(I)%Nele))%first) EXIT END DO ! failed in this superblock, can exit now @@ -343,7 +343,7 @@ CONTAINS INTEGER :: J - IF (superclass_of_atom(I) .EQ. -1 .AND. classes(class_of_atom(I))%Nele > 1) THEN + IF (superclass_of_atom(I) == -1 .AND. classes(class_of_atom(I))%Nele > 1) THEN superclass_of_atom(I) = isuperclass DO J = 1, classes(class_of_atom(I))%Nele CALL spread_superclass(classes(class_of_atom(I))%reference(J), isuperclass, & @@ -385,7 +385,7 @@ CONTAINS SIZE(reference(order(I))%bonds) == SIZE(unordered(I)%bonds)) IF (res) THEN DO J = 1, SIZE(reference(order(I))%bonds) - IF (ALL(reference(order(I))%bonds(:) .NE. order(unordered(I)%bonds(J)))) THEN + IF (ALL(reference(order(I))%bonds(:) /= order(unordered(I)%bonds(J)))) THEN res = .FALSE. EXIT loop END IF @@ -419,7 +419,7 @@ CONTAINS SIZE(reference(order(I))%bonds) == SIZE(unordered(I)%bonds)) IF (res) THEN DO J = 1, SIZE(reference(order(I))%bonds) - IF (ALL(reference(order(I))%bonds(:) .NE. order(unordered(I)%bonds(J)))) THEN + IF (ALL(reference(order(I))%bonds(:) /= order(unordered(I)%bonds(J)))) THEN res = .FALSE. EXIT loop END IF @@ -536,7 +536,7 @@ CONTAINS q(m) = n END DO END IF - IF (q(n - 1) .EQ. n) THEN + IF (q(n - 1) == n) THEN q(n - 1) = n - 1 t = x(n) x(n) = x(n - 1) @@ -544,7 +544,7 @@ CONTAINS RETURN END IF DO k = n - 1, 1, -1 - IF (q(k) .EQ. k) THEN + IF (q(k) == k) THEN q(k) = n ELSE go to 1 @@ -565,7 +565,7 @@ CONTAINS x(k) = t m = m - 1 k = k + 1 - DO WHILE (k .LT. m) + DO WHILE (k < m) t = x(m) x(m) = x(k) x(k) = t diff --git a/src/gw_integrals.F b/src/gw_integrals.F index d07f83ef17..1a4e7a8f42 100644 --- a/src/gw_integrals.F +++ b/src/gw_integrals.F @@ -266,13 +266,13 @@ CONTAINS DO at_k = 1, natom IF (PRESENT(atom_i)) THEN - IF (at_i .NE. atom_i) CYCLE + IF (at_i /= atom_i) CYCLE END IF IF (PRESENT(atom_j)) THEN - IF (at_j .NE. atom_j) CYCLE + IF (at_j /= atom_j) CYCLE END IF IF (PRESENT(atom_k)) THEN - IF (at_k .NE. atom_k) CYCLE + IF (at_k /= atom_k) CYCLE END IF my_cell_i(1:3) = 0 @@ -360,7 +360,7 @@ CONTAINS sgfj = first_sgf_j(1, jset) sgfk = first_sgf_k(1, kset) - IF (ncoj*ncok*ncoi .LE. 0) CYCLE + IF (ncoj*ncok*ncoi <= 0) CYCLE ALLOCATE (sijk(ncoj, ncok, ncoi)) sijk(:, :, :) = 0.0_dp diff --git a/src/gw_large_cell_gamma.F b/src/gw_large_cell_gamma.F index fb3de510ff..24c6779bdc 100644 --- a/src/gw_large_cell_gamma.F +++ b/src/gw_large_cell_gamma.F @@ -795,13 +795,13 @@ CONTAINS qs_kind_set=qs_kind_set, & atomic_kind_set=atomic_kind_set) - IF (ikp_end .LE. bs_env%nkp_chi_eps_W_orig) THEN + IF (ikp_end <= bs_env%nkp_chi_eps_W_orig) THEN ! 1. 2c Coulomb integrals for the first "original" k-point grid bs_env%kpoints_chi_eps_W%nkp_grid = bs_env%nkp_grid_chi_eps_W_orig ELSE IF (ikp_start > bs_env%nkp_chi_eps_W_orig .AND. & - ikp_end .LE. bs_env%nkp_chi_eps_W_orig_plus_extra) THEN + ikp_end <= bs_env%nkp_chi_eps_W_orig_plus_extra) THEN ! 2. 2c Coulomb integrals for the second "extrapolation" k-point grid bs_env%kpoints_chi_eps_W%nkp_grid = bs_env%nkp_grid_chi_eps_W_extra @@ -1158,7 +1158,7 @@ CONTAINS cfm_W_ikp_freq_j, ikp, bs_env%kpoints_chi_eps_W, & "RI_AUX") ! non-kpoint extrapolated - IF (ikp .LE. bs_env%nkp_chi_eps_W_orig) THEN + IF (ikp <= bs_env%nkp_chi_eps_W_orig) THEN CALL MIC_contribution_from_ikp(bs_env, qs_env, bs_env%fm_W_MIC_freq_1_no_extra, & cfm_W_ikp_freq_j, ikp, bs_env%kpoints_chi_eps_W, & "RI_AUX", wkp_ext=bs_env%wkp_orig) @@ -1167,7 +1167,7 @@ CONTAINS END IF ! for all ω_j, we need to compute W^MIC without k-point extrpolation - IF (ikp .LE. bs_env%nkp_chi_eps_W_orig) THEN + IF (ikp <= bs_env%nkp_chi_eps_W_orig) THEN CALL MIC_contribution_from_ikp(bs_env, qs_env, fm_W_MIC_freq_j, cfm_W_ikp_freq_j, & ikp, bs_env%kpoints_chi_eps_W, "RI_AUX", & wkp_ext=bs_env%wkp_orig) diff --git a/src/gw_small_cell_full_kp.F b/src/gw_small_cell_full_kp.F index a702ca20b2..dd3e0267ce 100644 --- a/src/gw_small_cell_full_kp.F +++ b/src/gw_small_cell_full_kp.F @@ -612,7 +612,7 @@ CONTAINS DO ikp = 1, bs_env%nkp_chi_eps_W_orig_plus_extra ! trivial parallelization over k-points - IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(ikp, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE ikp_local = ikp_local + 1 @@ -713,7 +713,7 @@ CONTAINS nkp_local = 0 DO ikp = 1, nkp ! trivial parallelization over k-points - IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(ikp, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE nkp_local = nkp_local + 1 END DO @@ -745,7 +745,7 @@ CONTAINS DO ikp = 1, nkp ! trivial parallelization - IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(ikp, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE ikp_local = ikp_local + 1 @@ -826,7 +826,7 @@ CONTAINS DO ikp = 1, bs_env%nkp_scf_desymm ! trivial parallelization - IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(ikp, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE ! M(k) = sum_R e^ikR M^R CALL trafo_rs_to_ikp(M_R, M_inv, & @@ -1063,7 +1063,7 @@ CONTAINS DO ikp = 1, nkp_scf ! trivial parallelization - IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(ikp, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE ! V_tr(k) = sum_R e^ikR V_tr^R CALL trafo_rs_to_ikp(V_tr_R, V_tr_kp, bs_env%kpoints_scf_desymm%index_to_cell, & bs_env%kpoints_scf_desymm%xkp(1:3, ikp)) diff --git a/src/gw_utils.F b/src/gw_utils.F index 1c0059e80a..ed47210d5e 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -1331,7 +1331,7 @@ CONTAINS bs_env%group_size_tensor = num_pe ! group_size_tensor must divide num_pe without rest; otherwise everything will be complicated - IF (MODULO(num_pe, bs_env%group_size_tensor) .NE. 0) THEN + IF (MODULO(num_pe, bs_env%group_size_tensor) /= 0) THEN CALL find_good_group_size(num_pe, bs_env%group_size_tensor) END IF @@ -1494,7 +1494,7 @@ CONTAINS gcd_max = -1 DO ipe = 1, CEILING(SQRT(REAL(nproc, dp))) jpe = nproc/ipe - IF (ipe*jpe .NE. nproc) CYCLE + IF (ipe*jpe /= nproc) CYCLE IF (gcd(ipe, jpe) >= gcd_max) THEN nprow = ipe npcol = jpe @@ -1531,7 +1531,7 @@ CONTAINS ! for periodic systems and for 20 minimax points, we use a regularized minimax mesh ! (from experience: regularized minimax meshes converges faster for periodic systems ! and for 20 pts) - IF (SUM(bs_env%periodic) .NE. 0 .OR. bs_env%num_time_freq_points >= 20) THEN + IF (SUM(bs_env%periodic) /= 0 .OR. bs_env%num_time_freq_points >= 20) THEN bs_env%regularization_minimax = 1.0E-6_dp ELSE bs_env%regularization_minimax = 0.0_dp @@ -1817,7 +1817,7 @@ CONTAINS ALLOCATE (points_and_weights(2*num_time_freq_points)) ! frequency points - IF (num_time_freq_points .LE. 20) THEN + IF (num_time_freq_points <= 20) THEN CALL get_rpa_minimax_coeff(num_time_freq_points, E_range, points_and_weights, ierr, .FALSE.) ELSE CALL get_rpa_minimax_coeff_larger_grid(num_time_freq_points, E_range, points_and_weights) @@ -1852,7 +1852,7 @@ CONTAINS END IF ! time points - IF (num_time_freq_points .LE. 20) THEN + IF (num_time_freq_points <= 20) THEN CALL get_exp_minimax_coeff(num_time_freq_points, E_range, points_and_weights) ELSE CALL get_exp_minimax_coeff_gw(num_time_freq_points, E_range, points_and_weights) @@ -2060,7 +2060,7 @@ CONTAINS DO atom_i = 1, bs_env%n_atom block_count = block_count + 1 - IF (MODULO(block_count, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(block_count, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE CALL scaled_to_real(vec_cell_j, REAL(index_to_cell_3c_max(j_cell, 1:3), kind=dp), cell) CALL scaled_to_real(vec_cell_k, REAL(index_to_cell_3c_max(k_cell, 1:3), kind=dp), cell) @@ -2568,7 +2568,7 @@ CONTAINS n_tasks_local = 0 - DO WHILE (ANY(n_tensor_ops_Delta_R(:) .NE. 0)) + DO WHILE (ANY(n_tensor_ops_Delta_R(:) /= 0)) ! get largest element of n_tensor_ops_Delta_R i_Delta_R_max_op = MAXLOC(n_tensor_ops_Delta_R, 1) @@ -2931,7 +2931,7 @@ CONTAINS nkp_local = 0 DO ikp = 1, nkp ! trivial parallelization over k-points - IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(ikp, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE nkp_local = nkp_local + 1 END DO @@ -2945,7 +2945,7 @@ CONTAINS DO ikp = 1, nkp ! trivial parallelization - IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + IF (MODULO(ikp, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE ikp_local = ikp_local + 1 @@ -3238,7 +3238,7 @@ CONTAINS bs_env%eigenval_HF(:, ikp, ispin) = eigenval_scf(:) + Sigma_x_ikp_n(:) - V_xc_ikp_n(:) ! only print eigenvalues of DOS k-points in case no bandstructure path has been given - print_DOS_kpoints = (bs_env%nkp_only_bs .LE. 0) + print_DOS_kpoints = (bs_env%nkp_only_bs <= 0) ! in kpoints_DOS, the last nkp_only_bs are bandstructure k-points is_bandstruc_kpoint = (ikp > bs_env%nkp_only_DOS) print_ikp = print_DOS_kpoints .OR. is_bandstruc_kpoint @@ -3272,7 +3272,7 @@ CONTAINS WRITE (iunit, "(A)") " " DO i_mo = 1, n_mo - IF (i_mo .LE. bs_env%n_occ(ispin)) occ_vir = 'occ' + IF (i_mo <= bs_env%n_occ(ispin)) occ_vir = 'occ' IF (i_mo > bs_env%n_occ(ispin)) occ_vir = 'vir' WRITE (iunit, "(I5,3A,I5,4F16.3,F17.3)") i_mo, ' (', occ_vir, ') ', ikp_for_print, & eigenval_scf(i_mo)*evolt, & @@ -3320,7 +3320,7 @@ CONTAINS ! if |𝚺^c| > 13 eV, we use a scissors shift IF (ABS(Sigma_c_ikp_n_qp(i_mo)) > 13.0_dp/evolt) THEN - is_occ = (i_mo .LE. homo) + is_occ = (i_mo <= homo) is_vir = (i_mo > homo) n_levels_scissor = 0 @@ -3331,7 +3331,7 @@ CONTAINS ! only compute scissor from other GW levels close in energy IF (is_occ .AND. j_mo > homo) CYCLE - IF (is_vir .AND. j_mo .LE. homo) CYCLE + IF (is_vir .AND. j_mo <= homo) CYCLE IF (ABS(i_mo - j_mo) > 10) CYCLE IF (i_mo == j_mo) CYCLE diff --git a/src/hairy_probes.F b/src/hairy_probes.F index 9d9d6af9bb..70d3ed5cd1 100644 --- a/src/hairy_probes.F +++ b/src/hairy_probes.F @@ -106,7 +106,7 @@ CONTAINS N_half = accurate_sum(occ) h = fermi_half - fermi_min - IF (h .GT. N*epsocc*100) THEN + IF (h > N*epsocc*100) THEN y0 = N_min - N y1 = N_half - N y2 = N_max - N @@ -135,8 +135,8 @@ CONTAINS END IF !define 2nd bracker using fermi_fit - IF (h .GT. N*epsocc*100) THEN - IF (fermi_fit .GE. fermi_min .AND. fermi_fit .LE. fermi_max) THEN + IF (h > N*epsocc*100) THEN + IF (fermi_fit >= fermi_min .AND. fermi_fit <= fermi_max) THEN IF (N_fit < N) THEN fermi_min = fermi_fit N_min = N_fit @@ -277,7 +277,7 @@ CONTAINS !***HP loop h = fermi_half - fermi_min - IF (h .GT. N*epsocc*100) THEN + IF (h > N*epsocc*100) THEN y0 = N_min - N y1 = N_half - N y2 = N_max - N @@ -317,8 +317,8 @@ CONTAINS END IF !define 2nd bracker using fermi_fit - IF (h .GT. N*epsocc*100) THEN - IF (fermi_fit .GE. fermi_min .AND. fermi_fit .LE. fermi_max) THEN + IF (h > N*epsocc*100) THEN + IF (fermi_fit >= fermi_min .AND. fermi_fit <= fermi_max) THEN IF (N_fit < N) THEN fermi_min = fermi_fit N_min = N_fit @@ -410,7 +410,7 @@ CONTAINS fermi_fun_sol = 0.0_dp probes2: DO ip = 1, np - IF (probe(ip)%alpha .LT. 1.0_dp) THEN + IF (probe(ip)%alpha < 1.0_dp) THEN alpha = probe(ip)%alpha !fermi distribution, solution probes CALL fermi_distribution(energies(iMO), fermi, probe(ip)%T, fermi_fun_sol) @@ -435,7 +435,7 @@ CONTAINS occupancy(iMO) = f*maxocc !entropy kTS= kT*[f ln f + (1-f) ln (1-f)] - IF (f .EQ. 0.0d0 .OR. f .EQ. 1.0d0) THEN + IF (f == 0.0d0 .OR. f == 1.0d0) THEN s = 0.0d0 ELSE s = f*LOG(f) + (1.0d0 - f)*LOG(1.0d0 - f) @@ -514,7 +514,7 @@ CONTAINS isgf = isgf + nso(lshell) boundaries: DO ii = 1, p_atom - IF (iatom .NE. probe%atom_ids(ii)) THEN + IF (iatom /= probe%atom_ids(ii)) THEN CYCLE boundaries ELSE !defines iAO boundaries*********** @@ -527,7 +527,7 @@ CONTAINS END DO sets END DO atoms - IF (isgf .NE. nAO) CPWARN("row count does not correspond to nAO, number of rows in mo_coeff") + IF (isgf /= nAO) CPWARN("row count does not correspond to nAO, number of rows in mo_coeff") END SUBROUTINE AO_boundaries @@ -593,7 +593,7 @@ CONTAINS b = (4.0_dp*y1 - 3.0_dp*y0 - y2)/(2.0_dp*h) c = y0 - IF (ABS(a) .LT. 1.0e-15_dp) THEN + IF (ABS(a) < 1.0e-15_dp) THEN delta = 0.0_dp RETURN END IF @@ -602,17 +602,17 @@ CONTAINS u0 = (-b + d)/(2.0_dp*a) - IF (u0 .GE. 0.0_dp .AND. u0 .LE. 2.0_dp*h) THEN + IF (u0 >= 0.0_dp .AND. u0 <= 2.0_dp*h) THEN delta = u0 !RETURN ELSE u0 = (-b - d)/(2.0_dp*a) - IF (u0 .GE. 0.0_dp .AND. u0 .LE. 2.0_dp*h) THEN + IF (u0 >= 0.0_dp .AND. u0 <= 2.0_dp*h) THEN delta = u0 !RETURN ELSE - IF (y1 .LT. 0.0_dp) delta = 2.0_dp*h - IF (y1 .GE. 0.0_dp) delta = 0.0_dp + IF (y1 < 0.0_dp) delta = 2.0_dp*h + IF (y1 >= 0.0_dp) delta = 0.0_dp END IF END IF diff --git a/src/hartree_local_methods.F b/src/hartree_local_methods.F index 3ac0f8375a..dc33a818bb 100644 --- a/src/hartree_local_methods.F +++ b/src/hartree_local_methods.F @@ -492,7 +492,7 @@ CONTAINS rho_atom => rho_atom_set_2nd(iatom) vrrad_0 => rho0_atom_set_2nd(iatom)%vrho0_rad_h%r_coef ! for potential END IF - IF (my_periodic .AND. back_ch .GT. 1.E-3_dp) THEN + IF (my_periodic .AND. back_ch > 1.E-3_dp) THEN factor = -2.0_dp*pi/3.0_dp*SQRT(fourpi)*qs_charges%background ELSE factor = 0._dp diff --git a/src/hfx_communication.F b/src/hfx_communication.F index 0e3b10ec5f..eb9238e78f 100644 --- a/src/hfx_communication.F +++ b/src/hfx_communication.F @@ -156,7 +156,7 @@ CONTAINS dest = MODULO(mepos + 1, ncpu) source = MODULO(mepos - 1, ncpu) DO icpu = 0, ncpu - 1 - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, & req(1), req(2), 13) END IF @@ -165,7 +165,7 @@ CONTAINS block_size = block_offset(source_cpu + 1) - block_offset(source_cpu) full_density(block_offset(source_cpu):block_offset(source_cpu) + block_size - 1) = sendbuffer(1:block_size) - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL mp_waitall(req) END IF swapbuffer => sendbuffer @@ -239,7 +239,7 @@ CONTAINS dest_cpu = MODULO(data_to, ncpu) + 1 block_size = block_offset(dest_cpu + 1) - block_offset(dest_cpu) sendbuffer(1:block_size) = sendbuffer(1:block_size) + full_ks(block_offset(dest_cpu):block_offset(dest_cpu) + block_size - 1) - IF (icpu .EQ. ncpu) EXIT + IF (icpu == ncpu) EXIT CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, & req(1), req(2), 13) @@ -502,7 +502,7 @@ CONTAINS itask = buffer_out(ibuf + 3) ! buffer_out can be 0 if buffer_in contained less elements than the max number of atom pairs ! is_assoc_atomic_block is a map for atom pairs to a processor (assumes symmetry, i,j on the ame as j,i) - IF (itask .NE. 0) THEN + IF (itask /= 0) THEN iatom = buffer_out(ibuf + 1) jatom = buffer_out(ibuf + 2) is_assoc_atomic_block(iatom, jatom) = itask diff --git a/src/hfx_derivatives.F b/src/hfx_derivatives.F index 1a9648245d..8829ebd052 100644 --- a/src/hfx_derivatives.F +++ b/src/hfx_derivatives.F @@ -231,7 +231,7 @@ CONTAINS my_resp_only = .FALSE. IF (PRESENT(resp_only)) my_resp_only = resp_only - is_anti_symmetric = dbcsr_get_matrix_type(rho_ao(1, 1)%matrix) .EQ. dbcsr_type_antisymmetric + is_anti_symmetric = dbcsr_get_matrix_type(rho_ao(1, 1)%matrix) == dbcsr_type_antisymmetric CALL get_qs_env(qs_env, & admm_env=admm_env, & @@ -696,7 +696,7 @@ CONTAINS !! is taken into account by the following criterion: !! !! IF(katom+latom<=iatom+jatom) THEN - !! IF( ((iatom+jatom).EQ.(katom+latom) ) .AND.(katom zero-contribution !VIIRAL IF((iatom==jatom .AND. iatom==katom .AND. iatom==latom)) CYCLE IF (.NOT. (katom + latom <= iatom + jatom)) CYCLE - IF (((iatom + jatom) .EQ. (katom + latom)) .AND. (katom < iatom)) CYCLE + IF (((iatom + jatom) == (katom + latom)) .AND. (katom < iatom)) CYCLE i_set_list_kl_start = list_kl%elements(i_list_kl)%set_bounds(1) i_set_list_kl_stop = list_kl%elements(i_list_kl)%set_bounds(2) diff --git a/src/hfx_energy_potential.F b/src/hfx_energy_potential.F index 7f06568228..b16ca11341 100644 --- a/src/hfx_energy_potential.F +++ b/src/hfx_energy_potential.F @@ -262,7 +262,7 @@ CONTAINS logger => cp_get_default_logger() - is_anti_symmetric = dbcsr_get_matrix_type(rho_ao(1, 1)%matrix) .EQ. dbcsr_type_antisymmetric + is_anti_symmetric = dbcsr_get_matrix_type(rho_ao(1, 1)%matrix) == dbcsr_type_antisymmetric IF (my_geo_change) THEN CALL m_memory(memsize_before) @@ -523,7 +523,7 @@ CONTAINS ALLOCATE (ee_buffer2(ncos_max**4)) ALLOCATE (ee_primitives_tmp(nsgf_max**4)) - IF (my_nspins .EQ. 0) my_nspins = dft_control%nspins + IF (my_nspins == 0) my_nspins = dft_control%nspins ALLOCATE (max_contraction(max_set, natom)) @@ -897,7 +897,7 @@ CONTAINS !! is taken into account by the following criterion: !! !! IF(katom+latom<=iatom+jatom) THEN - !! IF( ((iatom+jatom).EQ.(katom+latom) ) .AND.(katom 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, & diff --git a/src/hfx_helpers.F b/src/hfx_helpers.F index a780ccf053..9a55e5252c 100644 --- a/src/hfx_helpers.F +++ b/src/hfx_helpers.F @@ -76,7 +76,7 @@ CONTAINS m = [i, j, k] EXIT outer END IF - IF (ALL(M .EQ. [i, j, k])) found = .TRUE. + IF (ALL(M == [i, j, k])) found = .TRUE. END DO inner END DO END DO diff --git a/src/hfx_load_balance_methods.F b/src/hfx_load_balance_methods.F index 5967ba3246..aa461da1fb 100644 --- a/src/hfx_load_balance_methods.F +++ b/src/hfx_load_balance_methods.F @@ -700,13 +700,13 @@ CONTAINS dest = MODULO(mepos + 1, ncpu) source = MODULO(mepos - 1, ncpu) DO icpu = 0, ncpu - 1 - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, & req(1), req(2), 13) END IF data_from = MODULO(mepos - icpu, ncpu) cost_matrix(data_from*nbins*n_threads + 1:data_from*nbins*n_threads + nbins*n_threads) = sendbuffer - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL mp_waitall(req) END IF swapbuffer => sendbuffer @@ -768,7 +768,7 @@ CONTAINS dest = MODULO(mepos + 1, ncpu) source = MODULO(mepos - 1, ncpu) DO icpu = 0, ncpu - 1 - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, & req(1), req(2), 13) END IF @@ -781,7 +781,7 @@ CONTAINS END DO END DO - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL mp_waitall(req) END IF swapbuffer => sendbuffer @@ -1137,7 +1137,7 @@ CONTAINS a = p b = q - DO WHILE (b .NE. 0) + DO WHILE (b /= 0) IF (a > b) THEN a = a - b ELSE @@ -1277,14 +1277,14 @@ CONTAINS row = (katom_block - 1)*nblocks + jatom_block inv_perm = 1 - DO WHILE (permute(inv_perm) .NE. row) + DO WHILE (permute(inv_perm) /= row) inv_perm = inv_perm + 1 END DO row = inv_perm col = (iatom_block - 1)*nblocks + latom_block inv_perm = 1 - DO WHILE (permute(inv_perm) .NE. col) + DO WHILE (permute(inv_perm) /= col) inv_perm = inv_perm + 1 END DO col = inv_perm @@ -1321,7 +1321,7 @@ CONTAINS ! every second recursion step, compute row sum instead of column sum - IF (MODULO(step, 2) .EQ. 0) THEN + IF (MODULO(step, 2) == 0) THEN idx = row ELSE idx = col @@ -1348,7 +1348,7 @@ CONTAINS ! calculate next prime factor of nProc nBins = 2 - DO WHILE (MODULO(INT(nProc), INT(nBins)) .NE. 0) + DO WHILE (MODULO(INT(nProc), INT(nBins)) /= 0) nBins = nBins + 1 END DO @@ -1609,7 +1609,7 @@ CONTAINS ! sync before/after ring of isendrecv CALL para_env%sync() DO icpu = 0, ncpu - 1 - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, & req(1), req(2), 13) END IF @@ -1618,7 +1618,7 @@ CONTAINS end_idx = start_idx + bins_per_rank(data_from + 1) - 1 cost_matrix(start_idx:end_idx) = sendbuffer(1:end_idx - start_idx + 1) - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL mp_waitall(req) END IF swapbuffer => sendbuffer @@ -1667,7 +1667,7 @@ CONTAINS ! sync before/after ring of isendrecv CALL para_env%sync() DO icpu = 0, ncpu - 1 - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, & req(1), req(2), 13) END IF @@ -1680,7 +1680,7 @@ CONTAINS END DO END DO - IF (icpu .NE. ncpu - 1) THEN + IF (icpu /= ncpu - 1) THEN CALL mp_waitall(req) END IF swapbuffer => sendbuffer @@ -2026,7 +2026,7 @@ CONTAINS latom = list_kl%elements(i_list_kl)%pair(2) IF (.NOT. (katom + latom <= iatom + jatom)) CYCLE - IF (((iatom + jatom) .EQ. (katom + latom)) .AND. (katom < iatom)) CYCLE + IF (((iatom + jatom) == (katom + latom)) .AND. (katom < iatom)) CYCLE IF (eval_type == hfx_do_eval_forces) THEN IF (.NOT. use_virial) THEN diff --git a/src/hfx_ri.F b/src/hfx_ri.F index d6c4efab97..65bf180668 100644 --- a/src/hfx_ri.F +++ b/src/hfx_ri.F @@ -4246,7 +4246,7 @@ CONTAINS DO iblk = 1, SIZE(bsizes_split) split_sum = split_sum + bsizes_split(iblk) - IF (split_sum .GT. full_sum) THEN + IF (split_sum > full_sum) THEN iat = iat + 1 full_sum = full_sum + bsizes_orig(iat) END IF diff --git a/src/hfx_ri_kp.F b/src/hfx_ri_kp.F index b36651ecc9..9a9e0747c7 100644 --- a/src/hfx_ri_kp.F +++ b/src/hfx_ri_kp.F @@ -248,7 +248,7 @@ CONTAINS CALL cleanup_kp(ri_data) !We do all the checks on what we allow in this initial implementation - IF (ri_data%flavor .NE. ri_pmat) CPABORT("K-points RI-HFX only with RHO flavor") + 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) & CPABORT("RI%EPS_PGF_ORB and QS%EPS_PGF_ORB must be identical for RI-HFX k-points") @@ -572,12 +572,12 @@ CONTAINS END DO CALL contract_pmat_3c(t_3c_apc, ri_data%rho_ao_t, ri_data, qs_env) - IF (MOD(para_env%num_pe, ngroups) .NE. 0) THEN + IF (MOD(para_env%num_pe, ngroups) /= 0) THEN CPWARN("KP_NGROUPS must be an integer divisor of the total number of MPI ranks. It was set to 1.") ngroups = 1 CALL section_vals_val_set(hfx_section, "KP_NGROUPS", i_val=ngroups) END IF - IF ((MOD(ngroups, natom) .NE. 0) .AND. (MOD(natom, ngroups) .NE. 0) .AND. geometry_did_change) THEN + IF ((MOD(ngroups, natom) /= 0) .AND. (MOD(natom, ngroups) /= 0) .AND. geometry_did_change) THEN IF (ngroups > 1) THEN CPWARN("Better load balancing is reached if NGROUPS is a multiple/divisor of the number of atoms") END IF @@ -616,7 +616,7 @@ CONTAINS END DO n_batch_nze = nimg_nze/batch_size - IF (MODULO(nimg_nze, batch_size) .NE. 0) n_batch_nze = n_batch_nze + 1 + IF (MODULO(nimg_nze, batch_size) /= 0) n_batch_nze = n_batch_nze + 1 ALLOCATE (batch_ranges_nze(n_batch_nze + 1)) DO i_batch = 1, n_batch_nze batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1 @@ -803,7 +803,7 @@ CONTAINS !desymmetrize mb_img = get_opp_index(b_img, qs_env) - IF (mb_img > 0 .AND. mb_img .LE. nimg) THEN + IF (mb_img > 0 .AND. mb_img <= nimg) THEN CALL dbt_copy(ks_t(i_spin, mb_img), ri_data%ks_t(i_spin, b_img), order=[2, 1], summation=.TRUE.) END IF END DO @@ -1013,7 +1013,7 @@ CONTAINS nimg_nze = ri_data%nimg_nze batch_size = ri_data%kp_stack_size n_batch = nimg_nze/batch_size - IF (MODULO(nimg_nze, batch_size) .NE. 0) n_batch = n_batch + 1 + IF (MODULO(nimg_nze, batch_size) /= 0) n_batch = n_batch + 1 ALLOCATE (batch_ranges_nze(n_batch + 1)) DO i_batch = 1, n_batch batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1 @@ -1630,7 +1630,7 @@ CONTAINS CALL dbt_iterator_start(iter, t_2c_in) DO WHILE (dbt_iterator_blocks_left(iter)) CALL dbt_iterator_next_block(iter, ind) - IF (ind(1) .NE. ind(2)) CYCLE !bump matrix is diagonal + IF (ind(1) /= ind(2)) CYCLE !bump matrix is diagonal CALL dbt_get_block(t_2c_in, ind, blk, found) IF (.NOT. found) CYCLE @@ -1707,8 +1707,8 @@ CONTAINS !Juerg r = (x - r0)/(r1 - r0) b = -6.0_dp*r**5 + 15.0_dp*r**4 - 10.0_dp*r**3 + 1.0_dp - IF (x .GE. r1) b = 0.0_dp - IF (x .LE. r0) b = 1.0_dp + IF (x >= r1) b = 0.0_dp + IF (x <= r0) b = 1.0_dp END FUNCTION bump @@ -1727,8 +1727,8 @@ CONTAINS r = (x - r0)/(r1 - r0) b = (-30.0_dp*r**4 + 60.0_dp*r**3 - 30.0_dp*r**2)/(r1 - r0) - IF (x .GE. r1) b = 0.0_dp - IF (x .LE. r0) b = 0.0_dp + IF (x >= r1) b = 0.0_dp + IF (x <= r0) b = 0.0_dp END FUNCTION dbump @@ -2037,7 +2037,7 @@ CONTAINS !symmetrize by addin transpose of opp img mi_img = get_opp_index(i_img, qs_env) - IF (mi_img > 0 .AND. mi_img .LE. nimg) THEN + IF (mi_img > 0 .AND. mi_img <= nimg) THEN CALL dbt_copy_matrix_to_tensor(rho_desymm(i_spin, mi_img)%matrix, tmp) CALL dbt_copy(tmp, rho_ao_t(i_spin, i_img), order=[2, 1], summation=.TRUE., move_data=.TRUE.) END IF @@ -2181,8 +2181,8 @@ CONTAINS j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3)) IF (j_img > nimg .OR. j_img < 1) CYCLE - IF (iatom == atom_i .AND. dij .LE. ri_data%kp_RI_range) present_atoms_i(jatom, j_img) = 1 - IF (iatom == atom_j .AND. dij .LE. ri_data%kp_RI_range) present_atoms_j(jatom, j_img) = 1 + IF (iatom == atom_i .AND. dij <= ri_data%kp_RI_range) present_atoms_i(jatom, j_img) = 1 + IF (iatom == atom_j .AND. dij <= ri_data%kp_RI_range) present_atoms_j(jatom, j_img) = 1 END DO CALL neighbor_list_iterator_release(nl_iterator) CALL release_neighbor_list_sets(nl_2c) @@ -2320,7 +2320,7 @@ CONTAINS IF (.NOT. found) CYCLE bfac = 1.0_dp - IF (iblk .NE. jblk) bfac = bump(NORM2(ri - rref), r0, r1)*bump(NORM2(rj - rref), r0, r1) + IF (iblk /= jblk) bfac = bump(NORM2(ri - rref), r0, r1)*bump(NORM2(rj - rref), r0, r1) CALL dbcsr_put_block(work_tight, iblk, jblk, bfac*pblock(:, :)) END DO END DO @@ -2446,7 +2446,7 @@ CONTAINS !batching over all images n_batch_img = nimg/batch_size - IF (MODULO(nimg, batch_size) .NE. 0) n_batch_img = n_batch_img + 1 + IF (MODULO(nimg, batch_size) /= 0) n_batch_img = n_batch_img + 1 ALLOCATE (batch_ranges_img(n_batch_img + 1)) DO i_batch = 1, n_batch_img batch_ranges_img(i_batch) = (i_batch - 1)*batch_size + 1 @@ -2455,7 +2455,7 @@ CONTAINS !batching over images with non-zero 3c integrals n_batch_nze = nimg_nze/batch_size - IF (MODULO(nimg_nze, batch_size) .NE. 0) n_batch_nze = n_batch_nze + 1 + IF (MODULO(nimg_nze, batch_size) /= 0) n_batch_nze = n_batch_nze + 1 ALLOCATE (batch_ranges_nze(n_batch_nze + 1)) DO i_batch = 1, n_batch_nze batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1 @@ -2586,7 +2586,7 @@ CONTAINS !For more efficiency, we stack multiple images of the 3-center integrals into a single tensor batch_size = ri_data%kp_stack_size n_batch = nimg/batch_size - IF (MODULO(nimg, batch_size) .NE. 0) n_batch = n_batch + 1 + IF (MODULO(nimg, batch_size) /= 0) n_batch = n_batch + 1 ALLOCATE (batch_ranges(n_batch + 1)) DO i_batch = 1, n_batch batch_ranges(i_batch) = (i_batch - 1)*batch_size + 1 @@ -2741,7 +2741,7 @@ CONTAINS !We go by batches, which cannot be larger than the maximum MPI tag value batch_size = MIN(para_env%get_tag_ub(), 128000, nocc*ngroups) n_batch = (nocc*ngroups)/batch_size - IF (MODULO(nocc*ngroups, batch_size) .NE. 0) n_batch = n_batch + 1 + IF (MODULO(nocc*ngroups, batch_size) /= 0) n_batch = n_batch + 1 DO i_batch = 1, n_batch !Loop over groups, blocks and send/receive @@ -2812,7 +2812,7 @@ CONTAINS tag = i_msg - (i_batch - 1)*batch_size IF (para_env%mepos == current_dest(iblk, jblk, igroup) .AND. & - block_source(iblk, jblk) .NE. current_dest(iblk, jblk, igroup)) THEN + block_source(iblk, jblk) /= current_dest(iblk, jblk, igroup)) THEN ALLOCATE (blk(bsizes1(iblk), bsizes2(jblk))) blk(:, :) = recv_buff(tag)%array(:, :) @@ -2954,7 +2954,7 @@ CONTAINS !We go by batches, which cannot be larger than the maximum MPI tag value batch_size = MIN(para_env%get_tag_ub(), 128000, nocc*ngroups) n_batch = (nocc*ngroups)/batch_size - IF (MODULO(nocc*ngroups, batch_size) .NE. 0) n_batch = n_batch + 1 + IF (MODULO(nocc*ngroups, batch_size) /= 0) n_batch = n_batch + 1 DO i_batch = 1, n_batch !Loop over groups, blocks and send/receive @@ -3040,7 +3040,7 @@ CONTAINS END IF IF (para_env%mepos == subgroup_dest(iblk, jblk, kblk, igroup + 1) .AND. & - block_source(iblk, jblk, kblk) .NE. subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN + block_source(iblk, jblk, kblk) /= subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN ir = ir + 1 CALL mp_waitall(recv_req(ir:ir)) @@ -3143,7 +3143,7 @@ CONTAINS END IF !receiving the message - IF (para_env%mepos == dest .AND. source .NE. dest) THEN + IF (para_env%mepos == dest .AND. source /= dest) THEN ALLOCATE (recv_buff(n_mess)%array(ri_data%bsizes_AO(iatom), ri_data%bsizes_AO(jatom))) ir = ir + 1 CALL para_env%irecv(msgout=recv_buff(n_mess)%array, source=source, & @@ -4097,7 +4097,7 @@ CONTAINS IF (j_img > nimg .OR. j_img < 1) CYCLE mj_img = get_opp_index(j_img, qs_env) - IF (mj_img .LE. nimg .AND. mj_img > 0) CYCLE + IF (mj_img <= nimg .AND. mj_img > 0) CYCLE IF (ri_data%present_images(j_img) == 0) CYCLE @@ -4110,7 +4110,7 @@ CONTAINS !If the opposite image is considered, then there is no need to compute diagonal twice DO j_img = 2, nimg DO iatom = 1, natom - IF (pattern(iatom, iatom, j_img) .NE. 0) THEN + IF (pattern(iatom, iatom, j_img) /= 0) THEN mj_img = get_opp_index(j_img, qs_env) IF (mj_img > nimg .OR. mj_img < 1) CYCLE pattern(iatom, iatom, mj_img) = 0 @@ -4195,7 +4195,7 @@ CONTAINS !We want each atom to be present the same amount of times. Some groups might have more atoms !than other to achieve this. ctr = 0 - DO WHILE (MODULO(SUM(max_at_per_group), natom) .NE. 0) + DO WHILE (MODULO(SUM(max_at_per_group), natom) /= 0) igroup = MODULO(ctr, ngroups) + 1 max_at_per_group(igroup) = max_at_per_group(igroup) + 1 ctr = ctr + 1 @@ -4269,7 +4269,7 @@ CONTAINS IF (scf_pattern(iatom, jatom, b_img) > -1) CYCLE !If not, take the cost of block j, i, -b (same energy contribution) - IF (mb_img > 0 .AND. mb_img .LE. nimg) THEN + IF (mb_img > 0 .AND. mb_img <= nimg) THEN IF (scf_pattern(jatom, iatom, mb_img) == -1) CYCLE bins(igroup + 1) = bins(igroup + 1) + ri_data%kp_cost(jatom, iatom, mb_img) force_pattern(iatom, jatom, b_img) = igroup @@ -5121,7 +5121,7 @@ CONTAINS !Only take forecs due to block diagonal or block off-diagonal, depending on arguments IF ((my_diag .AND. .NOT. my_offdiag) .OR. (.NOT. my_diag .AND. my_offdiag)) THEN - IF (my_diag .AND. (ind(1) .NE. ind(2))) CYCLE + IF (my_diag .AND. (ind(1) /= ind(2))) CYCLE IF (my_offdiag .AND. (ind(1) == ind(2))) CYCLE END IF diff --git a/src/hfx_types.F b/src/hfx_types.F index 367899bf81..4f78c932b1 100644 --- a/src/hfx_types.F +++ b/src/hfx_types.F @@ -2980,7 +2980,7 @@ CONTAINS CALL section_vals_val_get(hfx_section1, "PW_HFX_BLOCKSIZE", i_val=ival1, i_rep_section=irep) CALL section_vals_val_get(hfx_section2, "PW_HFX_BLOCKSIZE", i_val=ival2, i_rep_section=irep) - IF (ival1 .NE. ival2) is_identical = .FALSE. + IF (ival1 /= ival2) is_identical = .FALSE. CALL section_vals_val_get(hfx_section1, "TREAT_LSD_IN_CORE", l_val=lval1, i_rep_section=irep) CALL section_vals_val_get(hfx_section2, "TREAT_LSD_IN_CORE", l_val=lval2, i_rep_section=irep) @@ -2995,7 +2995,7 @@ CONTAINS CALL section_vals_val_get(hfx_sub_section1, "POTENTIAL_TYPE", i_val=ival1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "POTENTIAL_TYPE", i_val=ival2, i_rep_section=irep) - IF (ival1 .NE. ival2) is_identical = .FALSE. + IF (ival1 /= ival2) is_identical = .FALSE. IF (.NOT. is_identical) RETURN IF (ival1 == do_potential_truncated .OR. ival1 == do_potential_mix_cl_trunc) THEN @@ -3005,7 +3005,7 @@ CONTAINS CALL section_vals_val_get(hfx_sub_section1, "T_C_G_DATA", c_val=cval1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "T_C_G_DATA", c_val=cval2, i_rep_section=irep) - IF (cval1 .NE. cval2) is_identical = .FALSE. + IF (cval1 /= cval2) is_identical = .FALSE. END IF CALL section_vals_val_get(hfx_sub_section1, "SCALE_COULOMB", r_val=rval1, i_rep_section=irep) @@ -3025,7 +3025,7 @@ CONTAINS CALL section_vals_val_get(hfx_sub_section1, "NUMBER_OF_SHELLS", i_val=ival1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "NUMBER_OF_SHELLS", i_val=ival2, i_rep_section=irep) - IF (ival1 .NE. ival2) is_identical = .FALSE. + IF (ival1 /= ival2) is_identical = .FALSE. hfx_sub_section1 => section_vals_get_subs_vals(hfx_section1, "RI", i_rep_section=irep) hfx_sub_section2 => section_vals_get_subs_vals(hfx_section2, "RI", i_rep_section=irep) @@ -3060,11 +3060,11 @@ CONTAINS CALL section_vals_val_get(hfx_sub_section1, "MAX_BLOCK_SIZE_MO", i_val=ival1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "MAX_BLOCK_SIZE_MO", i_val=ival2, i_rep_section=irep) - IF (ival1 .NE. ival2) is_identical = .FALSE. + IF (ival1 /= ival2) is_identical = .FALSE. CALL section_vals_val_get(hfx_sub_section1, "MIN_BLOCK_SIZE", i_val=ival1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "MIN_BLOCK_SIZE", i_val=ival2, i_rep_section=irep) - IF (ival1 .NE. ival2) is_identical = .FALSE. + IF (ival1 /= ival2) is_identical = .FALSE. CALL section_vals_val_get(hfx_sub_section1, "OMEGA", r_val=rval1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "OMEGA", r_val=rval2, i_rep_section=irep) @@ -3072,11 +3072,11 @@ CONTAINS CALL section_vals_val_get(hfx_sub_section1, "RI_FLAVOR", i_val=ival1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "RI_FLAVOR", i_val=ival2, i_rep_section=irep) - IF (ival1 .NE. ival2) is_identical = .FALSE. + IF (ival1 /= ival2) is_identical = .FALSE. CALL section_vals_val_get(hfx_sub_section1, "RI_METRIC", i_val=ival1, i_rep_section=irep) CALL section_vals_val_get(hfx_sub_section2, "RI_METRIC", i_val=ival2, i_rep_section=irep) - IF (ival1 .NE. ival2) is_identical = .FALSE. + IF (ival1 /= ival2) is_identical = .FALSE. hfx_sub_section1 => section_vals_get_subs_vals(hfx_section1, "SCREENING", i_rep_section=irep) hfx_sub_section2 => section_vals_get_subs_vals(hfx_section2, "SCREENING", i_rep_section=irep) diff --git a/src/input/cp_output_handling.F b/src/input/cp_output_handling.F index 73bf5dcbd1..a8764d3b6f 100644 --- a/src/input/cp_output_handling.F +++ b/src/input/cp_output_handling.F @@ -1090,7 +1090,7 @@ CONTAINS logger%para_env%is_source() .OR. & my_mpi_io)) THEN CALL section_vals_val_get(print_key, "FILENAME", c_val=outPath) - IF (my_on_file .OR. outPath .NE. '__STD_OUT__') THEN + IF (my_on_file .OR. outPath /= '__STD_OUT__') THEN CPASSERT(unit_nr > 0) IF (.NOT. my_mpi_io) THEN CALL close_file(unit_nr, "KEEP") diff --git a/src/input/input_parsing.F b/src/input/input_parsing.F index 524e79dd55..cea5524525 100644 --- a/src/input/input_parsing.F +++ b/src/input/input_parsing.F @@ -628,7 +628,7 @@ CONTAINS CALL cp_abort(__LOCATION__, & "type "//cp_to_string(type_of_var)//"unknown to the parser") END SELECT - IF (parser_test_next_token(parser) .NE. "EOL") THEN + IF (parser_test_next_token(parser) /= "EOL") THEN location = TRIM(parser_location(parser)) CALL parser_get_object(parser, info) CALL cp_abort(__LOCATION__, & diff --git a/src/input/input_section_types.F b/src/input/input_section_types.F index 6f67a5f424..3a6a283973 100644 --- a/src/input/input_section_types.F +++ b/src/input/input_section_types.F @@ -748,7 +748,7 @@ CONTAINS ! prepare for recursive parsing of subsections. i_rep_section will be used for last section my_index = INDEX(subsection_name, "%") - IF (my_index .EQ. 0) THEN + IF (my_index == 0) THEN is_path = .FALSE. my_index = LEN_TRIM(subsection_name) ELSE diff --git a/src/input_cp2k_almo.F b/src/input_cp2k_almo.F index 4c979554f3..49d8b314f3 100644 --- a/src/input_cp2k_almo.F +++ b/src/input_cp2k_almo.F @@ -669,7 +669,7 @@ CONTAINS CALL keyword_release(keyword) ! add keywords specific to each type - IF (optimizer_type .EQ. optimizer_diis) THEN + IF (optimizer_type == optimizer_diis) THEN CALL keyword_create(keyword, __LOCATION__, name="N_DIIS", & description="Number of error vectors to be used in the DIIS "// & @@ -680,9 +680,9 @@ CONTAINS END IF - IF (optimizer_type .EQ. optimizer_pcg .OR. & - optimizer_type .EQ. optimizer_lin_eq_pcg .OR. & - optimizer_type .EQ. optimizer_trustr) THEN + IF (optimizer_type == optimizer_pcg .OR. & + optimizer_type == optimizer_lin_eq_pcg .OR. & + optimizer_type == optimizer_trustr) THEN CALL keyword_create(keyword, __LOCATION__, name="MAX_ITER_OUTER_LOOP", & description="Maximum number of iterations in the outer loop. "// & @@ -709,7 +709,7 @@ CONTAINS END IF - IF (optimizer_type .EQ. optimizer_pcg) THEN + IF (optimizer_type == optimizer_pcg) THEN CALL keyword_create(keyword, __LOCATION__, name="LIN_SEARCH_EPS_ERROR", & description="Target value of the gradient norm during the linear search", & @@ -736,8 +736,8 @@ CONTAINS END IF - IF (optimizer_type .EQ. optimizer_pcg .OR. & - optimizer_type .EQ. optimizer_trustr) THEN + IF (optimizer_type == optimizer_pcg .OR. & + optimizer_type == optimizer_trustr) THEN CALL keyword_create(keyword, __LOCATION__, name="CONJUGATOR", & description="Various methods to compute step directions in the PCG optimization", & @@ -757,7 +757,7 @@ CONTAINS END IF - IF (optimizer_type .EQ. optimizer_trustr) THEN + IF (optimizer_type == optimizer_trustr) THEN CALL keyword_create(keyword, __LOCATION__, name="ALGORITHM", & description="Selects an algorithm to solve the fixed-radius subproblem", & diff --git a/src/input_cp2k_pwdft.F b/src/input_cp2k_pwdft.F index e5756b61b4..73198dbc99 100644 --- a/src/input_cp2k_pwdft.F +++ b/src/input_cp2k_pwdft.F @@ -337,7 +337,7 @@ CONTAINS CASE (SIRIUS_INTEGER_ARRAY_TYPE) CALL sirius_option_get(section_name, name, ctype, C_LOC(ivec(1)), max_length=16) - IF (num_possible_values .EQ. 0) THEN + IF (num_possible_values == 0) THEN CALL keyword_create(keyword, __LOCATION__, & name=name, & description=TRIM(ADJUSTL(description)), & @@ -383,7 +383,7 @@ CONTAINS CASE (SIRIUS_NUMBER_ARRAY_TYPE) CALL sirius_option_get(section_name, name, ctype, C_LOC(rvec(1)), max_length=16) - IF (num_possible_values .EQ. 0) THEN + IF (num_possible_values == 0) THEN CALL keyword_create(keyword, __LOCATION__, & name=name, & description=TRIM(ADJUSTL(description)), & diff --git a/src/iterate_matrix.F b/src/iterate_matrix.F index 659e75732d..cc25be1a7d 100644 --- a/src/iterate_matrix.F +++ b/src/iterate_matrix.F @@ -156,7 +156,7 @@ CONTAINS CALL dbcsr_add_on_diag(tmp2, -1.0_dp) frobnorm = dbcsr_frobenius_norm(tmp2) IF (unit_nr > 0) THEN - IF (recursion_depth .EQ. 0) THEN + IF (recursion_depth == 0) THEN WRITE (unit_nr, '()') ELSE WRITE (unit_nr, '(T6,A28,1X,I15)') & @@ -167,7 +167,7 @@ CONTAINS CALL m_flush(unit_nr) END IF - IF (frobnorm .GE. 1.0_dp) THEN + IF (frobnorm >= 1.0_dp) THEN CALL dbcsr_add_on_diag(tmp2, 1.0_dp) ! these controls should be provided as input @@ -245,7 +245,7 @@ CONTAINS END IF ! decide to do sqrt or not IF (unit_nr > 0) THEN - IF (recursion_depth .EQ. 0) THEN + IF (recursion_depth == 0) THEN WRITE (unit_nr, '(T6,A28,1X,F15.10)') & "Final determinant:", det WRITE (unit_nr, '()') @@ -322,7 +322,7 @@ CONTAINS accelerator_type = 0 IF (PRESENT(accelerator_order)) accelerator_type = accelerator_order - IF (accelerator_type .GT. 1) accelerator_type = 1 + IF (accelerator_type > 1) accelerator_type = 1 use_inv_guess = .FALSE. IF (PRESENT(use_inv_as_guess)) use_inv_guess = use_inv_as_guess @@ -352,7 +352,7 @@ CONTAINS ! invert the main diagonal CALL dbcsr_get_diag(matrix, p_diagonal) DO i = 1, nrows - IF (p_diagonal(i) .NE. 0.0_dp) THEN + IF (p_diagonal(i) /= 0.0_dp) THEN p_diagonal(i) = 1.0_dp/p_diagonal(i) END IF END DO @@ -511,7 +511,7 @@ CONTAINS accelerator_type = 1 IF (PRESENT(accelerator_order)) accelerator_type = accelerator_order - IF (accelerator_type .GT. 1) accelerator_type = 1 + IF (accelerator_type > 1) accelerator_type = 1 use_inv_guess = .FALSE. IF (PRESENT(use_inv_as_guess)) use_inv_guess = use_inv_as_guess @@ -717,10 +717,10 @@ CONTAINS CALL dbcsr_create(tmp1, template=matrix_sign) CALL dbcsr_create(tmp2, template=matrix_sign) - IF (ABS(order) .GE. 4) THEN + IF (ABS(order) >= 4) THEN CALL dbcsr_create(tmp3, template=matrix_sign) END IF - IF (ABS(order) .GT. 4) THEN + IF (ABS(order) > 4) THEN CALL dbcsr_create(tmp4, template=matrix_sign) END IF @@ -778,13 +778,13 @@ CONTAINS ! y=1-X*X ! tmp1 = I-x*x - IF (order .EQ. 2) THEN + IF (order == 2) THEN prefactor = 0.5_dp ! update the above to 3*I-X*X CALL dbcsr_add_on_diag(tmp1, +2.0_dp) occ_matrix = dbcsr_get_occupation(matrix_sign) - ELSE IF (order .EQ. 3) THEN + ELSE IF (order == 3) THEN ! with one multiplication ! tmp1=y CALL dbcsr_copy(tmp2, tmp1) @@ -797,7 +797,7 @@ CONTAINS floptot = floptot + flops prefactor = 3.0_dp/8.0_dp - ELSE IF (order .EQ. 4) THEN + ELSE IF (order == 4) THEN ! with two multiplications ! tmp1=y CALL dbcsr_copy(tmp3, tmp1) @@ -816,7 +816,7 @@ CONTAINS floptot = floptot + flops prefactor = 5.0_dp/16.0_dp - ELSE IF (order .EQ. -5) THEN + ELSE IF (order == -5) THEN ! with three multiplications ! tmp1=y CALL dbcsr_copy(tmp3, tmp1) @@ -841,7 +841,7 @@ CONTAINS floptot = floptot + flops prefactor = 35.0_dp/128.0_dp - ELSE IF (order .EQ. 5) THEN + ELSE IF (order == 5) THEN ! with two multiplications ! z(y)=(y+a_0)*y+a_1 ! f5(y)=35/128*((z(y)+y+a_2)*z(y)+a_3) @@ -873,7 +873,7 @@ CONTAINS CALL dbcsr_copy(tmp1, tmp3) prefactor = 35.0_dp/128.0_dp - ELSE IF (order .EQ. 6) THEN + ELSE IF (order == 6) THEN ! with four multiplications ! f6(y)=63/256*(256/63 + (128 y)/63 + (32 y^2)/21 + (80 y^3)/63 + (10 y^4)/9 + y^5) ! tmp1=y @@ -905,7 +905,7 @@ CONTAINS floptot = floptot + flops prefactor = 63.0_dp/256.0_dp - ELSE IF (order .EQ. 7) THEN + ELSE IF (order == 7) THEN ! with three multiplications a0 = 1.3686502058092053653287666647611728507211996691324048468010382350359929055186612505791532871573242422_dp @@ -988,10 +988,10 @@ CONTAINS CALL dbcsr_release(tmp1) CALL dbcsr_release(tmp2) - IF (ABS(order) .GE. 4) THEN + IF (ABS(order) >= 4) THEN CALL dbcsr_release(tmp3) END IF - IF (ABS(order) .GT. 4) THEN + IF (ABS(order) > 4) THEN CALL dbcsr_release(tmp4) END IF @@ -1146,13 +1146,13 @@ CONTAINS END DO frob_matrix = dlange('F', sz, sz, tmp1, sz, work) - IF (sign_order .EQ. 2) THEN + IF (sign_order == 2) THEN prefactor = 0.5_dp ! update the above to 3*I-X*X DO j = 1, sz tmp1(j, j) = tmp1(j, j) + 2.0_dp END DO - ELSE IF (sign_order .EQ. 3) THEN + ELSE IF (sign_order == 3) THEN tmp2(:, :) = tmp1 tmp1 = tmp1*4.0_dp/3.0_dp DO j = 1, sz @@ -1233,7 +1233,7 @@ CONTAINS CALL dsyevd('V', 'U', N, eigvecs, N, eigvals, WORK, LWORK, IWORK, LIWORK, INFO) DEALLOCATE (IWORK) DEALLOCATE (WORK) - IF (INFO .NE. 0) CPABORT("dsyevd did not succeed") + IF (INFO /= 0) CPABORT("dsyevd did not succeed") DEALLOCATE (tmp) END SUBROUTINE eigdecomp @@ -1490,7 +1490,7 @@ CONTAINS CALL dissection%get_relevant_sm_columns(my_sms(i), sm_firstcol, sm_lastcol) - IF (variant .EQ. ls_scf_submatrix_sign_direct_muadj) THEN + IF (variant == ls_scf_submatrix_sign_direct_muadj) THEN ! Store all eigenvectors in buffer. We will use it to compute sm_sign at the end. CALL eigdecomp(sm, sm_size, eigvals=eigbufs(i)%eigvals, eigvecs=eigbufs(i)%eigvecs) ELSE @@ -1554,7 +1554,7 @@ CONTAINS END DO ! Finalize sign matrix from eigendecompositions if we kept all eigenvectors - IF (variant .EQ. ls_scf_submatrix_sign_direct_muadj) THEN + IF (variant == ls_scf_submatrix_sign_direct_muadj) THEN !$OMP PARALLEL DEFAULT(OMP_DEFAULT_NONE_WITH_OOP) & !$OMP PRIVATE(sm, sm_sign, sm_size, sm_firstcol, sm_lastcol, j) & !$OMP SHARED(dissection, myrank, my_sms, unit_nr, eigbufs, mu, new_mu) @@ -1574,7 +1574,7 @@ CONTAINS DEALLOCATE (eigbufs) ! If we only stored parts of the eigenvectors and mu has changed, we need to recompute sm_sign - IF ((variant .EQ. ls_scf_submatrix_sign_direct_muadj_lowmem) .AND. (mu .NE. new_mu)) THEN + IF ((variant == ls_scf_submatrix_sign_direct_muadj_lowmem) .AND. (mu /= new_mu)) THEN !$OMP PARALLEL DEFAULT(OMP_DEFAULT_NONE_WITH_OOP) & !$OMP PRIVATE(sm, sm_sign, sm_size, sm_firstcol, sm_lastcol, j) & !$OMP SHARED(dissection, myrank, my_sms, unit_nr, eigbufs, mu, new_mu) @@ -1666,7 +1666,7 @@ CONTAINS ! for stability symmetry can not be assumed CALL dbcsr_create(tmp1, template=matrix, matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_create(tmp2, template=matrix, matrix_type=dbcsr_type_no_symmetry) - IF (order .GE. 4) THEN + IF (order >= 4) THEN CALL dbcsr_create(tmp3, template=matrix, matrix_type=dbcsr_type_no_symmetry) END IF @@ -1849,7 +1849,7 @@ CONTAINS CALL dbcsr_release(tmp1) CALL dbcsr_release(tmp2) - IF (order .GE. 4) THEN + IF (order >= 4) THEN CALL dbcsr_release(tmp3) END IF @@ -1921,7 +1921,7 @@ CONTAINS CALL dbcsr_create(matrixS, template=matrix, matrix_type=dbcsr_type_no_symmetry) CALL dbcsr_copy(matrixS, matrix) - IF (1 .EQ. 1) THEN + IF (1 == 1) THEN ! scale the matrix to get into the convergence range CALL arnoldi_extremal(matrixS, max_ev, min_ev, threshold=eps_lanczos, & max_iter=max_iter_lanczos, converged=arnoldi_converged) @@ -1952,7 +1952,7 @@ CONTAINS DO i = 1, 100 t1 = m_walltime() - IF (1 .EQ. 1) THEN + IF (1 == 1) THEN !build R=1-A B_K^2 CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_sqrt_inv, matrix_sqrt_inv, 0.0_dp, tmp1, & filter_eps=threshold, flop=flop1) @@ -1968,7 +1968,7 @@ CONTAINS flop3 = 0 DO j = 2, order - IF (j .EQ. 2) THEN + IF (j == 2) THEN CALL dbcsr_copy(tmp2, Rmat) ELSE f = 0 @@ -1999,7 +1999,7 @@ CONTAINS !choose=factorial(order)/(factorial(j)*factorial(order-j)) choose = PRODUCT([(ii, ii=1, order)])/(PRODUCT([(ii, ii=1, j)])*PRODUCT([(ii, ii=1, order - j)])) CALL dbcsr_add(tmp1, tmp2, 1.0_dp, -1.0_dp*(-1)**j*choose) - IF (j .LT. order) THEN + IF (j < order) THEN f = 0 CALL dbcsr_copy(tmp3, tmp2) CALL dbcsr_multiply("N", "N", 1.0_dp, tmp3, BK2A, 0.0_dp, tmp2, & diff --git a/src/kg_environment.F b/src/kg_environment.F index de95a204a6..c40419c0b3 100644 --- a/src/kg_environment.F +++ b/src/kg_environment.F @@ -582,7 +582,7 @@ CONTAINS jmol = kg_env%atom_to_molecule(jatom) !IF (imol maxdegree) maxdegree = nneighbors END IF imol = jmol nneighbors = 0 @@ -120,10 +120,10 @@ CONTAINS nneighbors = nneighbors + 1 END DO - IF (imol .NE. 0) THEN + IF (imol /= 0) THEN ALLOCATE (graph(imol)%vertex%neighbors(nneighbors)) graph(imol)%vertex%degree = nneighbors - IF (nneighbors .GT. maxdegree) maxdegree = nneighbors + IF (nneighbors > maxdegree) maxdegree = nneighbors END IF kg_env%maxdegree = maxdegree @@ -137,7 +137,7 @@ CONTAINS DO i = 1, SIZE(pairs, 2) jmol = pairs(1, i) - IF (jmol .NE. imol) THEN + IF (jmol /= imol) THEN ineighbor = 0 imol = jmol END IF @@ -189,7 +189,7 @@ CONTAINS nneighbors = SIZE(graph(i)%vertex%neighbors) DO j = 1, nneighbors color = graph(i)%vertex%neighbors(j)%vertex%color - IF (color .NE. 0) color_present(color) = .TRUE. + IF (color /= 0) color_present(color) = .TRUE. END DO END IF DO j = 1, maxdegree + 1 !nnodes @@ -198,7 +198,7 @@ CONTAINS EXIT END IF END DO - IF (newcolor .GT. ncolors) ncolors = newcolor + IF (newcolor > ncolors) ncolors = newcolor graph(i)%vertex%color = newcolor ! smallest possible END DO @@ -236,9 +236,9 @@ CONTAINS WRITE (unit_nr, '(T2,I5,1X,A)', ADVANCE='NO') i, "|" counter = 0 DO j = 1, nnodes - IF (graph(j)%vertex%color .EQ. i) THEN + IF (graph(j)%vertex%color == i) THEN counter = counter + 1 - IF (MOD(counter, 13) .EQ. 0) THEN + IF (MOD(counter, 13) == 0) THEN counter = counter + 1 WRITE (unit_nr, '()') ! line break WRITE (unit_nr, '(6X,A)', ADVANCE='NO') " |" ! indent next line @@ -361,7 +361,7 @@ CONTAINS maxdegree = kg_env%maxdegree nnodes = SIZE(graph) - IF (kg_env%maxdegree .EQ. 0) THEN + IF (kg_env%maxdegree == 0) THEN ! all nodes are disconnected ncolors = 1 @@ -398,7 +398,7 @@ CONTAINS EXIT END IF END DO - IF (this%color .GT. ncolors) ncolors = this%color + IF (this%color > ncolors) ncolors = this%color ! update all neighboring nodes DO i = 1, nneighbors diff --git a/src/kpoint_coulomb_2c.F b/src/kpoint_coulomb_2c.F index b22c38694d..53902c8079 100644 --- a/src/kpoint_coulomb_2c.F +++ b/src/kpoint_coulomb_2c.F @@ -758,7 +758,7 @@ CONTAINS vec_s = [REAL(i_x, dp), REAL(j_y, dp), REAL(k_z, dp)] - IF (MODULO(i_cell, para_env%num_pe) .NE. para_env%mepos) CYCLE + IF (MODULO(i_cell, para_env%num_pe) /= para_env%mepos) CYCLE vec_L = MATMUL(hmat, vec_s) @@ -780,7 +780,7 @@ CONTAINS ! add exp(iq*vec_L) * (P 0 | Q vec_L) to V_PQ(q) DO ik = 1, ikp_end - IF (MODULO(ik, para_env%num_pe) .NE. para_env%mepos) CYCLE + IF (MODULO(ik, para_env%num_pe) /= para_env%mepos) CYCLE ikp_local = ikp_local + 1 diff --git a/src/kpoint_methods.F b/src/kpoint_methods.F index 50b0acc2c9..2bb0400d39 100644 --- a/src/kpoint_methods.F +++ b/src/kpoint_methods.F @@ -381,9 +381,9 @@ CONTAINS ! making sure that the group size divides the npe and the nkp_grp the nkp ! in the worst case, there will be no parallelism over kpoints. DO igr = npe, 1, -1 - IF (MOD(npe, igr) .NE. 0) CYCLE + IF (MOD(npe, igr) /= 0) CYCLE nkp_grp = npe/igr - IF (MOD(nkp, nkp_grp) .NE. 0) CYCLE + IF (MOD(nkp, nkp_grp) /= 0) CYCLE ngr = igr END DO ELSE IF (kpoint%parallel_group_size == 0) THEN diff --git a/src/kpsym.F b/src/kpsym.F index 827fec3032..9381702af0 100644 --- a/src/kpsym.F +++ b/src/kpsym.F @@ -194,9 +194,9 @@ CONTAINS itype = 0 DO i = 1, nat ! Assign an atomic type (for internal purposes) - IF (i .NE. 1) THEN + IF (i /= 1) THEN DO j = 1, (i - 1) - IF (ty(j) .EQ. ty(i)) THEN + IF (ty(j) == ty(i)) THEN ! Type located GOTO 178 END IF @@ -204,7 +204,7 @@ CONTAINS ! New type END IF itype = itype + 1 - IF (itype .GT. nsp) THEN + IF (itype > nsp) THEN IF (iout > 0) & WRITE (iout, '(A,I4,")")') & ' KPSYM| NUMBER OF ATOMIC TYPES EXCEEDS DIMENSION (NSP=)', & @@ -228,7 +228,7 @@ CONTAINS DO i = 1, 6 totstr = totstr + ABS(strain(i)) END DO - IF (totstr .GT. dtotstr) istrin = 1 + IF (totstr > dtotstr) istrin = 1 ! ==--------------------------------------------------------------== ! Volume of the cell. volum = a1(1)*a2(2)*a3(3) + a2(1)*a3(2)*a1(3) + & @@ -262,7 +262,7 @@ CONTAINS END DO ! ==--------------------------------------------------------------== invadd = 0 - IF (li .EQ. 0) THEN + IF (li == 0) THEN IF (iout > 0) & WRITE (iout, '(A,/,A,/,A)') & ' KPSYM| ALTHOUGH THE POINT GROUP OF THE CRYSTAL DOES NOT', & @@ -291,24 +291,24 @@ CONTAINS icst(ihg) ! IHC .... Code distinguishing between hexagonal and cubic groups ! ISY .... Code indicating whether the space group is symmorphic - IF (isy .EQ. 0) THEN + IF (isy == 0) THEN IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP")') - ELSEIF (isy .EQ. 1) THEN + ELSEIF (isy == 1) THEN IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP")') - ELSEIF (isy .EQ. -1) THEN + ELSEIF (isy == -1) THEN IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"SYMMORPHIC GROUP WITH NON-STANDARD ORIGIN")') - ELSEIF (isy .EQ. -2) THEN + ELSEIF (isy == -2) THEN IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NONSYMMORPHIC GROUP???")') END IF ! LI ..... Inversions symmetry - IF (li .EQ. 0) THEN + IF (li == 0) THEN IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"NO INVERSION SYMMETRY")') - ELSEIF (li .GT. 0) THEN + ELSEIF (li > 0) THEN IF (iout > 0) & WRITE (iout, '(" KPSYM|",4X,"INVERSION SYMMETRY")') END IF @@ -325,7 +325,7 @@ CONTAINS IF (iout > 0) & WRITE (iout, '(7X,12I4)') (ib(i), i=1, nc) ! V ...... Nonprimitive translations (for nonsymmorphic groups) - IF (isy .LE. 0) THEN + IF (isy <= 0) THEN IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"NONPRIMITIVE TRANSLATIONS:")') IF (iout > 0) & @@ -355,16 +355,16 @@ CONTAINS DO j = 1, nat IF (iout > 0) & WRITE (iout, '(I5,2I4)', advance="no") ib(k), j, f0(k, j) - IF ((MOD(j, 5) .EQ. 0) .AND. iout > 0) & + IF ((MOD(j, 5) == 0) .AND. iout > 0) & WRITE (iout, *) END DO - IF ((MOD(j - 1, 5) .NE. 0) .AND. iout > 0) & + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & WRITE (iout, *) END DO ! R ...... List of the 3 x 3 rotation matrices IF (iout > 0) & WRITE (iout, '(/," KPSYM|",4X,"LIST OF THE 3 X 3 ROTATION MATRICES:")') - IF (ihc .EQ. 0) THEN + IF (ihc == 0) THEN DO k = 1, nc IF (iout > 0) & WRITE (iout, & @@ -402,8 +402,8 @@ CONTAINS IF (iout > 0) & WRITE (iout, '(A,/,1X,3F10.5)') & ' KPSYM| CONSTANT VECTOR SHIFT (MACDONALD) OF THIS MESH:', wvk0 - IF (iabs(iq1) + iabs(iq2) + iabs(iq3) .EQ. 0) GOTO 710 - IF (ABS(istriz) .NE. 1) THEN + IF (iabs(iq1) + iabs(iq2) + iabs(iq3) == 0) GOTO 710 + IF (ABS(istriz) /= 1) THEN IF (iout > 0) & WRITE (iout, '(" KPSYM| INVALID SWITCH FOR SYMMETRIZATION",I10)') istriz IF (iout > 0) & @@ -412,7 +412,7 @@ CONTAINS END IF IF (iout > 0) & WRITE (iout, '(" KPSYM| SYMMETRIZATION SWITCH: ",I3)', advance="no") istriz - IF (istriz .EQ. 1) THEN + IF (istriz == 1) THEN IF (iout > 0) & WRITE (iout, '(" (SYMMETRIZATION OF MONKHORST-PACK MESH)")') ELSE @@ -427,11 +427,11 @@ CONTAINS ! == Generation of the points (they are not multiplied == ! == by 2*Pi because B1,2,3 were not,either) == ! ==--------------------------------------------------------------== - IF (nc .GT. nc0) THEN + IF (nc > nc0) THEN ! Due to non-use of primitive cell, the crystal has more ! rotations than Bravais lattice. ! We use only the rotations for Bravais lattices - IF (ntvec .EQ. 1) THEN + IF (ntvec == 1) THEN IF (iout > 0) & WRITE (iout, *) ' KPSYM| NUMBER OF ROTATIONS FOR BRAVAIS LATTICE', nc0 IF (iout > 0) & @@ -468,9 +468,9 @@ CONTAINS ! ==--------------------------------------------------------------== IF (iout > 0) & WRITE (iout, '(/," KPSYM|",1X,I5," SPECIAL POINTS GENERATED")') ntot - IF (ntot .EQ. 0) THEN + IF (ntot == 0) THEN GOTO 710 - ELSE IF (ntot .LT. 0) THEN + ELSE IF (ntot < 0) THEN IF (iout > 0) & WRITE (iout, '(A,I5,/,A,/,A)') ' KPSYM| DIMENSION NKPOINT =', nkpoint, & ' KPSYM| INSUFFICIENT FOR ACCOMMODATING ALL THE SPECIAL POINTS', & @@ -490,9 +490,9 @@ CONTAINS ! Set near-zeroes equal to zero: DO l = 1, ntot DO i = 1, 3 - IF (ABS(wvkl(i, l)) .LT. delta) wvkl(i, l) = 0._dp + IF (ABS(wvkl(i, l)) < delta) wvkl(i, l) = 0._dp END DO - IF (istrin .NE. 0) THEN + IF (istrin /= 0) THEN ! Express special points in (unstrained) basis. proj1 = 0._dp proj2 = 0._dp @@ -568,11 +568,11 @@ CONTAINS ! == INPUT DATA: == ! == IOUT ... NUMBER OF THE OUTPUT UNIT FOR ON-LINE PRINTING == ! == OF VARIOUS MESSAGES == - ! == IF IOUT.LE.0 NO MESSAGE == + ! == IF IOUT<=0 NO MESSAGE == ! == A1,A2,A3 .. ELEMENTARY TRANSLATIONS OF THE LATTICE, IN SOME == ! == UNIT OF LENGTH == ! == NAT .... NUMBER OF ATOMS IN THE UNIT CELL == - ! == ALL THE DIMENSIONS ARE SET FOR NAT .LE. 20 == + ! == ALL THE DIMENSIONS ARE SET FOR NAT <= 20 == ! == TY ..... INTEGERS DISTINGUISHING BETWEEN THE ATOMS OF == ! == DIFFERENT TYPE. TY(I) IS THE TYPE OF THE I-TH ATOM == ! == OF THE BASIS == @@ -611,7 +611,7 @@ CONTAINS ! == (OPERATIONS 13 OR 25 IN RESPECTIVELY HEXAGONAL == ! == OR CUBIC GROUPS). == ! == LI=0 MEANS: DOES NOT CONTAIN INVERSION == - ! == LI.GT.0 MEANS: THERE IS INVERSION IN THE POINT == + ! == LI>0 MEANS: THERE IS INVERSION IN THE POINT == ! == GROUP OF THE CRYSTAL == ! == NC ..... TOTAL NUMBER OF ELEMENTS IN THE POINT GROUP OF THE == ! == CRYSTAL == @@ -704,13 +704,13 @@ CONTAINS ! ==--------------------------------------------------------------== ! Determination of the holohedral group (and crystal system) CALL pgl1(ap, api, ihc, nc, ib, ihg, r, delta) - IF (ntvec .GT. 1) THEN + IF (ntvec > 1) THEN ! All rotations found by PGL1 have axes in x, y or z cart. axis ! So we have too check if we do not loose symmetry ncprim = nc ! The hexagonal system is found if the z axis is the sixfold axis CALL pgl1(a, ai, ihc, nc, ib, ihg, r, delta) - IF (ncprim .GT. nc) THEN + IF (ncprim > nc) THEN ! More symmetry with CALL pgl1(ap, api, ihc, nc, ib, ihg, r, delta) END IF @@ -720,8 +720,8 @@ CONTAINS CALL atftm1(iout, r, v, x, f0, origin, ib, ty, nat, ihg, ihc, rx, & nc, indpg, ntvec, a, ai, li, isy, isc, delta) - IF (iout .GT. 0) THEN - IF (li .GT. 0) THEN + IF (iout > 0) THEN + IF (li > 0) THEN IF (iout > 0) & WRITE (iout, '(1X,A)') & 'KPSYM| THE POINT GROUP OF THE CRYSTAL CONTAINS THE INVERSION' @@ -758,13 +758,13 @@ CONTAINS DO i = 1, 3 il = 1 iu = 3 - IF (i .EQ. 1) il = 2 - IF (i .EQ. 3) iu = 2 + IF (i == 1) il = 2 + IF (i == 3) iu = 2 DO j = 1, 3 jl = 1 ju = 3 - IF (j .EQ. 1) jl = 2 - IF (j .EQ. 3) ju = 2 + IF (j == 1) jl = 2 + IF (j == 3) ju = 2 ai(j, i) = (-1._dp)**(i + j)*det* & (A(IL, JL)*A(IU, JU) - A(IL, JU)*A(IU, JL)) END DO @@ -840,7 +840,7 @@ CONTAINS f0(49, i) = i END DO DO k2 = 2, nat - IF (ty(1) .NE. ty(k2)) GOTO 100 + IF (ty(1) /= ty(k2)) GOTO 100 DO i = 1, 3 xb(i) = x(i, k2) - x(i, 1) END DO @@ -853,7 +853,7 @@ CONTAINS ! F0(49,1:NAT) gives number of equivalent atoms ! and has atom indexes of inequivalent atoms (for translation) DO i = 1, nat - IF (f0(49, i) .GT. f0(1, i)) f0(49, i) = f0(1, i) + IF (f0(49, i) > f0(1, i)) f0(49, i) = f0(1, i) END DO DO i = 1, 3 tvec(i, ntvec) = vr(i) @@ -870,7 +870,7 @@ CONTAINS api(2, i) = ai(2, i) api(3, i) = ai(3, i) END DO - IF (ntvec .EQ. 1) THEN + IF (ntvec == 1) THEN ! The current cell is definitely a primitive one ! Copy A and AI to AP and API ELSE @@ -886,9 +886,9 @@ CONTAINS ! We calculare TVEC in AP basis CALL rlv3(api, xb, vr, il, delta) DO i = 1, 3 - IF (ABS(vr(i)) .GT. delta) THEN + IF (ABS(vr(i)) > delta) THEN il = NINT(1._dp/ABS(vr(i))) - IF (il .GT. 1) THEN + IF (il > 1) THEN ! We replace AP(1:3,I) by TVEC(1:3,IV) DO j = 1, 3 ap(j, i) = xb(j) @@ -963,7 +963,7 @@ CONTAINS DO ihc = 0, 1 ! IHC is 0 for hexagonal groups and 1 for cubic groups. - IF (ihc .EQ. 0) THEN + IF (ihc == 0) THEN nr = 24 ELSE nr = 48 @@ -987,7 +987,7 @@ CONTAINS tr = tr + ABS(vr(i)) END DO ! If VR.ne.0, then XA cannot be a multiple of a lattice vector - IF (tr .GT. delta) GOTO 140 + IF (tr > delta) GOTO 140 END DO nc = nc + 1 ib(nc) = n @@ -995,19 +995,19 @@ CONTAINS END DO ! ==------------------------------------------------------------== ! IHG stands for holohedral group number. - IF (ihc .EQ. 0) THEN + IF (ihc == 0) THEN ! Hexagonal group: - IF (nc .EQ. 12) ihg = 6 - IF (nc .GT. 12) ihg = 7 - IF (nc .GE. 12) RETURN + IF (nc == 12) ihg = 6 + IF (nc > 12) ihg = 7 + IF (nc >= 12) RETURN ! Too few operations, try cubic group: (IHC=1,NR=48) ELSE ! Cubic group: - IF (nc .LT. 4) ihg = 1 - IF (nc .EQ. 4) ihg = 2 - IF (nc .GT. 4) ihg = 3 - IF (nc .EQ. 16) ihg = 4 - IF (nc .GT. 16) ihg = 5 + IF (nc < 4) ihg = 1 + IF (nc == 4) ihg = 2 + IF (nc > 4) ihg = 3 + IF (nc == 16) ihg = 4 + IF (nc > 16) ihg = 5 RETURN END IF END DO @@ -1056,7 +1056,7 @@ CONTAINS vr(i) = 0._dp END DO ts = ABS(xb(1)) + ABS(xb(2)) + ABS(xb(3)) - IF (ts .LE. delta) RETURN + IF (ts <= delta) RETURN DO i = 1, 3 vr(i) = vr(i) + ai(i, 1)*xb(1) + ai(i, 2)*xb(2) + ai(i, 3)*xb(3) il = il + NINT(ABS(vr(i))) @@ -1110,7 +1110,7 @@ CONTAINS ! ==--------------------------------------------------------------== ! == INPUT: == ! == IOUT Logical file number (output) == - ! == If IOUT.LE.0 no message == + ! == If IOUT<=0 no message == ! == IHG Holohedral group number (determined by PGL1) == ! == IHC Code distinguishing between hexagonal and cubic groups== ! == IHC=0 stands for hexagonal groups == @@ -1145,7 +1145,7 @@ CONTAINS ! == (operations 13 or 25 in respectively hexagonal == ! == or cubic groups). == ! == LI=0 : does not contain inversion == - ! == LI.GT.0 : there is inversion in the point == + ! == LI>0 : there is inversion in the point == ! == group of the crystal == ! ==--------------------------------------------------------------== ! INDPG group indpg group indpg group indpg group == @@ -1200,7 +1200,7 @@ CONTAINS LOGICAL :: nodupli, oksym REAL(dp) :: vc(3, 48), vr(3), vs, xb(3) - nodupli = ntvec .EQ. 1 + nodupli = ntvec == 1 nca = 0 DO n = 1, 48 iis(n) = 0 @@ -1227,8 +1227,8 @@ CONTAINS ! Now we try other possible VR ! F0(49,1:NAT) has only inequivalent atom indexes for translation DO k2 = 1, nat - IF (f0(49, k2) .LT. k2) GOTO 185 - IF (ty(1) .NE. ty(k2)) GOTO 185 + IF (f0(49, k2) < k2) GOTO 185 + IF (ty(1) /= ty(k2)) GOTO 185 DO i = 1, 3 xb(i) = rx(i, 1) - x(i, k2) END DO @@ -1267,14 +1267,14 @@ CONTAINS ! Remove unused operations i = 0 ni = 13 - IF (ihg .LT. 6) ni = 25 + IF (ihg < 6) ni = 25 li = 0 DO n = 1, nc l = ib(n) - IF (iis(l) .EQ. 0) GOTO 230 ! CYCLE + IF (iis(l) == 0) GOTO 230 ! CYCLE i = i + 1 ib(i) = ib(n) - IF (ib(i) .EQ. ni) li = i + IF (ib(i) == ni) li = i DO k = 1, nat f0(i, k) = f0(n, k) END DO @@ -1289,7 +1289,7 @@ CONTAINS ! THE ORIGINAL VALUE DELTA=0.0001 WAS MODIFIED ! BY K.K. , SEPTEMBER 1979 TO 0.0005 ! AND RETURNED TO 0.0001 BY RJN OCT 1987 - IF (vs .GT. delta) THEN + IF (vs > delta) THEN isy = 0 ELSE isy = 1 @@ -1297,140 +1297,140 @@ CONTAINS ! ==--------------------------------------------------------------== ! Determination of the point group ! (Thierry Deutsch - 1998 [Maybe not complete!!]) - IF (ihg .LT. 6) THEN - IF (nc .EQ. 0) THEN + IF (ihg < 6) THEN + IF (nc == 0) THEN IF (iout > 0) & WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSEIF (nc .EQ. 1) THEN + ELSEIF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSEIF (nc .EQ. 2 .AND. ib(2) .EQ. 25) THEN + ELSEIF (nc == 2 .AND. ib(2) == 25) THEN ! IB=125 indpg = 2 ! <1>(ci) - ELSEIF (nc .EQ. 2 .AND. ( & - ib(2) .EQ. 4 .OR. & ! 2[001] - ib(2) .EQ. 2 .OR. & ! 2[100] - ib(2) .EQ. 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) - ELSEIF (nc .EQ. 2 .AND. ( & - ib(2) .EQ. 28 .OR. & - ib(2) .EQ. 26 .OR. & - ib(2) .EQ. 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) - ELSEIF (nc .EQ. 4 .AND. ( & - ib(4) .EQ. 28 .OR. & ! 2[001] - ib(4) .EQ. 27 .OR. & ! 2[010] - ib(4) .EQ. 26 .OR. & ! 2[100] - ib(4) .EQ. 37 .OR. & ! -2[-110] - ib(4) .EQ. 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) - ELSEIF (nc .EQ. 4 .AND. ( & - ib(4) .EQ. 15 .OR. & - ib(4) .EQ. 20 .OR. & - ib(4) .EQ. 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) - ELSEIF (nc .EQ. 4 .AND. ( & - ib(4) .EQ. 39 .OR. & - ib(4) .EQ. 44 .OR. & - ib(4) .EQ. 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) - ELSEIF (nc .EQ. 8 .AND. ( & - (ib(3) .EQ. 14 .AND. ib(8) .EQ. 39) .OR. & - (ib(3) .EQ. 19 .AND. ib(8) .EQ. 44) .OR. & - (ib(3) .EQ. 22 .AND. ib(8) .EQ. 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) - ELSEIF (nc .EQ. 8 .AND. ib(4) .EQ. 4 .AND. ( & - ib(8) .EQ. 16 .OR. & - ib(8) .EQ. 20 .OR. & - ib(8) .EQ. 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) - ELSEIF (nc .EQ. 8 .AND. ( & - ib(8) .EQ. 40 .OR. & - ib(8) .EQ. 42 .OR. & - ib(8) .EQ. 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) - ELSEIF (nc .EQ. 8 .AND. ( & - (ib(3) .EQ. 13 .AND. ib(8) .EQ. 39) .OR. & - (ib(3) .EQ. 17 .AND. ib(8) .EQ. 44) .OR. & - (ib(3) .EQ. 21 .AND. ib(8) .EQ. 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) - ELSEIF (nc .EQ. 16 .AND. ( & - ib(16) .EQ. 40 .OR. & - ib(16) .EQ. 44 .OR. & - ib(16) .EQ. 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) - ELSEIF (nc .EQ. 4 .AND. (ib(4) .EQ. 4)) THEN + ELSEIF (nc == 4 .AND. (ib(4) == 4)) THEN ! Orthorhombic system ! IB=12 3 4 indpg = 25 ! 222(d2) - ELSEIF (nc .EQ. 4 .AND. ( & - ib(4) .EQ. 27 .OR. & - ib(4) .EQ. 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) - ELSEIF (nc .EQ. 8) THEN + ELSEIF (nc == 8) THEN ! IB=12 3 425 2627 28 indpg = 27 ! mmm(d2h) - ELSEIF (nc .EQ. 12 .AND. ( & - ib(12) .EQ. 12 .OR. & - ib(12) .EQ. 47 .OR. & - ib(12) .EQ. 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) - ELSEIF (nc .EQ. 24 .AND. ib(24) .EQ. 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) - ELSEIF (nc .EQ. 24 .AND. ib(24) .EQ. 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) - ELSEIF (nc .EQ. 24 .AND. ib(24) .EQ. 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) - ELSEIF (nc .EQ. 48) THEN + ELSEIF (nc == 48) THEN ! IB=1..48 indpg = 32 ! m3m(oh) ELSE @@ -1440,69 +1440,69 @@ CONTAINS ! Probably a sub-group of 32 indpg = -32 END IF - ELSEIF (ihg .GE. 6) THEN - IF (nc .EQ. 0) THEN + ELSEIF (ihg >= 6) THEN + IF (nc == 0) THEN IF (iout > 0) & WRITE (iout, '(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nC CALL stopgm('ATFTM1', 'NUMBER OF ROTATION NULL') ! Triclinic system - ELSEIF (nc .EQ. 1) THEN + ELSEIF (nc == 1) THEN ! IB=1 indpg = 1 ! 1 (c1) - ELSEIF (nc .EQ. 2 .AND. ib(2) .EQ. 13) THEN + ELSEIF (nc == 2 .AND. ib(2) == 13) THEN ! IB=113 indpg = 2 ! <1>(ci) - ELSEIF (nc .EQ. 2 .AND. ( & - ib(2) .EQ. 4)) THEN ! 2[001] + ELSEIF (nc == 2 .AND. ( & + ib(2) == 4)) THEN ! 2[001] ! Monoclinic system ! IB=1 4 indpg = 3 ! 2 (c2) - ELSEIF (nc .EQ. 2 .AND. ( & - ib(2) .EQ. 16)) THEN + ELSEIF (nc == 2 .AND. ( & + ib(2) == 16)) THEN ! IB=116 indpg = 4 ! m (c1h) - ELSEIF (nc .EQ. 4 .AND. ( & - ib(4) .EQ. 24 .OR. & - ib(4) .EQ. 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) - ELSEIF (nc .EQ. 3 .AND. ib(3) .EQ. 5) THEN + ELSEIF (nc == 3 .AND. ib(3) == 5) THEN ! Trigonal system ! IB=13 5 indpg = 6 ! 3 (c3) - ELSEIF (nc .EQ. 6 .AND. ib(6) .EQ. 17) THEN + ELSEIF (nc == 6 .AND. ib(6) == 17) THEN ! IB=113 1517 35 indpg = 7 ! <3>(c3i) - ELSEIF (nc .EQ. 6 .AND. ib(6) .EQ. 11) THEN + ELSEIF (nc == 6 .AND. ib(6) == 11) THEN ! IB=17 9 1135 indpg = 8 ! 32 (d3) - ELSEIF (nc .EQ. 6 .AND. ib(6) .EQ. 23) THEN + ELSEIF (nc == 6 .AND. ib(6) == 23) THEN ! IB=13 5 1921 23 indpg = 9 ! 3m (c3v) - ELSEIF (nc .EQ. 12 .AND. ib(12) .EQ. 23) THEN + ELSEIF (nc == 12 .AND. ib(12) == 23) THEN ! IB=13 5 79 1113 1517 1921 23 indpg = 10 ! <3>m(d3d) - ELSEIF (nc .EQ. 6 .AND. ib(6) .EQ. 6) THEN + ELSEIF (nc == 6 .AND. ib(6) == 6) THEN ! Hexagonal system ! IB=12 3 45 6 indpg = 18 ! 6 (c6) - ELSEIF (nc .EQ. 6 .AND. ib(6) .EQ. 18) THEN + ELSEIF (nc == 6 .AND. ib(6) == 18) THEN ! IB=13 5 1416 18 indpg = 19 ! <6>(c3h) - ELSEIF (nc .EQ. 12 .AND. ib(12) .EQ. 18) THEN + ELSEIF (nc == 12 .AND. ib(12) == 18) THEN ! IB=12 3 45 6 1314 1516 1718 indpg = 20 ! 6/m(c6h) - ELSEIF (nc .EQ. 12 .AND. ib(12) .EQ. 12) THEN + ELSEIF (nc == 12 .AND. ib(12) == 12) THEN ! IB=12 3 45 6 78 9 1011 12 indpg = 21 ! 622(d6) - ELSEIF (nc .EQ. 12 .AND. ib(2) .EQ. 2 .AND. ib(12) .EQ. 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) - ELSEIF (nc .EQ. 12 .AND. ib(2) .EQ. 3 .AND. ib(12) .EQ. 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) - ELSEIF (nc .EQ. 24) THEN + ELSEIF (nc == 24) THEN ! IB=1..24 indpg = 24 ! 6/mmm(d6h) ELSE @@ -1516,7 +1516,7 @@ CONTAINS ! ==--------------------------------------------------------------== ! == Determination if the space group is symmorphic or not == ! ==--------------------------------------------------------------== - IF (isy .NE. 1) THEN + IF (isy /= 1) THEN ! Transform V in cartesian coordinates DO n = 1, nc vc(1, n) = a(1, 1)*v(1, n) + a(1, 2)*v(2, n) + a(1, 3)*v(3, n) @@ -1524,12 +1524,12 @@ CONTAINS vc(3, n) = a(3, 1)*v(1, n) + a(3, 2)*v(2, n) + a(3, 3)*v(3, n) END DO CALL symmorphic(nc, ib, r, vc, ai, info, origin, delta) - IF (info .EQ. 1) THEN + IF (info == 1) THEN CALL rlv3(ai, origin, xb, il, delta) ! !!!RLV3 determines -XB in crystal coordinates ! !!We want between 0.0 and 1.0 DO i = 1, 3 - IF (-xb(i) .GE. 0._dp) THEN + IF (-xb(i) >= 0._dp) THEN origin(i) = -xb(i) ELSE origin(i) = 1._dp - xb(i) @@ -1539,7 +1539,7 @@ CONTAINS xb(i) = a(i, 1)*origin(1) + a(i, 2)*origin(2) + a(i, 3)*origin(3) END DO isy = -1 - ELSEIF (info .EQ. 0) THEN + ELSEIF (info == 0) THEN isy = 0 ELSE isy = -2 @@ -1552,12 +1552,12 @@ CONTAINS ! ==--------------------------------------------------------------== ! == Output == ! ==--------------------------------------------------------------== - IF (iout .GT. 0) THEN + IF (iout > 0) THEN IF (iout > 0) & WRITE (iout, *) CALL xstring(icst(ihg), i, j) - IF ((ihg .EQ. 7 .AND. nc .EQ. 24) .OR. & - (ihg .EQ. 5 .AND. nc .EQ. 48)) THEN + IF ((ihg == 7 .AND. nc == 24) .OR. & + (ihg == 5 .AND. nc == 48)) THEN IF (iout > 0) & WRITE (iout, '(A,A,A)') & ' KPSYM| THE POINT GROUP OF THE CRYSTAL IS THE FULL ', & @@ -1569,7 +1569,7 @@ CONTAINS ' KPSYM| THE CRYSTAL SYSTEM IS ', & icst(ihg) (i:j), & ' WITH ', nc, ' OPERATIONS:' - IF (ihc .EQ. 0) THEN + IF (ihc == 0) THEN IF (iout > 0) & WRITE (iout, '( 5(5(A13),/))') (rname_hexai(ib(i)), i=1, nc) ELSE @@ -1578,11 +1578,11 @@ CONTAINS END IF END IF ! ==------------------------------------------------------------== - IF (isy .EQ. 1) THEN + IF (isy == 1) THEN IF (iout > 0) & WRITE (iout, '(A)') & ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' - ELSEIF (isy .EQ. -1) THEN + ELSEIF (isy == -1) THEN IF (iout > 0) & WRITE (iout, '(A)') & ' KPSYM| THE SPACE GROUP OF THE CRYSTAL IS SYMMORPHIC' @@ -1590,12 +1590,12 @@ CONTAINS WRITE (iout, '(A,A,/,T3,3F10.6,3X,3F10.6)') & ' KPSYM| THE STANDARD ORIGIN OF COORDINATES IS: ', & '[CARTESIAN] [CRYSTAL]', xb, origin - ELSEIF (isy .EQ. 0) THEN + 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, ')' - ELSEIF (isy .EQ. -2) THEN + ELSEIF (isy == -2) THEN IF (iout > 0) & WRITE (iout, '(A,A)') & ' KPSYM| CANNOT DETERMINE IF THE SPACE GROUP IS', & @@ -1606,7 +1606,7 @@ CONTAINS ' KPSYM| OR ELSE A NON STANDARD ORIGIN OF COORDINATES WAS USED.', & ' KPSYM| (SUM OF TRANSLATION VECTORS=', vs, ')' END IF - IF (indpg .GT. 0) THEN + IF (indpg > 0) THEN CALL xstring(pgrp(indpg), i, j) CALL xstring(pgrd(indpg), k, l) IF (iout > 0) & @@ -1622,7 +1622,7 @@ CONTAINS ' SUBGROUP OF ', pgrp(-indpg) (i:j), & pgrd(-indpg) (k:l), -indpg END IF - IF (ntvec .EQ. 1) THEN + IF (ntvec == 1) THEN IF (iout > 0) & WRITE (iout, '(A,T60,I6)') & ' KPSYM| NUMBER OF PRIMITIVE CELL:', ntvec @@ -1696,15 +1696,15 @@ CONTAINS ! Now we check if ROT(N)+VR gives a correct symmetry. DO ia = 1, nat DO ib = 1, nat - IF (ty(ia) .EQ. ty(ib) .AND. isc(ib) .EQ. 0) THEN + IF (ty(ia) == ty(ib) .AND. isc(ib) == 0) THEN xb(1) = rx(1, ia) - x(1, ib) xb(2) = rx(2, ia) - x(2, ib) xb(3) = rx(3, ia) - x(3, ib) CALL rlv3(ai, xb, vt, il, delta) ! VT STANDS FOR V-TEST - oksym = (ABS((vr(1) - vt(1)) - NINT(vr(1) - vt(1))) .LT. delta) .AND. & - (ABS((vr(2) - vt(2)) - NINT(vr(2) - vt(2))) .LT. delta) .AND. & - (ABS((vr(3) - vt(3)) - NINT(vr(3) - vt(3))) .LT. delta) + oksym = (ABS((vr(1) - vt(1)) - NINT(vr(1) - vt(1))) < delta) .AND. & + (ABS((vr(2) - vt(2)) - NINT(vr(2) - vt(2))) < delta) .AND. & + (ABS((vr(3) - vt(3)) - NINT(vr(3) - vt(3))) < delta) IF (oksym) THEN IF (nodupli) isc(ib) = 1 f0(n, ia) = ib @@ -1780,7 +1780,7 @@ CONTAINS END DO DO ir = 1, nc dif = v(1, ir)*v(1, ir) + v(2, ir)*v(2, ir) + v(3, ir)*v(3, ir) - IF (dif .GT. delta*delta) THEN + IF (dif > delta*delta) THEN DO i = 1, 3 igood(i) = 1 END DO @@ -1792,7 +1792,7 @@ CONTAINS r3(i, i) = 1 + r3(i, i) END DO CALL invmat(r3, ierror) - IF (ierror .EQ. 0) THEN + IF (ierror == 0) THEN ! The matrix 3x3 has an inverse. DO i = 1, 3 vr(i) = r3(i, 1)*v(1, ir) & @@ -1806,11 +1806,11 @@ CONTAINS imissing3 = ierror i1 = 0 DO i = 1, 3 - IF (i .NE. ierror) THEN + IF (i /= ierror) THEN i1 = i1 + 1 j1 = 0 DO j = 1, 3 - IF (j .NE. ierror) THEN + IF (j /= ierror) THEN j1 = j1 + 1 r2(i1, j1) = -r(i, j, ib(ir)) END IF @@ -1819,17 +1819,17 @@ CONTAINS END IF END DO CALL invmat(r2, ierror) - IF (ierror .EQ. 0) THEN + IF (ierror == 0) THEN ! The matrix 2X2 has an inverse. ! Solve Vxy = (1-R).OAxy + OAz R3z (z is IMISSING3) i1 = 0 DO i = 1, 3 - IF (igood(i) .EQ. 1) THEN + IF (igood(i) == 1) THEN i1 = i1 + 1 vr(i) = 0._dp j1 = 0 DO j = 1, 3 - IF (igood(j) .EQ. 1) THEN + IF (igood(j) == 1) THEN j1 = j1 + 1 vr(i) = vr(i) + r2(i1, j1)*(v(j, ir) + & origin(imissing3)*r(j, imissing3, ib(ir))) @@ -1843,9 +1843,9 @@ CONTAINS ! Construct matrix 1-R with 1x1 i1 = 0 DO i = 1, 3 - IF (i .NE. imissing3) THEN + IF (i /= imissing3) THEN i1 = i1 + 1 - IF (i1 .EQ. ierror) THEN + IF (i1 == ierror) THEN igood(i) = 0 imissing2 = i ELSE @@ -1854,7 +1854,7 @@ CONTAINS END IF END DO diag = (1 - r(ionly, ionly, ib(ir))) - IF (ABS(diag) .GT. delta) THEN + IF (ABS(diag) > delta) THEN vr(ionly) = 1._dp/diag*(v(ionly, ir) + & origin(imissing3)*r(ionly, imissing3, ib(ir)) + & origin(imissing2)*r(ionly, imissing2, ib(ir))) @@ -1871,17 +1871,17 @@ CONTAINS dif = 0._dp ! If NTVEC /=1 there are NTVEC possible standard origins DO i = 1, 3 - IF (iok(i) .EQ. 1) THEN + IF (iok(i) == 1) THEN dif = dif + ABS(origin(i) - vr(i)) END IF END DO - IF (dif .GT. delta) THEN + IF (dif > delta) THEN ! Non-symmorphic info = 0 RETURN ELSE DO i = 1, 3 - IF (iok(i) .NE. 1 .AND. igood(i) .EQ. 1) THEN + IF (iok(i) /= 1 .AND. igood(i) == 1) THEN iok(i) = 1 origin(i) = vr(i) END IF @@ -1890,7 +1890,7 @@ CONTAINS END IF END DO ! ==--------------------------------------------------------------== - IF (iok(1) .EQ. 0 .AND. iok(2) .EQ. 0 .AND. iok(3) .EQ. 0) THEN + IF (iok(1) == 0 .AND. iok(2) == 0 .AND. iok(3) == 0) THEN ! Cannot not determine info = -1 RETURN @@ -1907,7 +1907,7 @@ CONTAINS END DO CALL rlv3(ai, vr, xb, il, delta) dif = ABS(xb(1)) + ABS(xb(2)) + ABS(xb(3)) - IF (dif .GT. delta) THEN + IF (dif > delta) THEN ! Non-symmorphic info = 0 RETURN @@ -1959,7 +1959,7 @@ CONTAINS END DO END DO END DO - IF (ihc .EQ. 0) THEN + IF (ihc == 0) THEN ! ==------------------------------------------------------------== ! DEFINE THE GENERATORS FOR THE ROTATION MATRICES--HEXAGONAL GROUP ! ==------------------------------------------------------------== @@ -2141,7 +2141,7 @@ CONTAINS ! ==--------------------------------------------------------------== ! == INPUT DATA: == ! == IOUT: LOGICAL UNIT FOR OUTPUT == - ! == IF (IOUT.LE.0) NO MESSAGE == + ! == IF (IOUT<=0) NO MESSAGE == ! == IQ1,IQ2,IQ3 .. PARAMETER Q OF MONKHORST AND PACK, == ! == GENERALIZED AND DIFFERENT FOR THE 3 DIRECTIONS B1, == ! == B2 AND B3 == @@ -2153,7 +2153,7 @@ CONTAINS ! == NKPOINT .. VARIABLE DIMENSION OF THE (OUTPUT) ARRAYS WVKL, == ! == LWGHT,LROT, I.E. SPACE RESERVED FOR THE SPECIAL == ! == POINTS AND ACCESSORIES. == - ! == NKPOINT HAS TO BE .GE. NTOT (TOTAL NUMBER OF SPECIAL== + ! == NKPOINT HAS TO BE >= NTOT (TOTAL NUMBER OF SPECIAL== ! == POINTS. THIS IS CHECKED BY THE SUBROUTINE. == ! == ISTRIZ . INDICATES WHETHER ADDITIONAL MESH POINTS SHOULD BE == ! == GENERATED BY APPLYING GROUP OPERATIONS TO THE MESH. == @@ -2167,8 +2167,8 @@ CONTAINS ! == TO THE POINT GROUP OF THE CRYSTAL OR NOT (IN THE == ! == CASE THAT THE POINT GROUP DOES NOT CONTAIN ANY). == ! == INV=0 MEANS: DO NOT ADD INVERSION == - ! == INV.NE.0 MEANS: ADD THE INVERSION == - ! == INV.NE.0 SHOULD BE THE STANDARD CHOICE WHEN SPPT2 == + ! == INV/=0 MEANS: ADD THE INVERSION == + ! == INV/=0 SHOULD BE THE STANDARD CHOICE WHEN SPPT2 == ! == IS USED IN RECIPROCAL SPACE - IN ORDER TO MAKE == ! == USE OF THE HERMITICITY OF HAMILTONIAN. == ! == WHEN USED IN DIRECT SPACE, THE RIGHT CHOICE OF INV == @@ -2226,7 +2226,7 @@ CONTAINS ! == NEGATIVE, THIS MEANS THAT THE CORRESPONDING ROTATION== ! == HAS TO BE APPLIED WITH INVERSION (THE LATTER HAVING == ! == BEEN ARTIFICIALLY ADDED AS SYMMETRY OPERATION IN == - ! == CASE INV.NE.0).NO OTHER EFFORT WAS TAKEN,TO RENUMBER== + ! == CASE INV/=0).NO OTHER EFFORT WAS TAKEN,TO RENUMBER== ! == THE ROTATIONS WITH MINUS SIGN OR TO EXTEND THE == ! == LIST OF THE POINT-GROUP OPERATIONS IN THE LIST NB. == ! == INCLUD ... INTEGER ARRAY USED BY SPPT2 INCLUD(NKPOINT) == @@ -2305,7 +2305,7 @@ CONTAINS ! Reduce WVK to the 1st Brillouin zone CALL bzrduc(wvk, a1, a2, a3, b1, b2, b3, rsdir, & nrsdir, nplane, delta) - IF (istriz .EQ. 1) THEN + IF (istriz == 1) THEN ! Symmetrization of the k-points mesh. ! Apply all the Bravais lattice operations to WVK DO iop = 1, ncbrav @@ -2323,8 +2323,8 @@ CONTAINS nkpoint, nhash, list, rlist, delta) ! If WVA was new (and therefore inserted), ! IPLACE is the number. - IF (iplace .GT. 0) imesh = iplace - IF (iplace .GT. nkpoint) GOTO 470 + IF (iplace > 0) imesh = iplace + IF (iplace > nkpoint) GOTO 470 END DO ELSE ! Place WVK in list @@ -2332,7 +2332,7 @@ CONTAINS CALL mesh(iout, wvk, iplace, igarb0, igarbg, & nkpoint, nhash, list, rlist, delta) imesh = iplace - IF (iplace .GT. nkpoint) GOTO 470 + IF (iplace > nkpoint) GOTO 470 END IF END DO END DO @@ -2340,7 +2340,7 @@ CONTAINS !deb !deb get full mesh !deb - IF (iout .GT. 0) THEN + IF (iout > 0) THEN ! IMESH: Number of k points in the mesh. IF (iout > 0) & WRITE (iout, & @@ -2351,7 +2351,7 @@ CONTAINS i = ii CALL mesh(iout, wva, i, igarb0, igarbg, nkpoint, nhash, & list, rlist, delta) - IF (MOD(i, 2) .EQ. 1) THEN + IF (MOD(i, 2) == 1) THEN IF (iout > 0) & WRITE (iout, '(1X,I5,3F10.4)', advance="no") i, wva ELSE @@ -2363,7 +2363,7 @@ CONTAINS WRITE (iout, *) END IF ! ==--------------------------------------------------------------== - IF (istriz .EQ. 1) THEN + IF (istriz == 1) THEN ! Now figure out if any special point difference (K - K'') is an ! integral multiple of a reciprocal-space vector iremov = 0 @@ -2397,17 +2397,17 @@ CONTAINS ! Check (PROJA - PROJB): Is it integral ? DO k = 1, 3 diff = proja(k) - projb(k) - IF (ABS(REAL(NINT(diff), kind=dp) - diff) .GT. delta) GOTO 280 + IF (ABS(REAL(NINT(diff), kind=dp) - diff) > delta) GOTO 280 END DO ! DIFF is integral: remove WVK from mesh: CALL remove(wvk, jplace, igarb0, igarbg, & nkpoint, nhash, list, rlist, delta) ! If WVK actually removed, increment IREMOV - IF (jplace .GT. 0) iremov = iremov + 1 + IF (jplace > 0) iremov = iremov + 1 280 CONTINUE END DO END DO - IF ((iremov .GT. 0 .AND. iout .GT. 0) .AND. iout > 0) & + IF ((iremov > 0 .AND. iout > 0) .AND. iout > 0) & WRITE (iout, '(A,A,/,A,1X,I6,A,/)') & ' KPSYM| SOME OF THESE MESH POINTS ARE RELATED BY LATTICE ', & 'TRANSLATION VECTORS', & @@ -2418,7 +2418,7 @@ CONTAINS ! == THE INVERSION (TIME REVERSAL !) MAY BE USED. == ! ==--------------------------------------------------------------== DO iwvk = 1, imesh - ! IF(INCLUD(IWVK) .EQ. YES) GOTO 350 + ! IF(INCLUD(IWVK) == YES) GOTO 350 IF (BTEST(includ(iwvk), 0)) GOTO 350 ! IWVK has not been encountered previously: new special point, ! (only if WVK is not a garbage vector, however.) @@ -2430,7 +2430,7 @@ CONTAINS ! Find out whether Wvk is in the garbage list CALL garbag(wvk, igarbage, igarb0, & nkpoint, nhash, list, rlist, delta) - IF (igarbage .GT. 0) GOTO 350 + IF (igarbage > 0) GOTO 350 ntot = ntot + 1 ! Give the index in the special k points table. includ(iwvk) = includ(iwvk) + ntot*2 @@ -2454,15 +2454,15 @@ CONTAINS iplace = -1 CALL mesh(iout, wva, iplace, igarb0, igarbg, & nkpoint, nhash, list, rlist, delta) - IF (iplace .EQ. 0) THEN - IF (istriz .EQ. -1) THEN + IF (iplace == 0) THEN + IF (istriz == -1) THEN ! No symmetrisation -> WVA not in the list GOTO 364 ELSE ! Find out whether WVA is in the garbage list CALL garbag(wva, igarbage, igarb0, & nkpoint, nhash, list, rlist, delta) - IF (igarbage .EQ. 0) THEN + IF (igarbage == 0) THEN ! I think this case is impossible (NC <= NCBRAV) ! Error message GOTO 490 @@ -2472,9 +2472,9 @@ CONTAINS ! Find out whether WVA is in the garbage list CALL garbag(wva, igarbage, igarb0, & nkpoint, nhash, list, rlist, delta) - IF (igarbage .GT. 0) GOTO 370 + IF (igarbage > 0) GOTO 370 ! Was WVA encountered before ? - ! IF(INCLUD(IPLACE) .EQ. YES) GOTO 364 + ! IF(INCLUD(IPLACE) == YES) GOTO 364 IF (BTEST(includ(iplace), 0)) GOTO 364 ! Increment weight. lwght(ntot) = lwght(ntot) + 1 @@ -2485,7 +2485,7 @@ CONTAINS ! Put the index of the special k-point. includ(iplace) = includ(iplace) + ntot*2 364 CONTINUE - IF (ibsign .EQ. -1 .OR. inv .EQ. 0) GOTO 370 + IF (ibsign == -1 .OR. inv == 0) GOTO 370 ! The case where we also apply the inversion to WVA ! Repeat the search, but for -WVA ibsign = -1 @@ -2503,14 +2503,14 @@ CONTAINS ! == MULTIPLIED BY 2*PI == ! == THE LIST OF WEIGHTS LWGHT IS NOT NORMALIZED == ! ==--------------------------------------------------------------== - IF (ntot .GT. nkpoint) THEN + IF (ntot > nkpoint) THEN IF (iout > 0) & WRITE (iout, *) 'IN SPPT2 NUMBER OF SPECIAL POINTS = ', ntot IF (iout > 0) & WRITE (iout, *) 'BUT NKPOINT = ', nkpoint ntot = -1 END IF - IF (iout .GT. 0) THEN + IF (iout > 0) THEN ! Write the index table relating k points in the mesh ! with special k points IF (iout > 0) & @@ -2522,10 +2522,10 @@ CONTAINS iplace = includ(i)/2 IF (iout > 0) & WRITE (iout, '(1X,I5,1X,I5)', advance="no") i, iplace - IF ((MOD(i, 5) .EQ. 0) .AND. iout > 0) & + IF ((MOD(i, 5) == 0) .AND. iout > 0) & WRITE (iout, *) END DO - IF ((MOD(j - 1, 5) .NE. 0) .AND. iout > 0) & + IF ((MOD(j - 1, 5) /= 0) .AND. iout > 0) & WRITE (iout, *) END IF RETURN @@ -2609,7 +2609,7 @@ CONTAINS ! ==--------------------------------------------------------------== delta1 = 10._dp*delta - IF (iplace .LE. -2) THEN + IF (iplace <= -2) THEN DO i = 1, nhash + nmesh list(i) = nil END DO @@ -2619,7 +2619,7 @@ CONTAINS igarbg = 0 RETURN ! ==--------------------------------------------------------------== - ELSEIF ((iplace .GT. -2) .AND. (iplace .LE. 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) & @@ -2630,10 +2630,10 @@ CONTAINS ipoint = list(ihash) DO i = 1, 100 ! List exhausted - IF (ipoint .EQ. nil) GOTO 130 + IF (ipoint == nil) GOTO 130 ! Compare WVK with this element DO j = 1, 3 - IF (ABS(wvk(j) - rlist(j, ipoint)) .GT. delta1) GOTO 115 + IF (ABS(wvk(j) - rlist(j, ipoint)) > delta1) GOTO 115 END DO ! WVK located GOTO 160 @@ -2650,14 +2650,14 @@ CONTAINS CALL stopgm('MESH', 'WARNING') ! WVK was not found 130 CONTINUE - IF (iplace .EQ. -1) THEN + IF (iplace == -1) THEN ! IPLACE=-1 : search for WVK unsuccessful iplace = 0 RETURN ELSE ! IPLACE=0: add WVK to the list list(ihash) = istore - IF (istore .GT. nmesh) THEN + IF (istore > nmesh) THEN IF (iout > 0) & WRITE (iout, '(A)') 'SUBROUTINE MESH *** FATAL ERROR ***' IF (iout > 0) & @@ -2676,7 +2676,7 @@ CONTAINS END IF ! WVK was found 160 CONTINUE - IF (iplace .EQ. 0) RETURN + IF (iplace == 0) RETURN ! IPLACE=-1 iplace = ipoint RETURN @@ -2685,7 +2685,7 @@ CONTAINS ! == Return a wavevector (IPLACE > 0) == ! ==--------------------------------------------------------------== ipoint = iplace - IF (ipoint .GE. istore) GOTO 190 + IF (ipoint >= istore) GOTO 190 DO i = 1, 3 wvk(i) = rlist(i, ipoint) END DO @@ -2756,21 +2756,21 @@ CONTAINS ipoint = list(ihash) DO i = 1, 100 ! List exhausted - IF (ipoint .EQ. nil) THEN + IF (ipoint == nil) THEN ! WVK was not found in the mesh: iplace = 0 RETURN END IF ! Compare WVK with this element DO j = 1, 3 - IF (ABS(wvk(j) - rlist(j, ipoint)) .GT. delta1) GOTO 215 + IF (ABS(wvk(j) - rlist(j, ipoint)) > delta1) GOTO 215 END DO ! WVK located, now remove it from the list: list(ihash) = list(ipoint) ! LIST(IHASH) now points to the next element in the list, ! and the present WVK has become garbage. ! Add WVK to the list of garbage: - IF (igarb0 .EQ. 0) THEN + IF (igarb0 == 0) THEN ! Start up the garbage list: igarb0 = ipoint ELSE @@ -2834,14 +2834,14 @@ CONTAINS ipoint = igarb0 DO i = 1, nmesh ! LIST EXHAUSTED - IF (ipoint .EQ. nil) THEN + IF (ipoint == nil) THEN ! WVK was not found in the mesh: iplace = 0 RETURN END IF ! Compare WVK with this element DO j = 1, 3 - IF (ABS(wvk(j) - rlist(j, ipoint)) .GT. delta1) GOTO 315 + IF (ABS(wvk(j) - rlist(j, ipoint)) > delta1) GOTO 315 END DO ! WVK was located in the garbage list iplace = i @@ -3018,7 +3018,7 @@ CONTAINS i2 = nb2 + 1 - n2 DO n3 = 1, nnb3 i3 = nb3 + 1 - n3 - IF (i1 .EQ. 0 .AND. i2 .EQ. 0 .AND. i3 .EQ. 0) GOTO 150 + IF (i1 == 0 .AND. i2 == 0 .AND. i3 == 0) GOTO 150 DO i = 1, 3 bvec(i) = REAL(i1, kind=dp)*b1(i) + REAL(i2, kind=dp)*b2(i) + & REAL(i3, kind=dp)*b3(i) @@ -3030,7 +3030,7 @@ CONTAINS ! 1/2*BVEC is outside the Bz - skip this direction ! The 1.e-6_dp takes care of single points touching the Bz, ! and of the -(plane) - IF (ABS(projct) .GT. 0.5_dp - delta) GOTO 150 + IF (ABS(projct) > 0.5_dp - delta) GOTO 150 END DO ! 1/2*BVEC further confines the 1Bz - include into RSDIR nplane = nplane + 1 diff --git a/src/libint_2c_3c.F b/src/libint_2c_3c.F index 7a039c01ff..e149001eac 100644 --- a/src/libint_2c_3c.F +++ b/src/libint_2c_3c.F @@ -359,7 +359,7 @@ CONTAINS S1234 = EXP(-zeti*zetj*params%EtaInv*SUM((rj - ri)**2)) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3)*S1234 - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) params%Fm = prefac*params%Fm @@ -389,7 +389,7 @@ CONTAINS S1234 = EXP(-zeti*zetj*params%EtaInv*SUM((rj - ri)**2)) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3)*S1234 - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) @@ -759,7 +759,7 @@ CONTAINS S1234 = EXP(-zeti*zetj*params%EtaInv*SUM((rj - ri)**2)) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3)*S1234 - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) params%Fm = prefac*params%Fm @@ -789,7 +789,7 @@ CONTAINS S1234 = EXP(-zeti*zetj*params%EtaInv*SUM((rj - ri)**2)) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3)*S1234 - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) @@ -984,7 +984,7 @@ CONTAINS T = params%Rho*SUM((rj - rk)**2) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3) - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) params%Fm = prefac*params%Fm @@ -1012,7 +1012,7 @@ CONTAINS T = params%Rho*SUM((rj - rk)**2) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3) - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) @@ -1237,7 +1237,7 @@ CONTAINS T = params%Rho*SUM((rj - rk)**2) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3) - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) params%Fm = prefac*params%Fm @@ -1265,7 +1265,7 @@ CONTAINS T = params%Rho*SUM((rj - rk)**2) prefac = 2._dp*pi/params%Rho*SQRT((pi*params%ZetapEtaInv)**3) - CPASSERT(get_lmax_init() .GE. params%m_max) !check if truncated coulomb init correctly + CPASSERT(get_lmax_init() >= params%m_max) !check if truncated coulomb init correctly CALL t_c_g0_n(params%Fm, use_gamma, R, T, params%m_max) IF (use_gamma) CALL fgamma(params%m_max, T, params%Fm) diff --git a/src/libint_wrapper.F b/src/libint_wrapper.F index f1d2dde6ef..74eadd8624 100644 --- a/src/libint_wrapper.F +++ b/src/libint_wrapper.F @@ -118,7 +118,7 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ .LE. m_max) & + 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) @@ -213,7 +213,7 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ .LE. m_max) & + 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) #endif @@ -285,7 +285,7 @@ CONTAINS #:for m_max in range(0, 4*libint_max_am_supported) #if 4*LIBINT2_MAX_AM_eri > ${m_max}$ - 1 - IF (${m_max}$ .LE. m_max) & + 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) #endif diff --git a/src/ls_matrix_exp.F b/src/ls_matrix_exp.F index 4e229771b0..0da844e277 100644 --- a/src/ls_matrix_exp.F +++ b/src/ls_matrix_exp.F @@ -219,7 +219,7 @@ CONTAINS END DO !Square the matrices, due to the scaling and squaring procedure - IF (nsquare .GT. 0) THEN + IF (nsquare > 0) THEN DO i = 1, nsquare CALL cp_complex_dbcsr_gemm_3("N", "N", one, Tres_re, Tres_im, & Tres_re, Tres_im, zero, exp_H(1)%matrix, exp_H(2)%matrix, & @@ -313,7 +313,7 @@ CONTAINS CALL dbcsr_copy(T1_im, T2_im) END DO - IF (nsquare .GT. 0) THEN + IF (nsquare > 0) THEN DO i = 1, nsquare ! T2 = Tres * Tres CALL cp_complex_dbcsr_gemm_3("N", "N", alpha=1.0_dp, beta=0.0_dp, & diff --git a/src/manybody_gal.F b/src/manybody_gal.F index 1715a43a29..4f61522243 100644 --- a/src/manybody_gal.F +++ b/src/manybody_gal.F @@ -96,7 +96,7 @@ CONTAINS !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Vang = 0.0_dp - IF (gcn_weight2 .NE. 0.0) THEN + 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 IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & @@ -136,7 +136,7 @@ CONTAINS !Attractive Gaussian %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Vgaussian = 0.0_dp drji2 = DOT_PRODUCT(rji, rji) - IF (gcn_weight .NE. 0.0) THEN + IF (gcn_weight /= 0.0) THEN !Alpha is the angle of the Me-O vector with the normale vector. Used for gaussian attaction cosalpha = DOT_PRODUCT(rji, nvec)/SQRT(drji2) @@ -405,7 +405,7 @@ CONTAINS IF (gal%gcn(jparticle) < 11.5_dp) gcn_weight2 = 1.0_dp !For angular, 0 only for true core atoms !Angular dependance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - IF (gcn_weight2 .NE. 0.0) THEN + 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 IF (gal%n_vectors(1, jparticle) == 0.0_dp .AND. & @@ -449,7 +449,7 @@ CONTAINS !END Angular%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !Attractive Gaussian %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - IF (gcn_weight .NE. 0.0) THEN + IF (gcn_weight /= 0.0) THEN !Alpha is the angle of the Me-O vector with the normale vector. Used for gaussian attaction cosalpha = DOT_PRODUCT(rji, nvec)/drji IF (cosalpha < -1.0_dp) cosalpha = -1.0_dp diff --git a/src/matrix_exp.F b/src/matrix_exp.F index 10b518fb17..b17fad672f 100644 --- a/src/matrix_exp.F +++ b/src/matrix_exp.F @@ -126,7 +126,7 @@ CONTAINS END DO - IF (nsquare .GT. 0) THEN + IF (nsquare > 0) THEN DO i = 1, nsquare CALL cp_complex_fm_gemm("N", "N", ndim, ndim, ndim, one, Tres_re, Tres_im, & Tres_re, Tres_im, zero, exp_H(1), exp_H(2)) @@ -211,7 +211,7 @@ CONTAINS CALL cp_cfm_to_cfm(T3, T2) END DO - IF (nsquare .GT. 0) THEN + IF (nsquare > 0) THEN DO i = 1, nsquare CALL parallel_gemm("N", "N", ndim, ndim, ndim, z_one, Tres, Tres, z_zero, & T2) @@ -264,12 +264,12 @@ CONTAINS D = 1.0_dp N = 1.0_dp DO i = 1, q - IF (i .LE. p) scaleN = fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)) + IF (i <= p) scaleN = fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)) scaleD = (-1.0)**i*fac(p + q - i)*fac(q)/(fac(p + q)*fac(i)*fac(q - i)) - IF (i .LE. p) N = N + scaleN*eval**i + IF (i <= p) N = N + scaleN*eval**i D = D + scaleD*eval**i END DO - IF (ABS((EXP(norm) - (N/D)**(2.0_dp**iscale))/MAX(1.0_dp, EXP(norm))) .LE. eps_exp) THEN + IF (ABS((EXP(norm) - (N/D)**(2.0_dp**iscale))/MAX(1.0_dp, EXP(norm))) <= eps_exp) THEN IF (do_emd) THEN cost = iscale + q prev_cost = orders(1) + orders(2) @@ -277,7 +277,7 @@ CONTAINS cost = iscale + CEILING(REAL(q, dp)/3.0_dp) prev_cost = orders(1) + CEILING(REAL(orders(2), dp)/3.0_dp) END IF - IF (cost .LT. prev_cost) THEN + IF (cost < prev_cost) THEN orders(:) = [iscale, q, p] myval = (N/D)**(2.0_dp**iscale) END IF @@ -287,14 +287,14 @@ CONTAINS END DO IF (new_scale) EXIT END DO - IF (iscale .GE. orders(1) + orders(2) .AND. new_scale) EXIT + IF (iscale >= orders(1) + orders(2) .AND. new_scale) EXIT END DO ELSE IF (method == 1) THEN q = 0 eval = norm DO iscale = 0, 6 new_scale = .FALSE. - IF (iscale .GE. 1) eval = norm/(2.0_dp**REAL(iscale, dp)) + IF (iscale >= 1) eval = norm/(2.0_dp**REAL(iscale, dp)) DO p = 1, 20 D = 1.0_dp N = 1.0_dp @@ -302,7 +302,7 @@ CONTAINS scaleN = 1.0_dp/fac(i) N = N + scaleN*(eval**REAL(i, dp)) END DO - IF (ABS((EXP(norm) - N**(2.0_dp**REAL(iscale, dp)))/MAX(1.0_dp, EXP(norm))) .LE. eps_exp) THEN + IF (ABS((EXP(norm) - N**(2.0_dp**REAL(iscale, dp)))/MAX(1.0_dp, EXP(norm))) <= eps_exp) THEN IF (do_emd) THEN cost = iscale + p prev_cost = orders(1) + orders(2) @@ -310,7 +310,7 @@ CONTAINS cost = iscale + CEILING(REAL(p, dp)/3.0_dp) prev_cost = orders(1) + CEILING(REAL(orders(2), dp)/3.0_dp) END IF - IF (cost .LT. prev_cost) THEN + IF (cost < prev_cost) THEN orders(:) = [iscale, p, 0] myval = (N)**(2.0_dp**iscale) END IF @@ -318,7 +318,7 @@ CONTAINS EXIT END IF END DO - IF (iscale .GE. orders(1) + orders(2) .AND. new_scale) EXIT + IF (iscale >= orders(1) + orders(2) .AND. new_scale) EXIT END DO END IF @@ -395,14 +395,14 @@ CONTAINS CALL cp_cfm_scale_and_add(z_one, Npq, z_one*0.5_dp, T2) CALL cp_cfm_scale_and_add(z_one, Dpq, -z_one*0.5_dp, T2) - IF (npade .GT. 2) THEN + IF (npade > 2) THEN DO i = 2, npade - IF (i .LE. p) scaleN = CMPLX(fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)), 0.0_dp, kind=dp) + IF (i <= p) scaleN = CMPLX(fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)), 0.0_dp, kind=dp) scaleD = CMPLX((-1.0_dp)**i*fac(p + q - i)*fac(q)/(fac(p + q)*fac(i)*fac(q - i)), 0.0_dp, kind=dp) CALL parallel_gemm("N", "N", ndim, ndim, ndim, z_one, T1, mult_p(MOD(i, 2) + 1), z_zero, & mult_p(MOD(i + 1, 2) + 1)) - IF (i .LE. p) CALL cp_cfm_scale_and_add(z_one, Npq, scaleN, mult_p(MOD(i + 1, 2) + 1)) - IF (i .LE. q) CALL cp_cfm_scale_and_add(z_one, Dpq, scaleD, mult_p(MOD(i + 1, 2) + 1)) + IF (i <= p) CALL cp_cfm_scale_and_add(z_one, Npq, scaleN, mult_p(MOD(i + 1, 2) + 1)) + IF (i <= q) CALL cp_cfm_scale_and_add(z_one, Dpq, scaleD, mult_p(MOD(i + 1, 2) + 1)) END DO END IF @@ -410,7 +410,7 @@ CONTAINS mult_p(2) = Npq mult_p(1) = Tres - IF (nsquare .GT. 0) THEN + IF (nsquare > 0) THEN DO i = 1, nsquare CALL parallel_gemm("N", "N", ndim, ndim, ndim, z_one, mult_p(MOD(i, 2) + 1), mult_p(MOD(i, 2) + 1), z_zero, & mult_p(MOD(i + 1, 2) + 1)) @@ -502,11 +502,11 @@ CONTAINS Dpq%local_data(:, i) = Dpq%local_data(:, i) - CMPLX(rzero, 0.5_dp*square_fac*local_data_im(:, i), dp) END DO - IF (npade .GT. 2) THEN + IF (npade > 2) THEN DO j = 1, FLOOR(npade/2.0_dp) i = 2*j my_fac = (-rone)**j - IF (i .LE. p) scaleN = CMPLX(my_fac*fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)), 0.0_dp, dp) + IF (i <= p) scaleN = CMPLX(my_fac*fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)), 0.0_dp, dp) scaleD = CMPLX(my_fac*fac(p + q - i)*fac(q)/(fac(p + q)*fac(i)*fac(q - i)), 0.0_dp, dp) CALL parallel_gemm("N", "N", ndim, ndim, ndim, square_fac, im_part, T2, rzero, Tres) @@ -515,9 +515,9 @@ CONTAINS Dpq%local_data(:, k) = Dpq%local_data(:, k) + scaleD*Tres%local_data(:, k) END DO - IF (2*j + 1 .LE. q) THEN + IF (2*j + 1 <= q) THEN i = 2*j + 1 - IF (i .LE. p) scaleN = CMPLX(my_fac*fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)), rzero, dp) + IF (i <= p) scaleN = CMPLX(my_fac*fac(p + q - i)*fac(p)/(fac(p + q)*fac(i)*fac(p - i)), rzero, dp) scaleD = CMPLX(-my_fac*fac(p + q - i)*fac(q)/(fac(p + q)*fac(i)*fac(q - i)), rzero, dp) CALL parallel_gemm("N", "N", ndim, ndim, ndim, square_fac, im_part, Tres, rzero, T2) @@ -533,7 +533,7 @@ CONTAINS cmult_p(2) = Npq cmult_p(1) = T1 - IF (nsquare .GT. 0) THEN + IF (nsquare > 0) THEN DO i = 1, nsquare CALL parallel_gemm("N", "N", ndim, ndim, ndim, z_one, cmult_p(MOD(i, 2) + 1), cmult_p(MOD(i, 2) + 1), z_zero, & cmult_p(MOD(i + 1, 2) + 1)) @@ -624,7 +624,7 @@ CONTAINS mult_p(1) = T2 mult_p(2) = Tres - IF (npade .GE. 2) THEN + IF (npade >= 2) THEN DO j = 2, npade my_fac = (-1.0_dp)**j scaleN = fac(p + q - j)*fac(p)/(fac(p + q)*fac(j)*fac(p - j)) @@ -643,7 +643,7 @@ CONTAINS mult_p(2) = Npq mult_p(1) = T1 - IF (nsquare .GT. 0) THEN + IF (nsquare > 0) THEN DO i = 1, nsquare CALL parallel_gemm("N", "N", ndim, ndim, ndim, one, mult_p(MOD(i, 2) + 1), mult_p(MOD(i, 2) + 1), zero, & mult_p(MOD(i + 1, 2) + 1)) @@ -798,7 +798,7 @@ CONTAINS CALL col_group%sum(results) - IF (i .LE. narnoldi) THEN + IF (i <= narnoldi) THEN !$OMP PARALLEL DO DEFAULT(NONE) SHARED(H_approx_save,last_norm,V_mats,ncol_local,i,results) DO icol_local = 1, ncol_local @@ -820,7 +820,7 @@ CONTAINS ! PADE approximation for exp(H_approx), everything is done locally convergence = .FALSE. - IF (i .GE. narn_old) THEN + IF (i >= narn_old) THEN npade = 9 mydim = MIN(i, narnoldi) ALLOCATE (ipivot(mydim)) @@ -888,7 +888,7 @@ CONTAINS CALL para_env%max(conv_norm) - IF (conv_norm .LT. eps_exp .OR. i .GT. narnoldi) THEN + IF (conv_norm < eps_exp .OR. i > narnoldi) THEN mos_new(1)%local_data = rzero mos_new(2)%local_data = rzero @@ -930,7 +930,7 @@ CONTAINS END DO END DO END IF - IF (conv_norm .LT. eps_exp) THEN + IF (conv_norm < eps_exp) THEN convergence = .TRUE. narn_old = i - 1 END IF diff --git a/src/metadyn_tools/graph.F b/src/metadyn_tools/graph.F index 4b5e335fee..4844204156 100644 --- a/src/metadyn_tools/graph.F +++ b/src/metadyn_tools/graph.F @@ -126,13 +126,13 @@ PROGRAM graph CALL GET_COMMAND_ARGUMENT(i, wq_char, status=istat) CPASSERT(istat == 0) - IF (INDEX(wq_char, '-file') .NE. 0) THEN + IF (INDEX(wq_char, '-file') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) file END IF - IF (INDEX(wq_char, '-out') .NE. 0) THEN + IF (INDEX(wq_char, '-out') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) out1 @@ -141,58 +141,58 @@ PROGRAM graph out2 = out1 END IF - IF (INDEX(wq_char, '-ndim') .NE. 0) THEN + IF (INDEX(wq_char, '-ndim') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) ndim END IF - IF (INDEX(wq_char, '-stride') .NE. 0) THEN + IF (INDEX(wq_char, '-stride') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) nt_p lstride = .TRUE. END IF - IF (INDEX(wq_char, '-cutoff') .NE. 0) THEN + IF (INDEX(wq_char, '-cutoff') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) eps_cut END IF - IF (INDEX(wq_char, '-integrated_fes') .NE. 0) THEN + IF (INDEX(wq_char, '-integrated_fes') /= 0) THEN l_fes_int = .TRUE. END IF - IF (INDEX(wq_char, '-orac') .NE. 0) THEN + IF (INDEX(wq_char, '-orac') /= 0) THEN l_orac = .TRUE. END IF - IF (INDEX(wq_char, '-cp2k') .NE. 0) THEN + IF (INDEX(wq_char, '-cp2k') /= 0) THEN l_cp2k = .TRUE. END IF - IF (INDEX(wq_char, '-cpmd') .NE. 0) THEN + IF (INDEX(wq_char, '-cpmd') /= 0) THEN l_cpmd = .TRUE. END IF - IF (INDEX(wq_char, '-find-minima') .NE. 0) THEN + IF (INDEX(wq_char, '-find-minima') /= 0) THEN l_fmin = .TRUE. END IF - IF (INDEX(wq_char, '-find-path') .NE. 0) THEN + IF (INDEX(wq_char, '-find-path') /= 0) THEN l_pmin = .TRUE. END IF - IF (INDEX(wq_char, '-mathlab') .NE. 0) THEN + IF (INDEX(wq_char, '-mathlab') /= 0) THEN l_math = .TRUE. END IF - IF (INDEX(wq_char, '-cube') .NE. 0) THEN + IF (INDEX(wq_char, '-cube') /= 0) THEN l_cube = .TRUE. END IF - IF (INDEX(wq_char, '-opt-path') .NE. 0) THEN + IF (INDEX(wq_char, '-opt-path') /= 0) THEN l_popt = .TRUE. CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) @@ -233,14 +233,14 @@ PROGRAM graph CALL GET_COMMAND_ARGUMENT(i, wq_char, status=istat) CPASSERT(istat == 0) - IF (INDEX(wq_char, '-ndw') .NE. 0) THEN + IF (INDEX(wq_char, '-ndw') /= 0) THEN DEALLOCATE (idw) ndw = 0 ndw_loop: DO ix = i + 1, COMMAND_ARGUMENT_COUNT() CALL GET_COMMAND_ARGUMENT(ix, wq_char, status=istat) CPASSERT(istat == 0) - IF (INDEX(wq_char, '-') .EQ. 0) THEN + IF (INDEX(wq_char, '-') == 0) THEN ndw = ndw + 1 ELSE EXIT ndw_loop @@ -257,12 +257,12 @@ PROGRAM graph END DO END IF - IF (INDEX(wq_char, '-periodic') .NE. 0) THEN + IF (INDEX(wq_char, '-periodic') /= 0) THEN nprd = 0 nprd_loop: DO ix = i + 1, COMMAND_ARGUMENT_COUNT() CALL GET_COMMAND_ARGUMENT(ix, wq_char, status=istat) CPASSERT(istat == 0) - IF (INDEX(wq_char, '-') .EQ. 0) THEN + IF (INDEX(wq_char, '-') == 0) THEN nprd = nprd + 1 ELSE EXIT nprd_loop @@ -280,7 +280,7 @@ PROGRAM graph END DO END IF - IF (INDEX(wq_char, '-ngrid') .NE. 0) THEN + IF (INDEX(wq_char, '-ngrid') /= 0) THEN DO ix = 1, ndim CALL GET_COMMAND_ARGUMENT(i + ix, wq_char, status=istat) CPASSERT(istat == 0) @@ -289,7 +289,7 @@ PROGRAM graph END DO END IF - IF (INDEX(wq_char, '-dp') .NE. 0) THEN + IF (INDEX(wq_char, '-dp') /= 0) THEN l_dp = .TRUE. l_grid = .FALSE. DO ix = 1, ndim @@ -299,7 +299,7 @@ PROGRAM graph END DO END IF - IF (INDEX(wq_char, '-fix') .NE. 0) THEN + IF (INDEX(wq_char, '-fix') /= 0) THEN fix = .TRUE. DO id = 1, ndw CALL GET_COMMAND_ARGUMENT(i + 2*(id - 1) + 1, wq_char, status=istat) @@ -323,7 +323,7 @@ PROGRAM graph CALL GET_COMMAND_ARGUMENT(i, wq_char, status=istat) CPASSERT(istat == 0) - IF (INDEX(wq_char, '-point-a') .NE. 0) THEN + IF (INDEX(wq_char, '-point-a') /= 0) THEN DO id = 1, ndw CALL GET_COMMAND_ARGUMENT(i + id, wq_char, status=istat) CPASSERT(istat == 0) @@ -331,7 +331,7 @@ PROGRAM graph END DO END IF - IF (INDEX(wq_char, '-point-b') .NE. 0) THEN + IF (INDEX(wq_char, '-point-b') /= 0) THEN DO id = 1, ndw CALL GET_COMMAND_ARGUMENT(i + id, wq_char, status=istat) CPASSERT(istat == 0) @@ -339,19 +339,19 @@ PROGRAM graph END DO END IF - IF (INDEX(wq_char, '-mep-iter') .NE. 0) THEN + IF (INDEX(wq_char, '-mep-iter') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) mep_input_data%max_iter END IF - IF (INDEX(wq_char, '-mep-kb') .NE. 0) THEN + IF (INDEX(wq_char, '-mep-kb') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) mep_input_data%kb END IF - IF (INDEX(wq_char, '-mep-nreplica') .NE. 0) THEN + IF (INDEX(wq_char, '-mep-nreplica') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) mep_input_data%nreplica @@ -375,19 +375,19 @@ PROGRAM graph CALL GET_COMMAND_ARGUMENT(i, wq_char, status=istat) CPASSERT(istat == 0) - IF (INDEX(wq_char, '-mep-kb') .NE. 0) THEN + IF (INDEX(wq_char, '-mep-kb') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) mep_input_data%kb END IF - IF (INDEX(wq_char, '-mep-iter') .NE. 0) THEN + IF (INDEX(wq_char, '-mep-iter') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) mep_input_data%max_iter END IF - IF (INDEX(wq_char, '-mep-nreplica') .NE. 0) THEN + IF (INDEX(wq_char, '-mep-nreplica') /= 0) THEN CALL GET_COMMAND_ARGUMENT(i + 1, wq_char, status=istat) CPASSERT(istat == 0) READ (wq_char, *) mep_input_data%nreplica @@ -631,8 +631,8 @@ PROGRAM graph coor = coor + 1 ss = ss + dp_grid(i) IF (iperd(i) == 0) THEN - IF (coor .GT. ngrid(i)) CYCLE - IF (coor .LT. 1) CYCLE + IF (coor > ngrid(i)) CYCLE + IF (coor < 1) CYCLE END IF diff = ss - ss0(i, it) dp2 = (diff/delta_s(i, it))**2 diff --git a/src/metadyn_tools/graph_methods.F b/src/metadyn_tools/graph_methods.F index dea28ef510..a750b8abb5 100644 --- a/src/metadyn_tools/graph_methods.F +++ b/src/metadyn_tools/graph_methods.F @@ -87,8 +87,8 @@ CONTAINS DO i = -k, k pos(idim) = ind(idim) + i IF (iperd(idim) == 0) THEN - IF (pos(idim) .GT. ngrid(idim)) CYCLE - IF (pos(idim) .LT. 1) CYCLE + IF (pos(idim) > ngrid(idim)) CYCLE + IF (pos(idim) < 1) CYCLE END IF IF (idim /= 1) THEN CALL fes_compute_low(idim - 1, nn, fes, gauss, pos, ind0, nfes, ndim, ngauss, ngrid, iperd) @@ -604,7 +604,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:, :), POINTER :: xat CALL init_periodic_table() - IF (ndw .GT. 3) THEN + IF (ndw > 3) THEN WRITE (*, *) WRITE (*, *) 'ERROR: GAUSSIAN format can only handle FES on 3 CV !' CPABORT("") @@ -630,7 +630,7 @@ CONTAINS END DO END DO - IF (residual .GT. 1.0d-6) THEN + IF (residual > 1.0d-6) THEN WRITE (*, *) WRITE (*, *) 'ERROR: this program can only handle orthogonal cells' WRITE (*, *) ' with vectors pointing in the X, Y and Z directions' @@ -664,19 +664,19 @@ CONTAINS iix = ix + id(1) iiy = iy + id(2) iiz = iz + id(3) - IF (iix .LT. 1) iix = iix + ngrid(1) - IF (iiy .LT. 1) iiy = iiy + ngrid(2) - IF (iiz .LT. 1) iiz = iiz + ngrid(3) - IF (iix .GT. ngrid(1)) iix = iix - ngrid(1) - IF (iiy .GT. ngrid(2)) iiy = iiy - ngrid(2) - IF (iiz .GT. ngrid(3)) iiz = iiz - ngrid(3) + IF (iix < 1) iix = iix + ngrid(1) + IF (iiy < 1) iiy = iiy + ngrid(2) + IF (iiz < 1) iiz = iiz + ngrid(3) + IF (iix > ngrid(1)) iix = iix - ngrid(1) + IF (iiy > ngrid(2)) iiy = iiy - ngrid(2) + IF (iiz > ngrid(3)) iiz = iiz - ngrid(3) - IF (iix .LT. 1) CPABORT("ix < 0") - IF (iiy .LT. 1) CPABORT("iy < 0") - IF (iiz .LT. 1) CPABORT("iz < 0") - IF (iix .GT. ngrid(1)) CPABORT("ix > cell") - IF (iiy .GT. ngrid(2)) CPABORT("iy > cell") - IF (iiz .GT. ngrid(3)) CPABORT("iz > cell") + IF (iix < 1) CPABORT("ix < 0") + IF (iiy < 1) CPABORT("iy < 0") + IF (iiz < 1) CPABORT("iz < 0") + IF (iix > ngrid(1)) CPABORT("ix > cell") + IF (iiy > ngrid(2)) CPABORT("iy > cell") + IF (iiz > ngrid(3)) CPABORT("iz > cell") i = ix + (iy - 1)*ngrid(1) + (iz - 1)*ngrid(1)*ngrid(2) ii = iix + (iiy - 1)*ngrid(1) + (iiz - 1)*ngrid(1)*ngrid(2) rhot(ii) = rho(i) @@ -716,8 +716,8 @@ CONTAINS DO i = 1, natoms DO ix = 1, 3 xat(i, ix) = xat(i, ix) + rt(ix) - delta(ix) - IF (xat(i, ix) .LT. rt(ix)) xat(i, ix) = xat(i, ix) + cell(ix, ix) - IF (xat(i, ix) .GT. -rt(ix)) xat(i, ix) = xat(i, ix) - cell(ix, ix) + IF (xat(i, ix) < rt(ix)) xat(i, ix) = xat(i, ix) + cell(ix, ix) + IF (xat(i, ix) > -rt(ix)) xat(i, ix) = xat(i, ix) - cell(ix, ix) END DO END DO diff --git a/src/metadynamics_utils.F b/src/metadynamics_utils.F index 662bd457e2..2ca02f561f 100644 --- a/src/metadynamics_utils.F +++ b/src/metadynamics_utils.F @@ -323,7 +323,7 @@ CONTAINS WRITE (iw, '( A )') ' METADYN| Spawning the Hills ' WRITE (iw, '( A,T71,F10.3)') ' METADYN| Height of the Spawned Gaussian', meta_env%hills_env%ww !RG Adaptive hills - IF (meta_env%hills_env%min_disp .GT. 0.0_dp) THEN + IF (meta_env%hills_env%min_disp > 0.0_dp) THEN WRITE (iw, '(A)') ' METADYN| Adapative meta time step is activated' WRITE (iw, '(A,T71,F10.4)') ' METADYN| Minimum displacement for next hill', & meta_env%hills_env%min_disp diff --git a/src/minimax/minimax_exp.F b/src/minimax/minimax_exp.F index c2c637cbc1..c2b0adbead 100644 --- a/src/minimax/minimax_exp.F +++ b/src/minimax/minimax_exp.F @@ -103,10 +103,10 @@ CONTAINS INTEGER, INTENT(OUT) :: ierr ierr = 0 - IF (k .LE. 15) THEN + IF (k <= 15) THEN CALL check_range_k15(k, Rc, ierr) ELSE - IF (k .GT. k_max) ierr = -1 + IF (k > k_max) ierr = -1 END IF END SUBROUTINE check_exp_minimax_range @@ -132,17 +132,17 @@ CONTAINS INTEGER :: ierr - IF (k .LE. 15) THEN + IF (k <= 15) THEN CALL check_range_k15(k, Rc, ierr) - IF (ierr .EQ. 1) THEN ! Rc too small for k15 coeffs --> use k53 + IF (ierr == 1) THEN ! Rc too small for k15 coeffs --> use k53 CALL get_minimax_coeff_k53(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k53 ELSE - CPASSERT(ierr .EQ. 0) + CPASSERT(ierr == 0) CALL get_minimax_coeff_k15(k, Rc, aw, mm_error) IF (PRESENT(which_coeffs)) which_coeffs = mm_k15 END IF - ELSEIF (k .LE. 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 @@ -191,25 +191,25 @@ CONTAINS REAL(KIND=dp) :: error_l, error_r, R_k_max, R_k_min REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: aw - CPASSERT(k .LE. k_max) + CPASSERT(k <= k_max) ! find k pointer and smallest and largest R_mm value for this k i_k = 1 - DO WHILE (k_mm(k_p(i_k)) .LT. k) + DO WHILE (k_mm(k_p(i_k)) < k) i_k = i_k + 1 END DO - CPASSERT(k_mm(k_p(i_k)) .EQ. k) + CPASSERT(k_mm(k_p(i_k)) == k) R_k_min = R_mm(k_p(i_k)) R_k_max = R_mm(k_p(i_k + 1) - 1) - IF (Rc .GE. R_k_max) THEN + IF (Rc >= R_k_max) THEN i_mm = k_p(i_k + 1) - 1 ! pointer to largest Rc for current k - ELSE IF (Rc .LE. R_k_min) THEN + ELSE IF (Rc <= R_k_min) THEN i_mm = k_p(i_k) ! pointer to smallest Rc for current k ELSE i = k_p(i_k) - DO WHILE (Rc .GT. R_mm(i)) + DO WHILE (Rc > R_mm(i)) i = i + 1 END DO i_r = i ! pointer to closest R_mm >= Rc @@ -230,7 +230,7 @@ CONTAINS CALL get_minimax_coeff_low(i_l, aw) error_r = get_minimax_numerical_error(Rc, aw) DEALLOCATE (aw) - i_mm = MERGE(i_r, i_l, error_l .LE. error_r) + i_mm = MERGE(i_r, i_l, error_l <= error_r) END IF END SUBROUTINE get_best_minimax_approx_k53 @@ -267,33 +267,33 @@ CONTAINS R = R_mm(i_mm) k = k_mm(i_mm) CALL check_exp_minimax_range(k, R, ierr) - IF (ierr .EQ. 0) THEN + IF (ierr == 0) THEN ALLOCATE (aw(2*k)) CALL get_exp_minimax_coeff(k, R, aw, mm_error, which_coeffs) ref_error = err_mm(i_mm) DEALLOCATE (aw) IF (iw > 0) WRITE (iw, '(T2,A4, I3, ES10.1, ES12.3, ES12.3, ES12.3)') & - MERGE("k15", "k53", which_coeffs .EQ. mm_k15), k, R, & + MERGE("k15", "k53", which_coeffs == mm_k15), k, R, & mm_error, ref_error, (mm_error - ref_error)/ref_error - CPASSERT(mm_error .LE. ref_error*1.05_dp + 1.0E-15_dp) + CPASSERT(mm_error <= ref_error*1.05_dp + 1.0E-15_dp) ELSE IF (iw > 0) WRITE (iw, '(T2,A4, I3, ES10.1, 3X, A)') "k15", k, R, "missing" END IF - IF (k .LE. 15) THEN + IF (k <= 15) THEN ALLOCATE (aw(2*k)) CALL get_minimax_coeff_k53(k, R, aw, mm_error) ref_error = err_mm(i_mm) DEALLOCATE (aw) IF (iw > 0) WRITE (iw, '(T2,A4,I3, ES10.1, ES12.3, ES12.3, ES12.3)') & "k53", k, R, mm_error, ref_error, (mm_error - ref_error)/ref_error - IF (mm_error .GT. ref_error*1.05_dp + 1.0E-15_dp) THEN + IF (mm_error > ref_error*1.05_dp + 1.0E-15_dp) THEN CPABORT("Test 1 failed: numerical error is larger than tabulated error") END IF END IF END DO - IF (iw > 0 .AND. n_R .GT. 0) THEN + IF (iw > 0 .AND. n_R > 0) THEN WRITE (iw, '(T2,54("-"))') WRITE (iw, '(/T2,A)') "Test 1 OK" WRITE (iw, '(/T2,A)') & @@ -311,15 +311,15 @@ CONTAINS R = dR**i_R CALL get_exp_minimax_coeff(k, R, aw, mm_error, which_coeffs) CALL get_best_minimax_approx_k53(k, R, i_mm, ge_Rc=.TRUE.) - IF (R .GT. R_mm(i_mm)) THEN + IF (R > R_mm(i_mm)) THEN R = R_max do_exit = .TRUE. END IF ref_error = err_mm(i_mm) IF (iw > 0) WRITE (iw, '(T2, A4, I3, ES10.1, ES12.3, ES12.3, ES12.3)') & - MERGE("k15", "k53", which_coeffs .EQ. mm_k15), k, R, & + MERGE("k15", "k53", which_coeffs == mm_k15), k, R, & mm_error, ref_error, (mm_error - ref_error)/ref_error - IF (mm_error .GT. ref_error*1.05_dp + 1.0E-15_dp) THEN + IF (mm_error > ref_error*1.05_dp + 1.0E-15_dp) THEN CPABORT("Test 2 failed: numerical error is larger than tabulated error") END IF IF (do_exit) EXIT diff --git a/src/mixed_cdft_methods.F b/src/mixed_cdft_methods.F index 177b4045b8..cbb7a058ac 100644 --- a/src/mixed_cdft_methods.F +++ b/src/mixed_cdft_methods.F @@ -180,7 +180,7 @@ CONTAINS mixed_env%do_mixed_cdft = .TRUE. IF (mixed_env%do_mixed_cdft) THEN ! Sanity check - IF (nforce_eval .LT. 2) & + IF (nforce_eval < 2) & CALL cp_abort(__LOCATION__, & "Mixed CDFT calculation requires at least 2 force_evals.") mapping_section => section_vals_get_subs_vals(mixed_section, "MAPPING") @@ -189,7 +189,7 @@ CONTAINS IF (explicit) & CPABORT("Please disable section &MAPPING for mixed CDFT calculations") CALL section_vals_val_get(mixed_section, "MIXED_CDFT%COUPLING", i_val=et_freq) - IF (et_freq .LT. 0) THEN + IF (et_freq < 0) THEN mixed_env%do_mixed_et = .FALSE. ELSE mixed_env%do_mixed_et = .TRUE. @@ -297,7 +297,7 @@ 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 .LT. 0.0_dp .OR. mixed_cdft%eps_svd .GT. 1.0_dp) & + 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.") ! MD related settings CALL force_env_get(force_env, root_section=root_section) @@ -561,8 +561,8 @@ CONTAINS DO i = 1, SIZE(mixed_cdft%source_list) lb(i) = recvbuffer(i)%iv(1) ub(i) = recvbuffer(i)%iv(2) - IF (lb(i) .LT. lb_min) lb_min = lb(i) - IF (ub(i) .GT. ub_max) ub_max = ub(i) + IF (lb(i) < lb_min) lb_min = lb(i) + IF (ub(i) > ub_max) ub_max = ub(i) DEALLOCATE (recvbuffer(i)%iv) END DO ! Take into account the grids already communicated during dlb @@ -572,9 +572,9 @@ CONTAINS IF (mixed_cdft%dlb_control%recv_work_repl(j)) THEN DO i = 1, SIZE(mixed_cdft%dlb_control%recvbuff(j)%buffs) IF (LBOUND(mixed_cdft%dlb_control%recvbuff(j)%buffs(i)%weight, 3) & - .LT. lb_min) lb_min = LBOUND(mixed_cdft%dlb_control%recvbuff(j)%buffs(i)%weight, 3) + < lb_min) lb_min = LBOUND(mixed_cdft%dlb_control%recvbuff(j)%buffs(i)%weight, 3) IF (UBOUND(mixed_cdft%dlb_control%recvbuff(j)%buffs(i)%weight, 3) & - .GT. ub_max) ub_max = UBOUND(mixed_cdft%dlb_control%recvbuff(j)%buffs(i)%weight, 3) + > ub_max) ub_max = UBOUND(mixed_cdft%dlb_control%recvbuff(j)%buffs(i)%weight, 3) END DO END IF END DO @@ -1258,7 +1258,7 @@ 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 .GT. 1.0_dp .OR. eps_occupied .LT. 0.0_dp) & + 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") IF (mixed_cdft%eps_svd == 0.0_dp) & @@ -1282,7 +1282,7 @@ CONTAINS homo(:, ispin) = nmo DO istate = 1, nforce_eval DO j = nmo, 1, -1 - IF (mixed_cdft%occupations(istate, ispin)%array(j) .GE. eps_occupied) THEN + IF (mixed_cdft%occupations(istate, ispin)%array(j) >= eps_occupied) THEN homo(istate, ispin) = j EXIT END IF @@ -1296,7 +1296,7 @@ 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) .GT. 1.0E-4_dp) & + IF (ABS(SUM(mixed_cdft%occupations(istate, ispin)%array(1:nmo)) - nelectron_tot) > 1.0E-4_dp) & nelectron_mismatch = .TRUE. END DO IF (ANY(homo(:, ispin) /= nmo)) THEN @@ -1579,7 +1579,7 @@ CONTAINS CALL diamat_all(S_mat, eigenv, .TRUE.) tmp_mat = 0.0_dp DO istate = 1, nforce_eval - IF (eigenv(istate) .LT. 1.0e-14_dp) THEN + IF (eigenv(istate) < 1.0e-14_dp) THEN ! Safeguard against division with 0 and negative numbers eigenv(istate) = 1.0e-14_dp CALL cp_warn(__LOCATION__, & @@ -1830,7 +1830,7 @@ CONTAINS IF (istate == 1) THEN WRITE (iounit, '(T3,A,T54,(3X,2F12.6))') & 'Expansion coefficients:', H_mat(istate, ivar), H_mat(istate + 1, ivar) - ELSE IF (istate .LT. nforce_eval) THEN + ELSE IF (istate < nforce_eval) THEN WRITE (iounit, '(T54,(3X,2F12.6))') H_mat(istate, ivar), H_mat(istate + 1, ivar) ELSE WRITE (iounit, '(T54,(3X,F12.6))') H_mat(istate, ivar) @@ -2171,7 +2171,7 @@ CONTAINS END IF ! Calculate coupling using eq. 12c ! The coupling is singular if A = B (i.e. states I/J are identical or charge in ground state is fully delocalized) - IF (ABS(overlaps(1, ipermutation, 1) - overlaps(2, ipermutation, 1)) .LE. 1.0e-14_dp) THEN + IF (ABS(overlaps(1, ipermutation, 1) - overlaps(2, ipermutation, 1)) <= 1.0e-14_dp) THEN CALL cp_warn(__LOCATION__, & "Coupling between states is singular and set to zero. "// & "Potential causes: coupling is computed between identical CDFT states or the spin/charge "// & @@ -2425,15 +2425,15 @@ CONTAINS CALL get_atomic_kind(atomic_kind=particle_set(jatom)%atomic_kind, & kind_number=ikind) jrcov = cdft_control%becke_control%radii(ikind) - IF (ircov .NE. jrcov) THEN + IF (ircov /= jrcov) THEN chi = ircov/jrcov uij = (chi - 1.0_dp)/(chi + 1.0_dp) cdft_control%becke_control%aij(iatom, jatom) = uij/(uij**2 - 1.0_dp) IF (cdft_control%becke_control%aij(iatom, jatom) & - .GT. 0.5_dp) THEN + > 0.5_dp) THEN cdft_control%becke_control%aij(iatom, jatom) = 0.5_dp ELSE IF (cdft_control%becke_control%aij(iatom, jatom) & - .LT. -0.5_dp) THEN + < -0.5_dp) THEN cdft_control%becke_control%aij(iatom, jatom) = -0.5_dp END IF ELSE @@ -2579,12 +2579,12 @@ CONTAINS CALL hfun_zero(cdft_control%becke_control%cavity%array, & cdft_control%becke_control%eps_cavity, & just_zero=.FALSE., bounds=bounds, work=my_work) - IF (bounds(2) .LT. bo(2, 3)) THEN + IF (bounds(2) < bo(2, 3)) THEN bounds(2) = bounds(2) - 1 ELSE bounds(2) = bo(2, 3) END IF - IF (bounds(1) .GT. bo(1, 3)) THEN + IF (bounds(1) > bo(1, 3)) THEN ! In the special case bounds(1) == bounds(2) == bo(2, 3), after this check ! bounds(1) > bounds(2) and the subsequent gradient allocation (:, :, :, bounds(1):bounds(2)) ! will correctly allocate a 0-sized array @@ -2614,7 +2614,7 @@ 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 .LT. 1) & + IF (force_env%para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") CALL cp_pw_to_cube(cdft_control%becke_control%cavity, & @@ -2826,10 +2826,10 @@ CONTAINS targets = 0 ! Convert the load imbalance to a multiple of the actual work size DO i = 1, force_env%para_env%num_pe - IF (load_imbalance(i) .GT. 0) THEN + IF (load_imbalance(i) > 0) THEN no_overloaded = no_overloaded + 1 ! Allow heavily overloaded processors to dump more data since most likely they have a lot of 'real' work - IF (expected_work(i) .GT. NINT(very_overloaded*average_work)) THEN + IF (expected_work(i) > NINT(very_overloaded*average_work)) THEN load_imbalance(i) = (CEILING(REAL(load_imbalance(i), dp)/REAL(work_size(i), dp)) + more_work)*work_size(i) ELSE load_imbalance(i) = CEILING(REAL(load_imbalance(i), dp)/REAL(work_size(i), dp))*work_size(i) @@ -2870,20 +2870,20 @@ CONTAINS DO i = 1, no_underloaded IF (my_pos == force_env%para_env%num_pe) EXIT nsend = -load_imbalance(work_index(i))/work_size(work_index(j)) - IF (nsend .LT. 1) nsend = 1 + IF (nsend < 1) nsend = 1 nsend_max = nsend_max - nsend - IF (nsend_max .LT. 0) nsend = nsend + nsend_max + IF (nsend_max < 0) nsend = nsend + nsend_max exhausted_work = exhausted_work + nsend*work_size(work_index(j)) offset = offset - nsend*work_size(work_index(j)) - IF (offset .LT. 0) EXIT - IF (exhausted_work .EQ. cumulative_work(j)) THEN + IF (offset < 0) EXIT + IF (exhausted_work == cumulative_work(j)) THEN j = j - 1 nsend_max = load_imbalance(work_index(j))/work_size(work_index(j)) END IF END DO ! Underloaded processors were fully exhausted: rewind index ! Load balancing will fail if this happens on multiple processors - IF (i .GT. no_underloaded) THEN + IF (i > no_underloaded) THEN i = no_underloaded END IF my_target = i @@ -2912,9 +2912,9 @@ CONTAINS ! Main loop. Note, we actually allow my_pos to offload more slices than nsend_max DO nsend = -load_imbalance(work_index(my_target))/work_size(force_env%para_env%mepos + 1) - IF (nsend .LT. 1) nsend = 1 ! send at least one block + IF (nsend < 1) nsend = 1 ! send at least one block ! Prevent over redistribution: leave at least (1-work_factor)*nsend_limit slices to my_pos - IF (nsend .GT. NINT(work_factor*nsend_limit - send_total)) THEN + IF (nsend > NINT(work_factor*nsend_limit - send_total)) THEN nsend = NINT(work_factor*nsend_limit - send_total) IF (debug_this_module) & should_warn(force_env%para_env%mepos + 1) = 1 @@ -2926,7 +2926,7 @@ CONTAINS DO j = ispecial, SIZE(mixed_cdft%dest_list) mixed_cdft%dlb_control%target_list(2, i) = mixed_cdft%dlb_control%target_list(2, i) + 1 touched(j) = .TRUE. - IF (nsend .LT. mixed_cdft%dest_list_bo(2, j) - mixed_cdft%dest_list_bo(1, j) + 1) THEN + IF (nsend < mixed_cdft%dest_list_bo(2, j) - mixed_cdft%dest_list_bo(1, j) + 1) THEN mixed_cdft%dlb_control%target_list(3 + 2*j - 1, i) = mixed_cdft%dest_list_bo(1, j) mixed_cdft%dlb_control%target_list(3 + 2*j, i) = mixed_cdft%dest_list_bo(1, j) + nsend - 1 mixed_cdft%dest_list_bo(1, j) = mixed_cdft%dest_list_bo(1, j) + nsend @@ -2938,9 +2938,9 @@ CONTAINS nsend = nsend - (mixed_cdft%dest_list_bo(2, j) - mixed_cdft%dest_list_bo(1, j) + 1) mixed_cdft%dest_list_bo(1:2, j) = should_deallocate END IF - IF (nsend .LE. 0) EXIT + IF (nsend <= 0) EXIT END DO - IF (mixed_cdft%dest_list_bo(1, ispecial) .EQ. should_deallocate) ispecial = j + 1 + IF (mixed_cdft%dest_list_bo(1, ispecial) == should_deallocate) ispecial = j + 1 actually_sent = actually_sent - nsend nsend_max = nsend_max - actually_sent send_total = send_total + actually_sent @@ -2949,8 +2949,8 @@ CONTAINS nsend_max = nsend_max - nsend send_total = send_total + nsend END IF - IF (nsend_max .LT. 0) nsend_max = 0 - IF (nsend_max .EQ. 0) EXIT + IF (nsend_max < 0) nsend_max = 0 + IF (nsend_max == 0) EXIT IF (my_target /= no_underloaded) THEN my_target = my_target + 1 ELSE @@ -2960,7 +2960,7 @@ CONTAINS EXIT END IF i = i + 1 - IF (i .GT. max_targets) & + IF (i > max_targets) & CALL cp_abort(__LOCATION__, & "Load balancing error: increase max_targets") END DO @@ -2972,7 +2972,7 @@ CONTAINS targets(2, my_pos) = my_target ! Equalize the load on the target processors IF (.NOT. mixed_cdft%is_special) THEN - IF (send_total .GT. NINT(work_factor*nsend_limit)) send_total = NINT(work_factor*nsend_limit) - 1 + IF (send_total > NINT(work_factor*nsend_limit)) send_total = NINT(work_factor*nsend_limit) - 1 nsend = NINT(REAL(send_total, dp)/REAL(SIZE(mixed_cdft%dlb_control%target_list, 2), dp)) mixed_cdft%dlb_control%target_list(2, :) = nsend END IF @@ -2996,8 +2996,8 @@ CONTAINS IF (force_env%para_env%is_source()) THEN consistent = .TRUE. DO i = force_env%para_env%num_pe - 1, force_env%para_env%num_pe - no_overloaded + 1, -1 - IF (targets(1, i) .GT. no_underloaded) consistent = .FALSE. - IF (targets(1, i) .GT. targets(2, i + 1)) THEN + IF (targets(1, i) > no_underloaded) consistent = .FALSE. + IF (targets(1, i) > targets(2, i + 1)) THEN CYCLE ELSE consistent = .FALSE. @@ -3019,9 +3019,9 @@ CONTAINS END IF END IF ! Tell the target processors which grid points they should compute - IF (my_pos .LE. no_underloaded) THEN + IF (my_pos <= no_underloaded) THEN DO i = force_env%para_env%num_pe, force_env%para_env%num_pe - no_overloaded + 1, -1 - IF (targets(1, i) .LE. my_pos .AND. targets(2, i) .GE. my_pos) THEN + IF (targets(1, i) <= my_pos .AND. targets(2, i) >= my_pos) THEN mixed_cdft%dlb_control%recv_work = .TRUE. mixed_cdft%dlb_control%my_source = work_index(i) - 1 EXIT @@ -3165,7 +3165,7 @@ CONTAINS tags = [(i - 1)*3 + 1 + force_env%para_env%mepos*6*max_targets, & (i - 1)*3 + 1 + 3*max_targets + force_env%para_env%mepos*6*max_targets] DO j = 4, SIZE(mixed_cdft%dlb_control%target_list, 1) - IF (mixed_cdft%dlb_control%target_list(j, i) .GT. uninitialized) EXIT + IF (mixed_cdft%dlb_control%target_list(j, i) > uninitialized) EXIT END DO offset_special = j offset_proc = j - 4 - (j - 4)/2 @@ -3244,13 +3244,13 @@ CONTAINS ALLOCATE (sbuff(j)%iv(3)) sbuff(j)%iv(1:2) = mixed_cdft%dest_list_bo(1:2, j) sbuff(j)%iv(3) = 0 - IF (sbuff(j)%iv(1) .EQ. should_deallocate) mask_send(j) = .TRUE. + IF (sbuff(j)%iv(1) == should_deallocate) mask_send(j) = .TRUE. IF (mixed_cdft%dlb_control%send_work) THEN sbuff(j)%bv = touched(j) 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) .NE. uninitialized) & + IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), ispecial) /= uninitialized) & nsend = nsend + 1 END DO sbuff(j)%iv(3) = nsend @@ -3276,7 +3276,7 @@ CONTAINS IF (mixed_cdft%is_special .AND. mixed_cdft%dlb_control%recv_work_repl(i)) THEN mixed_cdft%source_list_bo(1:2, i) = recvbuffer(i)%iv(1:2) nrecv(i) = recvbuffer(i)%iv(3) - IF (recvbuffer(i)%iv(1) .EQ. should_deallocate) mask_recv(i) = .TRUE. + IF (recvbuffer(i)%iv(1) == should_deallocate) mask_recv(i) = .TRUE. END IF DEALLOCATE (recvbuffer(i)%bv) IF (ASSOCIATED(recvbuffer(i)%iv)) DEALLOCATE (recvbuffer(i)%iv) @@ -3381,7 +3381,7 @@ CONTAINS sbuff(j)%iv(1:4) = [bo_conf(1, 2), bo_conf(2, 2), bo_conf(1, 3), bo_conf(2, 3)] offset = 5 DO i = 1, SIZE(mixed_cdft%dlb_control%target_list, 2) - IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), i) .NE. uninitialized) THEN + IF (mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), i) /= uninitialized) THEN sbuff(j)%iv(offset:offset + 2) = [mixed_cdft%dlb_control%target_list(1, i), & mixed_cdft%dlb_control%target_list(4 + 2*(j - 1), i), & mixed_cdft%dlb_control%target_list(4 + 2*j - 1, i)] @@ -3787,8 +3787,8 @@ CONTAINS DO k = LBOUND(weight, 1), UBOUND(weight, 1) IF (mixed_cdft%dlb .AND. mixed_cdft%is_pencil .AND. .NOT. mixed_cdft%is_special) THEN IF (mixed_cdft%dlb_control%send_work) THEN - IF (k .GE. mixed_cdft%dlb_control%distributed(1) .AND. & - k .LE. mixed_cdft%dlb_control%distributed(2)) THEN + IF (k >= mixed_cdft%dlb_control%distributed(1) .AND. & + k <= mixed_cdft%dlb_control%distributed(2)) THEN CYCLE END IF END IF @@ -3796,8 +3796,8 @@ CONTAINS DO j = LBOUND(weight, 2), UBOUND(weight, 2) IF (mixed_cdft%dlb .AND. .NOT. mixed_cdft%is_pencil .AND. .NOT. mixed_cdft%is_special) THEN IF (mixed_cdft%dlb_control%send_work) THEN - IF (j .GE. mixed_cdft%dlb_control%distributed(1) .AND. & - j .LE. mixed_cdft%dlb_control%distributed(2)) THEN + IF (j >= mixed_cdft%dlb_control%distributed(1) .AND. & + j <= mixed_cdft%dlb_control%distributed(2)) THEN CYCLE END IF END IF @@ -3874,7 +3874,7 @@ CONTAINS CYCLE END IF IF (store_vectors) THEN - IF (distances(iatom) .EQ. 0.0_dp) THEN + IF (distances(iatom) == 0.0_dp) THEN r = position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) @@ -3892,18 +3892,18 @@ CONTAINS dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF - IF (dist1 .LE. cutoffs(iatom)) THEN + IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN - IF (dist1 .LE. th) dist1 = th + IF (dist1 <= th) dist1 = th dr_i_dR(:) = dist_vec(:)/dist1 END IF DO jatom = 1, natom - IF (jatom .NE. iatom) THEN + IF (jatom /= iatom) THEN IF (jatom < iatom) THEN IF (.NOT. skip_me(jatom)) CYCLE END IF IF (store_vectors) THEN - IF (distances(jatom) .EQ. 0.0_dp) THEN + IF (distances(jatom) == 0.0_dp) THEN r1 = position_vecs(:, jatom) dist_vec = (r1 - grid_p) - ANINT((r1 - grid_p)/cell_v)*cell_v dist2 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) @@ -3927,7 +3927,7 @@ CONTAINS ELSE dr1_r2 = (r - r1) - ANINT((r - r1)/cell_v)*cell_v END IF - IF (dist2 .LE. th) dist2 = th + IF (dist2 <= th) dist2 = th tmp_const = (R12(iatom, jatom)**3) dr_ij_dR(:) = dr1_r2(:)/tmp_const !derivativ w.r.t. Rj @@ -3961,16 +3961,16 @@ CONTAINS tmp_const = 0.5_dp*(1.0_dp - myexp) cell_functions(iatom) = cell_functions(iatom)*tmp_const IF (in_memory) THEN - IF (ABS(tmp_const) .LE. th) tmp_const = tmp_const + th + IF (ABS(tmp_const) <= th) tmp_const = tmp_const + th dP_i_dRi(:, iatom) = dP_i_dRi(:, iatom) + ds_dR_i(:)/tmp_const dP_i_dRj(:, iatom, jatom) = ds_dR_j(:)/tmp_const END IF - IF (dist2 .LE. cutoffs(jatom)) THEN + IF (dist2 <= cutoffs(jatom)) THEN tmp_const = 0.5_dp*(1.0_dp + myexp) cell_functions(jatom) = cell_functions(jatom)*tmp_const IF (in_memory) THEN - IF (ABS(tmp_const) .LE. th) tmp_const = tmp_const + th + IF (ABS(tmp_const) <= th) tmp_const = tmp_const + th dP_i_dRj(:, jatom, iatom) = -ds_dR_i(:)/tmp_const dP_i_dRi(:, jatom) = dP_i_dRi(:, jatom) - ds_dR_j(:)/tmp_const END IF @@ -3986,7 +3986,7 @@ CONTAINS d_sum_const_dR(:, iatom) = d_sum_const_dR(:, iatom) + dP_i_dRi(:, iatom)* & coefficients(iatom) DO jatom = 1, natom - IF (jatom .NE. iatom) THEN + 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) @@ -4035,14 +4035,14 @@ CONTAINS END DO IF (in_memory) THEN DO iatom = 1, natom - IF (ABS(sum_cell_f_all) .GT. 0.0_dp) THEN + IF (ABS(sum_cell_f_all) > 0.0_dp) THEN gradients(3*(iatom - 1) + 1:3*(iatom - 1) + 3, k, j, i) = & d_sum_const_dR(:, iatom)/sum_cell_f_all - sum_cell_f_constr* & d_sum_Pm_dR(:, iatom)/(sum_cell_f_all**2) END IF END DO END IF - IF (ABS(sum_cell_f_all) .GT. 0.000001) & + IF (ABS(sum_cell_f_all) > 0.000001) & weight(k, j, i) = sum_cell_f_constr/sum_cell_f_all END DO ! i END DO ! j @@ -4078,7 +4078,7 @@ CONTAINS dest=mixed_cdft%dlb_control%sendbuff(ispecial)%rank(i), & request=req_send(i, 3*(ispecial - 1) + 3), tag=3) END DO - IF (ispecial .EQ. my_special_work) THEN + IF (ispecial == my_special_work) THEN should_communicate = .TRUE. nsent_total = 0 END IF diff --git a/src/mixed_cdft_utils.F b/src/mixed_cdft_utils.F index c5a1ecc4ac..7cea0a7c2c 100644 --- a/src/mixed_cdft_utils.F +++ b/src/mixed_cdft_utils.F @@ -227,7 +227,7 @@ 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 .GT. SIZE(settings%atoms, 1)) & + 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.") @@ -274,7 +274,7 @@ 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 .GT. settings%max_nkinds) & + 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"// & @@ -288,7 +288,7 @@ CONTAINS "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// & "match number of atomic kinds in the input coordinate file.") nkinds = SIZE(cdft_control%becke_control%radii_tmp) - IF (nkinds .GT. settings%max_nkinds) & + 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"// & @@ -304,7 +304,7 @@ CONTAINS "Length of keyword HIRSHFELD_CONSTRAINT&RADII does not "// & "match number of atomic kinds in the input coordinate file.") nkinds = SIZE(cdft_control%hirshfeld_control%radii) - IF (nkinds .GT. settings%max_nkinds) & + 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"// & @@ -706,12 +706,12 @@ 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 .GT. settings%npts(1, 1)) & + IF (ncpu/2 > settings%npts(1, 1)) & CPABORT("ncpu/2 => nx: decrease ncpu or disable xc_smoothing") ! ALLOCATE (mixed_rs_dims(2)) IF (settings%rs_dims(2, 1) /= 1) mixed_cdft%is_pencil = .TRUE. - IF (.NOT. mixed_cdft%is_pencil .AND. ncpu .GT. settings%npts(1, 1)) mixed_cdft%is_special = .TRUE. + IF (.NOT. mixed_cdft%is_pencil .AND. ncpu > settings%npts(1, 1)) mixed_cdft%is_special = .TRUE. IF (mixed_cdft%is_special) THEN mixed_rs_dims = [-1, -1] ELSE IF (mixed_cdft%is_pencil) THEN @@ -867,11 +867,11 @@ CONTAINS ntargets = 0 offset = -1 DO i = 0, auxbas_pw_pool%pw_grid%para%group%num_pe - 1 - IF ((bounds(i, 1) .GE. bo_mixed(1, 1) .AND. bounds(i, 1) .LE. bo_mixed(2, 1)) .OR. & - (bounds(i, 2) .GE. bo_mixed(1, 1) .AND. bounds(i, 2) .LE. bo_mixed(2, 1))) THEN + IF ((bounds(i, 1) >= bo_mixed(1, 1) .AND. bounds(i, 1) <= bo_mixed(2, 1)) .OR. & + (bounds(i, 2) >= bo_mixed(1, 1) .AND. bounds(i, 2) <= bo_mixed(2, 1))) THEN ntargets = ntargets + 1 IF (offset == -1) offset = i - ELSE IF (bounds(i, 2) .GT. bo_mixed(2, 1)) THEN + ELSE IF (bounds(i, 2) > bo_mixed(2, 1)) THEN EXIT ELSE CYCLE @@ -904,11 +904,11 @@ CONTAINS ntargets = 0 offset = -1 DO i = 0, pw_pools(1)%pool%pw_grid%para%group%num_pe - 1 - IF ((bo(1, 1) .GE. bounds(i, 1) .AND. bo(1, 1) .LE. bounds(i, 2)) .OR. & - (bo(2, 1) .GE. bounds(i, 1) .AND. bo(2, 1) .LE. bounds(i, 2))) THEN + IF ((bo(1, 1) >= bounds(i, 1) .AND. bo(1, 1) <= bounds(i, 2)) .OR. & + (bo(2, 1) >= bounds(i, 1) .AND. bo(2, 1) <= bounds(i, 2))) THEN ntargets = ntargets + 1 IF (offset == -1) offset = i - ELSE IF (bo(2, 1) .LT. bounds(i, 1)) THEN + ELSE IF (bo(2, 1) < bounds(i, 1)) THEN EXIT ELSE CYCLE @@ -919,10 +919,10 @@ CONTAINS j = 1 DO i = offset, offset + ntargets - 1 mixed_cdft%source_list(j) = i - IF (bo(1, 1) .GE. bounds(i, 1) .AND. bo(2, 1) .LE. bounds(i, 2)) THEN + IF (bo(1, 1) >= bounds(i, 1) .AND. bo(2, 1) <= bounds(i, 2)) THEN mixed_cdft%source_list_bo(:, j) = [bo(1, 1), bo(2, 1), & bounds(i, 3), bounds(i, 4)] - ELSE IF (bo(1, 1) .GE. bounds(i, 1) .AND. bo(1, 1) .LE. bounds(i, 2)) THEN + ELSE IF (bo(1, 1) >= bounds(i, 1) .AND. bo(1, 1) <= bounds(i, 2)) THEN mixed_cdft%source_list_bo(:, j) = [bo(1, 1), bounds(i, 2), & bounds(i, 3), bounds(i, 4)] ELSE @@ -1399,7 +1399,7 @@ CONTAINS 'Charge transfer energy (J-I) (Hartree):', (mixed_cdft%results%energy(jstate) - mixed_cdft%results%energy(istate)) WRITE (iounit, *) IF (ALLOCATED(mixed_cdft%results%rotation)) THEN - IF (ABS(mixed_cdft%results%rotation(ipermutation))*1.0E3_dp .GE. 0.1_dp) THEN + IF (ABS(mixed_cdft%results%rotation(ipermutation))*1.0E3_dp >= 0.1_dp) THEN WRITE (iounit, '(T3,A,T60,(3X,F18.12))') & 'Diabatic electronic coupling (rotation, mHartree):', & ABS(mixed_cdft%results%rotation(ipermutation)*1.0E3_dp) @@ -1410,7 +1410,7 @@ CONTAINS END IF END IF IF (ALLOCATED(mixed_cdft%results%lowdin)) THEN - IF (ABS(mixed_cdft%results%lowdin(ipermutation))*1.0E3_dp .GE. 0.1_dp) THEN + IF (ABS(mixed_cdft%results%lowdin(ipermutation))*1.0E3_dp >= 0.1_dp) THEN WRITE (iounit, '(T3,A,T60,(3X,F18.12))') & 'Diabatic electronic coupling (Lowdin, mHartree):', & ABS(mixed_cdft%results%lowdin(ipermutation)*1.0E3_dp) @@ -1421,7 +1421,7 @@ CONTAINS END IF END IF IF (ALLOCATED(mixed_cdft%results%wfn)) THEN - IF (mixed_cdft%results%wfn(ipermutation)*1.0E3_dp .GE. 0.1_dp) THEN + IF (mixed_cdft%results%wfn(ipermutation)*1.0E3_dp >= 0.1_dp) THEN WRITE (iounit, '(T3,A,T60,(3X,F18.12))') & 'Diabatic electronic coupling (wfn overlap, mHartree):', & ABS(mixed_cdft%results%wfn(ipermutation)*1.0E3_dp) @@ -1709,7 +1709,7 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_block(i)%array .GE. 0.0_dp)) & + 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.") @@ -1847,7 +1847,7 @@ CONTAINS END DO END DO ! Check that none of the interaction energies is repulsive - IF (ANY(H_offdiag .GE. 0.0_dp)) & + 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.") @@ -1860,10 +1860,10 @@ CONTAINS ! The S/H matrices contain only positive/negative values so that any sign flipping occurs in the ! same elements in both matrices ! Check for sign flipping using the S matrix - IF (ANY(S_offdiag .LT. 0.0_dp)) THEN + IF (ANY(S_offdiag < 0.0_dp)) THEN DO l = 1, SIZE(S_offdiag, 2) DO k = 1, SIZE(S_offdiag, 1) - IF (S_offdiag(k, l) .LT. 0.0_dp) THEN + IF (S_offdiag(k, l) < 0.0_dp) THEN S_offdiag(k, l) = -1.0_dp*S_offdiag(k, l) H_offdiag(k, l) = -1.0_dp*H_offdiag(k, l) END IF diff --git a/src/mm_collocate_potential.F b/src/mm_collocate_potential.F index 77338fc735..17a1968bf4 100644 --- a/src/mm_collocate_potential.F +++ b/src/mm_collocate_potential.F @@ -128,7 +128,7 @@ CONTAINS END DO ! Loop on y ! cleanup loop: check if the last loop element has done - IF (iy2 .NE. yub) THEN + IF (iy2 /= yub) THEN iy2 = yub fx2 = 0.0_dp fyz2 = 0.0_dp @@ -191,7 +191,7 @@ CONTAINS REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: grid radius = exp_radius(0, zetp, eps_mm_rspace, scale*W) - IF (radius .EQ. 0.0_dp) THEN + IF (radius == 0.0_dp) THEN RETURN END IF @@ -213,7 +213,7 @@ CONTAINS ylb = MAX(bo(1, 2), cubecenter(2) + lb_cube(2)) xub = MIN(bo(2, 1), cubecenter(1) + ub_cube(1)) xlb = MAX(bo(1, 1), cubecenter(1) + lb_cube(1)) - IF (zlb .GT. zub .OR. ylb .GT. yub .OR. xlb .GT. xub) RETURN + IF (zlb > zub .OR. ylb > yub .OR. xlb > xub) RETURN DO ig = zlb, zub rpg = REAL(ig - gbo(1, 3), dp)*dr(3) - rpl(3) zap = EXP(-zetp*rpg**2) @@ -245,7 +245,7 @@ CONTAINS ylb = MAX(bo(1, 2), cubecenter(2) + lb_cube(2)) xub = MIN(bo(2, 1), cubecenter(1) + ub_cube(1)) xlb = MAX(bo(1, 1), cubecenter(1) + lb_cube(1)) - IF (zlb .GT. zub .OR. ylb .GT. yub .OR. xlb .GT. xub) CYCLE + IF (zlb > zub .OR. ylb > yub .OR. xlb > xub) CYCLE DO ig = zlb, zub rpg = REAL(ig - gbo(1, 3), dp)*dr(3) - rpl(3) zap = EXP(-zetp*rpg**2) @@ -318,7 +318,7 @@ CONTAINS force = 0.0_dp radius = exp_radius(0, zetp, eps_mm_rspace, scale*W) - IF (radius .EQ. 0.0_dp) RETURN + IF (radius == 0.0_dp) RETURN ! *** properties of the grid *** rpl = rp @@ -337,7 +337,7 @@ CONTAINS ylb = MAX(bo(1, 2), cubecenter(2) + lb_cube(2)) xub = MIN(bo(2, 1), cubecenter(1) + ub_cube(1)) xlb = MAX(bo(1, 1), cubecenter(1) + lb_cube(1)) - IF (zlb .GT. zub .OR. ylb .GT. yub .OR. xlb .GT. xub) RETURN + IF (zlb > zub .OR. ylb > yub .OR. xlb > xub) RETURN DO ig = zlb, zub rpg = REAL(ig - gbo(1, 3), dp)*dr(3) - rpl(3) zap = EXP(-zetp*rpg**2) @@ -372,7 +372,7 @@ CONTAINS ylb = MAX(bo(1, 2), cubecenter(2) + lb_cube(2)) xub = MIN(bo(2, 1), cubecenter(1) + ub_cube(1)) xlb = MAX(bo(1, 1), cubecenter(1) + lb_cube(1)) - IF (zlb .GT. zub .OR. ylb .GT. yub .OR. xlb .GT. xub) CYCLE + IF (zlb > zub .OR. ylb > yub .OR. xlb > xub) CYCLE DO ig = zlb, zub rpg = REAL(ig - gbo(1, 3), dp)*dr(3) - rpl(3) zap = EXP(-zetp*rpg**2) diff --git a/src/mode_selective.F b/src/mode_selective.F index 0523761b3b..ab753979d4 100644 --- a/src/mode_selective.F +++ b/src/mode_selective.F @@ -285,9 +285,9 @@ CONTAINS CALL section_vals_val_get(ms_vib_section, "EPS_NORM", r_val=ms_vib%eps(2)) CALL section_vals_val_get(ms_vib_section, "RANGE", n_rep_val=n_rep_val) ms_vib%select_id = 0 - IF (n_rep_val .NE. 0) THEN + IF (n_rep_val /= 0) THEN CALL section_vals_val_get(ms_vib_section, "RANGE", r_vals=ms_vib%f_range) - IF (ms_vib%f_range(1) .GT. ms_vib%f_range(2)) THEN + IF (ms_vib%f_range(1) > ms_vib%f_range(2)) THEN my_val = ms_vib%f_range(2) ms_vib%f_range(2) = ms_vib%f_range(1) ms_vib%f_range(1) = my_val @@ -296,7 +296,7 @@ CONTAINS END IF CALL section_vals_val_get(ms_vib_section, "FREQUENCY", r_val=ms_vib%sel_freq) CALL section_vals_val_get(ms_vib_section, "LOWEST_FREQUENCY", r_val=ms_vib%low_freq) - IF (ms_vib%sel_freq .GT. 0._dp) ms_vib%select_id = 1 + IF (ms_vib%sel_freq > 0._dp) ms_vib%select_id = 1 involved_at_section => section_vals_get_subs_vals(ms_vib_section, "INVOLVED_ATOMS") CALL section_vals_get(involved_at_section, explicit=do_involved_atoms) IF (do_involved_atoms) THEN @@ -308,7 +308,7 @@ CONTAINS jj = jj + 1 END DO END DO - IF (jj .GE. 1) THEN + IF (jj >= 1) THEN natoms = jj ALLOCATE (ms_vib%inv_atoms(natoms)) jj = 0 @@ -321,9 +321,9 @@ CONTAINS ms_vib%select_id = 3 END IF CALL section_vals_val_get(involved_at_section, "RANGE", n_rep_val=n_rep_val) - IF (n_rep_val .NE. 0) THEN + IF (n_rep_val /= 0) THEN CALL section_vals_val_get(involved_at_section, "RANGE", r_vals=ms_vib%inv_range) - IF (ms_vib%inv_range(1) .GT. ms_vib%inv_range(2)) THEN + IF (ms_vib%inv_range(1) > ms_vib%inv_range(2)) THEN ms_vib%inv_range(2) = my_val ms_vib%inv_range(2) = ms_vib%inv_range(1) ms_vib%inv_range(1) = my_val @@ -378,11 +378,11 @@ CONTAINS ms_vib%b_vec(:, i) = ms_vib%b_vec(:, i)/norm END DO - IF (nrep .GT. 1) THEN + IF (nrep > 1) THEN DO k = 1, 10 DO j = 1, nrep DO i = 1, nrep - IF (i .NE. j) THEN + IF (i /= j) THEN 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) = & @@ -510,7 +510,7 @@ CONTAINS tmp(i) = tmp(i) + SQRT(ms_vib%hes_bfgs(jj, i)**2) END DO END DO - IF ((SIGN(1._dp, ms_vib%eig_bfgs(i))*SQRT(ABS(ms_vib%eig_bfgs(i))*massunit)*vibfac) .LE. 400._dp) tmp(i) = 0._dp + IF ((SIGN(1._dp, ms_vib%eig_bfgs(i))*SQRT(ABS(ms_vib%eig_bfgs(i))*massunit)*vibfac) <= 400._dp) tmp(i) = 0._dp END DO tmp(:) = -tmp(:) END IF @@ -623,7 +623,7 @@ CONTAINS CALL diamat_all(approx_H, eigenval) CALL select_vector(ms_vib, nrep, mass, ncoord, approx_H, eigenval, ind, ms_vib%b_vec) - IF (ms_vib%initial_guess .NE. 4) THEN + IF (ms_vib%initial_guess /= 4) THEN ms_vib%b_vec = 0._dp DO i = 1, nrep @@ -751,7 +751,7 @@ CONTAINS istat = istat + stat END DO END DO - IF (ms_filename .NE. "") CALL close_file(iw) + IF (ms_filename /= "") CALL close_file(iw) IF (output_unit > 0) THEN IF (istat /= 0) THEN WRITE (output_unit, FMT="(/,T2,A)") "** Error while reading MOLDEN file **" @@ -777,7 +777,7 @@ CONTAINS tmp(i) = tmp(i) + SQRT(modes(jj, i)**2) END DO END DO - IF (freq(i) .LE. 400._dp) tmp(i) = 0._dp + IF (freq(i) <= 400._dp) tmp(i) = 0._dp END DO tmp(:) = -tmp(:) END IF @@ -850,7 +850,7 @@ CONTAINS nrep = SIZE(rep_env%f, 2) !!!!!!!! reallocate and update the davidson matrices !!!!!!!!!! - IF (ms_vib%mat_size .NE. 0) THEN + IF (ms_vib%mat_size /= 0) THEN ALLOCATE (tmp_b(3*natoms, ms_vib%mat_size)) ALLOCATE (tmp_s(3*natoms, ms_vib%mat_size)) @@ -868,7 +868,7 @@ CONTAINS ms_vib%s_mat = 0.0_dp DO i = 1, 3*natoms - IF (ms_vib%mat_size .NE. 0) THEN + IF (ms_vib%mat_size /= 0) THEN DO j = 1, ms_vib%mat_size ms_vib%b_mat(i, j) = tmp_b(i, j) ms_vib%s_mat(i, j) = tmp_s(i, j) @@ -879,7 +879,7 @@ CONTAINS END DO END DO - IF (ms_vib%mat_size .NE. 0) THEN + IF (ms_vib%mat_size /= 0) THEN DEALLOCATE (tmp_s) DEALLOCATE (tmp_b) END IF @@ -924,8 +924,8 @@ CONTAINS 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, :)) .LE. ms_vib%eps(1) .AND. MAXVAL(criteria(2, :)) & - .LE. ms_vib%eps(2) .OR. ms_vib%mat_size .GE. ncoord) converged = .TRUE. + IF (MAXVAL(criteria(1, :)) <= ms_vib%eps(1) .AND. MAXVAL(criteria(2, :)) & + <= ms_vib%eps(2) .OR. ms_vib%mat_size >= ncoord) converged = .TRUE. ALLOCATE (freq(nrep)) DO i = 1, nrep freq(i) = SQRT(ABS(eigenval(ind(i)))*massunit)*vibfac @@ -964,7 +964,7 @@ CONTAINS CALL ms_out(output_unit_ms, converged, freq, criteria, ms_vib, & input, nrep, approx_H, eigenval, calc_intens, logger=logger) END IF - dump_only_positive = ms_vib%low_freq .GT. 0.0_dp + dump_only_positive = ms_vib%low_freq > 0.0_dp CALL write_vibrations_molden(input, particles, eigenval, tmp_b, intensities, calc_intens, & dump_only_positive=dump_only_positive, logger=logger) IF (calc_intens) THEN @@ -1052,10 +1052,10 @@ CONTAINS END DO END DO IF (.NOT. ASSOCIATED(ms_vib%inv_range)) THEN - IF ((SIGN(1._dp, eigenval(i))*SQRT(ABS(eigenval(i))*massunit)*vibfac) .LE. 400._dp) tmp(i) = 0._dp + IF ((SIGN(1._dp, eigenval(i))*SQRT(ABS(eigenval(i))*massunit)*vibfac) <= 400._dp) tmp(i) = 0._dp ELSE - IF ((SIGN(1._dp, eigenval(i))*SQRT(ABS(eigenval(i))*massunit)*vibfac) .LE. ms_vib%inv_range(1)) tmp(i) = 0._dp - IF ((SIGN(1._dp, eigenval(i))*SQRT(ABS(eigenval(i))*massunit)*vibfac) .GE. ms_vib%inv_range(2)) tmp(i) = 0._dp + IF ((SIGN(1._dp, eigenval(i))*SQRT(ABS(eigenval(i))*massunit)*vibfac) <= ms_vib%inv_range(1)) tmp(i) = 0._dp + IF ((SIGN(1._dp, eigenval(i))*SQRT(ABS(eigenval(i))*massunit)*vibfac) >= ms_vib%inv_range(2)) tmp(i) = 0._dp END IF END DO tmp(:) = -tmp(:) @@ -1093,9 +1093,9 @@ CONTAINS residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), ms_vib%b_mat(:, i))*ms_vib%b_mat(:, i) residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) END DO - IF (nrep .GT. 1) THEN + IF (nrep > 1) THEN DO i = 1, nrep - IF (i .NE. j) THEN + IF (i /= j) THEN residuum(:, j) = residuum(:, j) - DOT_PRODUCT(residuum(:, j), residuum(:, i))*residuum(:, i) residuum(:, j) = residuum(:, j)/SQRT(DOT_PRODUCT(residuum(:, j), residuum(:, j))) END IF @@ -1150,7 +1150,7 @@ CONTAINS fint = 42.255_dp*massunit*debye**2*bohr**2 IF (converged) THEN - IF (iw .GT. 0) THEN + IF (iw > 0) THEN WRITE (iw, '(T2,A)') "MS| DAVIDSON ALGORITHM CONVERGED" DO i = 1, nrep WRITE (iw, '(T2,"MS| TRACKED FREQUENCY (",I0,") IS:",F12.6,3X,A)') i, freq(i), 'cm-1' @@ -1175,19 +1175,19 @@ CONTAINS crit_b = SQRT(DOT_PRODUCT(residuum, residuum)) IF (PRESENT(intensities)) THEN gintval = fint*intensities(i)**2 - IF (crit_a .LE. ms_vib%eps(1) .AND. crit_b .LE. ms_vib%eps(2)) THEN - IF (eigenval(i) .GT. ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,1X,F12.6,3X,E12.3,7X,E12.3,11X,A)') & + IF (crit_a <= ms_vib%eps(1) .AND. crit_b <= ms_vib%eps(2)) THEN + IF (eigenval(i) > ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,1X,F12.6,3X,E12.3,7X,E12.3,11X,A)') & 'VIB|', eigenval(i), gintval, crit_a, crit_b, 'YES' ELSE - IF (eigenval(i) .GT. ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,1X,F12.6,3X,E12.3,7X,E12.3,11X,A)') & + IF (eigenval(i) > ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,1X,F12.6,3X,E12.3,7X,E12.3,11X,A)') & 'VIB|', eigenval(i), gintval, crit_a, crit_b, 'NO' END IF ELSE - IF (crit_a .LE. ms_vib%eps(1) .AND. crit_b .LE. ms_vib%eps(2)) THEN - IF (eigenval(i) .GT. ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,5X,E12.6,5X,E12.3,11X,A)') & + IF (crit_a <= ms_vib%eps(1) .AND. crit_b <= ms_vib%eps(2)) THEN + IF (eigenval(i) > ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,5X,E12.6,5X,E12.3,11X,A)') & 'VIB|', eigenval(i), crit_a, crit_b, 'YES' ELSE - IF (eigenval(i) .GT. ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,5X,E12.6,5X,E12.3,11X,A)') & + IF (eigenval(i) > ms_vib%low_freq) WRITE (iw, '(2X,A,2X,F9.3,5X,E12.6,5X,E12.3,11X,A)') & 'VIB|', eigenval(i), crit_a, crit_b, 'NO' END IF END IF @@ -1210,7 +1210,7 @@ CONTAINS "PRINT%MS_RESTART") END IF ELSE - IF (iw .GT. 0) THEN + IF (iw > 0) THEN msunit = cp_print_key_unit_nr(logger, ms_vib_section, & "PRINT%MS_RESTART", extension=".bin", middle_name="MS_RESTART", & file_status="REPLACE", file_form="UNFORMATTED", & @@ -1228,7 +1228,7 @@ CONTAINS WRITE (iw, '(T2,A,3X,I6)') "MS| ITERATION STEP", ms_vib%mat_size/nrep DO i = 1, nrep - IF (criter(1, i) .LE. 1E-7 .AND. (criter(2, i)) .LE. 1E-6) THEN + IF (criter(1, i) <= 1E-7 .AND. (criter(2, i)) <= 1E-6) THEN WRITE (iw, '(T2,A,3X,F12.6,A)') "MS| TRACKED MODE ", freq(i), "cm-1 IS CONVERGED" ELSE WRITE (iw, '(T2,A,3X,F12.6,A)') "MS| TRACKED MODE ", freq(i), "cm-1 NOT CONVERGED" @@ -1273,7 +1273,7 @@ CONTAINS ALLOCATE (map1(SIZE(eigenval), 2)) ALLOCATE (tmp(SIZE(eigenval))) DO i = 1, SIZE(eigenval) - IF (ABS(eigenval(i) - myrange(1)) + ABS(eigenval(i) - myrange(2)) .LE. & + IF (ABS(eigenval(i) - myrange(1)) + ABS(eigenval(i) - myrange(2)) <= & ABS(myrange(1) - myrange(2)) + myrange(1)*0.001_dp) THEN count1 = count1 + 1 map1(count1, 1) = i @@ -1284,14 +1284,14 @@ CONTAINS END IF END DO - IF (count1 .EQ. nrep) THEN + IF (count1 == nrep) THEN DO j = 1, count1 DO i = 1, ms_vib%mat_size residuum(:, j) = residuum(:, j) + approx_H(i, map1(j, 1))*(ms_vib%s_mat(:, i) - eigenval(map1(j, 1))*ms_vib%b_mat(:, i)) ind(j) = map1(j, 1) END DO END DO - ELSE IF (count1 .GT. nrep) THEN + ELSE IF (count1 > nrep) THEN ALLOCATE (tmp_resid(SIZE(ms_vib%b_mat, 1), count1)) ALLOCATE (tmp1(count1)) ALLOCATE (map2(count1)) @@ -1317,10 +1317,10 @@ CONTAINS DEALLOCATE (tmp_resid) DEALLOCATE (tmp1) DEALLOCATE (map2) - ELSE IF (count1 .LT. nrep) THEN + ELSE IF (count1 < nrep) THEN ALLOCATE (map2(count2)) - IF (count1 .NE. 0) THEN + IF (count1 /= 0) THEN DO j = 1, count1 DO i = 1, ms_vib%mat_size residuum(:, j) = residuum(:, j) + approx_H(i, map1(j, 1))* & diff --git a/src/molden_utils.F b/src/molden_utils.F index c6e9754ce3..85a04dde45 100644 --- a/src/molden_utils.F +++ b/src/molden_utils.F @@ -418,7 +418,7 @@ CONTAINS iw = cp_print_key_unit_nr(logger, input, "VIBRATIONAL_ANALYSIS%PRINT%MOLDEN_VIB", & extension=".mol", file_status='REPLACE') - IF (iw .GT. 0) THEN + IF (iw > 0) THEN CPASSERT(MOD(SIZE(eigen_vec, 1), 3) == 0) CPASSERT(SIZE(freq, 1) == SIZE(eigen_vec, 2)) ALLOCATE (my_list(SIZE(particles))) @@ -464,7 +464,7 @@ CONTAINS l = l + 1 WRITE (iw, '(T2,A,1X,I6)') "vibration", l DO j = 1, SIZE(particles) - IF (my_list(j) .NE. 0) THEN + IF (my_list(j) /= 0) THEN k = (my_list(j) - 1)*3 WRITE (iw, '(T2,3(F12.6,3X))') eigen_vec(k + 1, i), eigen_vec(k + 2, i), eigen_vec(k + 3, i) ELSE diff --git a/src/molecular_states.F b/src/molecular_states.F index f66b88b8c9..1809a697a2 100644 --- a/src/molecular_states.F +++ b/src/molecular_states.F @@ -155,7 +155,7 @@ CONTAINS END IF CALL section_vals_val_get(loc_print_section, "MOLECULAR_STATES%MARK_STATES", & n_rep_val=n_rep) - IF (n_rep .GT. 0) THEN + IF (n_rep > 0) THEN ALLOCATE (mark_states(2, n_rep)) IF (.NOT. ASSOCIATED(marked_states)) THEN ALLOCATE (marked_states(n_rep)) diff --git a/src/motion/bfgs_optimizer.F b/src/motion/bfgs_optimizer.F index 7472f5e891..05304f1856 100644 --- a/src/motion/bfgs_optimizer.F +++ b/src/motion/bfgs_optimizer.F @@ -240,7 +240,7 @@ CONTAINS "BFGS: Matrix diagonalization failed, using unity as model Hessian." ELSE DO its = 1, SIZE(eigval) - IF (eigval(its) .LT. 0.1_dp) eigval(its) = 0.1_dp + IF (eigval(its) < 0.1_dp) eigval(its) = 0.1_dp END DO CALL cp_fm_to_fm(eigvec_mat, hess_tmp) CALL cp_fm_column_scale(eigvec_mat, eigval) @@ -1071,8 +1071,8 @@ CONTAINS at_row = 3 DO i = 1, natom CALL get_atomic_kind(atomic_kind=particles%els(i)%atomic_kind, z=z) - IF (z .LE. 10) at_row(i) = 2 - IF (z .LE. 2) at_row(i) = 1 + IF (z <= 10) at_row(i) = 2 + IF (z <= 2) at_row(i) = 1 END DO DO i = 2, natom iat_row = at_row(i) @@ -1091,35 +1091,35 @@ CONTAINS iglobal = col_indices(i) iind = MOD(iglobal - 1, 3) + 1 iat_col = (iglobal + 2)/3 - IF (iat_col .GT. natom) CYCLE + IF (iat_col > natom) CYCLE DO j = 1, nrow_local jglobal = row_indices(j) jind = MOD(jglobal - 1, 3) + 1 iat_row = (jglobal + 2)/3 - IF (iat_row .GT. natom) CYCLE - IF (iat_row .NE. iat_col) THEN - IF (d_ij(iat_row, iat_col) .LT. 6.0_dp) & + IF (iat_row > natom) CYCLE + IF (iat_row /= iat_col) 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) 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 .NE. iat_row) THEN - IF (d_ij(iat_row, iat_col) .LT. 6.0_dp) & + IF (iat_col /= iat_row) 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)) ELSE DO k = 1, natom IF (k == iat_col) CYCLE - IF (d_ij(iat_row, k) .LT. 6.0_dp) & + 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 DO END IF - IF (fixed(jind, iat_row) .LT. 0.5_dp .OR. fixed(iind, iat_col) .LT. 0.5_dp) THEN + IF (fixed(jind, iat_row) < 0.5_dp .OR. fixed(iind, iat_col) < 0.5_dp) THEN local_data(j, i) = 0.0_dp IF (jind == iind .AND. iat_row == iat_col) local_data(j, i) = 1.0_dp END IF @@ -1177,11 +1177,11 @@ CONTAINS deriv = 0._dp IF (iat_der == jat_der) THEN DO i = 1, natom - 1 - IF (rho_ij(iat_der, i) .LT. 0.00001) CYCLE + IF (rho_ij(iat_der, i) < 0.00001) CYCLE DO j = i + 1, natom - IF (rho_ij(iat_der, j) .LT. 0.00001) CYCLE + IF (rho_ij(iat_der, j) < 0.00001) CYCLE IF (i == iat_der .OR. j == iat_der) CYCLE - IF (iat_der .LT. i .OR. iat_der .GT. j) THEN + IF (iat_der < i .OR. iat_der > j) THEN r12 = r_ij(iat_der, i, :); r23 = r_ij(i, j, :); r31 = r_ij(j, iat_der, :) d12 = d_ij(iat_der, i); d23 = d_ij(i, j); d31 = d_ij(j, iat_der) rho12 = rho_ij(iat_der, i); rho23 = rho_ij(i, j); rho31 = rho_ij(j, iat_der) @@ -1205,9 +1205,9 @@ CONTAINS rsst3*r12(idir)/(d31*d12**3) D_mat(3, 2) = (r31(jdir) - r12(jdir))/(d31*d12) + rsst3*r31(jdir)/(d31**3*d12) - & rsst3*r12(jdir)/(d31*d12**3) - IF (ABS(denom1) .LE. 0.011_dp) D_mat(1, 1) = 0.0_dp - IF (ABS(denom2) .LE. 0.011_dp) D_mat(2, 1) = 0.0_dp - IF (ABS(denom3) .LE. 0.011_dp) D_mat(3, 1) = 0.0_dp + IF (ABS(denom1) <= 0.011_dp) D_mat(1, 1) = 0.0_dp + IF (ABS(denom2) <= 0.011_dp) D_mat(2, 1) = 0.0_dp + IF (ABS(denom3) <= 0.011_dp) D_mat(3, 1) = 0.0_dp deriv = deriv + ka1*D_mat(1, 1)*D_mat(1, 2)/denom1 + & ka2*D_mat(2, 1)*D_mat(2, 2)/denom2 + & ka3*D_mat(3, 1)*D_mat(3, 2)/denom3 @@ -1217,12 +1217,12 @@ CONTAINS ELSE DO i = 1, natom IF (i == iat_der .OR. i == jat_der) CYCLE - IF (jat_der .LT. iat_der) THEN + IF (jat_der < iat_der) THEN iat = jat_der; jat = iat_der; idr = jdir; jdr = idir ELSE iat = iat_der; jat = jat_der; idr = idir; jdr = jdir END IF - IF (jat .LT. i .OR. iat .GT. i) THEN + IF (jat < i .OR. iat > i) THEN r12 = r_ij(iat, jat, :); r23 = r_ij(jat, i, :); r31 = r_ij(i, iat, :) d12 = d_ij(iat, jat); d23 = d_ij(jat, i); d31 = d_ij(i, iat) rho12 = rho_ij(iat, jat); rho23 = rho_ij(jat, i); rho31 = rho_ij(i, iat) @@ -1242,7 +1242,7 @@ CONTAINS D_mat(2, 1) = -r23(idr)/(d23*d31) + rsst2*r31(idr)/(d23*d31**3) D_mat(3, 1) = (r31(idr) - r12(idr))/(d31*d12) + rsst3*r31(idr)/(d31**3*d12) - & rsst3*r12(idr)/(d31*d12**3) - IF (jat .LT. i .OR. iat .GT. i) THEN + IF (jat < i .OR. iat > i) THEN D_mat(1, 2) = (r12(jdr) - r23(jdr))/(d12*d23) + rsst1*r12(jdr)/(d12**3*d23) - & rsst1*r23(jdr)/(d12*d23**3) D_mat(2, 2) = r31(jdr)/(d23*d31) - rsst2*r23(jdr)/(d23**3*d31) @@ -1253,9 +1253,9 @@ CONTAINS rsst2*r31(jdr)/(d23*d31**3) D_mat(3, 2) = r12(jdr)/(d31*d12) - rsst3*r31(jdr)/(d31**3*d12) END IF - IF (ABS(denom1) .LE. 0.011_dp) D_mat(1, 1) = 0.0_dp - IF (ABS(denom2) .LE. 0.011_dp) D_mat(2, 1) = 0.0_dp - IF (ABS(denom3) .LE. 0.011_dp) D_mat(3, 1) = 0.0_dp + IF (ABS(denom1) <= 0.011_dp) D_mat(1, 1) = 0.0_dp + IF (ABS(denom2) <= 0.011_dp) D_mat(2, 1) = 0.0_dp + IF (ABS(denom3) <= 0.011_dp) D_mat(3, 1) = 0.0_dp deriv = deriv + ka1*D_mat(1, 1)*D_mat(1, 2)/denom1 + & ka2*D_mat(2, 1)*D_mat(2, 2)/denom2 + & diff --git a/src/motion/cg_utils.F b/src/motion/cg_utils.F index bb3e4f26a6..a8a18bcffd 100644 --- a/src/motion/cg_utils.F +++ b/src/motion/cg_utils.F @@ -589,7 +589,7 @@ CONTAINS fa = cg_eval1d(gopt_env, ax, pcom, xicom) fb = cg_eval1d(gopt_env, bx, pcom, xicom) END IF - IF (fb .GT. fa) THEN + IF (fb > fa) THEN dum = ax ax = bx bx = dum @@ -606,7 +606,7 @@ CONTAINS fc = cg_eval1d(gopt_env, cx, pcom, xicom) END IF loc_iter = 3 - DO WHILE (fb .GE. fc) + DO WHILE (fb >= fc) CALL external_control(should_stop, "MNBRACK", globenv=globenv) IF (should_stop) EXIT ! @@ -614,7 +614,7 @@ CONTAINS q = (bx - cx)*(fb - fa) u = bx - ((bx - cx)*q - (bx - ax)*r)/(2.0_dp*SIGN(MAX(ABS(q - r), TINY(0.0_dp)), q - r)) ulim = bx + brack_limit*(cx - bx) - IF ((bx - u)*(u - cx) .GT. 0.0_dp) THEN + IF ((bx - u)*(u - cx) > 0.0_dp) THEN IF (hist) THEN odim = SIZE(histpoint, 1) CALL reallocate(histpoint, 1, odim + 1, 1, 3) @@ -625,13 +625,13 @@ CONTAINS fu = cg_eval1d(gopt_env, u, pcom, xicom) END IF loc_iter = loc_iter + 1 - IF (fu .LT. fc) THEN + IF (fu < fc) THEN ax = bx fa = fb bx = u fb = fu EXIT - ELSE IF (fu .GT. fb) THEN + ELSE IF (fu > fb) THEN cx = u fc = fu EXIT @@ -647,7 +647,7 @@ CONTAINS fu = cg_eval1d(gopt_env, u, pcom, xicom) END IF loc_iter = loc_iter + 1 - ELSE IF ((cx - u)*(u - ulim) .GT. 0.) THEN + ELSE IF ((cx - u)*(u - ulim) > 0.) THEN IF (hist) THEN odim = SIZE(histpoint, 1) CALL reallocate(histpoint, 1, odim + 1, 1, 3) @@ -658,7 +658,7 @@ CONTAINS fu = cg_eval1d(gopt_env, u, pcom, xicom) END IF loc_iter = loc_iter + 1 - IF (fu .LT. fc) THEN + IF (fu < fc) THEN bx = cx cx = u u = cx + gold*(cx - bx) @@ -675,7 +675,7 @@ CONTAINS END IF loc_iter = loc_iter + 1 END IF - ELSE IF ((u - ulim)*(ulim - cx) .GE. 0.) THEN + ELSE IF ((u - ulim)*(ulim - cx) >= 0.) THEN u = ulim IF (hist) THEN odim = SIZE(histpoint, 1) @@ -783,22 +783,22 @@ CONTAINS tol2 = 2.0_dp*tol1 skip0 = .FALSE. skip1 = .FALSE. - IF (ABS(x - xm) .LE. (tol2 - 0.5_dp*(b - a))) EXIT - IF (ABS(e) .GT. tol1) THEN + IF (ABS(x - xm) <= (tol2 - 0.5_dp*(b - a))) EXIT + IF (ABS(e) > tol1) THEN d1 = 2.0_dp*(b - a) d2 = d1 - IF (dw .NE. dx) d1 = (w - x)*dx/(dx - dw) - IF (dv .NE. dx) d2 = (v - x)*dx/(dx - dv) + IF (dw /= dx) d1 = (w - x)*dx/(dx - dw) + IF (dv /= dx) d2 = (v - x)*dx/(dx - dv) u1 = x + d1 u2 = x + d2 - ok1 = ((a - u1)*(u1 - b) .GT. 0.0_dp) .AND. (dx*d1 .LE. 0.0_dp) - ok2 = ((a - u2)*(u2 - b) .GT. 0.0_dp) .AND. (dx*d2 .LE. 0.0_dp) + ok1 = ((a - u1)*(u1 - b) > 0.0_dp) .AND. (dx*d1 <= 0.0_dp) + ok2 = ((a - u2)*(u2 - b) > 0.0_dp) .AND. (dx*d2 <= 0.0_dp) olde = e e = d IF (.NOT. (ok1 .OR. ok2)) THEN skip0 = .TRUE. ELSE IF (ok1 .AND. ok2) THEN - IF (ABS(d1) .LT. ABS(d2)) THEN + IF (ABS(d1) < ABS(d2)) THEN d = d1 ELSE d = d2 @@ -809,23 +809,23 @@ CONTAINS d = d2 END IF IF (.NOT. skip0) THEN - IF (ABS(d) .GT. ABS(0.5_dp*olde)) skip0 = .TRUE. + IF (ABS(d) > ABS(0.5_dp*olde)) skip0 = .TRUE. IF (.NOT. skip0) THEN u = x + d - IF ((u - a) .LT. tol2 .OR. (b - u) .LT. tol2) d = SIGN(tol1, xm - x) + IF ((u - a) < tol2 .OR. (b - u) < tol2) d = SIGN(tol1, xm - x) skip1 = .TRUE. END IF END IF END IF IF (.NOT. skip1) THEN - IF (dx .GE. 0.0_dp) THEN + IF (dx >= 0.0_dp) THEN e = a - x ELSE e = b - x END IF d = 0.5_dp*e END IF - IF (ABS(d) .GE. tol1) THEN + IF (ABS(d) >= tol1) THEN u = x + d du = cg_deval1d(gopt_env, u, pcom, xicom, fu) loc_iter = loc_iter + 1 @@ -833,10 +833,10 @@ CONTAINS u = x + SIGN(tol1, d) du = cg_deval1d(gopt_env, u, pcom, xicom, fu) loc_iter = loc_iter + 1 - IF (fu .GT. fx) EXIT + IF (fu > fx) EXIT END IF - IF (fu .LE. fx) THEN - IF (u .GE. x) THEN + IF (fu <= fx) THEN + IF (u >= x) THEN a = x ELSE b = x @@ -844,15 +844,15 @@ CONTAINS v = w; fv = fw; dv = dw; w = x fw = fx; dw = dx; x = u; fx = fu; dx = du ELSE - IF (u .LT. x) THEN + IF (u < x) THEN a = u ELSE b = u END IF - IF (fu .LE. fw .OR. w .EQ. x) THEN + IF (fu <= fw .OR. w == x) THEN v = w; fv = fw; dv = dw w = u; fw = fu; dw = du - ELSE IF (fu .LE. fv .OR. v .EQ. x .OR. v .EQ. w) THEN + ELSE IF (fu <= fv .OR. v == x .OR. v == w) THEN v = u fv = fu dv = du diff --git a/src/motion/cp_lbfgs.F b/src/motion/cp_lbfgs.F index c883e0026b..6fa0b53316 100644 --- a/src/motion/cp_lbfgs.F +++ b/src/motion/cp_lbfgs.F @@ -3047,22 +3047,22 @@ CONTAINS IF (nbd(k) /= 0) THEN ! ! lower bounds only - IF (nbd(k) .EQ. 1) THEN + IF (nbd(k) == 1) THEN x(k) = MAX(lower_bound(k), xk + dk) - IF (x(k) .EQ. lower_bound(k)) iword = 1 + IF (x(k) == lower_bound(k)) iword = 1 ELSE ! ! upper and lower bounds - IF (nbd(k) .EQ. 2) THEN + IF (nbd(k) == 2) THEN xk = MAX(lower_bound(k), xk + dk) x(k) = MIN(upper_bound(k), xk) - IF (x(k) .EQ. lower_bound(k) .OR. x(k) .EQ. upper_bound(k)) iword = 1 + IF (x(k) == lower_bound(k) .OR. x(k) == upper_bound(k)) iword = 1 ELSE ! ! upper bounds only - IF (nbd(k) .EQ. 3) THEN + IF (nbd(k) == 3) THEN x(k) = MIN(upper_bound(k), xk + dk) - IF (x(k) .EQ. upper_bound(k)) iword = 1 + IF (x(k) == upper_bound(k)) iword = 1 END IF END IF END IF @@ -3073,7 +3073,7 @@ CONTAINS END IF END DO ! - IF (.NOT. (iword .EQ. 0)) THEN + IF (.NOT. (iword == 0)) THEN ! ! check sign of the directional derivative ! @@ -3081,7 +3081,7 @@ CONTAINS DO i = 1, n dd_p = dd_p + (x(i) - xx(i))*gg(i) END DO - IF (dd_p .GT. zero) THEN + IF (dd_p > zero) THEN CALL dcopy(n, xp, 1, x, 1) IF (iprint > 0) WRITE (*, *) ' Positive dir derivative in projection ' IF (iprint > 0) WRITE (*, *) ' Using the backtracking step ' diff --git a/src/motion/free_energy_methods.F b/src/motion/free_energy_methods.F index c3a67b9975..bdfd98b9e2 100644 --- a/src/motion/free_energy_methods.F +++ b/src/motion/free_energy_methods.F @@ -233,7 +233,7 @@ CONTAINS ii = ii + 1 END DO DO i = my_reject + 1, ng_points - IF ((ng_points - my_reject) .LT. min_sample_size) THEN + IF ((ng_points - my_reject) < min_sample_size) THEN my_reject = MAX(0, my_reject - 1) test_avg = .FALSE. EXIT @@ -261,7 +261,7 @@ CONTAINS ii = ii + 1 END DO DO i = my_reject + 1, ng_points - IF ((ng_points - my_reject) .LT. min_sample_size) THEN + IF ((ng_points - my_reject) < min_sample_size) THEN my_reject = MAX(0, my_reject - 1) test_std = .FALSE. EXIT diff --git a/src/motion/helium_common.F b/src/motion/helium_common.F index f622cc0729..c9dbe742d3 100644 --- a/src/motion/helium_common.F +++ b/src/motion/helium_common.F @@ -257,7 +257,7 @@ CONTAINS ! follow to the next atom in the cycle curr_idx = helium%permutation(curr_idx) - IF (curr_idx .EQ. start_idx) THEN + IF (curr_idx == start_idx) THEN path_end_reached = .TRUE. EXIT END IF @@ -323,7 +323,7 @@ CONTAINS curat = 1 nused = 0 ncycl = 0 - DO WHILE (curat .LE. nsize) + DO WHILE (curat <= nsize) ! get the permutation cycle the current atom belongs to cur_cycle => helium_cycle_of(curat, permutation) @@ -341,7 +341,7 @@ CONTAINS NULLIFY (cur_cycle) ! try to increment the current atom index - DO WHILE (ANY(used_indices .EQ. curat)) + DO WHILE (ANY(used_indices == curat)) curat = curat + 1 END DO @@ -445,7 +445,7 @@ CONTAINS DO ib = 1, helium%beads vlink(:) = helium_link_winding_number(helium, aa, ib) DO id = 1, 3 - IF (ABS(wn(id)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + IF (ABS(wn(id)) > 100.0_dp*EPSILON(0.0_dp)) THEN ii = helium%rho_property(ir)%component_index(id) helium%rho_incr(ii, aa, ib) = vtotal(id)*vlink(id)*angstrom*angstrom END IF @@ -468,7 +468,7 @@ CONTAINS DO ic = 1, SIZE(cycles) wn = helium_cycle_winding_number(helium, cycles(ic)%iap, helium%pos) DO id = 1, 3 - IF (ABS(wn(id)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + IF (ABS(wn(id)) > 100.0_dp*EPSILON(0.0_dp)) THEN nw(id) = nw(id) + SIZE(cycles(ic)%iap) END IF END DO @@ -477,11 +477,11 @@ CONTAINS DO ic = 1, SIZE(cycles) wn = helium_cycle_winding_number(helium, cycles(ic)%iap, helium%pos) DO id = 1, 3 - IF (ABS(wn(id)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + IF (ABS(wn(id)) > 100.0_dp*EPSILON(0.0_dp)) THEN DO ia = 1, SIZE(cycles(ic)%iap) aa = cycles(ic)%iap(ia) DO ib = 1, helium%beads - IF (nw(id) .GT. 0) THEN ! this test should always get passed + IF (nw(id) > 0) THEN ! this test should always get passed ii = helium%rho_property(ir)%component_index(id) rtmp = invp/REAL(nw(id), dp) helium%rho_incr(ii, aa, ib) = rtmp*vtotal(id)*vtotal(id)*angstrom*angstrom @@ -526,9 +526,9 @@ CONTAINS by = INT((r(2) + maxr_half(2))*invdr) + 1 bz = INT((r(3) + maxr_half(3))*invdr) + 1 ! check that the resulting bin numbers are within array bounds - ltmp1 = (0 .LT. bx) .AND. (bx .LE. nbin) - ltmp2 = (0 .LT. by) .AND. (by .LE. nbin) - ltmp3 = (0 .LT. bz) .AND. (bz .LE. nbin) + ltmp1 = (0 < bx) .AND. (bx <= nbin) + ltmp2 = (0 < by) .AND. (by <= nbin) + ltmp3 = (0 < bz) .AND. (bz <= nbin) IF (ltmp1 .AND. ltmp2 .AND. ltmp3) THEN ! increment all the estimators (those that the current atom does not ! contribute to have increment incr(ic)==0) @@ -547,7 +547,7 @@ CONTAINS ! since enforced PBC should have taken care of such leaks WRITE (msgstr, *) n_out_of_range msgstr = "Number of bead positions out of range: "//TRIM(ADJUSTL(msgstr)) - IF (n_out_of_range .GT. 0) THEN + IF (n_out_of_range > 0) THEN CPABORT(msgstr) END IF @@ -660,7 +660,7 @@ CONTAINS CALL helium_pbc(helium, r) ri = SQRT(r(1)*r(1) + r(2)*r(2) + r(3)*r(3)) bin = INT(ri*invdr) + 1 - IF ((0 .LT. bin) .AND. (bin .LE. nbin)) THEN + IF ((0 < bin) .AND. (bin <= nbin)) THEN ! increment the RDF value for He atoms inside the r_6 sphere helium%rdf_inst(ind_hehe, bin) = helium%rdf_inst(ind_hehe, bin) + 1.0_dp ELSE @@ -682,7 +682,7 @@ CONTAINS CALL helium_pbc(helium, r) ri = SQRT(r(1)*r(1) + r(2)*r(2) + r(3)*r(3)) bin = INT(ri*invdr) + 1 - IF ((0 .LT. bin) .AND. (bin .LE. nbin)) THEN + IF ((0 < bin) .AND. (bin <= nbin)) THEN ! increment the RDF value for He atoms inside the r_6 sphere helium%rdf_inst(ind_hehe + ia, bin) = helium%rdf_inst(ind_hehe + ia, bin) + 1.0_dp ELSE @@ -697,7 +697,7 @@ CONTAINS ! for periodic case we intentionally truncate RDFs to spherical volume ! so we skip atoms in the corners IF (.NOT. helium%periodic) THEN - IF (n_out_of_range .GT. 0) THEN + IF (n_out_of_range > 0) THEN WRITE (msgstr, *) n_out_of_range msgstr = "Number of bead positions out of range: "//TRIM(ADJUSTL(msgstr)) CPWARN(msgstr) @@ -1477,8 +1477,8 @@ CONTAINS !> \author Lukasz Walewski !> \note Cycles (or paths) are numbered from 1 to , where !> is in the range of (1, ). -!> if (num_cycles .EQ. 1) then all atoms belong to one cycle -!> if (num_cycles .EQ. helium%atoms) then there are no cycles of +!> if (num_cycles == 1) then all atoms belong to one cycle +!> if (num_cycles == helium%atoms) then there are no cycles of !> length greater than 1 (i.e. no atoms are connected) ! ************************************************************************************************** FUNCTION helium_cycle_number(helium, atom_number, permutation) RESULT(cycle_number) @@ -1502,7 +1502,7 @@ CONTAINS cycle_num = -1 DO ia = 1, helium%atoms ! this loop reaches its maximum iteration count when atom in question - ! is the last one (i.e. when atom_number .EQ. helium%atoms) + ! is the last one (i.e. when atom_number == helium%atoms) ! exit if we have found the cycle number for the atom in question IF (found) THEN @@ -1520,13 +1520,13 @@ CONTAINS ! proceed along the path atom_idx = permutation(atom_idx) - IF (atom_idx .EQ. ia) THEN + IF (atom_idx == ia) THEN ! end of cycle detected (looped back to the first atom) ! check if this is a new cycle new_cycle = .TRUE. DO ic = 1, num_cycles - IF (cycle_index(ic) .EQ. cycle_idx) THEN + IF (cycle_index(ic) == cycle_idx) THEN new_cycle = .FALSE. END IF END DO @@ -1538,7 +1538,7 @@ CONTAINS END IF ! if this was the atom in question - IF (ia .EQ. atom_number) THEN + IF (ia == atom_number) THEN ! save the cycle index it belongs to cycle_num = cycle_idx @@ -1551,7 +1551,7 @@ CONTAINS END IF ! set the cycle index to the lowest atom index in this cycle - IF (atom_idx .LT. cycle_idx) THEN + IF (atom_idx < cycle_idx) THEN cycle_idx = atom_idx END IF @@ -1571,7 +1571,7 @@ CONTAINS ! (don't do it actually - just return the requested ) cycle_number = 0 DO ic = 1, num_cycles - IF (cycle_index(ic) .EQ. cycle_num) THEN + IF (cycle_index(ic) == cycle_num) THEN cycle_number = ic EXIT END IF @@ -1607,7 +1607,7 @@ CONTAINS DO ia = 1, helium%atoms path_length = path_length + 1 atom_idx = permutation(atom_idx) - IF (atom_idx .EQ. atom_number) THEN + IF (atom_idx == atom_number) THEN path_end_reached = .TRUE. EXIT END IF @@ -1653,7 +1653,7 @@ CONTAINS len = len + 1 my_cycle(len) = icur icur = permutation(icur) - IF (icur .EQ. element) THEN + IF (icur == element) THEN cycle_end_reached = .TRUE. EXIT END IF @@ -1728,7 +1728,7 @@ CONTAINS INTEGER :: ja1, ja2, jb1, jb2 REAL(KIND=dp), DIMENSION(:), POINTER :: r1, r2 - IF (ib .EQ. helium%beads) THEN + IF (ib == helium%beads) THEN ja1 = ia ja2 = helium%permutation(ia) jb1 = ib @@ -1806,7 +1806,7 @@ CONTAINS ! contribution from the last bead of the current atom ! and the first bead of the next atom i1 = CYCLE(ia) - IF (ia .EQ. nsize) THEN + IF (ia == nsize) THEN i2 = CYCLE(1) ELSE i2 = CYCLE(ia + 1) @@ -1921,7 +1921,7 @@ CONTAINS INTEGER :: ja1, ja2, jb1, jb2 REAL(KIND=dp), DIMENSION(3) :: r1, r12, r2 - IF (ib .EQ. helium%beads) THEN + IF (ib == helium%beads) THEN ja1 = ia ja2 = helium%permutation(ia) jb1 = ib @@ -2006,7 +2006,7 @@ CONTAINS ! contribution from the last bead of the current atom ! and the first bead of the next atom i1 = CYCLE(ia) - IF (ia .EQ. nsize) THEN + IF (ia == nsize) THEN i2 = CYCLE(1) ELSE i2 = CYCLE(ia + 1) @@ -2061,7 +2061,7 @@ CONTAINS ! contribution from the last bead of the current atom ! and the first bead of the next atom i1 = CYCLE(ia) - IF (ia .EQ. nsize) THEN + IF (ia == nsize) THEN i2 = CYCLE(1) ELSE i2 = CYCLE(ia + 1) @@ -2184,7 +2184,7 @@ CONTAINS com(:) = helium%center(:) - IF (ib .EQ. helium%beads) THEN + IF (ib == helium%beads) THEN ja1 = ia ja2 = helium%permutation(ia) jb1 = ib @@ -2271,7 +2271,7 @@ CONTAINS ! contribution from the last bead of the current atom ! and the first bead of the next atom i1 = CYCLE(ia) - IF (ia .EQ. nsize) THEN + IF (ia == nsize) THEN i2 = CYCLE(1) ELSE i2 = CYCLE(ia + 1) @@ -2418,7 +2418,7 @@ CONTAINS INTEGER :: ia1, ia2, ib1, ib2 REAL(KIND=dp), DIMENSION(:), POINTER :: r1, r2 - IF (ib .EQ. helium%beads) THEN + IF (ib == helium%beads) THEN ia1 = ia ia2 = helium%permutation(ia) ib1 = ib @@ -2511,7 +2511,7 @@ CONTAINS wnum(:) = bohr*helium_cycle_winding_number(helium, CYCLE, pos) inum(:) = helium_wnumber_to_integer(helium, wnum) DO ic = 1, 3 - IF (ABS(inum(ic)) .GT. 0) THEN + IF (ABS(inum(ic)) > 0) THEN is_winding = .TRUE. EXIT END IF diff --git a/src/motion/helium_interactions.F b/src/motion/helium_interactions.F index 4f45e0eea2..ce9f48791c 100644 --- a/src/motion/helium_interactions.F +++ b/src/motion/helium_interactions.F @@ -556,7 +556,7 @@ CONTAINS CALL helium_pbc(helium_env(k)%helium, pbc2) wrapped = .FALSE. DO ic = 1, 3 - IF (ABS(pbc1(ic) - pbc2(ic)) .GT. 10.0_dp*EPSILON(0.0_dp)) THEN + IF (ABS(pbc1(ic) - pbc2(ic)) > 10.0_dp*EPSILON(0.0_dp)) THEN wrapped = .TRUE. END IF END DO diff --git a/src/motion/helium_io.F b/src/motion/helium_io.F index 009ab57d59..2298b03178 100644 --- a/src/motion/helium_io.F +++ b/src/motion/helium_io.F @@ -243,7 +243,7 @@ CONTAINS CALL helium_write_line("PBC turned off.") END IF - IF (helium%droplet_radius .LT. HUGE(1.0_dp)) THEN + IF (helium%droplet_radius < HUGE(1.0_dp)) THEN WRITE (stmp, *) helium%droplet_radius*angstrom CALL helium_write_line("Droplet radius: "//TRIM(ADJUSTL(stmp))//" [angstrom]") END IF @@ -667,7 +667,7 @@ CONTAINS IF (is_new) THEN ! comment - IF (cmmnt .NE. "") THEN + IF (cmmnt /= "") THEN WRITE (unit_nr, '(A)') "# "//cmmnt END IF ! column labels @@ -681,7 +681,7 @@ CONTAINS IF (my_avg) THEN DO i = 1, 3 WRITE (unit_nr, '(E27.20)', ADVANCE='NO') uconv*avg_data(i) - IF (i .LT. 3) THEN + IF (i < 3) THEN WRITE (unit_nr, '(1X)', ADVANCE='NO') END IF END DO @@ -696,7 +696,7 @@ CONTAINS ! write out the data DO i = 1, 3 WRITE (unit_nr, '(E27.20)', ADVANCE='NO') uconv*data_p(i) - IF (i .LT. 3) THEN + IF (i < 3) THEN WRITE (unit_nr, '(1X)', ADVANCE='NO') END IF END DO @@ -831,7 +831,7 @@ CONTAINS ! get the output type CALL section_vals_val_get(print_key, "FORMAT", i_val=outformat) - IF (outformat .EQ. perm_cycle) THEN + IF (outformat == perm_cycle) THEN ! gather positions from all processors helium_env(1)%helium%rtmp_3_atoms_beads_np_1d = 0.0_dp j = SIZE(helium_env(1)%helium%rtmp_3_atoms_beads_1d) @@ -888,7 +888,7 @@ CONTAINS curat = 1 nused = 0 first_cycle = .TRUE. - DO WHILE (curat .LE. helium_env(1)%helium%atoms) + DO WHILE (curat <= helium_env(1)%helium%atoms) ! get the permutation cycle the current atom belongs to my_cycle => helium_cycle_of(curat, my_perm) @@ -932,7 +932,7 @@ CONTAINS NULLIFY (my_cycle) ! try to increment the current atom index - DO WHILE (ANY(used_indices .EQ. curat)) + DO WHILE (ANY(used_indices == curat)) curat = curat + 1 END DO @@ -1154,7 +1154,7 @@ CONTAINS CALL helium_pbc(helium_env(k)%helium, r2) ltmp = .FALSE. DO ic = 1, 3 - IF (ABS(r1(ic) - r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + IF (ABS(r1(ic) - r2(ic)) > 100.0_dp*EPSILON(0.0_dp)) THEN ltmp = .TRUE. CYCLE END IF @@ -1268,7 +1268,7 @@ CONTAINS ! write connectivity records for this atom only if the path ! it belongs to is longer than 1. - IF (helium_path_length(helium_env(1)%helium, ia, my_perm) .LE. 1) THEN + IF (helium_path_length(helium_env(1)%helium, ia, my_perm) <= 1) THEN CYCLE END IF @@ -1279,7 +1279,7 @@ CONTAINS CALL helium_pbc(helium_env(1)%helium, r2) are_connected = .TRUE. DO ic = 1, 3 - IF (ABS(r1(ic) - r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + IF (ABS(r1(ic) - r2(ic)) > 100.0_dp*EPSILON(0.0_dp)) THEN ! if the distance betw ib and ib+1 changes upon applying ! PBC do not connect them are_connected = .FALSE. @@ -1290,7 +1290,7 @@ CONTAINS tmp1 = (ia - 1)*helium_env(1)%helium%beads + ib tmp2 = (ia - 1)*helium_env(1)%helium%beads + ib + 1 ! smaller value has to go first - IF (tmp1 .LT. tmp2) THEN + IF (tmp1 < tmp2) THEN ib1 = tmp1 ib2 = tmp2 ELSE @@ -1308,7 +1308,7 @@ CONTAINS CALL helium_pbc(helium_env(1)%helium, r2) are_connected = .TRUE. DO ic = 1, 3 - IF (ABS(r1(ic) - r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + IF (ABS(r1(ic) - r2(ic)) > 100.0_dp*EPSILON(0.0_dp)) THEN ! if the distance betw ib and ib+1 changes upon applying ! PBC do not connect them are_connected = .FALSE. @@ -1318,7 +1318,7 @@ CONTAINS IF (are_connected) THEN tmp1 = ia*helium_env(1)%helium%beads tmp2 = (my_perm(ia) - 1)*helium_env(1)%helium%beads + 1 - IF (tmp1 .LT. tmp2) THEN + IF (tmp1 < tmp2) THEN ib1 = tmp1 ib2 = tmp2 ELSE @@ -1609,7 +1609,7 @@ CONTAINS WRITE (fname, '(A)') "helium-rho-"// & TRIM(ADJUSTL(helium_env(1)%helium%rho_property(id)%filename_suffix(ic))) - IF (helium_env(1)%helium%rho_property(id)%component_name(ic) .EQ. "") THEN + IF (helium_env(1)%helium%rho_property(id)%component_name(ic) == "") THEN WRITE (comment, '(A)') TRIM(helium_env(1)%helium%rho_property(id)%name) ELSE WRITE (comment, '(A)') TRIM(helium_env(1)%helium%rho_property(id)%name)// & @@ -1695,7 +1695,7 @@ CONTAINS DO iz = 1, ndim WRITE (unit, '(1X,E13.5)', ADVANCE='NO') inva3*DATA(ix, iy, iz) nw = nw + 1 - IF (MOD(nw, 6) .EQ. 0) THEN + IF (MOD(nw, 6) == 0) THEN nw = 0 WRITE (unit, *) END IF @@ -1706,7 +1706,7 @@ CONTAINS ! values written on that line unless line terminator is written at the end ! so make sure that the last WRITE statement runs without ADVANCE='NO' ! (observed for ifort 14.0.1 and 14.0.2 but not for gfortran 4.8.2) - IF (nw .NE. 0) THEN + IF (nw /= 0) THEN WRITE (unit, *) END IF @@ -1756,7 +1756,7 @@ CONTAINS DO i = 1, helium_env(1)%helium%atoms WRITE (unit_nr, '(F20.10)', ADVANCE='NO') helium_env(1)%helium%plength_avrg(i) - IF (i .LT. helium_env(1)%helium%atoms) THEN + IF (i < helium_env(1)%helium%atoms) THEN WRITE (unit_nr, '(1X)', ADVANCE='NO') END IF END DO diff --git a/src/motion/helium_methods.F b/src/motion/helium_methods.F index 7802fc8038..43510a602f 100644 --- a/src/motion/helium_methods.F +++ b/src/motion/helium_methods.F @@ -152,7 +152,7 @@ CONTAINS num_env = logger%para_env%num_pe END IF CPASSERT(num_env >= 0) - IF (num_env .NE. logger%para_env%num_pe) THEN + IF (num_env /= logger%para_env%num_pe) THEN msg_str = "NUM_ENV not equal to number of processors" CPWARN(msg_str) END IF @@ -181,7 +181,7 @@ CONTAINS END IF NULLIFY (helium_env) - IF (mepos .GT. 0) THEN + IF (mepos > 0) THEN ALLOCATE (helium_env(mepos)) DO k = 1, mepos helium_env(k)%comm => new_comm @@ -299,7 +299,7 @@ CONTAINS explicit=expl_cell) cgeof = 1.0_dp IF (helium_env(k)%helium%periodic) THEN - IF (helium_env(k)%helium%cell_shape .EQ. helium_cell_shape_octahedron) cgeof = 2.0_dp + IF (helium_env(k)%helium%cell_shape == helium_cell_shape_octahedron) cgeof = 2.0_dp END IF rtmp = (cgeof*helium_env(k)%helium%atoms/helium_env(k)%helium%density)**(1.0_dp/3.0_dp) IF (.NOT. expl_cell) THEN @@ -308,7 +308,7 @@ CONTAINS CALL section_vals_val_get(helium_section, "CELL_SIZE", & r_val=helium_env(k)%helium%cell_size) ! only more work if not all three values are consistent: - IF (ABS(helium_env(k)%helium%cell_size - rtmp) .GT. 100.0_dp*EPSILON(0.0_dp)* & + IF (ABS(helium_env(k)%helium%cell_size - rtmp) > 100.0_dp*EPSILON(0.0_dp)* & (ABS(helium_env(k)%helium%cell_size) + rtmp)) THEN IF (expl_dens .AND. expl_nats) THEN msg_str = "DENSITY, NATOMS and CELL_SIZE options "// & @@ -331,7 +331,7 @@ CONTAINS ! (should be a small correction) rtmp = (cgeof*helium_env(k)%helium%atoms/helium_env(k)%helium%density & )**(1.0_dp/3.0_dp) - IF (ABS(helium_env(k)%helium%cell_size - rtmp) .GT. 100.0_dp*EPSILON(0.0_dp) & + IF (ABS(helium_env(k)%helium%cell_size - rtmp) > 100.0_dp*EPSILON(0.0_dp) & *(ABS(helium_env(k)%helium%cell_size) + rtmp)) THEN msg_str = "Adjusting actual cell size "// & "to maintain correct density." @@ -771,7 +771,7 @@ CONTAINS ! set the interaction potential type CALL section_vals_val_get(helium_section, "SOLUTE_INTERACTION", & i_val=helium_env(k)%helium%solute_interaction) - IF (helium_env(k)%helium%solute_interaction .EQ. helium_solute_intpot_nnp) THEN + IF (helium_env(k)%helium%solute_interaction == helium_solute_intpot_nnp) THEN IF (k == 1) THEN NULLIFY (nnp_section) nnp_section => section_vals_get_subs_vals(helium_section, "NNP") @@ -786,7 +786,7 @@ CONTAINS CALL cp_rm_default_logger() CALL cp_logger_release(tmplogger) END IF - IF (helium_env(k)%helium%solute_interaction .EQ. helium_solute_intpot_none) THEN + IF (helium_env(k)%helium%solute_interaction == helium_solute_intpot_none) THEN WRITE (msg_str, '(A,I0,A)') & "Solute found but no helium-solute interaction selected "// & "(see SOLUTE_INTERACTION keyword)" @@ -829,7 +829,7 @@ CONTAINS helium_env(k)%helium%beads*helium_env(k)%helium%num_env)) ALLOCATE (helium_env(k)%helium%ltmp_3_atoms_beads_3d(3, helium_env(k)%helium%atoms, & helium_env(k)%helium%beads)) - IF (k .EQ. 1) THEN + IF (k == 1) THEN CALL helium_write_setup(helium_env(k)%helium) END IF END DO @@ -837,7 +837,7 @@ CONTAINS ELSE ! Deallocate env_all on processors without helium_env DEALLOCATE (env_all) - END IF ! mepos .GT. 0 + END IF ! mepos > 0 NULLIFY (env_all) CALL timestop(handle) @@ -859,7 +859,7 @@ CONTAINS IF (ASSOCIATED(helium_env)) THEN DO k = 1, SIZE(helium_env) - IF (k .EQ. 1) THEN + IF (k == 1) THEN CALL helium_env(k)%comm%free() DEALLOCATE (helium_env(k)%comm) DEALLOCATE (helium_env(k)%env_all) @@ -1506,7 +1506,7 @@ CONTAINS actlen = SIZE(message) num_env_restart = actlen/helium_env(1)%helium%atoms/helium_env(1)%helium%beads/3 - IF (num_env_restart .NE. helium_env(1)%helium%num_env) THEN + IF (num_env_restart /= helium_env(1)%helium%num_env) THEN err_str = "Reading bead coordinates from the input file." CALL helium_write_line(err_str) err_str = "Number of environments in the restart...: '" @@ -1697,7 +1697,7 @@ CONTAINS !TODO maybe add some sanity checks here: ! is num_env_restart integer ? - IF (num_env_restart .NE. helium_env(1)%helium%num_env) THEN + IF (num_env_restart /= helium_env(1)%helium%num_env) THEN err_str = "Reading permutation state from the input file." CALL helium_write_line(err_str) err_str = "Number of environments in the restart...: '" @@ -1963,7 +1963,7 @@ CONTAINS END DO DO i = 1, helium_env(1)%helium%num_env - IF (i .LE. offset .OR. i .GT. offset + SIZE(helium_env)) THEN + IF (i <= offset .OR. i > offset + SIZE(helium_env)) THEN ! only deallocate pointers here which were not passed on to helium_env(*)%helium DEALLOCATE (uniform_array(i)%stream) DEALLOCATE (gaussian_array(i)%stream) @@ -2014,7 +2014,7 @@ CONTAINS num_env_restart = actlen/40 ! check, if RNG restart has the same dimension as helium%num_env - IF (num_env_restart .NE. helium_env(1)%helium%num_env) THEN + IF (num_env_restart /= helium_env(1)%helium%num_env) THEN err_str = "Reading RNG state from the input file." CALL helium_write_line(err_str) err_str = "Number of environments in the restart...: '" @@ -2048,7 +2048,7 @@ CONTAINS ig(:, :) = UNPACK(message(off + 13:off + 18), MASK=m, FIELD=f) bf = message(off + 19) bu = message(off + 20) - IF (bf .GT. 0) THEN + IF (bf > 0) THEN lbf = .TRUE. ELSE lbf = .FALSE. @@ -2060,7 +2060,7 @@ CONTAINS ig(:, :) = UNPACK(message(off + 33:off + 38), MASK=m, FIELD=f) bf = message(off + 39) bu = message(off + 40) - IF (bf .GT. 0) THEN + IF (bf > 0) THEN lbf = .TRUE. ELSE lbf = .FALSE. @@ -2239,7 +2239,7 @@ CONTAINS r_vals=message) msglen = SIZE(message) itmp = SIZE(helium_env(1)%helium%rdf_rstr) - ltmp = (msglen .EQ. itmp) + ltmp = (msglen == itmp) IF (.NOT. ltmp) THEN stmp1 = "" WRITE (stmp1, *) msglen @@ -2247,7 +2247,7 @@ CONTAINS WRITE (stmp2, *) itmp err_str = "Size of the RDF array in the input ("// & TRIM(ADJUSTL(stmp1))// & - ") .NE. that in the runtime ("// & + ") /= that in the runtime ("// & TRIM(ADJUSTL(stmp2))//")." CPABORT(err_str) END IF @@ -2569,7 +2569,7 @@ CONTAINS "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_WDG", & i_vals=helium%rho_min_len_wdg_vals) itmp = SIZE(helium%rho_min_len_wdg_vals) - IF (itmp .GT. 0) THEN + IF (itmp > 0) THEN helium%rho_num_min_len_wdg = itmp helium%rho_num_act = helium%rho_num_act + itmp END IF @@ -2588,7 +2588,7 @@ CONTAINS "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_NON", & i_vals=helium%rho_min_len_non_vals) itmp = SIZE(helium%rho_min_len_non_vals) - IF (itmp .GT. 0) THEN + IF (itmp > 0) THEN helium%rho_num_min_len_non = itmp helium%rho_num_act = helium%rho_num_act + itmp END IF @@ -2607,7 +2607,7 @@ CONTAINS "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_ALL", & i_vals=helium%rho_min_len_all_vals) itmp = SIZE(helium%rho_min_len_all_vals) - IF (itmp .GT. 0) THEN + IF (itmp > 0) THEN helium%rho_num_min_len_all = itmp helium%rho_num_act = helium%rho_num_act + itmp END IF @@ -2665,7 +2665,7 @@ CONTAINS r_vals=message) msglen = SIZE(message) itmp = SIZE(helium_env(1)%helium%rho_rstr) - ltmp = (msglen .EQ. itmp) + ltmp = (msglen == itmp) IF (.NOT. ltmp) THEN stmp1 = "" WRITE (stmp1, *) msglen @@ -2673,7 +2673,7 @@ CONTAINS WRITE (stmp2, *) itmp err_str = "Size of the S density array in the input ("// & TRIM(ADJUSTL(stmp1))// & - ") .NE. that in the runtime ("// & + ") /= that in the runtime ("// & TRIM(ADJUSTL(stmp2))//")." CPABORT(err_str) END IF diff --git a/src/motion/helium_sampling.F b/src/motion/helium_sampling.F index 3dd18b8fbe..56139cbcdf 100644 --- a/src/motion/helium_sampling.F +++ b/src/motion/helium_sampling.F @@ -100,7 +100,7 @@ CONTAINS ! create iteration level ! Although the Helium MC is not really an md it is most of the times ! embedded in the pint code so the same step counter applies. - IF (k .EQ. 1) THEN + IF (k == 1) THEN CALL cp_add_iter_level(helium_env(k)%helium%logger%iter_info, "PINT") CALL cp_iterate(helium_env(k)%helium%logger%iter_info, & iter_nr=helium_env(k)%helium%first_step) @@ -132,7 +132,7 @@ CONTAINS IF (ASSOCIATED(helium_env)) THEN DO k = 1, SIZE(helium_env) - IF (k .EQ. 1) THEN + IF (k == 1) THEN CALL cp_iterate(helium_env(k)%helium%logger%iter_info, & last=(step == helium_env(k)%helium%num_steps), & iter_nr=tot_steps) @@ -388,7 +388,7 @@ CONTAINS ALLOCATE (work_2d(SIZE(helium_env(1)%helium%force_avrg, 1), & SIZE(helium_env(1)%helium%force_avrg, 2))) work_2d(:, :) = 0.0_dp - IF (sel_mp_source .GE. offset .AND. sel_mp_source .LT. offset + SIZE(helium_env)) THEN + IF (sel_mp_source >= offset .AND. sel_mp_source < offset + SIZE(helium_env)) THEN work_2d(:, :) = helium_env(sel_mp_source - offset + 1)%helium%force_avrg(:, :) END IF CALL helium_env(1)%comm%sum(work_2d(:, :)) @@ -534,10 +534,10 @@ CONTAINS time_stop = m_walltime() time_used = time_stop - time_start time_unit = "sec" - IF (time_used .GE. 60.0_dp) THEN + IF (time_used >= 60.0_dp) THEN time_used = time_used/60.0_dp time_unit = "min" - IF (time_used .GE. 60.0_dp) THEN + IF (time_used >= 60.0_dp) THEN time_used = time_used/60.0_dp time_unit = "hours" END IF @@ -588,7 +588,7 @@ CONTAINS IF (helium%maxcycle > 1) CALL helium_update_transition_matrix(helium) ! consecutive calls to helium_slice_metro_cyclic require that - ! ALL(helium%pos.EQ.helium%work) - see a comment there, + ! ALL(helium%pos==helium%work) - see a comment there, ! besides there is a magic regarding helium%permutation ! you have been warned helium%work(:, :, :) = helium%pos(:, :, :) @@ -605,7 +605,7 @@ CONTAINS CASE (helium_mdist_singlev) x = helium%rng_stream_uniform%next() - IF (x .LT. r) THEN + IF (x < r) THEN cyclen = 1 ELSE cyclen = helium%m_value @@ -613,32 +613,32 @@ CONTAINS CASE (helium_mdist_uniform) x = helium%rng_stream_uniform%next() - IF (x .LT. r) THEN + IF (x < r) THEN cyclen = helium%m_value ELSE DO x = helium%rng_stream_uniform%next() cyclen = INT(helium%maxcycle*x) + 1 - IF (cyclen .NE. helium%m_value) EXIT + IF (cyclen /= helium%m_value) EXIT END DO END IF CASE (helium_mdist_linear) x = helium%rng_stream_uniform%next() - IF (x .LT. r) THEN + IF (x < r) THEN cyclen = helium%m_value ELSE DO x = helium%rng_stream_uniform%next() y = SQRT(2.0_dp*x) cyclen = INT(helium%maxcycle*y/SQRT(2.0_dp)) + 1 - IF (cyclen .NE. helium%m_value) EXIT + IF (cyclen /= helium%m_value) EXIT END DO END IF CASE (helium_mdist_quadratic) x = helium%rng_stream_uniform%next() - IF (x .LT. r) THEN + IF (x < r) THEN cyclen = helium%m_value ELSE DO @@ -646,36 +646,36 @@ CONTAINS y = (3.0_dp*x)**(1.0_dp/3.0_dp) z = 3.0_dp**(1.0_dp/3.0_dp) cyclen = INT(helium%maxcycle*y/z) + 1 - IF (cyclen .NE. helium%m_value) EXIT + IF (cyclen /= helium%m_value) EXIT END DO END IF CASE (helium_mdist_exponential) x = helium%rng_stream_uniform%next() - IF (x .LT. r) THEN + IF (x < r) THEN cyclen = helium%m_value ELSE DO DO x = helium%rng_stream_uniform%next() - IF (x .GE. 0.01_dp) EXIT + IF (x >= 0.01_dp) EXIT END DO z = -LOG(0.01_dp) y = LOG(x)/z + 1.0_dp; cyclen = INT(helium%maxcycle*y) + 1 - IF (cyclen .NE. helium%m_value) EXIT + IF (cyclen /= helium%m_value) EXIT END DO END IF CASE (helium_mdist_gaussian) x = helium%rng_stream_uniform%next() - IF (x .LT. r) THEN + IF (x < r) THEN cyclen = 1 ELSE DO x = helium%rng_stream_gaussian%next() cyclen = INT(x*0.75_dp + helium%m_value - 0.5_dp) + 1 - IF (cyclen .NE. 1) EXIT + IF (cyclen /= 1) EXIT END DO END IF @@ -1176,7 +1176,7 @@ CONTAINS END DO bis(:) = bis(:)/helium%beads rtmp = DOT_PRODUCT(bis, bis) - IF (rtmp .GE. helium%droplet_radius**2) THEN + IF (rtmp >= helium%droplet_radius**2) THEN biso(:) = 0.0_dp DO ib = 1, helium%beads DO ic = 1, 3 diff --git a/src/motion/input_cp2k_restarts.F b/src/motion/input_cp2k_restarts.F index c028ccec36..0d61e40eae 100644 --- a/src/motion/input_cp2k_restarts.F +++ b/src/motion/input_cp2k_restarts.F @@ -1166,7 +1166,7 @@ CONTAINS ! ! update the weighting factor itmp = helium_env(1)%helium%averages_iweight - IF (itmp .LT. 0) THEN + IF (itmp < 0) THEN itmp = helium_env(1)%helium%current_step - helium_env(1)%helium%first_step ELSE itmp = itmp + helium_env(1)%helium%current_step - helium_env(1)%helium%first_step diff --git a/src/motion/integrator.F b/src/motion/integrator.F index 50385df0cc..e5df32292a 100644 --- a/src/motion/integrator.F +++ b/src/motion/integrator.F @@ -565,7 +565,7 @@ CONTAINS END IF IF (ehrenfest_md) deallocate_vel = force_env%qs_env%rtp%converged - IF (i_iter .EQ. n_iter) deallocate_vel = .TRUE. + IF (i_iter == n_iter) deallocate_vel = .TRUE. ! Broadcast the new particle velocities and deallocate the full temporary CALL update_dealloc_tmp(tmp, particle_set, shell_particle_set, & core_particle_set, para_env, shell_adiabatic, vel=.TRUE., & diff --git a/src/motion/mc/mc_control.F b/src/motion/mc/mc_control.F index 67d454105a..9884c30bb8 100644 --- a/src/motion/mc/mc_control.F +++ b/src/motion/mc/mc_control.F @@ -127,7 +127,7 @@ CONTAINS ! can't do a simple particles%els%atomic_kind%element_symbol because ! of the classical force_env - IF (nunits_tot .GT. 0) THEN + IF (nunits_tot > 0) THEN nmol_types = SIZE(molecule_kinds%els(:)) iparticle = 1 DO imol_type = 1, nmol_types @@ -228,7 +228,7 @@ CONTAINS CALL group%bcast(nchains, source) ! do some checking - IF (ABS(temperature - mc_temp) .GT. 0.01E0_dp) THEN + IF (ABS(temperature - mc_temp) > 0.01E0_dp) THEN IF (ionode) THEN WRITE (iw, *) 'The temperature in the restart file is ', & 'not the same as the input file.' @@ -237,7 +237,7 @@ CONTAINS END IF CPABORT("Temperature difference between restart and input") END IF - IF (nunits_tot .NE. mc_nunits_tot) THEN + IF (nunits_tot /= mc_nunits_tot) THEN IF (ionode) THEN WRITE (iw, *) 'The total number of units in the restart ', & 'file is not the same as the input file.' @@ -246,7 +246,7 @@ CONTAINS END IF mc_nunits_tot = nunits_tot END IF - IF (ensemble .NE. mc_ensemble) THEN + IF (ensemble /= mc_ensemble) THEN IF (ionode) THEN WRITE (iw, *) 'The ensemble in the restart file is ', & 'not the same as the input file.' @@ -268,9 +268,9 @@ CONTAINS box_length(1:3) = box_length(1:3)/angstrom ! convert to a.u. END IF CALL group%bcast(box_length, source) - IF (ABS(box_length(1) - abc(1)) .GT. 0.0001E0_dp .OR. & - ABS(box_length(2) - abc(2)) .GT. 0.0001E0_dp .OR. & - ABS(box_length(3) - abc(3)) .GT. 0.0001E0_dp) THEN + IF (ABS(box_length(1) - abc(1)) > 0.0001E0_dp .OR. & + ABS(box_length(2) - abc(2)) > 0.0001E0_dp .OR. & + ABS(box_length(3) - abc(3)) > 0.0001E0_dp) THEN IF (ionode) THEN WRITE (iw, *) 'The cell length in the restart file is ', & 'not the same as the input file.' diff --git a/src/motion/mc/mc_coordinates.F b/src/motion/mc/mc_coordinates.F index 604c7739f5..266b9f5ecc 100644 --- a/src/motion/mc/mc_coordinates.F +++ b/src/motion/mc/mc_coordinates.F @@ -514,9 +514,9 @@ CONTAINS trial_energy(imove) = (bias_energy - old_energy) exponent = -BETA*trial_energy(imove) - IF (exponent .GT. exp_max_val) THEN + IF (exponent > exp_max_val) THEN boltz_weights(imove) = max_val - ELSEIF (exponent .LT. exp_min_val) THEN + ELSEIF (exponent < exp_min_val) THEN boltz_weights(imove) = min_val ELSE boltz_weights(imove) = EXP(exponent) @@ -527,7 +527,7 @@ CONTAINS ! now we need to pick a configuration based on the Rosenbluth weight, ! which is just the sum of the Boltzmann weights rosenbluth_weight = SUM(boltz_weights(:)) - IF (rosenbluth_weight .EQ. 0.0_dp .AND. lremove) THEN + IF (rosenbluth_weight == 0.0_dp .AND. lremove) THEN ! should never have 0.0 for an old weight...causes a divide by zero ! in the acceptance rule IF (ionode) THEN @@ -554,7 +554,7 @@ CONTAINS IF (loverlap_array(imove)) CYCLE all_overlaps = .FALSE. total_running_weight = total_running_weight + boltz_weights(imove) - IF (total_running_weight .GE. rand*rosenbluth_weight) THEN + IF (total_running_weight >= rand*rosenbluth_weight) THEN choosen = imove EXIT END IF @@ -787,7 +787,7 @@ CONTAINS ! find which box it's in nchains_tot = 0 DO ibox = 1, SIZE(nchains(molecule_type_old, :)) - IF (molecule_number .LE. nchains(molecule_type_old, ibox)) THEN + IF (molecule_number <= nchains(molecule_type_old, ibox)) THEN box_number = ibox EXIT END IF @@ -821,7 +821,7 @@ CONTAINS ! now which box it's in DO ibox = 1, SUM(nchains(1, :)) - IF (molecule_number .LE. SUM(nchains(:, ibox))) THEN + IF (molecule_number <= SUM(nchains(:, ibox))) THEN box_number = ibox EXIT END IF @@ -881,8 +881,8 @@ CONTAINS length2 = ABS(cell(2) - cell(3)) ! now let's figure out all the different cases - IF (length1 .LT. 0.01_dp*step_size .AND. & - length2 .LT. 0.01_dp*step_size) THEN + IF (length1 < 0.01_dp*step_size .AND. & + length2 < 0.01_dp*step_size) THEN ! all sides are equal, so we can move up or down discrete_array(1:3, 1) = 1 discrete_array(1:3, 2) = 1 @@ -892,13 +892,13 @@ CONTAINS high_value = -1.0_dp low_value = cell(1)*cell(2)*cell(3) DO iside = 1, 3 - IF (cell(iside) .LT. low_value) low_value = cell(iside) - IF (cell(iside) .GT. high_value) high_value = cell(iside) + IF (cell(iside) < low_value) low_value = cell(iside) + IF (cell(iside) > high_value) high_value = cell(iside) END DO DO iside = 1, 3 ! now we see if the value is a high value or a low value...it can only be ! one of the two - IF (ABS(cell(iside) - low_value) .LT. 0.01_dp*step_size) THEN + IF (ABS(cell(iside) - low_value) < 0.01_dp*step_size) THEN ! low value, we can only increase the cell size discrete_array(iside, 1) = 1 discrete_array(iside, 2) = 0 @@ -949,7 +949,7 @@ CONTAINS eta_1 = rng_stream%next() eta_2 = rng_stream%next() eta_sq = eta_1**2 + eta_2**2 - IF (eta_sq .LT. 1.0_dp) THEN + IF (eta_sq < 1.0_dp) THEN r_insert(1) = 2.0_dp*eta_1*SQRT(1.0_dp - eta_sq) r_insert(2) = 2.0_dp*eta_2*SQRT(1.0_dp - eta_sq) r_insert(3) = 1.0_dp - 2.0_dp*eta_sq @@ -982,7 +982,7 @@ CONTAINS dist = RIJ(1)**2 + RIJ(2)**2 + RIJ(3)**2 - IF (dist .LT. rmin**2 .OR. dist .GT. rmax**2) THEN + IF (dist < rmin**2 .OR. dist > rmax**2) THEN EXIT END IF @@ -1072,9 +1072,9 @@ CONTAINS rclussquare = rclus*rclus ! Starting the cluster count loop - DO WHILE (SUM(decision) .LT. nend) + DO WHILE (SUM(decision) < nend) DO nstart = 1, nend - IF (clusmat(nstart) .EQ. 0) THEN + IF (clusmat(nstart) == 0) THEN counter = counter + 1 clusmat(nstart) = counter EXIT @@ -1087,7 +1087,7 @@ CONTAINS nunits_i = nunits(mol_type(imol)) ! Allocating the xcoord,ycoord,zcoord based upon the size of molecule nunits lclus = .FALSE. - IF (clusmat(imol) .EQ. counter .AND. decision(imol) .EQ. 0) THEN + IF (clusmat(imol) == counter .AND. decision(imol) == 0) THEN ALLOCATE (xcoord(nunits_i), ycoord(nunits_i), zcoord(nunits_i)) decision(imol) = 1 lclus = .TRUE. @@ -1102,7 +1102,7 @@ CONTAINS IF (lclus .EQV. .TRUE.) THEN DO jmol = 1, nend nunits_j = nunits(mol_type(jmol)) - IF (clusmat(jmol) .EQ. 0 .AND. decision(jmol) .EQ. 0) THEN + IF (clusmat(jmol) == 0 .AND. decision(jmol) == 0) THEN !Calculating the distance between atoms DO iunit = 1, nunits_i DO junit = 1, nunits_j @@ -1114,7 +1114,7 @@ CONTAINS dz = dz - abc(3)*ANINT(dz/abc(3)) rsquare = (dx*dx) + (dy*dy) + (dz*dz) !Checking the distance based on rclus square(rclussq) - IF (rsquare .LT. rclussquare) THEN + IF (rsquare < rclussquare) THEN clusmat(jmol) = counter END IF END DO @@ -1131,7 +1131,7 @@ CONTAINS DO imol = 1, counter DO jmol = 1, nend - IF (imol .EQ. clusmat(jmol)) THEN + IF (imol == clusmat(jmol)) THEN cluster(imol, jmol) = jmol END IF END DO diff --git a/src/motion/mc/mc_ensembles.F b/src/motion/mc/mc_ensembles.F index 3910cf4286..1d678effe0 100644 --- a/src/motion/mc/mc_ensembles.F +++ b/src/motion/mc/mc_ensembles.F @@ -233,7 +233,7 @@ CONTAINS ALLOCATE (moves(1:nmol_types, 1:nboxes)) ALLOCATE (move_updates(1:nmol_types, 1:nboxes)) - IF (nboxes .GT. 1) THEN + IF (nboxes > 1) THEN DO ibox = 2, nboxes CALL get_mc_par(mc_par(ibox)%mc_par, & data_file=data_file(ibox), & @@ -247,13 +247,13 @@ CONTAINS END IF ! this is a check we can't do in the input checking - IF (pmvol_box(nboxes) .LT. 1.0E0_dp) THEN + IF (pmvol_box(nboxes) < 1.0E0_dp) THEN CPABORT('The last value of PMVOL_BOX needs to be 1.0') END IF - IF (pmclus_box(nboxes) .LT. 1.0E0_dp) THEN + IF (pmclus_box(nboxes) < 1.0E0_dp) THEN CPABORT('The last value of PMVOL_BOX needs to be 1.0') END IF - IF (pmhmc_box(nboxes) .LT. 1.0E0_dp) THEN + IF (pmhmc_box(nboxes) < 1.0E0_dp) THEN CPABORT('The last value of PMHMC_BOX needs to be 1.0') END IF @@ -286,7 +286,7 @@ CONTAINS CALL mc_averages_create(averages(ibox)%averages) ! find the energy of the initial configuration - IF (SUM(nchains(:, ibox)) .NE. 0) THEN + IF (SUM(nchains(:, ibox)) /= 0) THEN CALL force_env_calc_energy_force(force_env(ibox)%force_env, & calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env, & @@ -342,7 +342,7 @@ CONTAINS r_old(:, :, ibox), atom_names_box(:), nunits_tot(ibox), & para_env, abc(:, ibox), nchains_box, input_declaration, mc_bias_file, & ionode) - IF (SUM(nchains(:, ibox)) .NE. 0) THEN + IF (SUM(nchains(:, ibox)) /= 0) THEN CALL force_env_calc_energy_force(bias_env(ibox)%force_env, & calc_force=.FALSE.) CALL force_env_get(bias_env(ibox)%force_env, & @@ -426,7 +426,7 @@ 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 .NE. 1) & + IF (nboxes /= 1) & CPABORT('ldiscrete=.true. ONLY for systems with 1 box') CALL create_discrete_array(abc(:, 1), discrete_array(:, :), & discrete_step) @@ -451,7 +451,7 @@ CONTAINS ! broadcast the random number, to make sure we're on the same move CALL group%bcast(rand, source) - IF (rand .LT. pmvolume) THEN + IF (rand < pmvolume) THEN IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN WRITE (iw, *) "Attempting a volume move" @@ -476,7 +476,7 @@ CONTAINS CALL group%bcast(rand, source) DO ibox = 1, nboxes - IF (rand .LE. pmvol_box(ibox)) THEN + IF (rand <= pmvol_box(ibox)) THEN box_number = ibox EXIT END IF @@ -535,7 +535,7 @@ CONTAINS para_env, abc(:, ibox), nchains_box, input_declaration, & mc_bias_file, ionode) - IF (SUM(nchains(:, ibox)) .NE. 0) THEN + IF (SUM(nchains(:, ibox)) /= 0) THEN CALL force_env_calc_energy_force( & bias_env(ibox)%force_env, & calc_force=.FALSE.) @@ -549,7 +549,7 @@ CONTAINS END DO END IF - ELSEIF (rand .LT. pmswap) THEN + ELSEIF (rand < pmswap) THEN ! try a swap move IF (MOD(nnstep, iprint) == 0 .AND. (iw > 0)) THEN @@ -569,7 +569,7 @@ CONTAINS mol_type=mol_type, nchain_total=nchain_total, nunits=nunits, & atom_names=atom_names, mass=mass) - ELSEIF (rand .LT. 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" @@ -581,7 +581,7 @@ CONTAINS CALL group%bcast(rand, source) DO ibox = 1, nboxes - IF (rand .LE. pmhmc_box(ibox)) THEN + IF (rand <= pmhmc_box(ibox)) THEN box_number = ibox EXIT END IF @@ -595,7 +595,7 @@ CONTAINS energy_check(box_number), r_old(:, :, box_number), & rng_stream) - ELSEIF (rand .LT. 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" @@ -606,8 +606,8 @@ CONTAINS IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) - IF (nboxes .EQ. 2) THEN - IF (rand .LT. 0.1E0_dp) THEN + IF (nboxes == 2) THEN + IF (rand < 0.1E0_dp) THEN box_number = 1 ELSE box_number = 2 @@ -621,7 +621,7 @@ CONTAINS CALL group%bcast(rand, source) molecule_type_swap = 0 DO imol_type = 1, nmol_types - IF (rand .LT. pmavbmc_mol(imol_type)) THEN + IF (rand < pmavbmc_mol(imol_type)) THEN molecule_type_swap = imol_type EXIT END IF @@ -631,7 +631,7 @@ CONTAINS ! now pick a molecule, automatically rejecting the move if the ! box is empty or only has one molecule - IF (SUM(nchains(:, box_number)) .LE. 1) THEN + IF (SUM(nchains(:, box_number)) <= 1) THEN ! indicate that we tried a move moves(molecule_type_swap, box_number)%moves%empty_avbmc = & moves(molecule_type_swap, box_number)%moves%empty_avbmc + 1 @@ -648,7 +648,7 @@ CONTAINS CALL find_mc_test_molecule(mc_molecule_info, & start_atom_target, idum, molecule_type_target, & rng_stream, box=box_number) - IF (start_atom_swap .NE. start_atom_target) THEN + IF (start_atom_swap /= start_atom_target) THEN start_atom_target = start_atom_target + & avbmc_atom(molecule_type_target) - 1 EXIT @@ -665,7 +665,7 @@ CONTAINS CALL group%bcast(start_atom_target, source) CALL group%bcast(rand, source) - IF (rand .LT. pbias(molecule_type_swap)) THEN + IF (rand < pbias(molecule_type_swap)) THEN move_type_avbmc = 'in' ELSE move_type_avbmc = 'out' @@ -695,13 +695,13 @@ CONTAINS IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) - IF (rand .LT. pmtraion) THEN + IF (rand < pmtraion) THEN ! change molecular conformation ! first, pick a box to do it for IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) - IF (nboxes .EQ. 2) THEN - IF (rand .LT. 0.75E0_dp) THEN + IF (nboxes == 2) THEN + IF (rand < 0.75E0_dp) THEN box_number = 1 ELSE box_number = 2 @@ -715,7 +715,7 @@ CONTAINS CALL group%bcast(rand, source) molecule_type = 0 DO imol_type = 1, nmol_types - IF (rand .LT. pmtraion_mol(imol_type)) THEN + IF (rand < pmtraion_mol(imol_type)) THEN molecule_type = imol_type EXIT END IF @@ -747,10 +747,10 @@ CONTAINS CALL group%bcast(molecule_type, source) ! figure out what kind of move we're doing - IF (rand .LT. conf_prob(1, molecule_type)) THEN + IF (rand < conf_prob(1, molecule_type)) THEN move_type = 'bond' - ELSEIF (rand .LT. (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' @@ -766,14 +766,14 @@ CONTAINS move_type, lreject, rng_stream) IF (lreject) EXIT END IF - ELSEIF (rand .LT. pmtrans) THEN + ELSEIF (rand < pmtrans) THEN ! translate a whole molecule in the system ! pick a molecule type IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) molecule_type = 0 DO imol_type = 1, nmol_types - IF (rand .LT. pmtrans_mol(imol_type)) THEN + IF (rand < pmtrans_mol(imol_type)) THEN molecule_type = imol_type EXIT END IF @@ -798,14 +798,14 @@ CONTAINS start_atom, box_number, bias_energy(box_number), & molecule_type, lreject, rng_stream) IF (lreject) EXIT - ELSEIF (rand .LT. 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() CALL group%bcast(rand, source) DO ibox = 1, nboxes - IF (rand .LE. pmclus_box(ibox)) THEN + IF (rand <= pmclus_box(ibox)) THEN box_number = ibox EXIT END IF @@ -826,7 +826,7 @@ CONTAINS CALL group%bcast(rand, source) molecule_type = 0 DO imol_type = 1, nmol_types - IF (rand .LT. pmrot_mol(imol_type)) THEN + IF (rand < pmrot_mol(imol_type)) THEN molecule_type = imol_type EXIT END IF @@ -976,7 +976,7 @@ CONTAINS ! don't care about overlaps if we're only doing HMC IF (.NOT. lhmc) THEN DO ibox = 1, nboxes - IF (SUM(nchains(:, ibox)) .NE. 0) THEN + IF (SUM(nchains(:, ibox)) /= 0) THEN start_mol = 1 DO jbox = 1, ibox - 1 start_mol = start_mol + SUM(nchains(:, jbox)) @@ -1031,7 +1031,7 @@ CONTAINS !debug code IF (debug_this_module) THEN DO ibox = 1, nboxes - IF (SUM(nchains(:, ibox)) .NE. 0) THEN + IF (SUM(nchains(:, ibox)) /= 0) THEN CALL force_env_calc_energy_force(force_env(ibox)%force_env, & calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env, & @@ -1041,7 +1041,7 @@ CONTAINS END IF IF (ABS(initial_energy(ibox) + energy_check(ibox) - & - test_energy) .GT. 0.0000001E0_dp) THEN + test_energy) > 0.0000001E0_dp) THEN IF (iw > 0) THEN WRITE (iw, *) '!!!!!!! We have an energy problem. !!!!!!!!' WRITE (iw, '(A,T64,F16.10)') 'Final Energy = ', test_energy @@ -1066,7 +1066,7 @@ CONTAINS ! calculate the final energy DO ibox = 1, nboxes - IF (SUM(nchains(:, ibox)) .NE. 0) THEN + IF (SUM(nchains(:, ibox)) /= 0) THEN CALL force_env_calc_energy_force(force_env(ibox)%force_env, & calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env, & @@ -1267,10 +1267,10 @@ CONTAINS particles=particles(1)%list) ! check and make sure the box is big enough - IF (abc(1) .NE. abc(2) .OR. abc(2) .NE. abc(3)) THEN + IF (abc(1) /= abc(2) .OR. abc(2) /= abc(3)) THEN CPABORT('The box needs to be cubic for a virial calculation (it is easiest).') END IF - IF (virial_cutoffs(nintegral_divisions) .GT. abc(1)/2.0E0_dp) THEN + IF (virial_cutoffs(nintegral_divisions) > abc(1)/2.0E0_dp) THEN IF (iw > 0) & WRITE (iw, *) "Box length ", abc(1)*angstrom, " virial cutoff ", & virial_cutoffs(nintegral_divisions)*angstrom @@ -1335,7 +1335,7 @@ CONTAINS ! find out what our stepsize is current_division = 0 DO idivision = 1, nintegral_divisions - IF (distance .LT. virial_cutoffs(idivision) - virial_stepsize(idivision)/2.0E0_dp) THEN + IF (distance < virial_cutoffs(idivision) - virial_stepsize(idivision)/2.0E0_dp) THEN current_division = idivision EXIT END IF @@ -1369,9 +1369,9 @@ CONTAINS exponent = -BETA(itemp)*trial_energy - IF (exponent .GT. exp_max_val) THEN + IF (exponent > exp_max_val) THEN exponent = exp_max_val - ELSEIF (exponent .LT. 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 @@ -1398,7 +1398,7 @@ CONTAINS DO current_division = 0 DO idivision = 1, nintegral_divisions - IF (distance .LT. virial_cutoffs(idivision) - virial_stepsize(idivision)/2.0E0_dp) THEN + IF (distance < virial_cutoffs(idivision) - virial_stepsize(idivision)/2.0E0_dp) THEN current_division = idivision EXIT END IF diff --git a/src/motion/mc/mc_ge_moves.F b/src/motion/mc/mc_ge_moves.F index be8ede13c4..8e3e793796 100644 --- a/src/motion/mc/mc_ge_moves.F +++ b/src/motion/mc/mc_ge_moves.F @@ -151,7 +151,7 @@ CONTAINS CALL get_mc_molecule_info(mc_molecule_info, nmol_types=nmol_types, & nchains=nchains, nunits_tot=nunits_tot, nunits=nunits, mol_type=mol_type) - IF (nboxes .GT. 1) THEN + IF (nboxes > 1) THEN DO ibox = 2, nboxes CALL get_mc_par(mc_par(ibox)%mc_par, diff=diff(ibox)) END DO @@ -233,7 +233,7 @@ CONTAINS DO ibox = 1, nboxes ! look for overlap - IF (SUM(nchains(:, ibox)) .NE. 0) THEN + IF (SUM(nchains(:, ibox)) /= 0) THEN ! find the molecule bounds start_mol = 1 DO jbox = 1, ibox - 1 @@ -252,9 +252,9 @@ CONTAINS - (SUM(old_energy(:)) - SUM(bias_energy_old(:)))) ! used to prevent over and underflows - IF (energies .GE. -1.0E-8) THEN + IF (energies >= -1.0E-8) THEN w = 1.0_dp - ELSEIF (energies .LE. -500.0_dp) THEN + ELSEIF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -270,9 +270,9 @@ CONTAINS ELSE energies = -BETA*(SUM(new_energy(:)) - SUM(old_energy(:))) ! used to prevent over and underflows - IF (energies .GE. 0.0_dp) THEN + IF (energies >= 0.0_dp) THEN w = 1.0_dp - ELSEIF (energies .LE. -500.0_dp) THEN + ELSEIF (energies <= -500.0_dp) THEN w = 0.0_dp ELSE w = EXP(energies) @@ -281,7 +281,7 @@ CONTAINS ELSE w = 0.0E0_dp END IF - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE @@ -289,7 +289,7 @@ CONTAINS CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move moves(1, 1)%moves%Quickstep%successes = & @@ -333,7 +333,7 @@ CONTAINS ! update coordinates DO ibox = 1, nboxes - IF (nunits_tot(ibox) .NE. 0) THEN + IF (nunits_tot(ibox) /= 0) THEN DO iparticle = 1, nunits_tot(ibox) r_old(1:3, iparticle, ibox) = & particles(ibox)%list%els(iparticle)%r(1:3) @@ -515,7 +515,7 @@ CONTAINS IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) - IF (rand .LE. 0.50E0_dp) THEN + IF (rand <= 0.50E0_dp) THEN remove_box = 1 insert_box = 2 ELSE @@ -535,7 +535,7 @@ CONTAINS IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) DO itype = 1, nmol_types - IF (rand .LT. pmswap_mol(itype)) THEN + IF (rand < pmswap_mol(itype)) THEN molecule_type = itype EXIT END IF @@ -989,9 +989,9 @@ CONTAINS bias_energy_new(remove_box) - bias_energy_old(insert_box) & - bias_energy_old(remove_box))) - IF (del_quickstep_energy .GT. exp_max_val) THEN + IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSEIF (del_quickstep_energy .LT. 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) @@ -1006,7 +1006,7 @@ CONTAINS END IF ! check if the move is accepted - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN rand = 0.0E0_dp ELSE IF (ionode) rand = rng_stream%next() @@ -1014,7 +1014,7 @@ CONTAINS END IF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move @@ -1245,10 +1245,10 @@ 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 .LE. (3.0E0_dp/angstrom)**3) & + 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') IF (old_cell_length(1, 2)*old_cell_length(2, 2)* & - old_cell_length(3, 2) + vol_dis .LE. (3.0E0_dp/angstrom)**3) & + 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') DO iside = 1, 3 @@ -1288,7 +1288,7 @@ CONTAINS END DO DO imolecule = 1, SUM(nchains(:, ibox)) molecule_type = mol_type(imolecule + molecule_index - 1) - IF (imolecule .NE. 1) THEN + IF (imolecule /= 1) THEN start_atom = start_atom + nunits(mol_type(imolecule + molecule_index - 2)) END IF end_atom = start_atom + nunits(molecule_type) - 1 @@ -1360,7 +1360,7 @@ CONTAINS END IF - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE @@ -1368,7 +1368,7 @@ CONTAINS CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! write cell length, volume, density, and trial displacement to a file IF (ionode) THEN diff --git a/src/motion/mc/mc_misc.F b/src/motion/mc/mc_misc.F index c82d50c21b..3e17d28fd1 100644 --- a/src/motion/mc/mc_misc.F +++ b/src/motion/mc/mc_misc.F @@ -153,7 +153,7 @@ CONTAINS '***************************' WRITE (iw, '(A,T66,F15.8)') "Average Energy [Hartrees]:", & averages%ave_energy - IF (pmswap .GT. 0.0E0_dp) THEN + IF (pmswap > 0.0E0_dp) THEN WRITE (iw, '(A,T66,F15.8)') "Average number of molecules:", & averages%molecules END IF @@ -175,7 +175,7 @@ CONTAINS displacement=rmvolume, lbias=.FALSE., format_string=format_string, & string3=string3) - IF (pmcltrans .GT. 0.0E0_dp) THEN + IF (pmcltrans > 0.0E0_dp) THEN ! Cluster translation moves WRITE (iw, '(A,A)') '-----------------------------------------------------', & @@ -235,9 +235,9 @@ CONTAINS CALL final_move_write(moves%avbmc_outout, string1, string2, iw) ! conformation changes - IF (moves%angle%attempts .GT. 0 .OR. & - moves%bond%attempts .GT. 0 .OR. & - moves%dihedral%attempts .GT. 0) THEN + IF (moves%angle%attempts > 0 .OR. & + moves%bond%attempts > 0 .OR. & + moves%dihedral%attempts > 0) THEN WRITE (iw, '(A,T43,A)') "Conformational Moves", & "Attempted Accepted Percent" WRITE (iw, '(T46,I6,9X,I6,7X,F7.3)') & @@ -294,7 +294,7 @@ CONTAINS string3=string3) ! swap moves - IF (moves%swap%attempts .GT. 0) THEN + IF (moves%swap%attempts > 0) THEN WRITE (iw, '(A,T43,A)') "Swap Moves into this box", & "Attempted Empty Percent" WRITE (iw, '(T46,I6,9X,I6,7X,F7.3)') & @@ -364,7 +364,7 @@ CONTAINS END DO ! see if the energies add up properly - IF (ABS(initial_energy + energy_check - final_energy) .GT. 0.0000001E0_dp) & + IF (ABS(initial_energy + energy_check - final_energy) > 0.0000001E0_dp) & THEN WRITE (iw, *) '!!!!!!! We have an energy problem. !!!!!!!!' WRITE (iw, '(A,T64,F16.10)') 'Final Energy = ', final_energy @@ -403,7 +403,7 @@ CONTAINS REAL(dp), OPTIONAL :: displacement IF (.NOT. PRESENT(format_string)) THEN - IF (move_data%attempts .GT. 0) THEN + IF (move_data%attempts > 0) THEN WRITE (iw, '(A,T43,A)') TRIM(ADJUSTL(string1)), & TRIM(ADJUSTL(string2)) WRITE (iw, '(T46,I6,9X,I6,7X,F7.3)') & @@ -419,7 +419,7 @@ CONTAINS .NOT. PRESENT(displacement)) THEN WRITE (iw, *) 'MISSING FLAGS IN FINAL_MOVE_WRITE' END IF - IF (move_data%attempts .GT. 0) THEN + IF (move_data%attempts > 0) THEN WRITE (iw, '(A,T43,A)') TRIM(ADJUSTL(string1)), & TRIM(ADJUSTL(string2)) WRITE (iw, '(T46,I6,9X,I6,7X,F7.3)') & diff --git a/src/motion/mc/mc_move_control.F b/src/motion/mc/mc_move_control.F index 38bb5333b0..697e29206d 100644 --- a/src/motion/mc/mc_move_control.F +++ b/src/motion/mc/mc_move_control.F @@ -396,7 +396,7 @@ CONTAINS molecule_type ! update the maximum displacement for bond length change - IF (move_updates%bias_bond%attempts .GT. 0) THEN + IF (move_updates%bias_bond%attempts > 0) THEN ! first account for the extreme cases IF (move_updates%bias_bond%successes == 0) THEN @@ -408,8 +408,8 @@ CONTAINS ! now for the middle case test_ratio = REAL(move_updates%bias_bond%successes, dp) & /REAL(move_updates%bias_bond%attempts, dp)/0.5E0_dp - IF (test_ratio .GT. 2.0E0_dp) test_ratio = 2.0E0_dp - IF (test_ratio .LT. 0.5E0_dp) test_ratio = 0.5E0_dp + IF (test_ratio > 2.0E0_dp) test_ratio = 2.0E0_dp + IF (test_ratio < 0.5E0_dp) test_ratio = 0.5E0_dp rmbond(molecule_type) = rmbond(molecule_type)*test_ratio END IF @@ -424,7 +424,7 @@ CONTAINS END IF ! update the maximum displacement for bond angle change - IF (move_updates%bias_angle%attempts .GT. 0) THEN + IF (move_updates%bias_angle%attempts > 0) THEN ! first account for the extreme cases IF (move_updates%bias_angle%successes == 0) THEN @@ -436,13 +436,13 @@ CONTAINS ! now for the middle case test_ratio = REAL(move_updates%bias_angle%successes, dp) & /REAL(move_updates%bias_angle%attempts, dp)/0.5E0_dp - IF (test_ratio .GT. 2.0E0_dp) test_ratio = 2.0E0_dp - IF (test_ratio .LT. 0.5E0_dp) test_ratio = 0.5E0_dp + IF (test_ratio > 2.0E0_dp) test_ratio = 2.0E0_dp + IF (test_ratio < 0.5E0_dp) test_ratio = 0.5E0_dp rmangle(molecule_type) = rmangle(molecule_type)*test_ratio END IF ! more than pi changes meaningless - IF (rmangle(molecule_type) .GT. pi) rmangle(molecule_type) = pi + IF (rmangle(molecule_type) > pi) rmangle(molecule_type) = pi ! clear the counters move_updates%bias_angle%attempts = 0 @@ -454,7 +454,7 @@ CONTAINS END IF ! update the maximum displacement for a dihedral change - IF (move_updates%bias_dihedral%attempts .GT. 0) THEN + IF (move_updates%bias_dihedral%attempts > 0) THEN ! first account for the extreme cases IF (move_updates%bias_dihedral%successes == 0) THEN @@ -466,13 +466,13 @@ CONTAINS ! now for the middle case test_ratio = REAL(move_updates%bias_dihedral%successes, dp) & /REAL(move_updates%bias_dihedral%attempts, dp)/0.5E0_dp - IF (test_ratio .GT. 2.0E0_dp) test_ratio = 2.0E0_dp - IF (test_ratio .LT. 0.5E0_dp) test_ratio = 0.5E0_dp + IF (test_ratio > 2.0E0_dp) test_ratio = 2.0E0_dp + IF (test_ratio < 0.5E0_dp) test_ratio = 0.5E0_dp rmdihedral(molecule_type) = rmdihedral(molecule_type)*test_ratio END IF ! more than pi changes meaningless - IF (rmdihedral(molecule_type) .GT. pi) rmdihedral(molecule_type) = pi + IF (rmdihedral(molecule_type) > pi) rmdihedral(molecule_type) = pi ! clear the counters move_updates%bias_dihedral%attempts = 0 @@ -484,7 +484,7 @@ CONTAINS END IF ! update the maximum displacement for molecule translation - IF (move_updates%bias_trans%attempts .GT. 0) THEN + IF (move_updates%bias_trans%attempts > 0) THEN ! first account for the extreme cases IF (move_updates%bias_trans%successes == 0) THEN @@ -496,13 +496,13 @@ CONTAINS ! now for the middle case test_ratio = REAL(move_updates%bias_trans%successes, dp) & /REAL(move_updates%bias_trans%attempts, dp)/0.5E0_dp - IF (test_ratio .GT. 2.0E0_dp) test_ratio = 2.0E0_dp - IF (test_ratio .LT. 0.5E0_dp) test_ratio = 0.5E0_dp + IF (test_ratio > 2.0E0_dp) test_ratio = 2.0E0_dp + IF (test_ratio < 0.5E0_dp) test_ratio = 0.5E0_dp rmtrans(molecule_type) = rmtrans(molecule_type)*test_ratio END IF ! make an upper bound...10 a.u. - IF (rmtrans(molecule_type) .GT. 10.0E0_dp) & + IF (rmtrans(molecule_type) > 10.0E0_dp) & rmtrans(molecule_type) = 10.0E0_dp ! clear the counters @@ -515,7 +515,7 @@ CONTAINS END IF ! update the maximum displacement for cluster translation - IF (move_updates%bias_cltrans%attempts .GT. 0) THEN + IF (move_updates%bias_cltrans%attempts > 0) THEN ! first account for the extreme cases IF (move_updates%bias_cltrans%successes == 0) THEN @@ -527,13 +527,13 @@ CONTAINS ! now for the middle case test_ratio = REAL(move_updates%bias_cltrans%successes, dp) & /REAL(move_updates%bias_cltrans%attempts, dp)/0.5E0_dp - IF (test_ratio .GT. 2.0E0_dp) test_ratio = 2.0E0_dp - IF (test_ratio .LT. 0.5E0_dp) test_ratio = 0.5E0_dp + IF (test_ratio > 2.0E0_dp) test_ratio = 2.0E0_dp + IF (test_ratio < 0.5E0_dp) test_ratio = 0.5E0_dp rmcltrans = rmcltrans*test_ratio END IF ! make an upper bound...10 a.u. - IF (rmcltrans .GT. 10.0E0_dp) & + IF (rmcltrans > 10.0E0_dp) & rmcltrans = 10.0E0_dp ! clear the counters @@ -546,31 +546,31 @@ CONTAINS END IF ! update the maximum displacement for molecule rotation - IF (move_updates%bias_rot%attempts .GT. 0) THEN + IF (move_updates%bias_rot%attempts > 0) THEN ! first account for the extreme cases IF (move_updates%bias_rot%successes == 0) THEN rmrot = rmrot/2.0E0_dp - IF (rmrot(molecule_type) .GT. pi) rmrot(molecule_type) = pi + IF (rmrot(molecule_type) > pi) rmrot(molecule_type) = pi 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 - IF (rmrot(molecule_type) .GT. pi) rmrot(molecule_type) = pi + IF (rmrot(molecule_type) > pi) rmrot(molecule_type) = pi ELSE ! now for the middle case test_ratio = REAL(move_updates%bias_rot%successes, dp) & /REAL(move_updates%bias_rot%attempts, dp)/0.5E0_dp - IF (test_ratio .GT. 2.0E0_dp) test_ratio = 2.0E0_dp - IF (test_ratio .LT. 0.5E0_dp) test_ratio = 0.5E0_dp + IF (test_ratio > 2.0E0_dp) test_ratio = 2.0E0_dp + IF (test_ratio < 0.5E0_dp) test_ratio = 0.5E0_dp rmrot(molecule_type) = rmrot(molecule_type)*test_ratio ! more than pi rotation is meaningless - IF (rmrot(molecule_type) .GT. pi) rmrot(molecule_type) = pi + IF (rmrot(molecule_type) > pi) rmrot(molecule_type) = pi END IF @@ -586,7 +586,7 @@ CONTAINS CASE ("volume") ! update the maximum displacement for volume displacement - IF (move_updates%volume%attempts .NE. 0) THEN + IF (move_updates%volume%attempts /= 0) THEN ! first account for the extreme cases IF (move_updates%volume%successes == 0) THEN @@ -599,8 +599,8 @@ CONTAINS ! now for the middle case test_ratio = REAL(move_updates%volume%successes, dp)/ & REAL(move_updates%volume%attempts, dp)/0.5E0_dp - IF (test_ratio .GT. 2.0E0_dp) test_ratio = 2.0E0_dp - IF (test_ratio .LT. 0.5E0_dp) test_ratio = 0.5E0_dp + IF (test_ratio > 2.0E0_dp) test_ratio = 2.0E0_dp + IF (test_ratio < 0.5E0_dp) test_ratio = 0.5E0_dp rmvolume = rmvolume*test_ratio END IF diff --git a/src/motion/mc/mc_moves.F b/src/motion/mc/mc_moves.F index 722b22fb97..826abea97f 100644 --- a/src/motion/mc/mc_moves.F +++ b/src/motion/mc/mc_moves.F @@ -99,8 +99,8 @@ CONTAINS INTEGER :: iatom DO iatom = 1, 6 - IF (connectivity(iatom, current_atom) .NE. 0) THEN - IF (connectivity(iatom, current_atom) .NE. avoid_atom) THEN + IF (connectivity(iatom, current_atom) /= 0) THEN + IF (connectivity(iatom, current_atom) /= avoid_atom) THEN atom(connectivity(iatom, current_atom)) = 1 CALL depth_first_search(connectivity(iatom, current_atom), & current_atom, connectivity, atom) @@ -336,9 +336,9 @@ CONTAINS ! correction factor for the change in phase space...dis_length is ! made unitless in change_bond_length value = -BETA*(bias_energy_new - bias_energy_old) - IF (value .GT. exp_max_val) THEN + IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value .LT. exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value)*dis_length**2 @@ -346,7 +346,7 @@ CONTAINS END IF - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE @@ -356,7 +356,7 @@ CONTAINS CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move IF (move_type == 'bond') THEN @@ -579,9 +579,9 @@ CONTAINS potential_energy=bias_energy_new) ! accept or reject the move based on the Metropolis rule value = -BETA*(bias_energy_new - bias_energy_old) - IF (value .GT. exp_max_val) THEN + IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value .LT. exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -589,7 +589,7 @@ CONTAINS END IF - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE @@ -597,7 +597,7 @@ CONTAINS CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move moves%bias_trans%successes = moves%bias_trans%successes + 1 @@ -778,9 +778,9 @@ CONTAINS ! 1,2,3 with equal prob dir = INT(3*rand) + 1 - IF (dir .EQ. 1) THEN + IF (dir == 1) THEN lx = .TRUE. - ELSEIF (dir .EQ. 2) THEN + ELSEIF (dir == 2) THEN ly = .TRUE. END IF @@ -882,9 +882,9 @@ CONTAINS potential_energy=bias_energy_new) ! accept or reject the move based on the Metropolis rule value = -BETA*(bias_energy_new - bias_energy_old) - IF (value .GT. exp_max_val) THEN + IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value .LT. exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -892,7 +892,7 @@ CONTAINS END IF - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE @@ -900,7 +900,7 @@ CONTAINS CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move moves%bias_rot%successes = moves%bias_rot%successes + 1 @@ -1053,7 +1053,7 @@ CONTAINS ! find the test cell lengths for the discrete volume move IF (ldiscrete) THEN - IF (rand .LT. 0.5_dp) THEN + IF (rand < 0.5_dp) THEN lincrease = .TRUE. ELSE lincrease = .FALSE. @@ -1067,7 +1067,7 @@ CONTAINS IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) iside_change = CEILING(3.0_dp*rand) - IF (discrete_array(iside_change, 1) .EQ. 1) THEN + IF (discrete_array(iside_change, 1) == 1) THEN new_cell_length(iside_change) = & new_cell_length(iside_change) + discrete_step EXIT @@ -1078,7 +1078,7 @@ CONTAINS IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) iside_change = CEILING(3.0_dp*rand) - IF (discrete_array(iside_change, 2) .EQ. 1) THEN + IF (discrete_array(iside_change, 2) == 1) THEN new_cell_length(iside_change) = & new_cell_length(iside_change) - discrete_step EXIT @@ -1094,7 +1094,7 @@ CONTAINS ! WRITE(output_unit,*) '************************ be sure to change back!',& ! old_cell_length(1),14.64_dp/angstrom ! vol_dis=-56.423592_dp/angstrom**3 -! IF(old_cell_length(1) .LE. 14.64_dp/angstrom) THEN +! IF(old_cell_length(1) <= 14.64_dp/angstrom) THEN ! vol_dis=0.0_dp ! WRITE(output_unit,*) 'Found the correct box length!' ! ENDIF @@ -1103,7 +1103,7 @@ CONTAINS old_cell_length(1)*old_cell_length(2)* & old_cell_length(3) - IF (temp_var .LE. 0.0E0_dp) THEN + IF (temp_var <= 0.0E0_dp) THEN loverlap = .TRUE. ! cannot have a negative volume ELSE new_cell_length(1) = (temp_var)**(1.0E0_dp/3.0E0_dp) @@ -1194,11 +1194,11 @@ CONTAINS ! stop if we're trying to change a box to a boxlength smaller than rcut IF (ionode) THEN ltoo_small = .FALSE. - IF (force_env%in_use .EQ. use_fist_force) THEN + IF (force_env%in_use == use_fist_force) THEN CALL get_mc_par(mc_par, rcut=rcut) - IF (new_cell_length(1) .LT. 2.0_dp*rcut) ltoo_small = .TRUE. - IF (new_cell_length(2) .LT. 2.0_dp*rcut) ltoo_small = .TRUE. - IF (new_cell_length(3) .LT. 2.0_dp*rcut) ltoo_small = .TRUE. + IF (new_cell_length(1) < 2.0_dp*rcut) ltoo_small = .TRUE. + IF (new_cell_length(2) < 2.0_dp*rcut) ltoo_small = .TRUE. + IF (new_cell_length(3) < 2.0_dp*rcut) ltoo_small = .TRUE. IF (ltoo_small) THEN WRITE (iw, *) 'new_cell_lengths ', & @@ -1225,9 +1225,9 @@ CONTAINS pressure_term = pressure*vol_dis value = -BETA*(energy_term + volume_term + pressure_term) - IF (value .GT. exp_max_val) THEN + IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value .LT. exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -1237,7 +1237,7 @@ CONTAINS ! w=1.0E0_dp ! w=0.0E0_dp - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE @@ -1245,7 +1245,7 @@ CONTAINS CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move moves%volume%successes = moves%volume%successes + 1 @@ -1645,7 +1645,7 @@ CONTAINS ! 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 IF (DOT_PRODUCT(cross_prod_plane(1:3), r_new(1:3, iatom)) & - .LT. 0.0_dp) THEN + < 0.0_dp) THEN ! need to figure out the current iatom-B-bisector angle, so we know what the new angle is new_angle_a = ACOS(DOT_PRODUCT(bisector, temp(1:3))/ & @@ -1672,7 +1672,7 @@ CONTAINS ! 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 IF (DOT_PRODUCT(cross_prod_plane(1:3), r_new(1:3, iatom)) & - .LT. 0.0_dp) THEN + < 0.0_dp) THEN ! need to figure out the current iatom-B-bisector angle, so we know what the new angle is new_angle_c = ACOS(DOT_PRODUCT(bisector(1:3), temp(1:3))/ & (temp_length)) - dis_angle_c @@ -2052,7 +2052,7 @@ CONTAINS (particles%els(start_atom_swap + avbmc_atom(molecule_type) - 1)%r(3) - & particles%els(target_atom)%r(3))/abc(3)) distance = SQRT(RIJ(1)**2 + RIJ(2)**2 + RIJ(3)**2) - IF (distance .LE. avbmc_rmax(molecule_type) .AND. distance .GE. avbmc_rmin(molecule_type)) THEN + IF (distance <= avbmc_rmax(molecule_type) .AND. distance >= avbmc_rmin(molecule_type)) THEN lin = .TRUE. ELSE lin = .FALSE. @@ -2227,9 +2227,9 @@ CONTAINS del_quickstep_energy = (-BETA)*(new_energy - old_energy - & (bias_energy_new - bias_energy_old)) - IF (del_quickstep_energy .GT. exp_max_val) THEN + IF (del_quickstep_energy > exp_max_val) THEN del_quickstep_energy = max_val - ELSEIF (del_quickstep_energy .LT. 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) @@ -2244,14 +2244,14 @@ CONTAINS END IF ! check if the move is accepted - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN rand = 0.0E0_dp ELSE IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move @@ -2414,15 +2414,15 @@ CONTAINS energy_term = new_energy + hmc_ekin%final_ekin - old_energy - hmc_ekin%initial_ekin value = -BETA*(energy_term) - IF (value .GT. exp_max_val) THEN + IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value .LT. exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) END IF - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE @@ -2430,7 +2430,7 @@ CONTAINS CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move moves%hmc%successes = moves%hmc%successes + 1 @@ -2604,7 +2604,7 @@ CONTAINS ! do the cluster move DO cstart = 1, nend imol = 0 - IF (cluster(jpart, cstart) .NE. 0) THEN + IF (cluster(jpart, cstart) /= 0) THEN imol = cluster(jpart, cstart) iunit = 1 DO ipart = 1, imol - 1 @@ -2650,11 +2650,11 @@ CONTAINS ! check if cluster size changes then reject the move IF (lbias) THEN - IF (total_clusafmo .NE. total_clus) THEN + IF (total_clusafmo /= total_clus) THEN loverlap = .TRUE. END IF ELSE - IF (total_clusafmo .NE. total_clus) THEN + IF (total_clusafmo /= total_clus) THEN loverlap = .TRUE. lreject = .TRUE. END IF @@ -2672,9 +2672,9 @@ CONTAINS potential_energy=bias_energy_new) ! accept or reject the move based on the Metropolis rule value = -BETA*(bias_energy_new - bias_energy_old) - IF (value .GT. exp_max_val) THEN + IF (value > exp_max_val) THEN w = 10.0_dp - ELSEIF (value .LT. exp_min_val) THEN + ELSEIF (value < exp_min_val) THEN w = 0.0_dp ELSE w = EXP(value) @@ -2682,14 +2682,14 @@ CONTAINS END IF - IF (w .GE. 1.0E0_dp) THEN + IF (w >= 1.0E0_dp) THEN w = 1.0E0_dp rand = 0.0E0_dp ELSE IF (ionode) rand = rng_stream%next() CALL group%bcast(rand, source) END IF - IF (rand .LT. w) THEN + IF (rand < w) THEN ! accept the move moves%bias_cltrans%successes = moves%bias_cltrans%successes + 1 diff --git a/src/motion/mc/mc_run.F b/src/motion/mc/mc_run.F index 7ad6084615..c9bfaa0de1 100644 --- a/src/motion/mc/mc_run.F +++ b/src/motion/mc/mc_run.F @@ -276,7 +276,7 @@ CONTAINS END DO ! if we're doing a classical simulation, figure out the largest ! potential cutoff and write it to the screen - IF (force_env(1)%force_env%in_use .EQ. use_fist_force) THEN + IF (force_env(1)%force_env%in_use == use_fist_force) THEN CALL find_mc_rcut(mc_par(1)%mc_par, force_env(1)%force_env, lterminate) CALL get_mc_par(mc_par(1)%mc_par, rcut=rcut) IF (iw > 0) WRITE (iw, '( A,T73,F8.4 )') & diff --git a/src/motion/mc/mc_types.F b/src/motion/mc/mc_types.F index ab5243676a..76aed5e3b6 100644 --- a/src/motion/mc/mc_types.F +++ b/src/motion/mc/mc_types.F @@ -969,7 +969,7 @@ CONTAINS nlines = 0 DO READ (unit, '(A)', IOSTAT=io_stat) line - IF (io_stat .NE. 0) EXIT + IF (io_stat /= 0) EXIT nlines = nlines + 1 END DO @@ -1085,7 +1085,7 @@ CONTAINS mc_input_file%mol_set_nmol_column(irep) = mc_input_file%mol_set_nmol_column(irep) + 5 END DO - IF (irep .NE. nmol_types) THEN + IF (irep /= nmol_types) THEN IF (iw > 0) THEN WRITE (iw, *) WRITE (iw, *) 'File name ', input_file_name @@ -1172,7 +1172,7 @@ CONTAINS index_string = -1 index_string = INDEX(text(iline), string_search(1:string_size)) - IF (index_string .GT. 0) THEN ! we found one + IF (index_string > 0) THEN ! we found one IF (.NOT. lend) THEN row_number = iline column_number = index_string @@ -1183,7 +1183,7 @@ CONTAINS ! now we find the &END that matches up with this one... ! I need proper indentation because I'm not very smart text_temp = text(jline) - IF (text_temp(column_number:column_number) .EQ. "&") THEN + IF (text_temp(column_number:column_number) == "&") THEN row_number = jline EXIT END IF @@ -1330,7 +1330,7 @@ CONTAINS END IF IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_i_array) .NE. nmol_types) THEN + IF (SIZE(temp_i_array) /= nmol_types) THEN CPABORT('AVBMC_ATOM must have as many values as there are molecule types.') END IF END IF @@ -1379,7 +1379,7 @@ CONTAINS ! all of these arrays should have one value for each type of molecule...so check that CALL section_vals_val_get(mc_section, "AVBMC%AVBMC_RMIN", r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('AVBMC_RMIN must have as many values as there are molecule types.') END IF END IF @@ -1388,7 +1388,7 @@ CONTAINS END DO CALL section_vals_val_get(mc_section, "AVBMC%AVBMC_RMAX", r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('AVBMC_RMAXL must have as many values as there are molecule types.') END IF END IF @@ -1397,7 +1397,7 @@ CONTAINS END DO CALL section_vals_val_get(mc_section, "AVBMC%PBIAS", r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('PBIAS must have as many values as there are molecule types.') END IF END IF @@ -1407,7 +1407,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MOVE_PROBABILITIES%MOL_PROBABILITIES%PMAVBMC_MOL", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('PMAVBMC_MOL must have as many values as there are molecule types.') END IF END IF @@ -1416,7 +1416,7 @@ CONTAINS END DO CALL section_vals_val_get(mc_section, "ETA", r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('ETA must have as many values as there are molecule types.') END IF END IF @@ -1426,7 +1426,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMBOND", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('RMBOND must have as many values as there are molecule types.') END IF END IF @@ -1436,7 +1436,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMANGLE", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('RMANGLE must have as many values as there are molecule types.') END IF END IF @@ -1446,7 +1446,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMDIHEDRAL", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('RMDIHEDRAL must have as many values as there are molecule types.') END IF END IF @@ -1456,7 +1456,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMROT", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('RMROT must have as many values as there are molecule types.') END IF END IF @@ -1466,7 +1466,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMTRANS", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('RMTRANS must have as many values as there are molecule types.') END IF END IF @@ -1477,7 +1477,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MOVE_PROBABILITIES%MOL_PROBABILITIES%PMTRAION_MOL", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('PMTRAION_MOL must have as many values as there are molecule types.') END IF END IF @@ -1488,7 +1488,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MOVE_PROBABILITIES%MOL_PROBABILITIES%PMTRANS_MOL", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('PMTRANS_MOL must have as many values as there are molecule types.') END IF END IF @@ -1499,7 +1499,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MOVE_PROBABILITIES%MOL_PROBABILITIES%PMROT_MOL", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('PMROT_MOL must have as many values as there are molecule types.') END IF END IF @@ -1510,7 +1510,7 @@ CONTAINS CALL section_vals_val_get(mc_section, "MOVE_PROBABILITIES%MOL_PROBABILITIES%PMSWAP_MOL", & r_vals=temp_r_array) IF (.NOT. mc_par%lhmc) THEN - IF (SIZE(temp_r_array) .NE. nmol_types) THEN + IF (SIZE(temp_r_array) /= nmol_types) THEN CPABORT('PMSWAP_MOL must have as many values as there are molecule types.') END IF END IF @@ -1608,7 +1608,7 @@ CONTAINS WRITE (iw, format_string) ' MC| AVBMC outer cutoff [ang]', & mc_par%avbmc_rmax END IF - IF (mc_par%ensemble .EQ. 'GEMC-NVT') THEN + IF (mc_par%ensemble == 'GEMC-NVT') THEN WRITE (iw, '( A,T58,A)') ' MC| Box 2 file', & TRIM(mc_par%box2_file) END IF @@ -1655,7 +1655,7 @@ CONTAINS ELSE WRITE (iw, '(A)') ' MC| The moves will not be biased,' END IF - IF (mc_par%nmoves .EQ. 1) THEN + IF (mc_par%nmoves == 1) THEN WRITE (iw, '(A,A)') ' MC| A full energy calculation ', & 'will be done at every step.' ELSE @@ -1751,7 +1751,7 @@ 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 .GT. rcutsq_max) & + IF (potparm%pot(itype, jtype)%pot%rcutsq > rcutsq_max) & rcutsq_max = potparm%pot(itype, jtype)%pot%rcutsq END DO END DO @@ -1760,7 +1760,7 @@ CONTAINS ! value mc_par%rcut = rcutsq_max**0.5_dp DO itype = 1, 3 - IF (abc(itype) .LT. 2.0_dp*mc_par%rcut) THEN + IF (abc(itype) < 2.0_dp*mc_par%rcut) THEN lterminate = .TRUE. END IF END DO @@ -1856,7 +1856,7 @@ CONTAINS molecule_kind => molecule_kinds(ibox)%list%els(imolecule) CALL get_molecule_kind(molecule_kind, name=names_init(itype), & natom=natom) - IF (natom .GT. natoms_large) natoms_large = natom + IF (natom > natoms_large) natoms_large = natom itype = itype + 1 END DO END DO @@ -1865,7 +1865,7 @@ CONTAINS DO itype = 1, ntypes lnew_type = .TRUE. DO jtype = 1, itype - 1 - IF (TRIM(names_init(itype)) .EQ. TRIM(names_init(jtype))) & + IF (TRIM(names_init(itype)) == TRIM(names_init(jtype))) & lnew_type = .FALSE. END DO IF (lnew_type) THEN @@ -1893,7 +1893,7 @@ CONTAINS IF (ibox == skip_box) CYCLE DO imolecule = 1, SIZE(molecule_kinds(ibox)%list%els(:)) itype = itype + 1 - IF (names_init(itype) .EQ. '') CYCLE + IF (names_init(itype) == '') CYCLE iunique = iunique + 1 mc_molecule_info%names(iunique) = names_init(itype) molecule_kind => molecule_kinds(ibox)%list%els(imolecule) @@ -1939,7 +1939,7 @@ CONTAINS molecule_kind => molecule_kinds(ibox)%list%els(imolecule) CALL get_molecule_kind(molecule_kind, nmolecule=nmolecule, & name=name) - IF (TRIM(name) .NE. mc_molecule_info%names(iunique)) CYCLE + IF (TRIM(name) /= mc_molecule_info%names(iunique)) CYCLE mc_molecule_info%nchains(iunique, ibox) = mc_molecule_info%nchains(iunique, ibox) + nmolecule END DO END DO @@ -1973,7 +1973,7 @@ CONTAINS ! figure out which molecule number this is this_molecule = 0 DO iunique = 1, nmol_types - IF (TRIM(name) .EQ. TRIM(mc_molecule_info%names(iunique))) THEN + IF (TRIM(name) == TRIM(mc_molecule_info%names(iunique))) THEN this_molecule = iunique END IF END DO @@ -2047,19 +2047,19 @@ CONTAINS ! the final value of these arrays needs to be 1.0, otherwise there is ! a chance we won't select a molecule type for a move - IF (mc_par%pmavbmc_mol(nmol_types) .LT. 0.9999E0_dp) THEN + IF (mc_par%pmavbmc_mol(nmol_types) < 0.9999E0_dp) THEN CPABORT('The last value of PMAVBMC_MOL needs to be 1.0') END IF - IF (mc_par%pmswap_mol(nmol_types) .LT. 0.9999E0_dp) THEN + IF (mc_par%pmswap_mol(nmol_types) < 0.9999E0_dp) THEN CPABORT('The last value of PMSWAP_MOL needs to be 1.0') END IF - IF (mc_par%pmtraion_mol(nmol_types) .LT. 0.9999E0_dp) THEN + IF (mc_par%pmtraion_mol(nmol_types) < 0.9999E0_dp) THEN CPABORT('The last value of PMTRAION_MOL needs to be 1.0') END IF - IF (mc_par%pmtrans_mol(nmol_types) .LT. 0.9999E0_dp) THEN + IF (mc_par%pmtrans_mol(nmol_types) < 0.9999E0_dp) THEN CPABORT('The last value of PMTRANS_MOL needs to be 1.0') END IF - IF (mc_par%pmrot_mol(nmol_types) .LT. 0.9999E0_dp) THEN + IF (mc_par%pmrot_mol(nmol_types) < 0.9999E0_dp) THEN CPABORT('The last value of PMROT_MOL needs to be 1.0') END IF @@ -2068,25 +2068,25 @@ CONTAINS ! some ensembles require multiple boxes or molecule types SELECT CASE (mc_par%ensemble) CASE ("GEMC_NPT") - IF (nmol_types .LE. 1) & + IF (nmol_types <= 1) & CPABORT('Cannot have GEMC-NPT simulation with only one molecule type') - IF (nboxes .LE. 1) & + IF (nboxes <= 1) & CPABORT('Cannot have GEMC-NPT simulation with only one box') CASE ("GEMC_NVT") - IF (nboxes .LE. 1) & + IF (nboxes <= 1) & CPABORT('Cannot have GEMC-NVT simulation with only one box') CASE ("TRADITIONAL") - IF (mc_par%pmswap .GT. 0.0E0_dp) & + IF (mc_par%pmswap > 0.0E0_dp) & CPABORT('You cannot do swap moves in a system with only one box') CASE ("VIRIAL") - IF (nchain_total .NE. 2) & + IF (nchain_total /= 2) & CPABORT('You need exactly two molecules in the box to compute the second virial.') END SELECT ! can't choose an AVBMC target atom number higher than the number ! of units in that molecule DO imol_type = 1, nmol_types - IF (mc_par%avbmc_atom(imol_type) .GT. nunits(imol_type)) THEN + IF (mc_par%avbmc_atom(imol_type) > nunits(imol_type)) THEN CPABORT('Cannot have avbmc_atom higher than the number of atoms for that molecule type!') END IF END DO diff --git a/src/motion/md_energies.F b/src/motion/md_energies.F index f922b8df28..10e43ca44e 100644 --- a/src/motion/md_energies.F +++ b/src/motion/md_energies.F @@ -790,7 +790,7 @@ CONTAINS END IF END IF WRITE (iw, '(T2,A)') 'MD| '//REPEAT('*', 75) - IF (max_memory .NE. 0) THEN + IF (max_memory /= 0) THEN WRITE (iw, '(T2,A,T73,I8)') & 'MD| Estimated peak process memory after this step [MiB]', & (max_memory + (1024*1024) - 1)/(1024*1024) diff --git a/src/motion/md_util.F b/src/motion/md_util.F index 9a38f420e7..8e3fe4169b 100644 --- a/src/motion/md_util.F +++ b/src/motion/md_util.F @@ -136,7 +136,7 @@ CONTAINS unit_number=unit_nr) ! the first record contains one integer giving degrees of freedom READ (unit_nr) dof - IF (dof .GT. SIZE(eigenvalues)) THEN + IF (dof > SIZE(eigenvalues)) THEN CPABORT("Too many DoFs found in "//filename) END IF ! the second record contains the eigenvalues diff --git a/src/motion/md_vel_utils.F b/src/motion/md_vel_utils.F index 87a98ef82f..c0ef72ffe7 100644 --- a/src/motion/md_vel_utils.F +++ b/src/motion/md_vel_utils.F @@ -153,7 +153,7 @@ CONTAINS DO i = 1, SIZE(part) atomic_kind => part(i)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, mass=mass) - IF (mass .NE. 0.0) THEN + IF (mass /= 0.0) THEN SELECT CASE (is_fixed(i)) CASE (use_perd_x, use_perd_y, use_perd_z, use_perd_xy, use_perd_xz, use_perd_yz, use_perd_none) vcom(1) = vcom(1) + part(i)%v(1)*mass @@ -909,7 +909,7 @@ CONTAINS dof, & eigenvalues, & eigenvectors) - IF (my_dof .NE. dof) THEN + IF (my_dof /= dof) THEN CALL cp_abort(__LOCATION__, & "number of degrees of freedom in vibrational analysis data "// & "do not match total number of cartesian degrees of freedom") @@ -920,7 +920,7 @@ CONTAINS ! generate random numbers random_stream = rng_stream_type(name="MD_INIT_VIB", distribution_type=UNIFORM) CALL random_stream%fill(random) - IF (my_phase .LT. 0.0_dp) THEN + IF (my_phase < 0.0_dp) THEN CALL random_stream%fill(phase) ELSE phase = my_phase @@ -1023,7 +1023,7 @@ CONTAINS ! the cores and shells must also move by the same amount. The ! shell positions will then be optimised if needed shell_index = particles(iatom)%shell_index - IF (shell_index .NE. 0) THEN + IF (shell_index /= 0) THEN core_particles(shell_index)%r(:) = core_particles(shell_index)%r(:) + & dr(:, iatom) shell_particles(shell_index)%r(:) = shell_particles(shell_index)%r(:) + & @@ -1085,7 +1085,7 @@ CONTAINS ! first three modes are acoustic with zero frequencies. These are ! excluded from considerations, and should have been reflected in ! the calculation of scale outside this function - IF (mass .GT. 0.0_dp) THEN + IF (mass > 0.0_dp) THEN ! eigenvector rows assumed to be grouped in atomic blocks ind = (iatom - 1)*3 + icart DO imode = 4, dof @@ -1141,7 +1141,7 @@ CONTAINS ! first three modes are acoustic with zero frequencies. These are ! excluded from considerations, and should have been reflected in ! the calculation of scale outside this function - IF (mass .GT. 0.0_dp) THEN + IF (mass > 0.0_dp) THEN ! eigenvector rows assumed to be grouped in atomic blocks ind = (iatom - 1)*3 + icart DO imode = 4, dof @@ -1192,7 +1192,7 @@ CONTAINS part(i)%v(1) = 0.0_dp part(i)%v(2) = 0.0_dp part(i)%v(3) = 0.0_dp - IF (mass .NE. 0.0) THEN + IF (mass /= 0.0) THEN SELECT CASE (is_fixed(i)) CASE (use_perd_x) part(i)%v(2) = globenv%gaussian_rng_stream%next()/SQRT(mass) diff --git a/src/motion/neb_utils.F b/src/motion/neb_utils.F index 66914a2ec2..01bd806a46 100644 --- a/src/motion/neb_utils.F +++ b/src/motion/neb_utils.F @@ -685,14 +685,14 @@ CONTAINS tangent(:) = (coords%wrk(:, i) - coords%wrk(:, i - 1))/distance1 + & (coords%wrk(:, i + 1) - coords%wrk(:, i))/distance2 CASE (do_it_neb, do_ci_neb, do_d_neb) - IF ((energies(i + 1) .GT. energies(i)) .AND. (energies(i) .GT. (energies(i - 1)))) THEN + IF ((energies(i + 1) > energies(i)) .AND. (energies(i) > (energies(i - 1)))) THEN tangent(:) = coords%wrk(:, i + 1) - coords%wrk(:, i) - ELSE IF ((energies(i + 1) .LT. energies(i)) .AND. (energies(i) .LT. (energies(i - 1)))) THEN + ELSE IF ((energies(i + 1) < energies(i)) .AND. (energies(i) < (energies(i - 1)))) THEN tangent(:) = coords%wrk(:, i) - coords%wrk(:, i - 1) ELSE DVmax = MAX(ABS(energies(i + 1) - energies(i)), ABS(energies(i - 1) - energies(i))) DVmin = MIN(ABS(energies(i + 1) - energies(i)), ABS(energies(i - 1) - energies(i))) - IF (energies(i + 1) .GE. energies(i - 1)) THEN + IF (energies(i + 1) >= energies(i - 1)) THEN tangent(:) = (coords%wrk(:, i + 1) - coords%wrk(:, i))*DVmax + (coords%wrk(:, i) - coords%wrk(:, i - 1))*DVmin ELSE tangent(:) = (coords%wrk(:, i + 1) - coords%wrk(:, i))*DVmin + (coords%wrk(:, i) - coords%wrk(:, i - 1))*DVmax diff --git a/src/motion/pint_io.F b/src/motion/pint_io.F index 827f45d77d..638aa92d9f 100644 --- a/src/motion/pint_io.F +++ b/src/motion/pint_io.F @@ -216,7 +216,7 @@ CONTAINS local=.FALSE., file_form=form, is_new_file=new_file) ! don't write the 0-th frame if the file already exists - IF (.NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step)) THEN + IF (.NOT. new_file .AND. (pint_env%iter <= pint_env%first_step)) THEN CALL cp_print_key_finished_output(unit_nr, logger, & print_key) CONTINUE @@ -366,7 +366,7 @@ CONTAINS local=.FALSE., file_form=form, is_new_file=new_file) ! don't write the 0-th frame if the file already exists - IF (.NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step)) THEN + IF (.NOT. new_file .AND. (pint_env%iter <= pint_env%first_step)) THEN CALL cp_print_key_finished_output(unit_nr, logger, & print_key) CONTINUE @@ -445,7 +445,7 @@ CONTAINS middle_name="com-pos", extension=".xyz") ! don't write the 0-th frame if the file already exists - IF (.NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step)) THEN + IF (.NOT. new_file .AND. (pint_env%iter <= pint_env%first_step)) THEN CALL cp_print_key_finished_output(unit_nr, logger, & print_key) RETURN @@ -497,7 +497,7 @@ CONTAINS extension=".dat", is_new_file=file_is_new) ! don't write the 0-th frame if the file already exists - IF (.NOT. file_is_new .AND. (pint_env%iter .LE. pint_env%first_step)) THEN + IF (.NOT. file_is_new .AND. (pint_env%iter <= pint_env%first_step)) THEN CALL cp_print_key_finished_output(unit_nr, logger, & print_key) RETURN @@ -523,7 +523,7 @@ CONTAINS t = cp_unit_from_cp2k(pint_env%t, "fs") ndof = pint_env%p - IF (pint_env%first_propagated_mode .EQ. 2) THEN + IF (pint_env%first_propagated_mode == 2) THEN ndof = ndof - 1 END IF temp = cp_unit_from_cp2k(2.0_dp*pint_env%e_kin_beads/ & @@ -573,7 +573,7 @@ CONTAINS extension=".dat", is_new_file=file_is_new) ! don't write the 0-th frame if the file already exists - IF (.NOT. file_is_new .AND. (pint_env%iter .LE. pint_env%first_step)) THEN + IF (.NOT. file_is_new .AND. (pint_env%iter <= pint_env%first_step)) THEN CALL cp_print_key_finished_output(unit_nr, logger, & print_key) RETURN @@ -630,11 +630,11 @@ CONTAINS time_used = pint_env%time_per_step time_unit = "sec" - IF (time_used .GE. 60.0_dp) THEN + IF (time_used >= 60.0_dp) THEN time_used = time_used/60.0_dp time_unit = "min" END IF - IF (time_used .GE. 60.0_dp) THEN + IF (time_used >= 60.0_dp) THEN time_used = time_used/60.0_dp time_unit = "hours" END IF @@ -731,7 +731,7 @@ CONTAINS middle_name="centroid-gyr", extension=".dat") ! don't write the 0-th frame if the file already exists - IF (.NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step)) THEN + IF (.NOT. new_file .AND. (pint_env%iter <= pint_env%first_step)) THEN CALL cp_print_key_finished_output(unit_nr, logger, & print_key) RETURN diff --git a/src/motion/pint_methods.F b/src/motion/pint_methods.F index e10962588a..8f0dfcc296 100644 --- a/src/motion/pint_methods.F +++ b/src/motion/pint_methods.F @@ -225,7 +225,7 @@ CONTAINS CALL rep_env_create(rep_env, para_env=para_env, input=input, & input_declaration=input_declaration, nrep=nrep, prep=prep, row_force=.TRUE.) CALL section_vals_val_set(input, "GLOBAL%PROJECT_NAME", c_val=TRIM(project_name)) - IF (LEN_TRIM(output_file_name) .GT. 0) THEN + IF (LEN_TRIM(output_file_name) > 0) THEN CALL section_vals_val_set(input, "GLOBAL%OUTPUT_FILE_NAME", c_val=TRIM(output_file_name)) ELSE CALL section_vals_val_unset(input, "GLOBAL%OUTPUT_FILE_NAME") @@ -448,7 +448,7 @@ CONTAINS ALLOCATE (pint_env%gle) CALL gle_init(pint_env%gle, dt=pint_env%dt/pint_env%nrespa, temp=pint_env%kT, & section=gle_section) - IF (pint_env%pimd_thermostat == thermostat_none .AND. pint_env%gle%ndim .GT. 0) THEN + IF (pint_env%pimd_thermostat == thermostat_none .AND. pint_env%gle%ndim > 0) THEN pint_env%pimd_thermostat = thermostat_gle ! initialize a GLE with ALL degrees of freedom on node 0, @@ -604,7 +604,7 @@ CONTAINS CALL section_vals_val_get(pint_section, "FIX_CENTROID_POS", & l_val=ltmp) - IF (ltmp .AND. (pint_env%transform .EQ. transformation_normal)) THEN + IF (ltmp .AND. (pint_env%transform == transformation_normal)) THEN pint_env%first_propagated_mode = 2 ELSE pint_env%first_propagated_mode = 1 @@ -1691,7 +1691,7 @@ CONTAINS CALL pint_f2uf(pint_env) ! set the centroid forces to 0 if FIX_CENTROID_POS - IF (pint_env%first_propagated_mode .EQ. 2) THEN + IF (pint_env%first_propagated_mode == 2) THEN pint_env%uf(1, :) = 0.0_dp END IF @@ -2163,7 +2163,7 @@ CONTAINS CALL pint_f2uf(pint_env) ! set the centroid forces to 0 if FIX_CENTROID_POS - IF (pint_env%first_propagated_mode .EQ. 2) THEN + IF (pint_env%first_propagated_mode == 2) THEN pint_env%uf(1, :) = 0.0_dp END IF !Scale physical forces and integrate velocities with physical @@ -2488,7 +2488,7 @@ CONTAINS END IF CALL pint_f2uf(pint_env) ! set the centroid forces to 0 if FIX_CENTROID_POS - IF (pint_env%first_propagated_mode .EQ. 2) THEN + IF (pint_env%first_propagated_mode == 2) THEN pint_env%uf(1, :) = 0.0_dp END IF pint_env%uv_t = pint_env%uv_t + dti2*pint_env%uf diff --git a/src/motion/pint_public.F b/src/motion/pint_public.F index a00220dc8e..258ebdfb94 100644 --- a/src/motion/pint_public.F +++ b/src/motion/pint_public.F @@ -158,7 +158,7 @@ CONTAINS ! indices of two points betw which to generate a new point i1 = 2*dl*ip i2 = 2*dl*(ip + 1) - IF (i2 .EQ. n) THEN + IF (i2 == n) THEN i2 = 0 END IF diff --git a/src/motion/velocity_verlet_control.F b/src/motion/velocity_verlet_control.F index 3b98ade343..95b09831bb 100644 --- a/src/motion/velocity_verlet_control.F +++ b/src/motion/velocity_verlet_control.F @@ -59,7 +59,7 @@ CONTAINS CALL get_md_env(md_env, force_env=force_env, simpar=simpar) ! RESPA implemented only for NVE - IF (simpar%do_respa .AND. nve_ensemble .NE. simpar%ensemble) THEN + IF (simpar%do_respa .AND. nve_ensemble /= simpar%ensemble) THEN CPABORT("RESPA integrator not implemented for this ensemble") END IF diff --git a/src/motion/vibrational_analysis.F b/src/motion/vibrational_analysis.F index b7f8696cfd..7f703d25cf 100644 --- a/src/motion/vibrational_analysis.F +++ b/src/motion/vibrational_analysis.F @@ -197,7 +197,7 @@ CONTAINS CALL f_env_rm_defaults(f_env, ierr) ELSE CALL get_moving_atoms(force_env=f_env%force_env, Ilist=Mlist) - something_frozen = SIZE(particles) .NE. SIZE(Mlist) + something_frozen = SIZE(particles) /= SIZE(Mlist) natoms = SIZE(Mlist) ncoord = natoms*3 ALLOCATE (Clist(ncoord)) @@ -1141,7 +1141,7 @@ CONTAINS INTEGER :: handle, jj CALL timeset(routineN, handle) - IF (unit .GT. 0) THEN + IF (unit > 0) THEN ! degrees of freedom, i.e. the rank WRITE (unit) dof ! eigenvalues in one record diff --git a/src/mp2.F b/src/mp2.F index 66467e8667..c7dcb2636d 100644 --- a/src/mp2.F +++ b/src/mp2.F @@ -249,7 +249,7 @@ CONTAINS extension=".mp2Log") IF (unit_nr > 0) THEN - IF (mp2_env%method .NE. ri_rpa_method_gpw) THEN + IF (mp2_env%method /= ri_rpa_method_gpw) THEN WRITE (unit_nr, *) WRITE (unit_nr, *) WRITE (unit_nr, '(T2,A)') 'MP2 section' @@ -283,7 +283,7 @@ CONTAINS END IF END IF - IF (mp2_env%do_im_time .AND. mp2_env%eri_method .NE. do_eri_gpw) THEN + IF (mp2_env%do_im_time .AND. mp2_env%eri_method /= do_eri_gpw) THEN mp2_env%mp2_num_proc = 1 END IF @@ -302,10 +302,10 @@ CONTAINS mp2_env%mp2_memory, ' MiB' END IF - IF ((mp2_env%method .NE. mp2_method_gpw) .AND. & - (mp2_env%method .NE. ri_mp2_method_gpw) .AND. & - (mp2_env%method .NE. ri_rpa_method_gpw) .AND. & - (mp2_env%method .NE. ri_mp2_laplace)) THEN + IF ((mp2_env%method /= mp2_method_gpw) .AND. & + (mp2_env%method /= ri_mp2_method_gpw) .AND. & + (mp2_env%method /= ri_rpa_method_gpw) .AND. & + (mp2_env%method /= ri_mp2_laplace)) THEN CALL m_memory(mem) mem_real = (mem + 1024*1024 - 1)/(1024*1024) CALL para_env%max(mem_real) @@ -748,7 +748,7 @@ CONTAINS t2 = m_walltime() IF (unit_nr > 0) WRITE (unit_nr, *) - IF (mp2_env%method .NE. ri_rpa_method_gpw) THEN + IF (mp2_env%method /= ri_rpa_method_gpw) THEN IF (unit_nr > 0) WRITE (unit_nr, '(T3,A,T56,F25.6)') 'Total MP2 Time=', t2 - t1 IF (mp2_env%method == ri_mp2_laplace) THEN Emp2_S = Emp2 diff --git a/src/mp2_eri.F b/src/mp2_eri.F index acc1df5f25..83ea693ad6 100644 --- a/src/mp2_eri.F +++ b/src/mp2_eri.F @@ -418,7 +418,7 @@ CONTAINS IF (PRESENT(force_a) .OR. PRESENT(force_b)) THEN CPASSERT(PRESENT(pab)) - CPASSERT(ALL(SHAPE(pab) .EQ. SHAPE(hab))) + CPASSERT(ALL(SHAPE(pab) == SHAPE(hab))) END IF la_max_d = la_max @@ -812,12 +812,12 @@ CONTAINS CALL dbcsr_get_block_p(matrix=pabc(ic)%matrix, & row=irow, col=icol, block=pab_block, found=found) CPASSERT(found) - IF (irow .EQ. iatom) THEN - to_be_asserted = SIZE(pab_block, 1) .EQ. SIZE(pabc_block, 1) .AND. SIZE(pab_block, 2) .EQ. SIZE(pabc_block, 2) + IF (irow == iatom) THEN + to_be_asserted = SIZE(pab_block, 1) == SIZE(pabc_block, 1) .AND. SIZE(pab_block, 2) == SIZE(pabc_block, 2) CPASSERT(to_be_asserted) pabc_block(:, :, ic) = pab_block(:, :) ELSE - to_be_asserted = SIZE(pab_block, 2) .EQ. SIZE(pabc_block, 1) .AND. SIZE(pab_block, 1) .EQ. SIZE(pabc_block, 2) + to_be_asserted = SIZE(pab_block, 2) == SIZE(pabc_block, 1) .AND. SIZE(pab_block, 1) == SIZE(pabc_block, 2) CPASSERT(to_be_asserted) pabc_block(:, :, ic) = TRANSPOSE(pab_block(:, :)) END IF @@ -910,7 +910,7 @@ CONTAINS $: 'force_b=force_b(jkind)%forces(:, atom_b), &'*doforce_2 $: 'force_c=force_c(kkind)%forces(:, atom_c), &'*doforce_3 do_symmetric=do_symmetric, & - on_diagonal=iatom .EQ. jatom, & + on_diagonal=iatom == jatom, & $: 'hdabc=hdabc, &'*dabc $: 'hadbc=hadbc, &'*adbc $: 'habdc=habdc, &'*abdc @@ -935,12 +935,12 @@ CONTAINS row=irow, col=icol, block=munu_block, found=found) CPASSERT(found) munu_block(:, :) = 0.0_dp - IF (irow .EQ. iatom) THEN - to_be_asserted = SIZE(munu_block, 1) .EQ. SIZE(habc, 1) .AND. SIZE(munu_block, 2) .EQ. SIZE(habc, 2) + IF (irow == iatom) THEN + to_be_asserted = SIZE(munu_block, 1) == SIZE(habc, 1) .AND. SIZE(munu_block, 2) == SIZE(habc, 2) CPASSERT(to_be_asserted) munu_block(:, :) = habc(:, :, ic) ELSE - to_be_asserted = SIZE(munu_block, 2) .EQ. SIZE(habc, 1) .AND. SIZE(munu_block, 1) .EQ. SIZE(habc, 2) + to_be_asserted = SIZE(munu_block, 2) == SIZE(habc, 1) .AND. SIZE(munu_block, 1) == SIZE(habc, 2) CPASSERT(to_be_asserted) munu_block(:, :) = TRANSPOSE(habc(:, :, ic)) END IF @@ -955,7 +955,7 @@ CONTAINS row=irow, col=icol, block=munu_block, found=found) CPASSERT(found) munu_block(:, :) = 0.0_dp - IF (irow .EQ. iatom) THEN + IF (irow == iatom) THEN munu_block(:, :) = hdabc(i_xyz, :, :, ic) ELSE munu_block(:, :) = TRANSPOSE(hdabc(i_xyz, :, :, ic)) @@ -967,7 +967,7 @@ CONTAINS row=irow, col=icol, block=munu_block, found=found) CPASSERT(found) munu_block(:, :) = 0.0_dp - IF (irow .EQ. iatom) THEN + IF (irow == iatom) THEN munu_block(:, :) = hadbc(i_xyz, :, :, ic) ELSE munu_block(:, :) = TRANSPOSE(hadbc(i_xyz, :, :, ic)) @@ -979,7 +979,7 @@ CONTAINS row=irow, col=icol, block=munu_block, found=found) CPASSERT(found) munu_block(:, :) = 0.0_dp - IF (irow .EQ. iatom) THEN + IF (irow == iatom) THEN munu_block(:, :) = habdc(i_xyz, :, :, ic) ELSE munu_block(:, :) = TRANSPOSE(habdc(i_xyz, :, :, ic)) diff --git a/src/mp2_gpw_method.F b/src/mp2_gpw_method.F index 00be54e624..d67b922b3e 100644 --- a/src/mp2_gpw_method.F +++ b/src/mp2_gpw_method.F @@ -228,7 +228,7 @@ CONTAINS mem_min = HUGE(0) DO p = 1, ngroup q = ngroup/p - IF (p*q .NE. ngroup) CYCLE + IF (p*q /= ngroup) CYCLE CALL estimate_memory_usage(wfn_size, p, q, para_env_sub%num_pe, nmo, virtual(1), homo(1), calc_ex, mem_try) @@ -253,7 +253,7 @@ CONTAINS wfn_calc_best = HUGE(wfn_calc_best) DO p = 1, ngroup q = ngroup/p - IF (p*q .NE. ngroup) CYCLE + IF (p*q /= ngroup) CYCLE CALL estimate_memory_usage(wfn_size, p, q, para_env_sub%num_pe, nmo, virtual(1), homo(1), calc_ex, mem_try) diff --git a/src/mp2_grids.F b/src/mp2_grids.F index 5b251bc2e9..b73b0f5d99 100644 --- a/src/mp2_grids.F +++ b/src/mp2_grids.F @@ -145,7 +145,7 @@ CONTAINS ALLOCATE (x_tw(2*num_integ_points)) x_tw = 0.0_dp ierr = 0 - IF (num_integ_points .LE. 20) THEN + IF (num_integ_points <= 20) THEN CALL get_rpa_minimax_coeff(num_integ_points, e_range, x_tw, ierr) ELSE CALL get_rpa_minimax_coeff_larger_grid(num_integ_points, e_range, x_tw) @@ -194,7 +194,7 @@ CONTAINS ALLOCATE (x_tw(2*num_integ_points)) x_tw = 0.0_dp - IF (num_integ_points .LE. 20) THEN + IF (num_integ_points <= 20) THEN CALL get_exp_minimax_coeff(num_integ_points, e_range, x_tw) ELSE CALL get_exp_minimax_coeff_gw(num_integ_points, e_range, x_tw) diff --git a/src/mp2_integrals.F b/src/mp2_integrals.F index c10cfed077..ad7cb0a875 100644 --- a/src/mp2_integrals.F +++ b/src/mp2_integrals.F @@ -352,7 +352,7 @@ CONTAINS ngroup = para_env%num_pe/para_env_sub%num_pe ! Preparations for MME method to compute ERIs - IF (qs_env%mp2_env%eri_method .EQ. do_eri_mme) THEN + IF (qs_env%mp2_env%eri_method == do_eri_mme) THEN ! cell might have changed, so we need to reset parameters CALL cp_eri_mme_set_params(eri_param, cell, qs_kind_set, basis_type_1="ORB", basis_type_2="RI_AUX", para_env=para_env) END IF @@ -973,11 +973,11 @@ CONTAINS ! local block index for R/P and a loc_P = igroup + 1; loc_a = iproc + 1 - CPASSERT(SIZE(sizes_L) .EQ. ngroup) - CPASSERT(SIZE(sizes_B) .EQ. nproc) - CPASSERT(sizes_L(loc_P) .EQ. SIZE(BIb_C, 1)) - CPASSERT(sizes_L(loc_P) .EQ. SIZE(my_Lrows, 2)) - CPASSERT(sizes_B(loc_a) .EQ. SIZE(BIb_C, 2)) + CPASSERT(SIZE(sizes_L) == ngroup) + CPASSERT(SIZE(sizes_B) == nproc) + CPASSERT(sizes_L(loc_P) == SIZE(BIb_C, 1)) + CPASSERT(sizes_L(loc_P) == SIZE(my_Lrows, 2)) + CPASSERT(sizes_B(loc_a) == SIZE(BIb_C, 2)) ! Tensor distributions as follows: ! Process grid NG x Nw @@ -1020,7 +1020,7 @@ CONTAINS IF (debug) THEN ! check that tensor distribution is correct CALL dbt_get_stored_coordinates(tB_in, [loc_P, loc_a, 1], check_proc) - CPASSERT(check_proc .EQ. iproc_glob) + CPASSERT(check_proc == iproc_glob) END IF ! reserve (R|ai) block diff --git a/src/mp2_ri_2c.F b/src/mp2_ri_2c.F index 2dccccec2c..6aa6cc8247 100644 --- a/src/mp2_ri_2c.F +++ b/src/mp2_ri_2c.F @@ -907,16 +907,16 @@ CONTAINS potential_type = potential%potential_type - IF ((eri_method .EQ. do_eri_mme .OR. eri_method .EQ. do_eri_os) & - .AND. potential_type .EQ. do_potential_coulomb .OR. & - (eri_method .EQ. do_eri_mme .AND. potential_type .EQ. do_potential_long)) THEN + IF ((eri_method == do_eri_mme .OR. eri_method == do_eri_os) & + .AND. potential_type == do_potential_coulomb .OR. & + (eri_method == do_eri_mme .AND. potential_type == do_potential_long)) THEN CALL mp2_eri_2c_integrate(eri_param, potential, para_env_sub, qs_env, & basis_type_a="RI_AUX", basis_type_b="RI_AUX", & hab=L_local_col, first_b=my_group_L_start, last_b=my_group_L_end, & eri_method=eri_method) - ELSEIF (eri_method .EQ. do_eri_gpw .OR. & + 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 diff --git a/src/mp2_ri_grad.F b/src/mp2_ri_grad.F index 2047245c82..06f752f251 100644 --- a/src/mp2_ri_grad.F +++ b/src/mp2_ri_grad.F @@ -257,7 +257,7 @@ CONTAINS END IF ! prepare integral derivatives with mme method - IF (eri_method .EQ. do_eri_mme) THEN + IF (eri_method == do_eri_mme) THEN ALLOCATE (matrix_P_munu_local(my_group_L_size)) ALLOCATE (mat_munu_local(my_group_L_size)) L_counter = 0 @@ -431,7 +431,7 @@ CONTAINS DEALLOCATE (matrix_P_inu, G_P_ia) ! move the forces in the correct place - IF (eri_method .EQ. do_eri_gpw) THEN + IF (eri_method == do_eri_gpw) THEN DO ikind = 1, SIZE(mp2_force) mp2_force(ikind)%mp2_non_sep(:, :) = force(ikind)%rho_elec(:, :) force(ikind)%rho_elec(:, :) = 0.0_dp diff --git a/src/mp2_ri_grad_util.F b/src/mp2_ri_grad_util.F index 2c2194e3cb..e71385c96a 100644 --- a/src/mp2_ri_grad_util.F +++ b/src/mp2_ri_grad_util.F @@ -604,7 +604,7 @@ CONTAINS IF (convert_pos) THEN ! if the group is not in the same RPA group cycle - IF ((rec_prow/integ_group_size) .NE. color_group) CYCLE + IF ((rec_prow/integ_group_size) /= color_group) CYCLE ! convert global position to position into the RPA group rec_prow = MOD(rec_prow, integ_group_size) END IF diff --git a/src/mp2_setup.F b/src/mp2_setup.F index 91dfe59bf0..1e0dec1b66 100644 --- a/src/mp2_setup.F +++ b/src/mp2_setup.F @@ -493,7 +493,7 @@ CONTAINS NULLIFY (mp2_env%eri_mme_param) ALLOCATE (mp2_env%eri_mme_param) - IF (mp2_env%eri_method .EQ. do_eri_mme) THEN + IF (mp2_env%eri_method == do_eri_mme) THEN eri_mme_section => section_vals_get_subs_vals(mp2_section, "INTEGRALS%ERI_MME") CALL cp_eri_mme_init_read_input(eri_mme_section, mp2_env%eri_mme_param) END IF @@ -522,7 +522,7 @@ CONTAINS ! print some info about the MP2 parameters unit_nr = cp_print_key_unit_nr(logger, mp2_section, "PRINT", & extension=".mp2Log") - IF ((mp2_env%method .NE. mp2_method_none) .AND. unit_nr > 0) THEN + IF ((mp2_env%method /= mp2_method_none) .AND. unit_nr > 0) THEN WRITE (unit_nr, '(T2,A)') "" SELECT CASE (mp2_env%method) CASE (mp2_method_direct) @@ -564,7 +564,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (method .NE. mp2_method_none) THEN + IF (method /= mp2_method_none) THEN CPABORT("Please use not more than one method to compute the correlation energy.") END IF diff --git a/src/mp2_types.F b/src/mp2_types.F index b80b6ecb18..834b741716 100644 --- a/src/mp2_types.F +++ b/src/mp2_types.F @@ -448,7 +448,7 @@ CONTAINS IF (ASSOCIATED(mp2_env%ri_rpa%xc_section_aux)) CALL section_vals_release(mp2_env%ri_rpa%xc_section_aux) IF (ASSOCIATED(mp2_env%ri_rpa%xc_section_primary)) CALL section_vals_release(mp2_env%ri_rpa%xc_section_primary) - IF (mp2_env%eri_method .EQ. do_eri_mme) CALL cp_eri_mme_finalize(mp2_env%eri_mme_param) + IF (mp2_env%eri_method == do_eri_mme) CALL cp_eri_mme_finalize(mp2_env%eri_mme_param) IF (ASSOCIATED(mp2_env%eri_mme_param)) DEALLOCATE (mp2_env%eri_mme_param) IF (ASSOCIATED(mp2_env%ri_rpa_im_time%tau_tj)) DEALLOCATE (mp2_env%ri_rpa_im_time%tau_tj) IF (ASSOCIATED(mp2_env%ri_rpa_im_time%tau_wj)) DEALLOCATE (mp2_env%ri_rpa_im_time%tau_wj) diff --git a/src/mpiwrap/message_passing.F b/src/mpiwrap/message_passing.F index f6c626ff96..5b1f40c3c3 100644 --- a/src/mpiwrap/message_passing.F +++ b/src/mpiwrap/message_passing.F @@ -200,8 +200,8 @@ MODULE message_passing ! Comparisons PROCEDURE, PRIVATE, PASS, NON_OVERRIDABLE :: mp_comm_op_eq PROCEDURE, PRIVATE, PASS, NON_OVERRIDABLE :: mp_comm_op_neq - GENERIC, PUBLIC :: operator(.EQ.) => mp_comm_op_eq - GENERIC, PUBLIC :: operator(.NE.) => mp_comm_op_neq + GENERIC, PUBLIC :: operator(==) => mp_comm_op_eq + GENERIC, PUBLIC :: operator(/=) => mp_comm_op_neq ! Communication routines PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: & mp_sendrecv_i, mp_sendrecv_l, mp_sendrecv_r, mp_sendrecv_d, & @@ -628,8 +628,8 @@ MODULE message_passing PROCEDURE, PUBLIC, NON_OVERRIDABLE :: get_handle => mp_request_type_get_handle PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_request_op_eq PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_request_op_neq - GENERIC, PUBLIC :: OPERATOR(.EQ.) => mp_request_op_eq - GENERIC, PUBLIC :: OPERATOR(.NE.) => mp_request_op_neq + GENERIC, PUBLIC :: OPERATOR(==) => mp_request_op_eq + GENERIC, PUBLIC :: OPERATOR(/=) => mp_request_op_neq PROCEDURE, PUBLIC, PASS(request), NON_OVERRIDABLE :: test => mp_test_1 @@ -644,8 +644,8 @@ MODULE message_passing PROCEDURE, PUBLIC, NON_OVERRIDABLE :: get_handle => mp_win_type_get_handle PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_win_op_eq PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_win_op_neq - GENERIC, PUBLIC :: OPERATOR(.EQ.) => mp_win_op_eq - GENERIC, PUBLIC :: OPERATOR(.NE.) => mp_win_op_neq + GENERIC, PUBLIC :: OPERATOR(==) => mp_win_op_eq + GENERIC, PUBLIC :: OPERATOR(/=) => mp_win_op_neq PROCEDURE, PRIVATE, PASS(win), NON_OVERRIDABLE :: mp_win_create_iv, mp_win_create_lv, & mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv @@ -674,8 +674,8 @@ MODULE message_passing PROCEDURE, PUBLIC, NON_OVERRIDABLE :: get_handle => mp_file_type_get_handle PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_file_op_eq PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_file_op_neq - GENERIC, PUBLIC :: OPERATOR(.EQ.) => mp_file_op_eq - GENERIC, PUBLIC :: OPERATOR(.NE.) => mp_file_op_neq + GENERIC, PUBLIC :: OPERATOR(==) => mp_file_op_eq + GENERIC, PUBLIC :: OPERATOR(/=) => mp_file_op_neq PROCEDURE, PRIVATE, PASS(fh), NON_OVERRIDABLE :: mp_file_write_at_ch, mp_file_write_at_chv, & mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, & @@ -733,8 +733,8 @@ MODULE message_passing PROCEDURE, NON_OVERRIDABLE :: get_handle => mp_info_type_get_handle PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_info_op_eq PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_info_op_neq - GENERIC, PUBLIC :: OPERATOR(.EQ.) => mp_info_op_eq - GENERIC, PUBLIC :: OPERATOR(.NE.) => mp_info_op_neq + GENERIC, PUBLIC :: OPERATOR(==) => mp_info_op_eq + GENERIC, PUBLIC :: OPERATOR(/=) => mp_info_op_neq END TYPE TYPE, EXTENDS(mp_comm_type) :: mp_cart_type @@ -977,18 +977,18 @@ CONTAINS LOGICAL FUNCTION mp_${type}$_op_eq(${type}$1, ${type}$2) CLASS(mp_${type}$_type), INTENT(IN) :: ${type}$1, ${type}$2 #if defined(__parallel) && defined(__MPI_F08) - mp_${type}$_op_eq = (${type}$1%handle%mpi_val .EQ. ${type}$2%handle%mpi_val) + mp_${type}$_op_eq = (${type}$1%handle%mpi_val == ${type}$2%handle%mpi_val) #else - mp_${type}$_op_eq = (${type}$1%handle .EQ. ${type}$2%handle) + mp_${type}$_op_eq = (${type}$1%handle == ${type}$2%handle) #endif END FUNCTION mp_${type}$_op_eq LOGICAL FUNCTION mp_${type}$_op_neq(${type}$1, ${type}$2) CLASS(mp_${type}$_type), INTENT(IN) :: ${type}$1, ${type}$2 #if defined(__parallel) && defined(__MPI_F08) - mp_${type}$_op_neq = (${type}$1%handle%mpi_val .NE. ${type}$2%handle%mpi_val) + mp_${type}$_op_neq = (${type}$1%handle%mpi_val /= ${type}$2%handle%mpi_val) #else - mp_${type}$_op_neq = (${type}$1%handle .NE. ${type}$2%handle) + mp_${type}$_op_neq = (${type}$1%handle /= ${type}$2%handle) #endif END FUNCTION mp_${type}$_op_neq @@ -1151,11 +1151,11 @@ CONTAINS #endif !$ IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init") #if defined(__DLAF) -!$ IF (provided_tsl .LT. MPI_THREAD_MULTIPLE) THEN +!$ IF (provided_tsl < MPI_THREAD_MULTIPLE) THEN !$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_MULTIPLE), required by DLA-Future. Build CP2K without DLA-Future.") !$ END IF #else -!$ IF (provided_tsl .LT. MPI_THREAD_SERIALIZED) THEN +!$ IF (provided_tsl < MPI_THREAD_SERIALIZED) THEN !$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).") !$ END IF #endif @@ -1239,7 +1239,7 @@ CONTAINS #if defined(__parallel) IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize") #endif - IF (debug_comm_count .NE. 0) THEN + IF (debug_comm_count /= 0) THEN ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens. ! Memory leak checking might be helpful to locate the culprit WRITE (unit=debug_comm_count_char, FMT='(I2)') debug_comm_count @@ -1800,7 +1800,7 @@ CONTAINS CLASS(mp_comm_type), INTENT(INOUT) :: comm LOGICAL, INTENT(IN), OPTIONAL :: owns_group - IF (comm%handle MPI_GET_COMP .NE. mp_comm_null_handle MPI_GET_COMP) THEN + IF (comm%handle MPI_GET_COMP /= mp_comm_null_handle MPI_GET_COMP) THEN comm%source = 0 CALL comm%get_size(comm%num_pe) CALL comm%get_rank(comm%mepos) @@ -1820,7 +1820,7 @@ CONTAINS comm%mepos_cart = 0 comm%periodic = .FALSE. - IF (comm%handle MPI_GET_COMP .NE. mp_comm_null_handle MPI_GET_COMP) THEN + IF (comm%handle MPI_GET_COMP /= mp_comm_null_handle MPI_GET_COMP) THEN CALL comm%get_info_cart(comm%num_pe_cart, comm%mepos_cart, & comm%periodic) END IF @@ -2488,7 +2488,7 @@ CONTAINS CALL comm%get_size(nnodes) CALL comm%get_rank(mepos) - IF (UBOUND(group_distribution, 1) .NE. nnodes - 1) THEN + IF (UBOUND(group_distribution, 1) /= nnodes - 1) THEN CPABORT(routineP//" group_distribution wrong bounds") END IF @@ -2530,7 +2530,7 @@ CONTAINS END DO ! even the user gave a partition, see if we can use it to overwrite this choice IF (PRESENT(group_partition)) THEN - IF (ALL(group_partition > 0) .AND. (SUM(group_partition) .EQ. nnodes) .AND. (ngroups == SIZE(group_partition))) THEN + IF (ALL(group_partition > 0) .AND. (SUM(group_partition) == nnodes) .AND. (ngroups == SIZE(group_partition))) THEN k = 0 DO i = 0, SIZE(group_partition) - 1 DO j = 1, group_partition(i) @@ -2591,7 +2591,7 @@ CONTAINS CALL mp_timeset(routineN, handle) #if defined(__parallel) - IF (source .EQ. mp_any_source) THEN + IF (source == mp_any_source) THEN CALL mpi_probe(mp_any_source, mp_any_tag, comm%handle, status_single, ierr) IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe") source = status_single MPI_STATUS_EXTRACT(MPI_SOURCE) @@ -3232,7 +3232,7 @@ CONTAINS REAL(kind=real_8), ALLOCATABLE :: res(:) #endif - IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN + IF ("d" == "l" .AND. real_8 == int_8) THEN CPABORT("Minimal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3276,7 +3276,7 @@ CONTAINS INTEGER(KIND=int_4), ALLOCATABLE :: res(:) #endif - IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN + IF ("i" == "l" .AND. int_4 == int_8) THEN CPABORT("Minimal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3318,7 +3318,7 @@ CONTAINS INTEGER(KIND=int_8), ALLOCATABLE :: res(:) #endif - IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN + IF ("l" == "l" .AND. int_8 == int_8) THEN CPABORT("Minimal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3360,7 +3360,7 @@ CONTAINS REAL(kind=real_4), ALLOCATABLE :: res(:) #endif - IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN + IF ("r" == "l" .AND. real_4 == int_8) THEN CPABORT("Minimal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3402,7 +3402,7 @@ CONTAINS REAL(kind=real_8), ALLOCATABLE :: res(:) #endif - IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN + IF ("d" == "l" .AND. real_8 == int_8) THEN CPABORT("Maximal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3444,7 +3444,7 @@ CONTAINS INTEGER(KIND=int_4), ALLOCATABLE :: res(:) #endif - IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN + IF ("i" == "l" .AND. int_4 == int_8) THEN CPABORT("Maximal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3486,7 +3486,7 @@ CONTAINS INTEGER(KIND=int_8), ALLOCATABLE :: res(:) #endif - IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN + IF ("l" == "l" .AND. int_8 == int_8) THEN CPABORT("Maximal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3528,7 +3528,7 @@ CONTAINS REAL(kind=real_4), ALLOCATABLE :: res(:) #endif - IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN + IF ("r" == "l" .AND. real_4 == int_8) THEN CPABORT("Maximal location not available with long integers @ "//routineN) END IF CALL mp_timeset(routineN, handle) @@ -3601,7 +3601,7 @@ CONTAINS CALL mp_timeset(routineN, handle) #if defined(__parallel) msglen = SIZE(msg) - IF (msglen .GT. 0) THEN + IF (msglen > 0) THEN CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, ierr) IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN) END IF @@ -3640,7 +3640,7 @@ CONTAINS CPASSERT(IS_CONTIGUOUS(msg)) #endif - IF (msglen .GT. 0) THEN + IF (msglen > 0) THEN CALL mpi_iallreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, request%handle, ierr) IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN) ELSE @@ -3716,20 +3716,20 @@ CONTAINS IF (PRESENT(info)) my_info = info%handle CALL mpi_file_open(groupid%handle, filepath, amode_status, my_info, fh%handle, ierr) CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open") #else MARK_USED(groupid) MARK_USED(info) amode = amode_status - IF (amode .GT. file_amode_append) THEN + IF (amode > file_amode_append) THEN fposition = "APPEND" amode = amode - file_amode_append ELSE fposition = "REWIND" END IF - IF ((amode .EQ. file_amode_create) .OR. & - (amode .EQ. file_amode_create + file_amode_wronly) .OR. & - (amode .EQ. file_amode_create + file_amode_wronly + file_amode_excl)) THEN + IF ((amode == file_amode_create) .OR. & + (amode == file_amode_create + file_amode_wronly) .OR. & + (amode == file_amode_create + file_amode_wronly + file_amode_excl)) THEN fstatus = "UNKNOWN" ELSE fstatus = "OLD" @@ -3766,7 +3766,7 @@ CONTAINS IF (PRESENT(info)) my_info = info%handle INQUIRE (FILE=filepath, EXIST=exists) IF (exists) CALL mpi_file_delete(filepath, my_info, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete") #else MARK_USED(filepath) MARK_USED(info) @@ -3793,7 +3793,7 @@ CONTAINS ierr = 0 CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr) CALL mpi_file_close(fh%handle, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close") #else CLOSE (fh%handle) fh%handle = mp_file_null_handle @@ -3830,7 +3830,7 @@ CONTAINS ierr = 0 CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr) CALL mpi_file_get_size(fh%handle, file_size, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size") #else INQUIRE (UNIT=fh%handle, SIZE=file_size) #endif @@ -3858,7 +3858,7 @@ CONTAINS ierr = 0 CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr) CALL mpi_file_get_position(fh%handle, pos, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position") #else INQUIRE (UNIT=fh%handle, POS=pos) #endif @@ -3889,7 +3889,7 @@ CONTAINS msg_len = SIZE(msg) IF (PRESENT(msglen)) msg_len = msglen CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_write_at_chv @ mp_file_write_at_chv") #else MARK_USED(msglen) @@ -3914,7 +3914,7 @@ CONTAINS #if defined(__parallel) CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_write_at_ch @ mp_file_write_at_ch") #else WRITE (UNIT=fh%handle, POS=offset + 1) msg @@ -3945,7 +3945,7 @@ CONTAINS msg_len = SIZE(msg) IF (PRESENT(msglen)) msg_len = msglen CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_write_at_all_chv @ mp_file_write_at_all_chv") #else MARK_USED(msglen) @@ -3970,7 +3970,7 @@ CONTAINS #if defined(__parallel) CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_write_at_all_ch @ mp_file_write_at_all_ch") #else WRITE (UNIT=fh%handle, POS=offset + 1) msg @@ -4002,7 +4002,7 @@ CONTAINS msg_len = SIZE(msg) IF (PRESENT(msglen)) msg_len = msglen CALL MPI_FILE_READ_AT(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_read_at_chv @ mp_file_read_at_chv") #else MARK_USED(msglen) @@ -4027,7 +4027,7 @@ CONTAINS #if defined(__parallel) CALL MPI_FILE_READ_AT(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_read_at_ch @ mp_file_read_at_ch") #else READ (UNIT=fh%handle, POS=offset + 1) msg @@ -4058,7 +4058,7 @@ CONTAINS msg_len = SIZE(msg) IF (PRESENT(msglen)) msg_len = msglen CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_read_at_all_chv @ mp_file_read_at_all_chv") #else MARK_USED(msglen) @@ -4083,7 +4083,7 @@ CONTAINS #if defined(__parallel) CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_file_read_at_all_ch @ mp_file_read_at_all_ch") #else READ (UNIT=fh%handle, POS=offset + 1) msg @@ -4107,7 +4107,7 @@ CONTAINS ierr = 0 CALL MPI_TYPE_SIZE(type_descriptor%type_handle, type_size, ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("mpi_type_size failed @ mp_type_size") #else SELECT CASE (type_descriptor%type_handle) @@ -4310,7 +4310,7 @@ CONTAINS CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr) CALL MPI_File_set_view(fh%handle, offset, MPI_CHARACTER, & type_descriptor%type_handle, "native", MPI_INFO_NULL, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view") #else ! Uses absolute offsets stored in mp_file_descriptor_type MARK_USED(fh) @@ -4356,7 +4356,7 @@ CONTAINS ierr = 0 MARK_USED(type_descriptor) CALL MPI_File_read_all(fh%handle, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all") CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen) #else MARK_USED(msglen) @@ -4411,7 +4411,7 @@ CONTAINS MARK_USED(type_descriptor) CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr) CALL MPI_File_write_all(fh%handle, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr) - IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all") + IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all") CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen) #else MARK_USED(msglen) diff --git a/src/mpiwrap/mp_perf_test.F b/src/mpiwrap/mp_perf_test.F index ebe7ce1911..844937680d 100644 --- a/src/mpiwrap/mp_perf_test.F +++ b/src/mpiwrap/mp_perf_test.F @@ -80,10 +80,10 @@ CONTAINS WRITE (output_unit, *) "Running with ", nprocs WRITE (output_unit, *) "running messages with npow = ", npow WRITE (output_unit, *) "use MPI X in the input for larger (e.g. 6) of smaller (e.g. 3) messages" - IF (MODULO(nprocs, 2) .NE. 0) WRITE (output_unit, *) "Testing only with an even number of tasks" + IF (MODULO(nprocs, 2) /= 0) WRITE (output_unit, *) "Testing only with an even number of tasks" END IF - IF (MODULO(nprocs, 2) .NE. 0) RETURN + IF (MODULO(nprocs, 2) /= 0) RETURN ! equal loads Nloc = Ngrid/nprocs @@ -122,7 +122,7 @@ CONTAINS DO i = 1, npow ncount = 10**i t2 = 0.0E0_dp - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") DO j = 1, 3**(npow - i) CALL comm%sync() t1 = MPI_WTIME() @@ -145,7 +145,7 @@ CONTAINS DO i = 1, npow ncount = 10**i t2 = 0.0E0_dp - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") DO j = 1, 3**(npow - i) CALL comm%sync() t1 = MPI_WTIME() @@ -167,15 +167,15 @@ CONTAINS END IF ncount = 10**npow IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "For messages of ", ncount*8, " bytes" - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") DO itask = 0, nprocs - 1 DO jtask = itask + 1, nprocs - 1 CALL comm%sync() t1 = MPI_WTIME() - IF (taskid .EQ. itask) THEN + IF (taskid == itask) THEN CALL comm%send(buffer1, jtask, itask*jtask) END IF - IF (taskid .EQ. jtask) THEN + IF (taskid == jtask) THEN source = itask tag = itask*jtask CALL comm%recv(buffer1, source, tag) @@ -202,7 +202,7 @@ CONTAINS DO i = 1, npow ncount = 10**i t2 = 0.0E0_dp - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") DO j = 1, 3**(npow - i) CALL comm%sync() t1 = MPI_WTIME() @@ -231,12 +231,12 @@ CONTAINS DO i = 1, npow ncount = 10**i t2 = 0.0E0_dp - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") DO j = 1, 3**(npow - i) CALL comm%sync() t1 = MPI_WTIME() ! first half with partner - IF (taskid .LT. nprocs/2) THEN + IF (taskid < nprocs/2) THEN CALL comm%send(buffer1, taskid + nprocs/2, 0) ELSE source = taskid - nprocs/2 @@ -261,7 +261,7 @@ CONTAINS DO i = 1, npow ncount = 10**i t2 = 0.0E0_dp - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") DO j = 1, 3**(npow - i) CALL comm%sync() t1 = MPI_WTIME() @@ -281,7 +281,7 @@ CONTAINS DO i = 1, npow ncount = 10**i t2 = 0.0E0_dp - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") DO j = 1, 3**(npow - i) buffer2(:) = buffer1 CALL comm%sync() @@ -305,7 +305,7 @@ CONTAINS DO i = 1, npow ncount = 10**i t2 = 0.0E0_dp - IF (ncount .GT. nbufmax) CPABORT("") + IF (ncount > nbufmax) CPABORT("") scount = ncount/nprocs rcount = ncount/nprocs DO j = 1, nprocs @@ -357,7 +357,7 @@ CONTAINS lgrid2 = 0.0E0_dp DO i = 1, Nprocs lgrid2(:) = lgrid2 + grid(:, MODULO(taskid - i, Nprocs) + 1) - IF (i .EQ. nprocs) EXIT + IF (i == nprocs) EXIT CALL comm%shift(lgrid2, 1) END DO t4 = MPI_WTIME() - t3 + threshold @@ -399,7 +399,7 @@ CONTAINS lgrid3 = 0.0E0_dp DO i = 1, Nprocs, 2 lgrid3(:) = lgrid3 + grid3(:, MODULO(taskid - i - 1, Nprocs) + 1) - IF (i .EQ. nprocs - 1) EXIT + IF (i == nprocs - 1) EXIT CALL comm%shift(lgrid3, 2) END DO t5 = MPI_WTIME() - t3 + threshold diff --git a/src/mscfg_methods.F b/src/mscfg_methods.F index 732a4b9268..24e9aa021d 100644 --- a/src/mscfg_methods.F +++ b/src/mscfg_methods.F @@ -170,7 +170,7 @@ CONTAINS CALL force_env_get(force_env, force_env_section=force_env_section, & qs_env=qs_env) CALL section_vals_val_get(force_env_section, "METHOD", i_val=force_method) - CPASSERT(force_method .EQ. do_qs) + CPASSERT(force_method == do_qs) root_section => force_env%root_section subsys_section => section_vals_get_subs_vals(force_env_section, "SUBSYS") dft_section => section_vals_get_subs_vals(force_env_section, "DFT") @@ -198,12 +198,12 @@ CONTAINS 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 .NE. tot_added_mos) THEN + IF (tot_isize /= tot_added_mos) THEN CPABORT("ALMO smearing currently requires ADDED_MOS == total number of atoms") END IF !! Get total number of MOs CALL get_qs_env(qs_env, mos=mos) - IF (SIZE(mos) .GT. 1) CPABORT("Unrestricted ALMO methods are NYI") !! Unrestricted ALMO is not implemented yet + 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)) @@ -310,7 +310,7 @@ CONTAINS ! mscfg_env%energy_of_frag(ifrag) = qs_energy%total nmosets_of_frag = SIZE(mos_of_frag) - CPASSERT(nmosets_of_frag .LE. mscfg_max_moset_size) + CPASSERT(nmosets_of_frag <= mscfg_max_moset_size) mscfg_env%nmosets_of_frag(ifrag) = nmosets_of_frag DO imo = 1, nmosets_of_frag !! Forcing compatibility for ALMO smearing @@ -439,7 +439,7 @@ CONTAINS CALL force_env_get(force_env, force_env_section=force_env_section) CALL section_vals_val_get(force_env_section, "METHOD", i_val=method_name_id) - IF (method_name_id .EQ. do_qs) THEN + IF (method_name_id == do_qs) THEN CALL force_env_get(force_env, qs_env=qs_env) CPASSERT(ASSOCIATED(qs_env)) @@ -473,17 +473,17 @@ CONTAINS frz_term_type = almo_frz_none ! Are we doing the loop ? - IF (scf_guess_type .EQ. molecular_guess .OR. & ! SCF guess is molecular - (almo_guess_type .EQ. molecular_guess .AND. almo_scf_is_on) .OR. & ! ALMO SCF guess is molecular - frz_term_type .NE. almo_frz_none) THEN ! ALMO FRZ term is requested + IF (scf_guess_type == molecular_guess .OR. & ! SCF guess is molecular + (almo_guess_type == molecular_guess .AND. almo_scf_is_on) .OR. & ! ALMO SCF guess is molecular + frz_term_type /= almo_frz_none) THEN ! ALMO FRZ term is requested do_mol_loop = .TRUE. ! If we are calculating molecular guess it is OK to do fast and dirty loop ! It is NOT ok to be sloppy with ALMO EDA calculations of the FRZ term - IF (frz_term_type .NE. almo_frz_none) THEN + IF (frz_term_type /= almo_frz_none) THEN is_fast_dirty = .FALSE. - IF (frz_term_type .EQ. almo_frz_crystal) THEN + IF (frz_term_type == almo_frz_crystal) THEN is_crystal = .TRUE. END IF END IF diff --git a/src/mscfg_types.F b/src/mscfg_types.F index 40591bacf6..a0d05df79f 100644 --- a/src/mscfg_types.F +++ b/src/mscfg_types.F @@ -75,7 +75,7 @@ CONTAINS !ENDIF env%nfrags = nfrags - IF (nfrags .GT. 0) THEN + IF (nfrags > 0) THEN ALLOCATE (env%energy_of_frag(nfrags)) ALLOCATE (env%nmosets_of_frag(nfrags)) ALLOCATE (env%mos_of_frag(nfrags, mscfg_max_moset_size)) @@ -134,7 +134,7 @@ CONTAINS CALL timeset(routineN, handle) - CPASSERT(iset .LE. mscfg_max_moset_size) + CPASSERT(iset <= mscfg_max_moset_size) CALL dbcsr_create(matrix_temp, & template=matrix_out, & @@ -148,7 +148,7 @@ CONTAINS DO ifrag = 1, mscfg_env%nfrags - CPASSERT(iset .LE. mscfg_env%nmosets_of_frag(ifrag)) + CPASSERT(iset <= mscfg_env%nmosets_of_frag(ifrag)) CALL dbcsr_get_info(mscfg_env%mos_of_frag(ifrag, iset), & nfullrows_total=submatrix_size(1), nfullcols_total=submatrix_size(2)) @@ -166,8 +166,8 @@ CONTAINS ! is exactly the same as the size of the big matrix ! This is to prevent unexpected conversion errors ! If however such conversion is intended - remove these safeguards - CPASSERT(offset(1) .EQ. matrix_size(1)) - CPASSERT(offset(2) .EQ. matrix_size(2)) + CPASSERT(offset(1) == matrix_size(1)) + CPASSERT(offset(2) == matrix_size(2)) CALL dbcsr_release(matrix_temp) @@ -214,11 +214,11 @@ CONTAINS add_blocks_after = 0 start_index = 1 trailing_size = matrix_size(dimen) - offset(dimen) - submatrix_size(dimen) - IF (offset(dimen) .GT. 0) THEN + IF (offset(dimen) > 0) THEN add_blocks_before(dimen) = add_blocks_before(dimen) + 1 start_index = 2 END IF - IF (trailing_size .GT. 0) THEN + IF (trailing_size > 0) THEN add_blocks_after = add_blocks_after + 1 END IF @@ -237,7 +237,7 @@ CONTAINS !IF (ASSOCIATED(cluster_distr)) THEN !ALLOCATE (cluster_distr_new(nblocks_new)) !END IF - IF (add_blocks_before(dimen) .GT. 0) THEN + IF (add_blocks_before(dimen) > 0) THEN block_sizes_new(1) = offset(dimen) distr_new_array(1) = 0 !IF (ASSOCIATED(cluster_distr)) THEN @@ -249,7 +249,7 @@ CONTAINS !IF (ASSOCIATED(cluster_distr)) THEN !cluster_distr_new(start_index:nblocks+start_index-1) = cluster_distr(1:nblocks) !END IF - IF (add_blocks_after .GT. 0) THEN + IF (add_blocks_after > 0) THEN block_sizes_new(nblocks_new) = trailing_size distr_new_array(nblocks_new) = 0 !IF (ASSOCIATED(cluster_distr)) THEN diff --git a/src/mulliken.F b/src/mulliken.F index 523de8e24a..7629b9b23e 100644 --- a/src/mulliken.F +++ b/src/mulliken.F @@ -239,7 +239,7 @@ CONTAINS IF (.NOT. found) CYCLE IF (.NOT. (ASSOCIATED(s_block) .AND. ASSOCIATED(p_block))) CYCLE - IF (iblock_row .EQ. iblock_col) THEN + IF (iblock_row == iblock_col) THEN mult = 0.5_dp ! avoid double counting of diagonal blocks ELSE mult = 1.0_dp @@ -288,7 +288,7 @@ CONTAINS IF (.NOT. found) CYCLE IF (.NOT. (ASSOCIATED(s_block) .AND. ASSOCIATED(p_block))) CYCLE - IF (iblock_row .EQ. iblock_col) THEN + IF (iblock_row == iblock_col) THEN mult = 0.5_dp ! avoid double counting of diagonal blocks ELSE mult = 1.0_dp @@ -340,7 +340,7 @@ CONTAINS IF (.NOT. found) CYCLE IF (.NOT. (ASSOCIATED(s_block) .AND. ASSOCIATED(p_block))) CYCLE - IF (iblock_row .EQ. iblock_col) THEN + IF (iblock_row == iblock_col) THEN mult = 0.5_dp ! avoid double counting of diagonal blocks ELSE mult = 1.0_dp @@ -934,7 +934,7 @@ CONTAINS ! we can cycle if a block is not present IF (.NOT. (ASSOCIATED(b_block) .AND. ASSOCIATED(a_block))) CYCLE - IF (iblock_row .EQ. iblock_col) THEN + IF (iblock_row == iblock_col) THEN mult = 0.5_dp ! avoid double counting of diagonal blocks ELSE mult = 1.0_dp diff --git a/src/negf_control_types.F b/src/negf_control_types.F index 9224f901d5..9e639b5852 100644 --- a/src/negf_control_types.F +++ b/src/negf_control_types.F @@ -522,7 +522,7 @@ CONTAINS DO iname = 1, nnames DO ikind = 1, nkinds - IF (molecule_kind_set(ikind)%name .EQ. cptr(iname)) EXIT + IF (molecule_kind_set(ikind)%name == cptr(iname)) EXIT END DO IF (ikind <= nkinds) THEN @@ -567,7 +567,7 @@ CONTAINS DO iname = 1, nnames DO ikind = 1, nkinds - IF (molecule_kind_set(ikind)%name .EQ. cptr(iname)) EXIT + IF (molecule_kind_set(ikind)%name == cptr(iname)) EXIT END DO IF (ikind <= nkinds) THEN diff --git a/src/nnp_acsf.F b/src/nnp_acsf.F index d3a88f4fc1..cafe7141ea 100644 --- a/src/nnp_acsf.F +++ b/src/nnp_acsf.F @@ -769,7 +769,7 @@ CONTAINS minimum = nuc_ele(i) loc = i DO j = i + 1, SIZE(ele) - IF (nuc_ele(j) .LT. minimum) THEN + IF (nuc_ele(j) < minimum) THEN loc = j minimum = nuc_ele(j) END IF @@ -806,7 +806,7 @@ CONTAINS DO j = 1, nnp%n_rad(i) - 1 loc = j DO k = j + 1, nnp%n_rad(i) - IF (nnp%rad(i)%funccut(loc) .GT. nnp%rad(i)%funccut(k)) THEN + IF (nnp%rad(i)%funccut(loc) > nnp%rad(i)%funccut(k)) THEN loc = k END IF END DO @@ -819,8 +819,8 @@ CONTAINS DO j = 1, nnp%n_rad(i) - 1 loc = j DO k = j + 1, nnp%n_rad(i) - IF (nnp%rad(i)%funccut(loc) .EQ. nnp%rad(i)%funccut(k) .AND. & - nnp%rad(i)%eta(loc) .GT. nnp%rad(i)%eta(k)) THEN + IF (nnp%rad(i)%funccut(loc) == nnp%rad(i)%funccut(k) .AND. & + nnp%rad(i)%eta(loc) > nnp%rad(i)%eta(k)) THEN loc = k END IF END DO @@ -833,9 +833,9 @@ CONTAINS DO j = 1, nnp%n_rad(i) - 1 loc = j DO k = j + 1, nnp%n_rad(i) - IF (nnp%rad(i)%funccut(loc) .EQ. nnp%rad(i)%funccut(k) .AND. & - nnp%rad(i)%eta(loc) .EQ. nnp%rad(i)%eta(k) .AND. & - nnp%rad(i)%rs(loc) .GT. nnp%rad(i)%rs(k)) THEN + IF (nnp%rad(i)%funccut(loc) == nnp%rad(i)%funccut(k) .AND. & + nnp%rad(i)%eta(loc) == nnp%rad(i)%eta(k) .AND. & + nnp%rad(i)%rs(loc) > nnp%rad(i)%rs(k)) THEN loc = k END IF END DO @@ -848,10 +848,10 @@ CONTAINS DO j = 1, nnp%n_rad(i) - 1 loc = j DO k = j + 1, nnp%n_rad(i) - IF (nnp%rad(i)%funccut(loc) .EQ. nnp%rad(i)%funccut(k) .AND. & - nnp%rad(i)%eta(loc) .EQ. nnp%rad(i)%eta(k) .AND. & - nnp%rad(i)%rs(loc) .EQ. nnp%rad(i)%rs(k) .AND. & - nnp%rad(i)%nuc_ele(loc) .GT. nnp%rad(i)%nuc_ele(k)) THEN + IF (nnp%rad(i)%funccut(loc) == nnp%rad(i)%funccut(k) .AND. & + nnp%rad(i)%eta(loc) == nnp%rad(i)%eta(k) .AND. & + nnp%rad(i)%rs(loc) == nnp%rad(i)%rs(k) .AND. & + nnp%rad(i)%nuc_ele(loc) > nnp%rad(i)%nuc_ele(k)) THEN loc = k END IF END DO @@ -864,7 +864,7 @@ CONTAINS DO j = 1, nnp%n_ang(i) - 1 loc = j DO k = j + 1, nnp%n_ang(i) - IF (nnp%ang(i)%funccut(loc) .GT. nnp%ang(i)%funccut(k)) THEN + IF (nnp%ang(i)%funccut(loc) > nnp%ang(i)%funccut(k)) THEN loc = k END IF END DO @@ -877,8 +877,8 @@ CONTAINS DO j = 1, nnp%n_ang(i) - 1 loc = j DO k = j + 1, nnp%n_ang(i) - IF (nnp%ang(i)%funccut(loc) .EQ. nnp%ang(i)%funccut(k) .AND. & - nnp%ang(i)%eta(loc) .GT. nnp%ang(i)%eta(k)) THEN + IF (nnp%ang(i)%funccut(loc) == nnp%ang(i)%funccut(k) .AND. & + nnp%ang(i)%eta(loc) > nnp%ang(i)%eta(k)) THEN loc = k END IF END DO @@ -891,9 +891,9 @@ CONTAINS DO j = 1, nnp%n_ang(i) - 1 loc = j DO k = j + 1, nnp%n_ang(i) - IF (nnp%ang(i)%funccut(loc) .EQ. nnp%ang(i)%funccut(k) .AND. & - nnp%ang(i)%eta(loc) .EQ. nnp%ang(i)%eta(k) .AND. & - nnp%ang(i)%zeta(loc) .GT. nnp%ang(i)%zeta(k)) THEN + IF (nnp%ang(i)%funccut(loc) == nnp%ang(i)%funccut(k) .AND. & + nnp%ang(i)%eta(loc) == nnp%ang(i)%eta(k) .AND. & + nnp%ang(i)%zeta(loc) > nnp%ang(i)%zeta(k)) THEN loc = k END IF END DO @@ -906,10 +906,10 @@ CONTAINS DO j = 1, nnp%n_ang(i) - 1 loc = j DO k = j + 1, nnp%n_ang(i) - IF (nnp%ang(i)%funccut(loc) .EQ. nnp%ang(i)%funccut(k) .AND. & - nnp%ang(i)%eta(loc) .EQ. nnp%ang(i)%eta(k) .AND. & - nnp%ang(i)%zeta(loc) .EQ. nnp%ang(i)%zeta(k) .AND. & - nnp%ang(i)%lam(loc) .GT. nnp%ang(i)%lam(k)) THEN + IF (nnp%ang(i)%funccut(loc) == nnp%ang(i)%funccut(k) .AND. & + nnp%ang(i)%eta(loc) == nnp%ang(i)%eta(k) .AND. & + nnp%ang(i)%zeta(loc) == nnp%ang(i)%zeta(k) .AND. & + nnp%ang(i)%lam(loc) > nnp%ang(i)%lam(k)) THEN loc = k END IF END DO @@ -922,11 +922,11 @@ CONTAINS DO j = 1, nnp%n_ang(i) - 1 loc = j DO k = j + 1, nnp%n_ang(i) - IF (nnp%ang(i)%funccut(loc) .EQ. nnp%ang(i)%funccut(k) .AND. & - nnp%ang(i)%eta(loc) .EQ. nnp%ang(i)%eta(k) .AND. & - nnp%ang(i)%zeta(loc) .EQ. nnp%ang(i)%zeta(k) .AND. & - nnp%ang(i)%lam(loc) .EQ. nnp%ang(i)%lam(k) .AND. & - nnp%ang(i)%nuc_ele1(loc) .GT. nnp%ang(i)%nuc_ele1(k)) THEN + IF (nnp%ang(i)%funccut(loc) == nnp%ang(i)%funccut(k) .AND. & + nnp%ang(i)%eta(loc) == nnp%ang(i)%eta(k) .AND. & + nnp%ang(i)%zeta(loc) == nnp%ang(i)%zeta(k) .AND. & + nnp%ang(i)%lam(loc) == nnp%ang(i)%lam(k) .AND. & + nnp%ang(i)%nuc_ele1(loc) > nnp%ang(i)%nuc_ele1(k)) THEN loc = k END IF END DO @@ -937,12 +937,12 @@ CONTAINS DO j = 1, nnp%n_ang(i) - 1 loc = j DO k = j + 1, nnp%n_ang(i) - IF (nnp%ang(i)%funccut(loc) .EQ. nnp%ang(i)%funccut(k) .AND. & - nnp%ang(i)%eta(loc) .EQ. nnp%ang(i)%eta(k) .AND. & - nnp%ang(i)%zeta(loc) .EQ. nnp%ang(i)%zeta(k) .AND. & - nnp%ang(i)%lam(loc) .EQ. nnp%ang(i)%lam(k) .AND. & - nnp%ang(i)%nuc_ele1(loc) .EQ. nnp%ang(i)%nuc_ele1(k) .AND. & - nnp%ang(i)%nuc_ele2(loc) .GT. nnp%ang(i)%nuc_ele2(k)) THEN + IF (nnp%ang(i)%funccut(loc) == nnp%ang(i)%funccut(k) .AND. & + nnp%ang(i)%eta(loc) == nnp%ang(i)%eta(k) .AND. & + nnp%ang(i)%zeta(loc) == nnp%ang(i)%zeta(k) .AND. & + nnp%ang(i)%lam(loc) == nnp%ang(i)%lam(k) .AND. & + nnp%ang(i)%nuc_ele1(loc) == nnp%ang(i)%nuc_ele1(k) .AND. & + nnp%ang(i)%nuc_ele2(loc) > nnp%ang(i)%nuc_ele2(k)) THEN loc = k END IF END DO diff --git a/src/nnp_environment.F b/src/nnp_environment.F index 2dded821a5..06256c27e7 100644 --- a/src/nnp_environment.F +++ b/src/nnp_environment.F @@ -498,10 +498,10 @@ CONTAINS IF (found) THEN READ (line, *) dummy, ele, symfnct_type DO i = 1, nele - IF (TRIM(ele) .EQ. nnp_env%ele(i)) THEN - IF (symfnct_type .EQ. 2) THEN + IF (TRIM(ele) == nnp_env%ele(i)) THEN + IF (symfnct_type == 2) THEN nnp_env%n_rad(i) = nnp_env%n_rad(i) + 1 - ELSE IF (symfnct_type .EQ. 3) THEN + ELSE IF (symfnct_type == 3) THEN nnp_env%n_ang(i) = nnp_env%n_ang(i) + 1 ELSE CALL cp_abort(__LOCATION__, TRIM(printtag)// & @@ -583,8 +583,8 @@ CONTAINS IF (found) THEN READ (line, *) dummy, ele, symfnct_type DO i = 1, nele - IF (TRIM(ele) .EQ. nnp_env%ele(i)) THEN - IF (symfnct_type .EQ. 2) THEN + IF (TRIM(ele) == nnp_env%ele(i)) THEN + IF (symfnct_type == 2) THEN nnp_env%n_rad(i) = nnp_env%n_rad(i) + 1 READ (line, *) dummy, ele, symfnct_type, & nnp_env%rad(i)%ele(nnp_env%n_rad(i)), & @@ -594,7 +594,7 @@ CONTAINS IF (nnp_env%max_cut < nnp_env%rad(i)%funccut(nnp_env%n_rad(i))) THEN nnp_env%max_cut = nnp_env%rad(i)%funccut(nnp_env%n_rad(i)) END IF - ELSE IF (symfnct_type .EQ. 3) THEN + ELSE IF (symfnct_type == 3) THEN nnp_env%n_ang(i) = nnp_env%n_ang(i) + 1 READ (line, *) dummy, ele, symfnct_type, & nnp_env%ang(i)%ele1(nnp_env%n_ang(i)), & @@ -631,7 +631,7 @@ CONTAINS CALL get_ptable_info(nnp_env%ang(i)%ele1(j), number=nnp_env%ang(i)%nuc_ele1(j)) CALL get_ptable_info(nnp_env%ang(i)%ele2(j), number=nnp_env%ang(i)%nuc_ele2(j)) ! sort ele1 and ele2 - IF (nnp_env%ang(i)%nuc_ele1(j) .GT. nnp_env%ang(i)%nuc_ele2(j)) THEN + IF (nnp_env%ang(i)%nuc_ele1(j) > nnp_env%ang(i)%nuc_ele2(j)) THEN ele = nnp_env%ang(i)%ele1(j) nnp_env%ang(i)%ele1(j) = nnp_env%ang(i)%ele2(j) nnp_env%ang(i)%ele2(j) = ele @@ -791,7 +791,7 @@ CONTAINS IF (explicit) THEN NULLIFY (work) CALL section_vals_val_get(bias_section, "ALIGN_NNP_ENERGIES", r_vals=work) - IF (SIZE(work) .NE. nnp_env%n_committee) THEN + IF (SIZE(work) /= nnp_env%n_committee) THEN CPABORT("ALIGN_NNP_ENERGIES size mismatch wrt committee size.") END IF nnp_env%bias_e_avrg(:) = work diff --git a/src/optimize_basis.F b/src/optimize_basis.F index d4574066bc..0680b83b81 100644 --- a/src/optimize_basis.F +++ b/src/optimize_basis.F @@ -670,7 +670,7 @@ CONTAINS 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) - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, '(1X,A,I8)') "BASOPT| Information at iteration number:", iopt WRITE (unit_nr, '(1X,A)') "BASOPT| Training set | Combination | Rho difference | Condition num. | Time" WRITE (unit_nr, '(1X,A)') "BASOPT| -----------------------------------------------------------------------" diff --git a/src/optimize_basis_utils.F b/src/optimize_basis_utils.F index 13533005e4..f843fed4ca 100644 --- a/src/optimize_basis_utils.F +++ b/src/optimize_basis_utils.F @@ -190,7 +190,7 @@ CONTAINS raise = .FALSE. DO j = opt_bas%nkind, 1, -1 IF (raise) tmp_i2(j) = tmp_i2(j) + 1 - IF (tmp_i2(j) .GT. tmp_i(j)) THEN + IF (tmp_i2(j) > tmp_i(j)) THEN tmp_i2(j) = 0 raise = .TRUE. END IF @@ -260,7 +260,7 @@ CONTAINS ! No input information available, try to equally distribute IF (.NOT. explicit) THEN - IF (nproc .GE. ncalc) THEN + IF (nproc >= ncalc) THEN iadd1 = nproc/ncalc iadd2 = MOD(nproc, ncalc) ALLOCATE (opt_bas%comp_group(ncalc)) @@ -269,7 +269,7 @@ CONTAINS ALLOCATE (opt_bas%comp_group(igroup + 1)%member_list(1)) opt_bas%comp_group(igroup + 1)%member_list(1) = igroup opt_bas%group_partition(igroup) = iadd1 - IF (igroup .LT. iadd2) opt_bas%group_partition(igroup) = opt_bas%group_partition(igroup) + 1 + IF (igroup < iadd2) opt_bas%group_partition(igroup) = opt_bas%group_partition(igroup) + 1 END DO ELSE iadd1 = ncalc/nproc @@ -280,7 +280,7 @@ CONTAINS DO igroup = 0, nproc - 1 opt_bas%group_partition(igroup) = 1 isize = iadd1 - IF (igroup .LT. iadd2) isize = isize + 1 + IF (igroup < iadd2) isize = isize + 1 ALLOCATE (opt_bas%comp_group(igroup + 1)%member_list(isize)) DO j = 1, isize opt_bas%comp_group(igroup + 1)%member_list(j) = icount @@ -298,21 +298,21 @@ CONTAINS CALL cp_abort(__LOCATION__, & "Number of processors in group distribution does not match number of MPI tasks."// & " Please change input.") - IF (.NOT. isize .LE. ncalc) & + IF (.NOT. isize <= ncalc) & CALL cp_abort(__LOCATION__, & "Number of Groups larger than number of calculations"// & " Please change input.") CPASSERT(nptot == nproc) ALLOCATE (opt_bas%comp_group(isize)) ALLOCATE (opt_bas%group_partition(0:isize - 1)) - IF (isize .LT. ncalc) THEN + IF (isize < ncalc) THEN iadd1 = ncalc/isize iadd2 = MOD(ncalc, isize) icount = 0 DO igroup = 0, isize - 1 opt_bas%group_partition(igroup) = i_vals(igroup + 1) isize = iadd1 - IF (igroup .LT. iadd2) isize = isize + 1 + IF (igroup < iadd2) isize = isize + 1 ALLOCATE (opt_bas%comp_group(igroup + 1)%member_list(isize)) DO j = 1, isize opt_bas%comp_group(igroup + 1)%member_list(j) = icount @@ -563,7 +563,7 @@ CONTAINS iind = convert_l_contr_to_entry(subset%lmin, subset%l, icon, subset%lmin + il - 1) IF (.NOT. in_use(iind)) tmp_l(il) = tmp_l(il) - 1 END DO - IF (tmp_l(il) .GT. 0) subset_new%lmax = subset_new%lmax + 1 + IF (tmp_l(il) > 0) subset_new%lmax = subset_new%lmax + 1 END DO subset_new%nl = subset_new%lmax - subset_new%lmin + 1 subset_new%ncon_tot = SUM(tmp_l) @@ -754,7 +754,7 @@ CONTAINS CALL set_constraint(flex_basis, iset, ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (def_exp(2) .LE. flex_basis%subset(iset)%nexp) & + 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.") @@ -762,7 +762,7 @@ CONTAINS END IF END DO ELSE - IF (.NOT. def_exp(1) .LE. flex_basis%nsets) & + 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.") @@ -771,7 +771,7 @@ CONTAINS CALL set_constraint(flex_basis, def_exp(1), ipgf, const_section, is_bound, is_varlim, irep) END DO ELSE - IF (.NOT. def_exp(2) .LE. flex_basis%subset(def_exp(1))%nexp) & + 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.") @@ -816,7 +816,7 @@ 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) .GT. MAXVAL(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) .LT. MINVAL(r_vals)) & + 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))// & diff --git a/src/optimize_embedding_potential.F b/src/optimize_embedding_potential.F index 488ff831a5..d557562346 100644 --- a/src/optimize_embedding_potential.F +++ b/src/optimize_embedding_potential.F @@ -140,7 +140,7 @@ CONTAINS change_spin = .FALSE. open_shell_embed = .FALSE. ALLOCATE (all_nspins(ref_subsys_number)) - IF (ref_subsys_number .EQ. 3) THEN + IF (ref_subsys_number == 3) THEN all_spins = 0 DO i_force_eval = 1, ref_subsys_number CALL get_qs_env(qs_env=force_env%sub_force_env(i_force_eval)%force_env%qs_env, & @@ -151,31 +151,31 @@ CONTAINS END DO ! Find out whether we need a spin-dependend embedding potential - IF (.NOT. ((all_nspins(1) .EQ. 1) .AND. (all_nspins(2) .EQ. 1) .AND. (all_nspins(3) .EQ. 1))) & + IF (.NOT. ((all_nspins(1) == 1) .AND. (all_nspins(2) == 1) .AND. (all_nspins(3) == 1))) & open_shell_embed = .TRUE. ! If it's open shell, we need to check spin states IF (open_shell_embed) THEN - IF (all_nspins(3) .EQ. 1) THEN + IF (all_nspins(3) == 1) THEN total_spin = 0 ELSE total_spin = all_spins(1, 3) - all_spins(2, 3) END IF - IF (all_nspins(1) .EQ. 1) THEN + IF (all_nspins(1) == 1) THEN sub_spin_1 = 0 ELSE sub_spin_1 = all_spins(1, 1) - all_spins(2, 1) END IF - IF (all_nspins(2) .EQ. 1) THEN + IF (all_nspins(2) == 1) THEN sub_spin_2 = 0 ELSE sub_spin_2 = all_spins(1, 2) - all_spins(2, 2) END IF - IF ((sub_spin_1 + sub_spin_2) .EQ. total_spin) THEN + IF ((sub_spin_1 + sub_spin_2) == total_spin) THEN change_spin = .FALSE. ELSE - IF (ABS(sub_spin_1 - sub_spin_2) .EQ. total_spin) THEN + IF (ABS(sub_spin_1 - sub_spin_2) == total_spin) THEN change_spin = .TRUE. ELSE CPABORT("Spin states of subsystems are not compatible.") @@ -626,7 +626,7 @@ CONTAINS pw_env=pw_env) qs_section => section_vals_get_subs_vals(input, "DFT%QS") open_shell_embed = .FALSE. - IF (dft_control%nspins .EQ. 2) open_shell_embed = .TRUE. + IF (dft_control%nspins == 2) open_shell_embed = .TRUE. ! Prepare plane-waves pool CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool_subsys) @@ -1106,7 +1106,7 @@ CONTAINS opt_embed%open_shell_embed, opt_embed%lri) ! Add regularization with kinetic matrix - IF (opt_embed%i_iter .EQ. 1) THEN ! Else it is kept in memory + IF (opt_embed%i_iter == 1) THEN ! Else it is kept in memory CALL compute_kinetic_mat(qs_env, opt_embed%kinetic_mat) END IF @@ -1510,11 +1510,11 @@ CONTAINS ! Do a simple steepest descent IF (opt_embed%steep_desc) THEN - IF (opt_embed%i_iter .GT. 2) & + 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) - IF (ABS(opt_embed%trust_rad) .GT. opt_embed%max_trad) THEN - IF (opt_embed%trust_rad .GT. 0.0_dp) THEN + 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 ELSE opt_embed%trust_rad = -opt_embed%max_trad @@ -1577,7 +1577,7 @@ CONTAINS DO LLL = 1, nrow_local l_global = row_indices(LLL) - IF (ABS(eigenval(l_global)) .GE. thresh) THEN + IF (ABS(eigenval(l_global)) >= thresh) THEN diag_step%local_data(LLL, 1) = & -diag_grad%local_data(LLL, 1)/(eigenval(l_global)) ELSE @@ -1601,7 +1601,7 @@ CONTAINS ! Scale the step to fit within the trust radius: it it's less already, ! then take the Newton step CALL cp_fm_trace(opt_embed%step, opt_embed%step, opt_embed%step_len) - IF (opt_embed%step_len .GT. opt_embed%trust_rad) THEN + IF (opt_embed%step_len > opt_embed%trust_rad) THEN IF (opt_embed%level_shift) THEN ! Find a level shift parameter and apply it @@ -2207,22 +2207,22 @@ CONTAINS CALL cp_fm_release(H_b) - IF (actual_ener_change .GT. 0.0_dp) THEN ! If energy increases + IF (actual_ener_change > 0.0_dp) THEN ! If energy increases ! We accept step opt_embed%accept_step = .TRUE. ! 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 .GT. 1.0_dp) .AND. (.NOT. opt_embed%newton_step) .AND. & - (opt_embed%trust_rad .LT. opt_embed%max_trad)) & + IF ((ener_ratio > 1.0_dp) .AND. (.NOT. opt_embed%newton_step) .AND. & + (opt_embed%trust_rad < opt_embed%max_trad)) & opt_embed%trust_rad = 2.0_dp*opt_embed%trust_rad ELSE ! Energy decreases ! If the decrease is not too large we allow this step to be taken ! Otherwise, the step is rejected - IF (ABS(actual_ener_change) .GE. opt_embed%allowed_decrease) THEN + IF (ABS(actual_ener_change) >= opt_embed%allowed_decrease) THEN 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 .GE. opt_embed%min_trad) & + IF (opt_embed%trust_rad >= opt_embed%min_trad) & opt_embed%trust_rad = 0.25_dp*opt_embed%trust_rad END IF @@ -2272,14 +2272,14 @@ CONTAINS CALL cp_fm_trace(diag_grad, diag_grad, diag_grad_norm) - IF (hess_min .LT. 0.0_dp) THEN + IF (hess_min < 0.0_dp) THEN !shift_min = -2.0_dp*(diag_grad_norm/opt_embed%trust_rad - min(hess_min, 0.0_dp)) !shift_max = max(0.0_dp, -hess_min + 0.5_dp*grad_min/opt_embed%trust_rad) !shift_max = MIN(-hess_min+0.5_dp*grad_min/opt_embed%trust_rad, 0.0_dp) shift_max = hess_min + 0.1 shift_min = diag_grad_norm/opt_embed%trust_rad shift_min = 10.0_dp - !If (abs(shift_max) .LE. thresh) then + !If (abs(shift_max) <= thresh) then ! shift_min = -20.0_dp*(diag_grad_norm/opt_embed%trust_rad - min(hess_min, 0.0_dp)) !Else ! shift_min = 20.0_dp*shift_max @@ -2292,30 +2292,30 @@ CONTAINS ! Find zero by bisection converged = .FALSE. do_shift = .FALSE. - IF (ABS(step_minus_trad_max) .LE. thresh) THEN + IF (ABS(step_minus_trad_max) <= thresh) THEN shift = shift_max ELSE - IF (ABS(step_minus_trad_min) .LE. thresh) THEN + IF (ABS(step_minus_trad_min) <= thresh) THEN shift = shift_min ELSE DO i_iter = 1, max_iter shift = 0.5_dp*(shift_max + shift_min) step_minus_trad = shifted_step(diag_grad, eigenval, shift, opt_embed%trust_rad) - IF (i_iter .EQ. 1) step_minus_trad_first = step_minus_trad - IF (step_minus_trad .GT. 0.0_dp) shift_max = shift - IF (step_minus_trad .LT. 0.0_dp) shift_min = shift - !IF (ABS(shift_max-shift_min) .LT. thresh) converged = .TRUE. - IF (ABS(step_minus_trad) .LT. thresh) converged = .TRUE. + IF (i_iter == 1) step_minus_trad_first = step_minus_trad + IF (step_minus_trad > 0.0_dp) shift_max = shift + IF (step_minus_trad < 0.0_dp) shift_min = shift + !IF (ABS(shift_max-shift_min) < thresh) converged = .TRUE. + IF (ABS(step_minus_trad) < thresh) converged = .TRUE. IF (converged) EXIT END DO - IF (ABS(step_minus_trad) .LT. ABS(step_minus_trad_first)) do_shift = .TRUE. + IF (ABS(step_minus_trad) < ABS(step_minus_trad_first)) do_shift = .TRUE. END IF END IF ! Apply level-shifting IF (converged .OR. do_shift) THEN DO LLL = 1, nrow_local l_global = row_indices(LLL) - IF (ABS(eigenval(l_global)) .GE. thresh) THEN + IF (ABS(eigenval(l_global)) >= thresh) THEN diag_step%local_data(LLL, 1) = & -diag_grad%local_data(LLL, 1)/(eigenval(l_global) - shift) ELSE @@ -2329,13 +2329,13 @@ CONTAINS END IF ! Special case - ELSE ! Hess min .LT. 0.0_dp + ELSE ! Hess min < 0.0_dp ! First, find all positive eigenvalues ALLOCATE (red_eigenval_map(opt_embed%dimen_var_aux)) red_eigenval_map = 0 DO LLL = 1, nrow_local l_global = row_indices(LLL) - IF (eigenval(l_global) .GE. 0.0_dp) THEN + IF (eigenval(l_global) >= 0.0_dp) THEN red_eigenval_map(l_global) = 1 END IF END DO @@ -2346,8 +2346,8 @@ CONTAINS shift = -hess_min DO LLL = 1, nrow_local l_global = row_indices(LLL) - IF (red_eigenval_map(l_global) .EQ. 0) THEN - IF (ABS(eigenval(l_global)) .GE. thresh) THEN + IF (red_eigenval_map(l_global) == 0) THEN + IF (ABS(eigenval(l_global)) >= thresh) THEN diag_step%local_data(LLL, 1) = & -diag_grad%local_data(LLL, 1)/(eigenval(l_global) - shift) ELSE @@ -2397,7 +2397,7 @@ CONTAINS step = 0.0_dp DO LLL = 1, nrow_local l_global = row_indices(LLL) - IF ((ABS(eigenval(l_global)) .GE. thresh) .AND. (ABS(diag_grad%local_data(LLL, 1)) .GE. thresh)) THEN + IF ((ABS(eigenval(l_global)) >= thresh) .AND. (ABS(diag_grad%local_data(LLL, 1)) >= thresh)) THEN step_1d = -diag_grad%local_data(LLL, 1)/(eigenval(l_global) + shift) step = step + step_1d**2 END IF @@ -2510,7 +2510,7 @@ CONTAINS DO k = lb(3), ub(3) DO j = lb(2), ub(2) DO i = lb(1), ub(1) - IF (rho_r_ref(1)%array(i, j, k) .GT. rho_cutoff) THEN + IF (rho_r_ref(1)%array(i, j, k) > rho_cutoff) THEN my_rho = rho_r_ref(1)%array(i, j, k) ELSE my_rho = rho_cutoff @@ -2547,7 +2547,7 @@ CONTAINS CALL pw_axpy(spin_embed_pot, temp_embed_pot(1), 1.0_dp) CALL pw_axpy(spin_embed_pot, temp_embed_pot(2), -1.0_dp) - IF (SIZE(rho_r_ref) .EQ. 2) THEN + IF (SIZE(rho_r_ref) == 2) THEN CALL pw_axpy(rho_r_ref(1), rho_n_1(1), 1.0_dp) CALL pw_axpy(rho_r_ref(2), rho_n_1(2), 1.0_dp) @@ -2557,14 +2557,14 @@ CONTAINS DO k = lb(3), ub(3) DO j = lb(2), ub(2) DO i = lb(1), ub(1) - IF (rho_r_ref(1)%array(i, j, k) .GT. rho_cutoff) THEN + IF (rho_r_ref(1)%array(i, j, k) > rho_cutoff) THEN my_rho = rho_r_ref(1)%array(i, j, k) ELSE my_rho = rho_cutoff END IF new_embed_pot(1)%array(i, j, k) = step_len*temp_embed_pot(1)%array(i, j, k)* & (rho_n_1(1)%array(i, j, k))/my_rho - IF (rho_r_ref(2)%array(i, j, k) .GT. rho_cutoff) THEN + IF (rho_r_ref(2)%array(i, j, k) > rho_cutoff) THEN my_rho = rho_r_ref(2)%array(i, j, k) ELSE my_rho = rho_cutoff @@ -2586,7 +2586,7 @@ CONTAINS DO k = lb(3), ub(3) DO j = lb(2), ub(2) DO i = lb(1), ub(1) - IF (rho_r_ref(1)%array(i, j, k) .GT. rho_cutoff) THEN + IF (rho_r_ref(1)%array(i, j, k) > rho_cutoff) THEN my_rho = 0.5_dp*rho_r_ref(1)%array(i, j, k) ELSE my_rho = rho_cutoff @@ -2678,7 +2678,7 @@ CONTAINS ! We calculate von Weizsaecker potential for the reference density ! only at the first iteration - IF (i_iter .LE. 1) THEN + IF (i_iter <= 1) THEN nspins = SIZE(rho_r_ref) NULLIFY (v_w_ref) ALLOCATE (v_w_ref(nspins)) @@ -2741,7 +2741,7 @@ CONTAINS CALL pw_scale(curr_rho(1), a=0.5_dp) CALL pw_scale(curr_rho(2), a=0.5_dp) - IF (SIZE(rho_r_ref) .EQ. 1) THEN ! If reference system is closed-shell + IF (SIZE(rho_r_ref) == 1) THEN ! If reference system is closed-shell CALL pw_axpy(rho_r_ref(1), curr_rho(1), 0.5_dp) CALL pw_axpy(rho_r_ref(1), curr_rho(2), 0.5_dp) ELSE ! If reference system is open-shell @@ -2764,7 +2764,7 @@ CONTAINS CALL pw_axpy(spin_embed_pot, temp_embed_pot(2), -1.0_dp) ! Compute new embedding potential - IF (SIZE(v_w_ref) .EQ. 1) THEN ! Reference system is closed-shell + IF (SIZE(v_w_ref) == 1) THEN ! Reference system is closed-shell CALL pw_copy(temp_embed_pot(1), new_embed_pot(1)) CALL pw_axpy(v_w(1), new_embed_pot(1), 0.5_dp*step_len) CALL pw_axpy(v_w_ref(1), new_embed_pot(1), -0.5_dp*step_len) @@ -2876,7 +2876,7 @@ CONTAINS CALL xc_rho_cflags_setall(needs, .FALSE.) - IF (nspins .EQ. 2) THEN + IF (nspins == 2) THEN needs%rho_spin = .TRUE. needs%norm_drho_spin = .TRUE. needs%laplace_rho_spin = .TRUE. @@ -2899,14 +2899,14 @@ CONTAINS lb(1:3) = rho_r(1)%pw_grid%bounds_local(1, 1:3) ub(1:3) = rho_r(1)%pw_grid%bounds_local(2, 1:3) - IF (nspins .EQ. 2) THEN + IF (nspins == 2) THEN !$OMP PARALLEL DO DEFAULT(NONE) & !$OMP PRIVATE(i,j,k, my_rho) & !$OMP SHARED(v_w, rho_r, rho_set, lb, ub, rho_cutoff) DO k = lb(3), ub(3) DO j = lb(2), ub(2) DO i = lb(1), ub(1) - IF (rho_r(1)%array(i, j, k) .GT. rho_cutoff) THEN + IF (rho_r(1)%array(i, j, k) > rho_cutoff) THEN my_rho = rho_r(1)%array(i, j, k) ELSE my_rho = rho_cutoff @@ -2914,7 +2914,7 @@ CONTAINS v_w(1)%array(i, j, k) = one_8*rho_set%norm_drhoa(i, j, k)**2/my_rho**2 - & one_4*rho_set%laplace_rhoa(i, j, k)/my_rho - IF (rho_r(2)%array(i, j, k) .GT. rho_cutoff) THEN + IF (rho_r(2)%array(i, j, k) > rho_cutoff) THEN my_rho = rho_r(2)%array(i, j, k) ELSE my_rho = rho_cutoff @@ -2932,7 +2932,7 @@ CONTAINS DO k = lb(3), ub(3) DO j = lb(2), ub(2) DO i = lb(1), ub(1) - IF (rho_r(1)%array(i, j, k) .GT. rho_cutoff) THEN + IF (rho_r(1)%array(i, j, k) > rho_cutoff) THEN my_rho = rho_r(1)%array(i, j, k) v_w(1)%array(i, j, k) = one_8*rho_set%norm_drho(i, j, k)**2/my_rho**2 - & one_4*rho_set%laplace_rho(i, j, k)/my_rho @@ -3389,7 +3389,7 @@ CONTAINS " Optimize embedding potential info at step = ", step_num WRITE (UNIT=output_unit, FMT="(T2,A,F20.10)") & " Functional value = ", opt_embed%w_func(step_num) - IF (step_num .GT. 1) THEN + IF (step_num > 1) THEN WRITE (UNIT=output_unit, FMT="(T2,A,F20.10)") & " Real energy change = ", opt_embed%w_func(step_num) - & opt_embed%w_func(step_num - 1) @@ -3504,14 +3504,14 @@ CONTAINS ! Open shell IF (opt_embed%open_shell_embed) THEN max_diff_spin = opt_embed%max_diff(2) - IF ((max_diff .LE. opt_embed%conv_max) .AND. (max_diff_spin .LE. opt_embed%conv_max_spin)) THEN + IF ((max_diff <= opt_embed%conv_max) .AND. (max_diff_spin <= opt_embed%conv_max_spin)) THEN conv_max_diff = .TRUE. ELSE conv_max_diff = .FALSE. END IF ELSE ! Closed shell - IF (max_diff .LE. opt_embed%conv_max) THEN + IF (max_diff <= opt_embed%conv_max) THEN conv_max_diff = .TRUE. ELSE conv_max_diff = .FALSE. @@ -3523,14 +3523,14 @@ CONTAINS ! Open shell IF (opt_embed%open_shell_embed) THEN int_diff_spin = opt_embed%int_diff(2) - IF ((int_diff .LE. opt_embed%conv_int) .AND. (int_diff_spin .LE. opt_embed%conv_int_spin)) THEN + IF ((int_diff <= opt_embed%conv_int) .AND. (int_diff_spin <= opt_embed%conv_int_spin)) THEN conv_int_diff = .TRUE. ELSE conv_int_diff = .FALSE. END IF ELSE ! Closed shell - IF (int_diff .LE. opt_embed%conv_int) THEN + IF (int_diff <= opt_embed%conv_int) THEN conv_int_diff = .TRUE. ELSE conv_int_diff = .FALSE. diff --git a/src/optimize_input.F b/src/optimize_input.F index 16cebda6fd..1eb4d19639 100644 --- a/src/optimize_input.F +++ b/src/optimize_input.F @@ -118,7 +118,7 @@ CONTAINS CALL parse_input(oi_env, root_section) ! if we have been asked to randomize the variables, we do this. - IF (oi_env%randomize_variables .NE. 0.0_dp) THEN + IF (oi_env%randomize_variables /= 0.0_dp) THEN seed = REAL(oi_env%seed, KIND=dp) rng_stream = rng_stream_type("run_optimize_input", distribution_type=UNIFORM, seed=seed) DO i_var = 1, SIZE(oi_env%variables, 1) @@ -525,7 +525,7 @@ CONTAINS n_frames_current = 0 NULLIFY (pos_traj, energy_traj, force_traj) filename = oi_env%fm_env%ref_traj_file_name - IF (filename .EQ. "") & + IF (filename == "") & CPABORT("The reference trajectory file name is empty") CALL parser_create(local_parser, filename, para_env=para_env) DO @@ -559,7 +559,7 @@ CONTAINS ! now force reference trajectory filename = oi_env%fm_env%ref_force_file_name - IF (filename .EQ. "") & + IF (filename == "") & CPABORT("The reference force file name is empty") CALL parser_create(local_parser, filename, para_env=para_env) DO iframe = 1, n_frames @@ -589,7 +589,7 @@ CONTAINS ! and cell, which is optional NULLIFY (cell_traj) filename = oi_env%fm_env%ref_cell_file_name - IF (filename .NE. "") THEN + IF (filename /= "") THEN CALL parser_create(local_parser, filename, para_env=para_env) ALLOCATE (cell_traj(3, 3, n_frames)) DO iframe = 1, n_frames diff --git a/src/pao_io.F b/src/pao_io.F index c4e5cfcc8d..d58a08178a 100644 --- a/src/pao_io.F +++ b/src/pao_io.F @@ -120,7 +120,7 @@ CONTAINS END IF ! check parametrization - IF (TRIM(param) .NE. TRIM(ADJUSTL(id2str(pao%parameterization)))) & + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & CPABORT("Restart PAO parametrization does not match") ! check kinds @@ -284,7 +284,7 @@ CONTAINS READ (unit_nr, fmt=*) label, iatom, str_in, pos_in CPASSERT(ALLOCATED(kinds)) DO ikind = 1, nkinds - IF (TRIM(kinds(ikind)%name) .EQ. TRIM(str_in)) EXIT + IF (TRIM(kinds(ikind)%name) == TRIM(str_in)) EXIT END DO CPASSERT(ALLOCATED(atom2kind) .AND. ALLOCATED(positions)) atom2kind(iatom) = ikind @@ -351,11 +351,11 @@ CONTAINS IF (pao_kind%nparams /= nparams) & CPABORT("Number of parameters do not match") - IF (TRIM(pao_kind%name) .NE. TRIM(name)) & + IF (TRIM(pao_kind%name) /= TRIM(name)) & CPABORT("Kind names do not match") IF (pao_kind%z /= z) & CPABORT("Atomic numbers do not match") - IF (TRIM(pao_kind%prim_basis_name) .NE. TRIM(basis_set%name)) & + IF (TRIM(pao_kind%prim_basis_name) /= TRIM(basis_set%name)) & CPABORT("Primary Basis-set name does not match") IF (pao_kind%prim_basis_size /= basis_set%nsgf) & CPABORT("Primary Basis-set size does not match") diff --git a/src/pao_ml.F b/src/pao_ml.F index 7f3b279fcd..a91bfd0eea 100644 --- a/src/pao_ml.F +++ b/src/pao_ml.F @@ -166,7 +166,7 @@ CONTAINS CALL pao_read_raw(filename, param, hmat, kinds, atom2kind, positions, xblocks, ml_range) ! check parametrization - IF (TRIM(param) .NE. TRIM(ADJUSTL(id2str(pao%parameterization)))) & + IF (TRIM(param) /= TRIM(ADJUSTL(id2str(pao%parameterization)))) & CPABORT("Restart PAO parametrization does not match") ! map read-in kinds onto kinds of this run @@ -269,7 +269,7 @@ CONTAINS DO jkind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(jkind), name=name) ! match kinds via their name - IF (TRIM(kinds(ikind)%name) .EQ. TRIM(name)) THEN + IF (TRIM(kinds(ikind)%name) == TRIM(name)) THEN CALL pao_kinds_ensure_equal(pao, qs_env, jkind, kinds(ikind)) kindsmap(ikind) = jkind EXIT diff --git a/src/pao_model.F b/src/pao_model.F index a8ae500561..df77642acf 100644 --- a/src/pao_model.F +++ b/src/pao_model.F @@ -122,11 +122,11 @@ CONTAINS CALL get_atomic_kind(atomic_kind_set(ikind), name=kind_name, z=z) IF (model%version /= 2) & CPABORT("Model version not supported.") - IF (TRIM(model%kind_name) .NE. TRIM(kind_name)) & + IF (TRIM(model%kind_name) /= TRIM(kind_name)) & CPABORT("Kind name does not match.") IF (model%atomic_number /= z) & CPABORT("Atomic number does not match.") - IF (TRIM(model%prim_basis_name) .NE. TRIM(basis_set%name)) & + IF (TRIM(model%prim_basis_name) /= TRIM(basis_set%name)) & CPABORT("Primary basis set name does not match.") IF (model%prim_basis_size /= basis_set%nsgf) & CPABORT("Primary basis set size does not match.") diff --git a/src/paw_proj_set_types.F b/src/paw_proj_set_types.F index 7e186850f7..d2d624ab5b 100644 --- a/src/paw_proj_set_types.F +++ b/src/paw_proj_set_types.F @@ -192,7 +192,7 @@ CONTAINS eps_iso = qs_control%gapw_control%eps_iso eps_svd = qs_control%gapw_control%eps_svd max_rad_local = qs_control%gapw_control%max_rad_local - IF (max_rad_local_type .LT. max_rad_local) THEN + IF (max_rad_local_type < max_rad_local) THEN max_rad_local = max_rad_local_type END IF eps_orb = qs_control%eps_pgf_orb @@ -441,7 +441,7 @@ CONTAINS END DO ! Compute inverse of the transpose - IF (eps_svd .EQ. 0.0_dp) THEN + IF (eps_svd == 0.0_dp) THEN CALL invert_matrix(smat, gcc, my_error, "T") ELSE work = TRANSPOSE(smat) diff --git a/src/pexsi_interface.F b/src/pexsi_interface.F index 7c91a8b350..154b30758a 100644 --- a/src/pexsi_interface.F +++ b/src/pexsi_interface.F @@ -281,7 +281,7 @@ CONTAINS CALL timeset(routineN, handle) cp_pexsi_plan_initialize = f_ppexsi_plan_initialize(comm%get_handle(), numProcRow, & numProcCol, outputFileIndex, info) - IF (info .NE. 0) & + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") CALL timestop(handle) #else @@ -329,7 +329,7 @@ CONTAINS CALL f_ppexsi_load_real_hs_matrix(plan, pexsi_options%options, nrows, nnz, nnzLocal, & numColLocal, colptrLocal, rowindLocal, & HnzvalLocal, isSIdentity, SnzvalLocal, info) - IF (info .NE. 0) & + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") CALL timestop(handle) #else @@ -396,7 +396,7 @@ CONTAINS CALL ieee_set_halting_mode(IEEE_ALL, halt) #endif - IF (info .NE. 0) & + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") CALL timestop(handle) #else @@ -440,7 +440,7 @@ CONTAINS CALL f_ppexsi_retrieve_real_dft_matrix(plan, DMnzvalLocal, EDMnzvalLocal, & FDMnzvalLocal, totalEnergyH, & totalEnergyS, totalFreeEnergy, info) - IF (info .NE. 0) & + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") CALL timestop(handle) #else @@ -470,7 +470,7 @@ CONTAINS CALL timeset(routineN, handle) CALL f_ppexsi_plan_finalize(plan, info) - IF (info .NE. 0) & + IF (info /= 0) & CPABORT("Pexsi returned an error. Consider logPEXSI0 for details.") CALL timestop(handle) #else diff --git a/src/pexsi_methods.F b/src/pexsi_methods.F index 1549f8053a..fea91aefb5 100644 --- a/src/pexsi_methods.F +++ b/src/pexsi_methods.F @@ -146,7 +146,7 @@ CONTAINS pexsi_env%num_ranks_per_pole = min_ranks_per_pole ! not a PEXSI option pexsi_env%csr_screening = csr_screening - IF (numElectronInitialTolerance .LT. numElectronTargetTolerance) & + IF (numElectronInitialTolerance < numElectronTargetTolerance) & numElectronInitialTolerance = numElectronTargetTolerance pexsi_env%tol_nel_initial = numElectronInitialTolerance @@ -255,7 +255,7 @@ CONTAINS mu_total = SUM(mu_spin(1:pexsi_env%nspin))/REAL(pexsi_env%nspin, KIND=dp) kTS_total = SUM(pexsi_env%kTS) - IF (pexsi_env%nspin .EQ. 1) kTS_total = kTS_total*2.0_dp + IF (pexsi_env%nspin == 1) kTS_total = kTS_total*2.0_dp IF (unit_nr > 0) THEN WRITE (unit_nr, "(/A,T55,F26.15)") & @@ -331,7 +331,7 @@ CONTAINS unit_nr = -1 END IF - first_call = (iscf .EQ. 1) .AND. (ispin .EQ. 1) + first_call = (iscf == 1) .AND. (ispin == 1) ! Assert a few things the first time PEXSI is called IF (first_call) THEN @@ -343,13 +343,13 @@ CONTAINS CPABORT("PEXSI interface expects a non-symmetric DBCSR overlap matrix") ! Assertion on datatype - IF ((pexsi_env%csr_mat_s%nzval_local%data_type .NE. dbcsr_csr_type_real_8) & - .OR. (pexsi_env%csr_mat_ks%nzval_local%data_type .NE. dbcsr_csr_type_real_8)) & + 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)) & CPABORT("Complex data type not supported by PEXSI") ! Assertion on number of non-zero elements !(TODO: update when PEXSI changes to Long Int) - IF (pexsi_env%csr_mat_s%nze_total .GE. INT(2, kind=int_8)**31) & + 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 @@ -375,7 +375,7 @@ CONTAINS CALL setup_arnoldi_env(arnoldi_env, arnoldi_matrices, max_iter=20, & threshold=1.0E-2_dp, selection_crit=2, nval_request=1, nrestarts=21, & generalized_ev=.TRUE., iram=.FALSE.) - IF (iscf .GT. 1) CALL set_arnoldi_initial_vector(arnoldi_env, pexsi_env%max_ev_vector(ispin)) + IF (iscf > 1) CALL set_arnoldi_initial_vector(arnoldi_env, pexsi_env%max_ev_vector(ispin)) CALL arnoldi_ev(arnoldi_matrices, arnoldi_env) delta_E = REAL(get_selected_ritz_val(arnoldi_env, 1), dp) ! increase delta_E a bit to make sure that it really is an upper bound @@ -390,7 +390,7 @@ CONTAINS CALL cp_pexsi_set_options(pexsi_env%options, deltaE=delta_E) ! Set PEXSI options appropriately for first SCF iteration - IF (iscf .EQ. 1) THEN + IF (iscf == 1) THEN ! Get option isInertiaCount to reset it later on and set it to 1 for first SCF iteration CALL cp_pexsi_get_options(pexsi_env%options, isInertiaCount=isInertiaCount) CALL cp_pexsi_set_options(pexsi_env%options, isInertiaCount=1, & @@ -407,7 +407,7 @@ CONTAINS ! ", spin component", ispin IF (unit_nr > 0) WRITE (unit_nr, '(/A,T41,L20)') " PEXSI| Do inertia counting?", & - isInertiaCount_out .EQ. 1 + isInertiaCount_out == 1 IF (unit_nr > 0) WRITE (unit_nr, '(A,T50,F5.2,T56,F5.2)') & " PEXSI| Guess for min mu, max mu", mu_min_in, mu_max_in @@ -415,7 +415,7 @@ CONTAINS " PEXSI| Tolerance in number of electrons", nel_tol ! IF(unit_nr>0) WRITE(unit_nr,'(A,T41,L20)') & -! " PEXSI| Do symbolic factorization?", is_symbolic_factorize.EQ.1 +! " PEXSI| Do symbolic factorization?", is_symbolic_factorize==1 IF (unit_nr > 0) WRITE (unit_nr, '(A,T41,F20.2)') & " PEXSI| Arnoldi est. spectral radius", delta_E @@ -445,7 +445,7 @@ CONTAINS ! Check convergence nelectron_diff = nelectron_out - nelectron_exact_pexsi - pexsi_convergence = ABS(nelectron_diff) .LT. nel_tol + pexsi_convergence = ABS(nelectron_diff) < nel_tol IF (unit_nr > 0) THEN IF (pexsi_convergence) THEN @@ -499,7 +499,7 @@ CONTAINS muMax0=mu_max_out) ! Reset isInertiaCount according to user input - IF (iscf .EQ. 1) THEN + IF (iscf == 1) THEN CALL cp_pexsi_set_options(pexsi_env%options, isInertiaCount= & isInertiaCount) END IF @@ -559,7 +559,7 @@ CONTAINS tol_nel = MIN(tol_nel, pexsi_env%tol_nel_initial) END IF - check_convergence = (tol_nel .LE. pexsi_env%tol_nel_target) + check_convergence = (tol_nel <= pexsi_env%tol_nel_target) CALL cp_pexsi_set_options(pexsi_env%options, numElectronPEXSITolerance=tol_nel) CALL timestop(handle) @@ -609,13 +609,13 @@ CONTAINS DO ispin = 1, ls_scf_env%nspins CALL matrix_ls_to_qs(matrix_w_qs(ispin)%matrix, matrix_w(ispin)%matrix, & ls_scf_env%ls_mstruct, covariant=.FALSE.) - IF (ls_scf_env%nspins .EQ. 1) CALL dbcsr_scale(matrix_w_qs(ispin)%matrix, 2.0_dp) + IF (ls_scf_env%nspins == 1) CALL dbcsr_scale(matrix_w_qs(ispin)%matrix, 2.0_dp) END DO END IF IF (PRESENT(kTS)) THEN kTS_total = SUM(kTS) - IF (ls_scf_env%nspins .EQ. 1) kTS_total = kTS_total*2.0_dp + IF (ls_scf_env%nspins == 1) kTS_total = kTS_total*2.0_dp energy%kTS = kTS_total END IF diff --git a/src/pexsi_types.F b/src/pexsi_types.F index 8a61fcb494..31cde07cd0 100644 --- a/src/pexsi_types.F +++ b/src/pexsi_types.F @@ -151,20 +151,20 @@ CONTAINS ! Use all nodes available per pole by default or if the user tries to use ! more nodes than MPI size - IF ((pexsi_env%num_ranks_per_pole .GT. numnodes) & - .OR. (pexsi_env%num_ranks_per_pole .EQ. 0)) THEN + IF ((pexsi_env%num_ranks_per_pole > numnodes) & + .OR. (pexsi_env%num_ranks_per_pole == 0)) THEN pexsi_env%num_ranks_per_pole = numnodes END IF ! Find num_ranks_per_pole from user input MIN_RANKS_PER_POLE s.t. num_ranks_per_pole ! is the smallest number greater or equal to min_ranks_per_pole that divides ! MPI size without remainder. - DO WHILE (MOD(numnodes, pexsi_env%num_ranks_per_pole) .NE. 0) + DO WHILE (MOD(numnodes, pexsi_env%num_ranks_per_pole) /= 0) pexsi_env%num_ranks_per_pole = pexsi_env%num_ranks_per_pole + 1 END DO CALL cp_pexsi_get_options(pexsi_env%options, npSymbFact=npSymbFact) - IF ((npSymbFact .GT. pexsi_env%num_ranks_per_pole) .OR. (npSymbFact .EQ. 0)) THEN + IF ((npSymbFact > pexsi_env%num_ranks_per_pole) .OR. (npSymbFact == 0)) THEN ! Use maximum possible number of ranks for symbolic factorization CALL cp_pexsi_set_options(pexsi_env%options, npSymbFact=pexsi_env%num_ranks_per_pole) END IF @@ -320,7 +320,7 @@ CONTAINS CASE (1) WRITE (unit_nr, '(A,T61,A20)') " PEXSI| Row permutation strategy", "make diagonal entry larger than off diagonal" END SELECT - IF (ordering .EQ. 0) WRITE (unit_nr, '(A,T61,I20/)') & + IF (ordering == 0) WRITE (unit_nr, '(A,T61,I20/)') & " PEXSI| Number of processors for symbolic factorization", npSymbFact END SUBROUTINE print_pexsi_info diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index bc56cf3193..a18de03642 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -416,7 +416,7 @@ CONTAINS ! we need in periodic directions at least 4 k-points in the SCF DO i_dim = 1, 3 IF (bs_env%periodic(i_dim) == 1) THEN - CPASSERT(nkp_grid(i_dim) .GE. 4) + CPASSERT(nkp_grid(i_dim) >= 4) END IF END DO @@ -780,7 +780,7 @@ CONTAINS ! check if Cholesky decomposition failed (Cholesky decomposition only works for ! positive definite matrices - IF (info .NE. 0) THEN + IF (info /= 0) THEN u = bs_env%unit_nr IF (u > 0) THEN @@ -1211,7 +1211,7 @@ CONTAINS IF (bs_env%do_soc) THEN ! only print eigenvalues of DOS k-points in case no bandstructure path has been given - print_DOS_kpoints = (bs_env%nkp_only_bs .LE. 0) + print_DOS_kpoints = (bs_env%nkp_only_bs <= 0) ! in kpoints_DOS, the last nkp_only_bs are bandstructure k-points is_bandstruc_kpoint = (ikp > bs_env%nkp_only_DOS) print_ikp = print_DOS_kpoints .OR. is_bandstruc_kpoint @@ -2002,7 +2002,7 @@ CONTAINS n_occ_spinor = bs_env%n_occ(1) + bs_env%n_occ(bs_env%n_spin) DO i_mo = 1, SIZE(eigenval_spinor) - IF (i_mo .LE. n_occ_spinor) occ_vir = 'occ' + IF (i_mo <= n_occ_spinor) occ_vir = 'occ' IF (i_mo > n_occ_spinor) occ_vir = 'vir' IF (PRESENT(eigenval_spinor_G0W0)) THEN ! SCF+SOC and G0W0+SOC eigenvalues @@ -2228,15 +2228,15 @@ CONTAINS i_global = row_indices(i_row) - IF (i_global .LE. n_ao) THEN + IF (i_global <= n_ao) THEN i_atom = atom_from_bf(i_global) - ELSE IF (i_global .LE. 2*n_ao) THEN + ELSE IF (i_global <= 2*n_ao) THEN i_atom = atom_from_bf(i_global - n_ao) ELSE CPABORT("Wrong indices.") END IF - IF (i_kind .NE. kind_of(i_atom)) THEN + IF (i_kind /= kind_of(i_atom)) THEN cfm_s_i_kind%local_data(i_row, j_col) = z_zero END IF @@ -2409,7 +2409,7 @@ CONTAINS j_atom = atom_from_bf(col_global) ! we only need to check for new MIC cell for new i_atom-j_atom pair - IF (i_atom .NE. i_atom_old .OR. j_atom .NE. j_atom_old) THEN + IF (i_atom /= i_atom_old .OR. j_atom /= j_atom_old) THEN DO i_cell = 1, num_cells ! only check nearest neigbors @@ -2552,7 +2552,7 @@ CONTAINS END SELECT END IF - IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old) THEN + IF (iatom /= iatom_old .OR. jatom /= jatom_old) THEN CALL compute_weight_re_im(weight_re, weight_im, & num_cells, iatom, jatom, xkp(1:3, ikp), wkp_of_ikp, & diff --git a/src/preconditioner_makes.F b/src/preconditioner_makes.F index 01eb60ce8c..daeeb0bde6 100644 --- a/src/preconditioner_makes.F +++ b/src/preconditioner_makes.F @@ -93,7 +93,7 @@ CONTAINS precon_type = preconditioner_env%in_use SELECT CASE (precon_type) CASE (ot_precond_full_single) - IF (my_solver_type .NE. ot_precond_solver_default) & + IF (my_solver_type /= ot_precond_solver_default) & CPABORT("Only PRECOND_SOLVER DEFAULT for the moment") IF (PRESENT(matrix_s)) THEN CALL make_full_single(preconditioner_env, preconditioner_env%fm, & @@ -104,22 +104,22 @@ CONTAINS END IF CASE (ot_precond_s_inverse) - IF (my_solver_type .EQ. ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol + IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol IF (.NOT. PRESENT(matrix_s)) & CPABORT("Type for S=1 not implemented") CALL make_full_s_inverse(preconditioner_env, matrix_s) CASE (ot_precond_full_kinetic) - IF (my_solver_type .EQ. ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol + 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))) & CPABORT("Type for S=1 not implemented") CALL make_full_kinetic(preconditioner_env, matrix_t, matrix_s, energy_gap) CASE (ot_precond_full_single_inverse) - IF (my_solver_type .EQ. ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol + IF (my_solver_type == ot_precond_solver_default) my_solver_type = ot_precond_solver_inv_chol CALL make_full_single_inverse(preconditioner_env, mo_coeff, matrix_h, energy_gap, & matrix_s=matrix_s) CASE (ot_precond_full_all) - IF (my_solver_type .NE. ot_precond_solver_default) THEN + IF (my_solver_type /= ot_precond_solver_default) THEN CPABORT("Only PRECOND_SOLVER DEFAULT for the moment") END IF IF (PRESENT(matrix_s)) THEN @@ -793,7 +793,7 @@ CONTAINS ! Shift the Lumo to the 1.5*the computed energy_gap or the external energy gap value ! The factor 1.5 is determined by trying. If the LUMO is positive, enough, just leave it alone pre_shift = MAX(1.5_dp*(min_ev - max_ev), energy_gap) - IF (min_ev .LT. pre_shift) THEN + IF (min_ev < pre_shift) THEN pre_shift = pre_shift - min_ev ELSE pre_shift = 0.0_dp diff --git a/src/preconditioner_solvers.F b/src/preconditioner_solvers.F index 6df29c5000..6828adab38 100644 --- a/src/preconditioner_solvers.F +++ b/src/preconditioner_solvers.F @@ -98,7 +98,7 @@ CONTAINS occ_matrix = dbcsr_get_occupation(preconditioner_env%sparse_matrix) END IF ! check whether we are in the first step and if it is a good idea to use cholesky (matrix sparsity) - IF (preconditioner_env%solver .NE. ot_precond_solver_update .AND. occ_matrix > 0.5_dp) THEN + IF (preconditioner_env%solver /= ot_precond_solver_update .AND. occ_matrix > 0.5_dp) THEN preconditioner_env%solver = ot_precond_solver_update CALL make_full_inverse_cholesky(preconditioner_env, matrix_s) ELSE @@ -193,7 +193,7 @@ CONTAINS CALL cp_fm_cholesky_decompose(fm, info_out=info_out) ! ! if fm not SPD we go with the overlap matrix - IF (info_out .NE. 0) THEN + IF (info_out /= 0) THEN ! ! just the overlap matrix IF (PRESENT(matrix_s)) THEN diff --git a/src/preconditioner_types.F b/src/preconditioner_types.F index 1ae1e982f7..0e9ddd92c4 100644 --- a/src/preconditioner_types.F +++ b/src/preconditioner_types.F @@ -73,7 +73,7 @@ CONTAINS TYPE(preconditioner_type) :: preconditioner LOGICAL :: preconditioner_in_use - preconditioner_in_use = .NOT. (preconditioner%in_use .EQ. 0) + preconditioner_in_use = .NOT. (preconditioner%in_use == 0) END FUNCTION ! ************************************************************************************************** diff --git a/src/pw/cube_utils.F b/src/pw/cube_utils.F index b1ff41fcf9..7567ed53d3 100644 --- a/src/pw/cube_utils.F +++ b/src/pw/cube_utils.F @@ -147,7 +147,7 @@ CONTAINS IF (info%orthorhombic) THEN imr = MAX(1, CEILING(radius/info%drmin)) - IF (imr .GT. info%max_radius) THEN + IF (imr > info%max_radius) THEN ! ! This is an important check. If the required radius for mapping the density is different ! from the actual computed one, (significant) errors can occur. @@ -309,7 +309,7 @@ CONTAINS END DO info%ub_cube(:, i) = 1 - info%lb_cube(:, i) END DO - IF (check_1 .NE. check_2) THEN + IF (check_1 /= check_2) THEN CPABORT("Irreproducible fp math caused memory corruption") END IF diff --git a/src/pw/dct.F b/src/pw/dct.F index 6dda495e43..2f4608a5d2 100644 --- a/src/pw/dct.F +++ b/src/pw/dct.F @@ -334,14 +334,14 @@ CONTAINS maxn_sendrecv = 4 ALLOCATE (srcs_coord(2, maxn_sendrecv)) - IF (MOD(rs_dim1, 2) .EQ. 0) THEN + IF (MOD(rs_dim1, 2) == 0) THEN tmp_size1 = rs_dim1 ELSE tmp_size1 = rs_dim1 + 1 END IF ALLOCATE (tmp1_arr(tmp_size1), src_pos1(2, 0:rs_dim1 - 1)) - IF (MOD(rs_dim1, 2) .EQ. 0) THEN + IF (MOD(rs_dim1, 2) == 0) THEN tmp1_arr(:) = [(i, i=1, rs_dim1)] src_pos1(:, :) = RESHAPE([tmp1_arr, -tmp1_arr(tmp_size1:1:-1)], [2, rs_dim1]) ELSE @@ -349,14 +349,14 @@ CONTAINS src_pos1(:, :) = RESHAPE([tmp1_arr, -tmp1_arr(tmp_size1 - 2:1:-1)], [2, rs_dim1]) END IF !--- - IF (MOD(rs_dim2, 2) .EQ. 0) THEN + IF (MOD(rs_dim2, 2) == 0) THEN tmp_size2 = rs_dim2 ELSE tmp_size2 = rs_dim2 + 1 END IF ALLOCATE (tmp2_arr(tmp_size2), src_pos2(2, 0:rs_dim2 - 1)) - IF (MOD(rs_dim2, 2) .EQ. 0) THEN + IF (MOD(rs_dim2, 2) == 0) THEN tmp2_arr(:) = [(i, i=1, rs_dim2)] src_pos2(:, :) = RESHAPE([tmp2_arr, -tmp2_arr(tmp_size2:1:-1)], [2, rs_dim2]) ELSE @@ -372,14 +372,14 @@ CONTAINS maxn_sendrecv = 2 ALLOCATE (srcs_coord(2, maxn_sendrecv)) - IF (MOD(rs_dim1, 2) .EQ. 0) THEN + IF (MOD(rs_dim1, 2) == 0) THEN tmp_size1 = rs_dim1 ELSE tmp_size1 = rs_dim1 + 1 END IF ALLOCATE (tmp1_arr(tmp_size1), src_pos1(2, 0:rs_dim1 - 1)) - IF (MOD(rs_dim1, 2) .EQ. 0) THEN + IF (MOD(rs_dim1, 2) == 0) THEN tmp1_arr(:) = [(i, i=1, rs_dim1)] src_pos1(:, :) = RESHAPE([tmp1_arr, -tmp1_arr(tmp_size1:1:-1)], [2, rs_dim1]) ELSE @@ -399,14 +399,14 @@ CONTAINS ALLOCATE (src_pos1_onesdd(0:rs_dim1 - 1)) src_pos1_onesdd(:) = [(i, i=1, rs_dim1)] !--- - IF (MOD(rs_dim2, 2) .EQ. 0) THEN + IF (MOD(rs_dim2, 2) == 0) THEN tmp_size2 = rs_dim2 ELSE tmp_size2 = rs_dim2 + 1 END IF ALLOCATE (tmp2_arr(tmp_size2), src_pos2(2, 0:rs_dim2 - 1)) - IF (MOD(rs_dim2, 2) .EQ. 0) THEN + IF (MOD(rs_dim2, 2) == 0) THEN tmp2_arr(:) = [(i, i=1, rs_dim2)] src_pos2(:, :) = RESHAPE([tmp2_arr, -tmp2_arr(tmp_size2:1:-1)], [2, rs_dim2]) ELSE @@ -436,11 +436,11 @@ CONTAINS ! convert srcs_coord to pid CALL pw_grid%para%group%rank_cart(ABS(srcs_coord(:, k)) - 1, srcs_expand(k)) ! find out the flipping status - IF ((srcs_coord(1, k) .GT. 0) .AND. (srcs_coord(2, k) .GT. 0)) THEN + IF ((srcs_coord(1, k) > 0) .AND. (srcs_coord(2, k) > 0)) THEN flipg_stat(k) = NOT_FLIPPED - ELSE IF ((srcs_coord(1, k) .LT. 0) .AND. (srcs_coord(2, k) .GT. 0)) THEN + ELSE IF ((srcs_coord(1, k) < 0) .AND. (srcs_coord(2, k) > 0)) THEN flipg_stat(k) = UD_FLIPPED - ELSE IF ((srcs_coord(1, k) .GT. 0) .AND. (srcs_coord(2, k) .LT. 0)) THEN + ELSE IF ((srcs_coord(1, k) > 0) .AND. (srcs_coord(2, k) < 0)) THEN flipg_stat(k) = LR_FLIPPED ELSE flipg_stat(k) = ROTATED @@ -455,7 +455,7 @@ CONTAINS k = 1 DO i = 1, group_size DO j = 1, maxn_sendrecv - IF (srcs_expand_all(j, i) .EQ. rs_mpo) THEN + IF (srcs_expand_all(j, i) == rs_mpo) THEN dests_expand(k) = i - 1 k = k + 1 END IF @@ -470,7 +470,7 @@ CONTAINS ! if the flipping status for a process is NOT_FLIPPED that means I will have to resend ! data to that process in the reverse procedure (the process is on my dests_shrink list) DO i = 1, maxn_sendrecv - IF (flipg_stat(i) .EQ. NOT_FLIPPED) dests_shrink(i) = srcs_expand(i) + IF (flipg_stat(i) == NOT_FLIPPED) dests_shrink(i) = srcs_expand(i) END DO ! let all the nodes know about each others dests_shrink list @@ -481,7 +481,7 @@ CONTAINS ! note that in the shrinking procedure I will receive from only one node DO i = 1, group_size DO j = 1, maxn_sendrecv - IF (dests_shrink_all(j, i) .EQ. rs_mpo) THEN + IF (dests_shrink_all(j, i) == rs_mpo) THEN srcs_shrink = i - 1 EXIT END IF @@ -567,7 +567,7 @@ CONTAINS DO i = 1, maxn_sendrecv ! no need to send to myself or to the destination that I have already sent to - IF ((dests_expand(i) .NE. rs_mpo) .AND. .NOT. ANY(dest_hist .EQ. dests_expand(i))) THEN + IF ((dests_expand(i) /= rs_mpo) .AND. .NOT. ANY(dest_hist == dests_expand(i))) THEN CALL rs_group%isend(pw_in%array, dests_expand(i), send_reqs(i)) END IF dest_hist(i) = dests_expand(i) @@ -581,11 +581,11 @@ CONTAINS lb3 = recv_msgs_bnds(1, 3, i) ub3 = recv_msgs_bnds(2, 3, i) ! no need to receive from myself - IF (srcs_expand(i) .EQ. rs_mpo) THEN + IF (srcs_expand(i) == rs_mpo) THEN ALLOCATE (recv_msgs(i)%msg(lb1:ub1, lb2:ub2, lb3:ub3)) recv_msgs(i)%msg(:, :, :) = pw_in%array ! if I have already received data from the source, just use the one from the last time - ELSE IF (ANY(src_hist .EQ. srcs_expand(i))) THEN + ELSE IF (ANY(src_hist == srcs_expand(i))) THEN loc = MINLOC(ABS(src_hist - srcs_expand(i)), 1) lb1_loc = recv_msgs_bnds(1, 1, loc) ub1_loc = recv_msgs_bnds(2, 1, loc) @@ -750,7 +750,7 @@ CONTAINS DO i = 1, maxn_sendrecv ! no need to send to myself or to an invalid destination (pid = -1) - IF ((dests_shrink(i) .NE. rs_mpo) .AND. (dests_shrink(i) .NE. -1)) THEN + IF ((dests_shrink(i) /= rs_mpo) .AND. (dests_shrink(i) /= -1)) THEN send_lb1 = bounds_local_all(1, 1, dests_shrink(i) + 1) send_ub1 = bounds_local_all(2, 1, dests_shrink(i) + 1) send_lb2 = bounds_local_all(1, 2, dests_shrink(i) + 1) @@ -773,9 +773,9 @@ CONTAINS ub3_orig = bounds_local_shftd(2, 3) ! no need to receive from myself - IF (srcs_shrink .EQ. rs_mpo) THEN + IF (srcs_shrink == rs_mpo) THEN pw_shrinked%array = cr3d(lb1_orig:ub1_orig, lb2_orig:ub2_orig, lb3_orig:ub3_orig) - ELSE IF (srcs_shrink .EQ. -1) THEN + ELSE IF (srcs_shrink == -1) THEN ! the source is invalid ... do nothing ELSE CALL rs_group%recv(pw_shrinked%array, srcs_shrink, tag) @@ -836,7 +836,7 @@ CONTAINS ! the last existing grid points ALLOCATE (indx(ub1_new - lb1_new + 1)) indx(:) = [(i, i=2*(ub1_glbl + 1) - lb1_new, 2*(ub1_glbl + 1) - ub1_new, -1)] - IF (lb1_new .EQ. ub1_glbl + 1) indx(1) = indx(2) + IF (lb1_new == ub1_glbl + 1) indx(1) = indx(2) cr3d_out(lb1_new:ub1_new, lb2_new:ub2_new, lb3_new:ub3_new) = cr3d_in(indx, :, :) CALL timestop(handle) @@ -892,7 +892,7 @@ CONTAINS ! the last existing grid points ALLOCATE (indy(ub2_new - lb2_new + 1)) indy(:) = [(i, i=2*(ub2_glbl + 1) - lb2_new, 2*(ub2_glbl + 1) - ub2_new, -1)] - IF (lb2_new .EQ. ub2_glbl + 1) indy(1) = indy(2) + IF (lb2_new == ub2_glbl + 1) indy(1) = indy(2) cr3d_out(lb1_new:ub1_new, lb2_new:ub2_new, lb3_new:ub3_new) = cr3d_in(:, indy, :) CALL timestop(handle) @@ -948,7 +948,7 @@ CONTAINS ! the last existing grid points ALLOCATE (indz(ub3_new - lb3_new + 1)) indz(:) = [(i, i=2*(ub3_glbl + 1) - lb3_new, 2*(ub3_glbl + 1) - ub3_new, -1)] - IF (lb3_new .EQ. ub3_glbl + 1) indz(1) = indz(2) + IF (lb3_new == ub3_glbl + 1) indz(1) = indz(2) cr3d_out(lb1_new:ub1_new, lb2_new:ub2_new, lb3_new:ub3_new) = cr3d_in(:, :, indz) CALL timestop(handle) @@ -1005,8 +1005,8 @@ CONTAINS ALLOCATE (indx(ub1_new - lb1_new + 1), indy(ub2_new - lb2_new + 1)) indx(:) = [(i, i=2*(ub1_glbl + 1) - lb1_new, 2*(ub1_glbl + 1) - ub1_new, -1)] indy(:) = [(i, i=2*(ub2_glbl + 1) - lb2_new, 2*(ub2_glbl + 1) - ub2_new, -1)] - IF (lb1_new .EQ. ub1_glbl + 1) indx(1) = indx(2) - IF (lb2_new .EQ. ub2_glbl + 1) indy(1) = indy(2) + IF (lb1_new == ub1_glbl + 1) indx(1) = indx(2) + IF (lb2_new == ub2_glbl + 1) indy(1) = indy(2) cr3d_out(lb1_new:ub1_new, lb2_new:ub2_new, lb3_new:ub3_new) = cr3d_in(indx, indy, :) CALL timestop(handle) @@ -1109,7 +1109,7 @@ CONTAINS DO i = 1, maxn_sendrecv ! no need to receive from myself - IF (srcs_expand(i) .EQ. rs_mpo) THEN + IF (srcs_expand(i) == rs_mpo) THEN recv_msgs_bnds(1, 1, i) = bounds_local_shftd(1, 1) recv_msgs_bnds(2, 1, i) = bounds_local_shftd(2, 1) recv_msgs_bnds(1, 2, i) = bounds_local_shftd(1, 2) @@ -1117,7 +1117,7 @@ CONTAINS recv_msgs_bnds(1, 3, i) = bounds_local_shftd(1, 3) recv_msgs_bnds(2, 3, i) = bounds_local_shftd(2, 3) ! if I have already received data from the source, just use the one from the last time - ELSE IF (ANY(src_hist .EQ. srcs_expand(i))) THEN + ELSE IF (ANY(src_hist == srcs_expand(i))) THEN loc = MINLOC(ABS(src_hist - srcs_expand(i)), 1) recv_msgs_bnds(1, 1, i) = bounds_local_all(1, 1, srcs_expand(loc) + 1) recv_msgs_bnds(2, 1, i) = bounds_local_all(2, 1, srcs_expand(loc) + 1) @@ -1200,8 +1200,8 @@ CONTAINS bndsl_out(1, 1) = 2*(bounds(2, 1) + 1) - bndsl_in(2, 1) bndsl_out(2, 1) = 2*(bounds(2, 1) + 1) - bndsl_in(1, 1) - IF (bndsl_out(1, 1) .EQ. bounds(2, 1) + 2) bndsl_out(1, 1) = bndsl_out(1, 1) - 1 - IF (bndsl_out(2, 1) .EQ. 2*(bounds(2, 1) + 1) - bounds(1, 1)) bndsl_out(2, 1) = bndsl_out(2, 1) - 1 + IF (bndsl_out(1, 1) == bounds(2, 1) + 2) bndsl_out(1, 1) = bndsl_out(1, 1) - 1 + IF (bndsl_out(2, 1) == 2*(bounds(2, 1) + 1) - bounds(1, 1)) bndsl_out(2, 1) = bndsl_out(2, 1) - 1 bndsl_out(1, 2) = bndsl_in(1, 2) bndsl_out(2, 2) = bndsl_in(2, 2) @@ -1230,8 +1230,8 @@ CONTAINS bndsl_out(1, 2) = 2*(bounds(2, 2) + 1) - bndsl_in(2, 2) bndsl_out(2, 2) = 2*(bounds(2, 2) + 1) - bndsl_in(1, 2) - IF (bndsl_out(1, 2) .EQ. bounds(2, 2) + 2) bndsl_out(1, 2) = bndsl_out(1, 2) - 1 - IF (bndsl_out(2, 2) .EQ. 2*(bounds(2, 2) + 1) - bounds(1, 2)) bndsl_out(2, 2) = bndsl_out(2, 2) - 1 + IF (bndsl_out(1, 2) == bounds(2, 2) + 2) bndsl_out(1, 2) = bndsl_out(1, 2) - 1 + IF (bndsl_out(2, 2) == 2*(bounds(2, 2) + 1) - bounds(1, 2)) bndsl_out(2, 2) = bndsl_out(2, 2) - 1 bndsl_out(1, 3) = bndsl_in(1, 3) bndsl_out(2, 3) = bndsl_in(2, 3) @@ -1260,8 +1260,8 @@ CONTAINS bndsl_out(1, 3) = 2*(bounds(2, 3) + 1) - bndsl_in(2, 3) bndsl_out(2, 3) = 2*(bounds(2, 3) + 1) - bndsl_in(1, 3) - IF (bndsl_out(1, 3) .EQ. bounds(2, 3) + 2) bndsl_out(1, 3) = bndsl_out(1, 3) - 1 - IF (bndsl_out(2, 3) .EQ. 2*(bounds(2, 3) + 1) - bounds(1, 3)) bndsl_out(2, 3) = bndsl_out(2, 3) - 1 + IF (bndsl_out(1, 3) == bounds(2, 3) + 2) bndsl_out(1, 3) = bndsl_out(1, 3) - 1 + IF (bndsl_out(2, 3) == 2*(bounds(2, 3) + 1) - bounds(1, 3)) bndsl_out(2, 3) = bndsl_out(2, 3) - 1 END FUNCTION flipbf_bounds_local @@ -1281,13 +1281,13 @@ CONTAINS bndsl_out(1, 1) = 2*(bounds(2, 1) + 1) - bndsl_in(2, 1) bndsl_out(2, 1) = 2*(bounds(2, 1) + 1) - bndsl_in(1, 1) - IF (bndsl_out(1, 1) .EQ. bounds(2, 1) + 2) bndsl_out(1, 1) = bndsl_out(1, 1) - 1 - IF (bndsl_out(2, 1) .EQ. 2*(bounds(2, 1) + 1) - bounds(1, 1)) bndsl_out(2, 1) = bndsl_out(2, 1) - 1 + IF (bndsl_out(1, 1) == bounds(2, 1) + 2) bndsl_out(1, 1) = bndsl_out(1, 1) - 1 + IF (bndsl_out(2, 1) == 2*(bounds(2, 1) + 1) - bounds(1, 1)) bndsl_out(2, 1) = bndsl_out(2, 1) - 1 bndsl_out(1, 2) = 2*(bounds(2, 2) + 1) - bndsl_in(2, 2) bndsl_out(2, 2) = 2*(bounds(2, 2) + 1) - bndsl_in(1, 2) - IF (bndsl_out(1, 2) .EQ. bounds(2, 2) + 2) bndsl_out(1, 2) = bndsl_out(1, 2) - 1 - IF (bndsl_out(2, 2) .EQ. 2*(bounds(2, 2) + 1) - bounds(1, 2)) bndsl_out(2, 2) = bndsl_out(2, 2) - 1 + IF (bndsl_out(1, 2) == bounds(2, 2) + 2) bndsl_out(1, 2) = bndsl_out(1, 2) - 1 + IF (bndsl_out(2, 2) == 2*(bounds(2, 2) + 1) - bounds(1, 2)) bndsl_out(2, 2) = bndsl_out(2, 2) - 1 bndsl_out(1, 3) = bndsl_in(1, 3) bndsl_out(2, 3) = bndsl_in(2, 3) diff --git a/src/pw/dielectric_methods.F b/src/pw/dielectric_methods.F index e90cbfd820..860141a96b 100644 --- a/src/pw/dielectric_methods.F +++ b/src/pw/dielectric_methods.F @@ -138,9 +138,9 @@ CONTAINS times_called = dielectric%params%times_called dielec_functiontype = dielectric%params%dielec_functiontype - IF (.NOT. dielec_functiontype .EQ. rho_dependent .AND. & - ((derivative_method .EQ. derivative_fft_use_deps) .OR. & - (derivative_method .EQ. derivative_fft_use_deps))) THEN + IF (.NOT. dielec_functiontype == rho_dependent .AND. & + ((derivative_method == derivative_fft_use_deps) .OR. & + (derivative_method == derivative_fft_use_deps))) THEN CALL cp_abort(__LOCATION__, & "The specified derivative method is not compatible with the type of "// & "the dielectric constant function.") @@ -173,7 +173,7 @@ CONTAINS CALL dielectric_constant_sccs(rho_elec_rs, dielectric%eps, dielectric%deps_drho, & eps0, rho_max, rho_min) CASE (spatially_dependent) - IF (times_called .EQ. 0) THEN + IF (times_called == 0) THEN CALL dielectric_constant_spatially_dependent(dielectric%eps, pw_pool, dielectric%params) END IF CASE (spatially_rho_dependent) @@ -182,9 +182,9 @@ CONTAINS END SELECT ! derivatives - IF ((dielec_functiontype .EQ. rho_dependent) .OR. & - (dielec_functiontype .EQ. spatially_rho_dependent) .OR. & - ((dielec_functiontype .EQ. spatially_dependent) .AND. times_called .EQ. 0)) THEN + IF ((dielec_functiontype == rho_dependent) .OR. & + (dielec_functiontype == spatially_rho_dependent) .OR. & + ((dielec_functiontype == spatially_dependent) .AND. times_called == 0)) THEN SELECT CASE (derivative_method) CASE (derivative_cd3, derivative_cd5, derivative_cd7, derivative_fft) CALL pw_pool%create_pw(ln_eps) @@ -224,7 +224,7 @@ CONTAINS DO k = lb(3), ub(3) DO j = lb(2), ub(2) DO i = lb(1), ub(1) - IF (ABS(dielectric%deps_drho%array(i, j, k)) .LE. small_value) THEN + IF (ABS(dielectric%deps_drho%array(i, j, k)) <= small_value) THEN deps(idir)%array(i, j, k) = 0.0_dp END IF END DO @@ -321,9 +321,9 @@ CONTAINS times_called = dielectric%params%times_called dielec_functiontype = dielectric%params%dielec_functiontype - IF (.NOT. dielec_functiontype .EQ. rho_dependent .AND. & - ((derivative_method .EQ. derivative_fft_use_deps) .OR. & - (derivative_method .EQ. derivative_fft_use_deps))) THEN + IF (.NOT. dielec_functiontype == rho_dependent .AND. & + ((derivative_method == derivative_fft_use_deps) .OR. & + (derivative_method == derivative_fft_use_deps))) THEN CALL cp_abort(__LOCATION__, & "The specified derivative method is not compatible with the type of "// & "the dielectric constant function.") @@ -366,7 +366,7 @@ CONTAINS CALL dielectric_constant_sccs(rho_elec_rs_xpndd, dielectric%eps, dielectric%deps_drho, & eps0, rho_max, rho_min) CASE (spatially_dependent) - IF (times_called .EQ. 0) THEN + IF (times_called == 0) THEN CALL dielectric_constant_spatially_dependent(dielectric%eps, pw_pool_xpndd, dielectric%params) END IF CASE (spatially_rho_dependent) @@ -375,9 +375,9 @@ CONTAINS END SELECT ! derivatives - IF ((dielec_functiontype .EQ. rho_dependent) .OR. & - (dielec_functiontype .EQ. spatially_rho_dependent) .OR. & - ((dielec_functiontype .EQ. spatially_dependent) .AND. times_called .EQ. 0)) THEN + IF ((dielec_functiontype == rho_dependent) .OR. & + (dielec_functiontype == spatially_rho_dependent) .OR. & + ((dielec_functiontype == spatially_dependent) .AND. times_called == 0)) THEN SELECT CASE (derivative_method) CASE (derivative_cd3, derivative_cd5, derivative_cd7, derivative_fft) CALL pw_pool_xpndd%create_pw(ln_eps) @@ -417,7 +417,7 @@ CONTAINS DO k = lb(3), ub(3) DO j = lb(2), ub(2) DO i = lb(1), ub(1) - IF (ABS(dielectric%deps_drho%array(i, j, k)) .LE. small_value) THEN + IF (ABS(dielectric%deps_drho%array(i, j, k)) <= small_value) THEN deps(idir)%array(i, j, k) = 0.0_dp END IF END DO @@ -488,7 +488,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (eps0 .LT. 1.0_dp) THEN + IF (eps0 < 1.0_dp) THEN CPABORT("The dielectric constant has to be greater than or equal to 1.") END IF @@ -501,10 +501,10 @@ CONTAINS DO k = lb3, ub3 DO j = lb2, ub2 DO i = lb1, ub1 - IF (rho%array(i, j, k) .LT. rho_min) THEN + IF (rho%array(i, j, k) < rho_min) THEN eps%array(i, j, k) = eps0 deps_drho%array(i, j, k) = 0.0_dp - ELSE IF (rho%array(i, j, k) .GT. rho_max) THEN + ELSE IF (rho%array(i, j, k) > rho_max) THEN eps%array(i, j, k) = 1.0_dp deps_drho%array(i, j, k) = 0.0_dp ELSE @@ -566,7 +566,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (dielec_const .LT. 1.0_dp) THEN + IF (dielec_const < 1.0_dp) THEN CPABORT("The dielectric constant has to be greater than or equal to 1.") END IF @@ -574,15 +574,15 @@ CONTAINS dx = pw_grid%dr(1); dy = pw_grid%dr(2); dz = pw_grid%dr(3) - forb_xtnt1 = x_xtnt(1) .LT. x_glbl(LBOUND(x_glbl, 1)) - forb_xtnt2 = x_xtnt(2) .GT. x_glbl(UBOUND(x_glbl, 1)) + dx - forb_xtnt3 = y_xtnt(1) .LT. y_glbl(LBOUND(y_glbl, 1)) - forb_xtnt4 = y_xtnt(2) .GT. y_glbl(UBOUND(y_glbl, 1)) + dy - forb_xtnt5 = z_xtnt(1) .LT. z_glbl(LBOUND(z_glbl, 1)) - forb_xtnt6 = z_xtnt(2) .GT. z_glbl(UBOUND(z_glbl, 1)) + dz + forb_xtnt1 = x_xtnt(1) < x_glbl(LBOUND(x_glbl, 1)) + forb_xtnt2 = x_xtnt(2) > x_glbl(UBOUND(x_glbl, 1)) + dx + forb_xtnt3 = y_xtnt(1) < y_glbl(LBOUND(y_glbl, 1)) + forb_xtnt4 = y_xtnt(2) > y_glbl(UBOUND(y_glbl, 1)) + dy + forb_xtnt5 = z_xtnt(1) < z_glbl(LBOUND(z_glbl, 1)) + forb_xtnt6 = z_xtnt(2) > z_glbl(UBOUND(z_glbl, 1)) + dz n_forb_xtnts = COUNT([forb_xtnt1, forb_xtnt2, forb_xtnt3, & forb_xtnt4, forb_xtnt5, forb_xtnt6] .EQV. test_forb_xtnts) - IF (n_forb_xtnts .GT. 0) THEN + IF (n_forb_xtnts > 0) THEN CALL cp_abort(__LOCATION__, & "The given extents for the dielectric region are outside the range of "// & "the simulation cell.") @@ -599,9 +599,9 @@ CONTAINS DO k = lb3, ub3 DO j = lb2, ub2 DO i = lb1, ub1 - IF ((x_locl(i) .GE. x_xtnt(1)) .AND. (x_locl(i) .LE. x_xtnt(2)) .AND. & - (y_locl(j) .GE. y_xtnt(1)) .AND. (y_locl(j) .LE. y_xtnt(2)) .AND. & - (z_locl(k) .GE. z_xtnt(1)) .AND. (z_locl(k) .LE. z_xtnt(2))) THEN + IF ((x_locl(i) >= x_xtnt(1)) .AND. (x_locl(i) <= x_xtnt(2)) .AND. & + (y_locl(j) >= y_xtnt(1)) .AND. (y_locl(j) <= y_xtnt(2)) .AND. & + (z_locl(k) >= z_xtnt(1)) .AND. (z_locl(k) <= z_xtnt(2))) THEN eps_tmp%array(i, j, k) = dielec_const END IF END DO @@ -661,7 +661,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (dielec_const .LT. 1.0_dp) THEN + IF (dielec_const < 1.0_dp) THEN CPABORT("The dielectric constant has to be greater than or equal to 1.") END IF @@ -670,15 +670,15 @@ CONTAINS bctry = base_center(1); bctrz = base_center(2) dx = pw_grid%dr(1); dy = pw_grid%dr(2); dz = pw_grid%dr(3) - forb_xtnt1 = x_xtnt(1) .LT. x_glbl(LBOUND(x_glbl, 1)) - forb_xtnt2 = x_xtnt(2) .GT. x_glbl(UBOUND(x_glbl, 1)) + dx - forb_xtnt3 = bctry - MAXVAL(base_radii) .LT. y_glbl(LBOUND(y_glbl, 1)) - forb_xtnt4 = bctry + MAXVAL(base_radii) .GT. y_glbl(UBOUND(y_glbl, 1)) + dy - forb_xtnt5 = bctrz - MAXVAL(base_radii) .LT. z_glbl(LBOUND(z_glbl, 1)) - forb_xtnt6 = bctrz + MAXVAL(base_radii) .GT. z_glbl(UBOUND(z_glbl, 1)) + dz + forb_xtnt1 = x_xtnt(1) < x_glbl(LBOUND(x_glbl, 1)) + forb_xtnt2 = x_xtnt(2) > x_glbl(UBOUND(x_glbl, 1)) + dx + forb_xtnt3 = bctry - MAXVAL(base_radii) < y_glbl(LBOUND(y_glbl, 1)) + forb_xtnt4 = bctry + MAXVAL(base_radii) > y_glbl(UBOUND(y_glbl, 1)) + dy + forb_xtnt5 = bctrz - MAXVAL(base_radii) < z_glbl(LBOUND(z_glbl, 1)) + forb_xtnt6 = bctrz + MAXVAL(base_radii) > z_glbl(UBOUND(z_glbl, 1)) + dz n_forb_xtnts = COUNT([forb_xtnt1, forb_xtnt2, forb_xtnt3, & forb_xtnt4, forb_xtnt5, forb_xtnt6] .EQV. test_forb_xtnts) - IF (n_forb_xtnts .GT. 0) THEN + IF (n_forb_xtnts > 0) THEN CALL cp_abort(__LOCATION__, & "The given extents for the dielectric region are outside the range of "// & "the simulation cell.") @@ -696,8 +696,8 @@ CONTAINS DO j = lb2, ub2 DO i = lb1, ub1 distsq = (y_locl(j) - bctry)**2 + (z_locl(k) - bctrz)**2 - IF ((x_locl(i) .GE. x_xtnt(1)) .AND. (x_locl(i) .LE. x_xtnt(2)) .AND. & - (distsq .GE. MINVAL(base_radii)**2) .AND. (distsq .LE. MAXVAL(base_radii)**2)) THEN + IF ((x_locl(i) >= x_xtnt(1)) .AND. (x_locl(i) <= x_xtnt(2)) .AND. & + (distsq >= MINVAL(base_radii)**2) .AND. (distsq <= MAXVAL(base_radii)**2)) THEN eps_tmp%array(i, j, k) = dielec_const END IF END DO @@ -746,7 +746,7 @@ CONTAINS CALL setup_grid_axes(pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) n_dielectric_region = n_aa_cuboidal + n_xaa_annular - IF (n_dielectric_region .EQ. 0) THEN + IF (n_dielectric_region == 0) THEN CPABORT("No density independent dielectric region is defined.") END IF @@ -806,7 +806,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (dielectric_params%eps0 .LT. 1.0_dp) THEN + IF (dielectric_params%eps0 < 1.0_dp) THEN CPABORT("The dielectric constant has to be greater than or equal to 1.") END IF diff --git a/src/pw/dirichlet_bc_methods.F b/src/pw/dirichlet_bc_methods.F index 8f86eb2053..c254e9a9c1 100644 --- a/src/pw/dirichlet_bc_methods.F +++ b/src/pw/dirichlet_bc_methods.F @@ -115,12 +115,12 @@ CONTAINS SELECT CASE (poisson_params%ps_implicit_params%boundary_condition) CASE (MIXED_BC, MIXED_PERIODIC_BC) - IF (n_dbcs .EQ. 0) THEN + IF (n_dbcs == 0) THEN CPABORT("No Dirichlet region is defined.") END IF ALLOCATE (dbcs(n_dbcs)) - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, '(/,T3,A,A,/,T3,A)') "POISSON| IMPLICIT (GENERALIZED) SOLVER ", REPEAT('-', 39), & "POISSON| Preparing Dirichlet regions ..." END IF @@ -138,7 +138,7 @@ CONTAINS parallel_plane = poisson_params%dbc_params%aa_planar_pplane(j) is_periodic = poisson_params%dbc_params%aa_planar_is_periodic(j) - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,I5)') "POISSON| Dirichlet region", j WRITE (unit_nr, '(T3,A)') "POISSON| type : axis-aligned planar" WRITE (unit_nr, '(T3,A,E13.4,2X,A)') "POISSON| applied potential :", v_D, "[Eh/e]" @@ -166,7 +166,7 @@ CONTAINS sigma = poisson_params%dbc_params%aa_cuboidal_sigma(j - l) is_periodic = poisson_params%dbc_params%aa_cuboidal_is_periodic(j - l) - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,I5)') "POISSON| Dirichlet region", j WRITE (unit_nr, '(T3,A)') "POISSON| type : axis-aligned cuboidal" WRITE (unit_nr, '(T3,A,E13.4,2X,A)') "POISSON| applied potential :", v_D, "[Eh/e]" @@ -196,7 +196,7 @@ CONTAINS thickness = poisson_params%dbc_params%planar_thickness(j - l) is_periodic = poisson_params%dbc_params%planar_is_periodic(j - l) - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,I5)') "POISSON| Dirichlet region", j WRITE (unit_nr, '(T3,A)') "POISSON| type : planar" WRITE (unit_nr, '(T3,A,E13.4,2X,A)') "POISSON| applied potential :", v_D, "[Eh/e]" @@ -232,7 +232,7 @@ CONTAINS phase = poisson_params%dbc_params%aa_cylindrical_phase(j) is_periodic = poisson_params%dbc_params%aa_cylindrical_is_periodic(j) - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, '(T3,A,I5)') "POISSON| Dirichlet region", l + j WRITE (unit_nr, '(T3,A)') "POISSON| type : axis-aligned cylindrical" WRITE (unit_nr, '(T3,A,E13.4,2X,A)') "POISSON| applied potential :", v_D, "[Eh/e]" @@ -311,7 +311,7 @@ CONTAINS dirichlet_bc%n_tiles = n_tiles ALLOCATE (dirichlet_bc%tiles(n_tiles)) dirichlet_bc%tiles = tiles - IF ((unit_nr .GT. 0) .AND. verbose) WRITE (unit_nr, '(T7,A,I5)') "number of partitions : ", n_tiles + IF ((unit_nr > 0) .AND. verbose) WRITE (unit_nr, '(T7,A,I5)') "number of partitions : ", n_tiles ALLOCATE (tile_maxvals(n_tiles)) tile_maxvals = 0.0_dp @@ -320,7 +320,7 @@ CONTAINS CALL pw_pool%create_pw(dirichlet_bc%tiles(k)%tile%tile_pw) CALL pw_zero(dirichlet_bc%tiles(k)%tile%tile_pw) - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T7,A,I5)') "tile", k DO i = 1, 8 WRITE (unit_nr, '(T10,A,I1,3F10.3)') & @@ -335,7 +335,7 @@ CONTAINS dirichlet_bc%tiles(k)%tile%volume = tile_volume END DO - IF ((unit_nr .GT. 0) .AND. verbose) WRITE (unit_nr, '(T3,A)') REPEAT('=', 78) + IF ((unit_nr > 0) .AND. verbose) WRITE (unit_nr, '(T3,A)') REPEAT('=', 78) DEALLOCATE (tiles) @@ -346,7 +346,7 @@ CONTAINS dirichlet_bc%n_tiles = n_tiles ALLOCATE (dirichlet_bc%tiles(n_tiles)) dirichlet_bc%tiles = tiles - IF ((unit_nr .GT. 0) .AND. verbose) WRITE (unit_nr, '(T7,A,I5)') "number of partitions : ", n_tiles + IF ((unit_nr > 0) .AND. verbose) WRITE (unit_nr, '(T7,A,I5)') "number of partitions : ", n_tiles NULLIFY (cylinder_pw) ALLOCATE (cylinder_pw) @@ -358,7 +358,7 @@ CONTAINS CALL pw_pool%create_pw(dirichlet_bc%tiles(k)%tile%tile_pw) CALL pw_zero(dirichlet_bc%tiles(k)%tile%tile_pw) - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T7,A,I5)') "tile", k DO i = 1, 8 WRITE (unit_nr, '(T10,A,I1,3F10.3)') & @@ -376,7 +376,7 @@ CONTAINS cyl_maxval = MAXVAL(cylinder_pw%array) CALL pw_pool%pw_grid%para%group%max(cyl_maxval) - IF (cyl_maxval .GT. 1.01_dp) THEN + IF (cyl_maxval > 1.01_dp) THEN CALL cp_abort(__LOCATION__, & "Inaccurate approximation of unit step function at cylindrical Dirichlet region. "// & "Increase the number of sides (N_SIDES) and/or the base radius. Alternatively, "// & @@ -386,7 +386,7 @@ CONTAINS CALL pw_pool%give_back_pw(cylinder_pw) DEALLOCATE (cylinder_pw) - IF ((unit_nr .GT. 0) .AND. verbose) WRITE (unit_nr, '(T3,A)') REPEAT('=', 78) + IF ((unit_nr > 0) .AND. verbose) WRITE (unit_nr, '(T3,A)') REPEAT('=', 78) DEALLOCATE (tiles) @@ -397,14 +397,14 @@ CONTAINS dirichlet_bc%n_tiles = n_tiles ALLOCATE (dirichlet_bc%tiles(n_tiles)) dirichlet_bc%tiles = tiles - IF ((unit_nr .GT. 0) .AND. verbose) WRITE (unit_nr, '(T7,A,I5)') "number of partitions : ", n_tiles + IF ((unit_nr > 0) .AND. verbose) WRITE (unit_nr, '(T7,A,I5)') "number of partitions : ", n_tiles DO k = 1, n_tiles ALLOCATE (dirichlet_bc%tiles(k)%tile%tile_pw) CALL pw_pool%create_pw(dirichlet_bc%tiles(k)%tile%tile_pw) CALL pw_zero(dirichlet_bc%tiles(k)%tile%tile_pw) - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T7,A,I5)') "tile", k DO i = 1, 8 WRITE (unit_nr, '(T10,A,I1,3F10.3)') & @@ -419,7 +419,7 @@ CONTAINS dirichlet_bc%tiles(k)%tile%volume = tile_volume END DO - IF ((unit_nr .GT. 0) .AND. verbose) WRITE (unit_nr, '(T3,A)') REPEAT('=', 78) + IF ((unit_nr > 0) .AND. verbose) WRITE (unit_nr, '(T3,A)') REPEAT('=', 78) DEALLOCATE (tiles) @@ -495,15 +495,15 @@ CONTAINS xub = xub + thickness*0.5_dp END SELECT - forb_xtnt1 = xlb .LT. cell_xtnts(1, 1) - forb_xtnt2 = xub .GT. cell_xtnts(2, 1) - forb_xtnt3 = ylb .LT. cell_xtnts(1, 2) - forb_xtnt4 = yub .GT. cell_xtnts(2, 2) - forb_xtnt5 = zlb .LT. cell_xtnts(1, 3) - forb_xtnt6 = zub .GT. cell_xtnts(2, 3) + forb_xtnt1 = xlb < cell_xtnts(1, 1) + forb_xtnt2 = xub > cell_xtnts(2, 1) + forb_xtnt3 = ylb < cell_xtnts(1, 2) + forb_xtnt4 = yub > cell_xtnts(2, 2) + forb_xtnt5 = zlb < cell_xtnts(1, 3) + forb_xtnt6 = zub > cell_xtnts(2, 3) n_forb_xtnts = COUNT([forb_xtnt1, forb_xtnt2, forb_xtnt3, & forb_xtnt4, forb_xtnt5, forb_xtnt6] .EQV. test_forb_xtnts) - IF (n_forb_xtnts .GT. 0) THEN + IF (n_forb_xtnts > 0) THEN CALL cp_abort(__LOCATION__, & "The given extents for the Dirichlet region are outside the range of "// & "the simulation cell.") @@ -527,7 +527,7 @@ CONTAINS dirichlet_bc%vertices(1:3, 7) = [xub, ylb, zub] dirichlet_bc%vertices(1:3, 8) = [xub, yub, zub] - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T3,A,A)') "======== verbose ", REPEAT('=', 61) DO i = 1, 8 WRITE (unit_nr, '(T10,A,I1,3F10.3)') " vertex ", i, angstrom*dirichlet_bc%vertices(:, i) @@ -583,15 +583,15 @@ CONTAINS unit_nr = -1 END IF - forb_xtnt1 = x_xtnt(1) .LT. cell_xtnts(1, 1) - forb_xtnt2 = x_xtnt(2) .GT. cell_xtnts(2, 1) - forb_xtnt3 = y_xtnt(1) .LT. cell_xtnts(1, 2) - forb_xtnt4 = y_xtnt(2) .GT. cell_xtnts(2, 2) - forb_xtnt5 = z_xtnt(1) .LT. cell_xtnts(1, 3) - forb_xtnt6 = z_xtnt(2) .GT. cell_xtnts(2, 3) + forb_xtnt1 = x_xtnt(1) < cell_xtnts(1, 1) + forb_xtnt2 = x_xtnt(2) > cell_xtnts(2, 1) + forb_xtnt3 = y_xtnt(1) < cell_xtnts(1, 2) + forb_xtnt4 = y_xtnt(2) > cell_xtnts(2, 2) + forb_xtnt5 = z_xtnt(1) < cell_xtnts(1, 3) + forb_xtnt6 = z_xtnt(2) > cell_xtnts(2, 3) n_forb_xtnts = COUNT([forb_xtnt1, forb_xtnt2, forb_xtnt3, & forb_xtnt4, forb_xtnt5, forb_xtnt6] .EQV. test_forb_xtnts) - IF (n_forb_xtnts .GT. 0) THEN + IF (n_forb_xtnts > 0) THEN CALL cp_abort(__LOCATION__, & "The given extents for the Dirichlet region are outside the range of "// & "the simulation cell.") @@ -615,7 +615,7 @@ CONTAINS dirichlet_bc%vertices(1:3, 7) = [x_xtnt(2), y_xtnt(1), z_xtnt(2)] dirichlet_bc%vertices(1:3, 8) = [x_xtnt(2), y_xtnt(2), z_xtnt(2)] - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T3,A,A)') "======== verbose ", REPEAT('=', 61) DO i = 1, 8 WRITE (unit_nr, '(T10,A,I1,3F10.3)') " vertex ", i, angstrom*dirichlet_bc%vertices(:, i) @@ -679,7 +679,7 @@ CONTAINS D = A + (C - B) AB = B - A; AC = C - A; AD = D - A; BC = C - B - are_orthogonal = ABS(DOT_PRODUCT(AB, BC)/(SQRT(SUM(AB**2))*SQRT(SUM(BC**2)))) .LE. small_value + are_orthogonal = ABS(DOT_PRODUCT(AB, BC)/(SQRT(SUM(AB**2))*SQRT(SUM(BC**2)))) <= small_value IF (.NOT. are_orthogonal) THEN CALL cp_abort(__LOCATION__, "The given vertices for defining a "// & "planar Dirichlet region do not form orthogonal edges.") @@ -688,25 +688,25 @@ CONTAINS normal_vector = vector_product(AB, AC) unit_normal = normal_vector/SQRT(SUM(normal_vector**2)) - A_is_inside = (A(1) .GT. cell_xtnts(1, 1) .AND. A(1) .LT. cell_xtnts(2, 1)) .AND. & - (A(2) .GT. cell_xtnts(1, 2) .AND. A(2) .LT. cell_xtnts(2, 2)) .AND. & - (A(3) .GT. cell_xtnts(1, 3) .AND. A(3) .LT. cell_xtnts(2, 3)) - B_is_inside = (B(1) .GT. cell_xtnts(1, 1) .AND. B(1) .LT. cell_xtnts(2, 1)) .AND. & - (B(2) .GT. cell_xtnts(1, 2) .AND. B(2) .LT. cell_xtnts(2, 2)) .AND. & - (B(3) .GT. cell_xtnts(1, 3) .AND. B(3) .LT. cell_xtnts(2, 3)) - C_is_inside = (C(1) .GT. cell_xtnts(1, 1) .AND. C(1) .LT. cell_xtnts(2, 1)) .AND. & - (C(2) .GT. cell_xtnts(1, 2) .AND. C(2) .LT. cell_xtnts(2, 2)) .AND. & - (C(3) .GT. cell_xtnts(1, 3) .AND. C(3) .LT. cell_xtnts(2, 3)) - D_is_inside = (D(1) .GT. cell_xtnts(1, 1) .AND. D(1) .LT. cell_xtnts(2, 1)) .AND. & - (D(2) .GT. cell_xtnts(1, 2) .AND. D(2) .LT. cell_xtnts(2, 2)) .AND. & - (D(3) .GT. cell_xtnts(1, 3) .AND. D(3) .LT. cell_xtnts(2, 3)) + A_is_inside = (A(1) > cell_xtnts(1, 1) .AND. A(1) < cell_xtnts(2, 1)) .AND. & + (A(2) > cell_xtnts(1, 2) .AND. A(2) < cell_xtnts(2, 2)) .AND. & + (A(3) > cell_xtnts(1, 3) .AND. A(3) < cell_xtnts(2, 3)) + B_is_inside = (B(1) > cell_xtnts(1, 1) .AND. B(1) < cell_xtnts(2, 1)) .AND. & + (B(2) > cell_xtnts(1, 2) .AND. B(2) < cell_xtnts(2, 2)) .AND. & + (B(3) > cell_xtnts(1, 3) .AND. B(3) < cell_xtnts(2, 3)) + C_is_inside = (C(1) > cell_xtnts(1, 1) .AND. C(1) < cell_xtnts(2, 1)) .AND. & + (C(2) > cell_xtnts(1, 2) .AND. C(2) < cell_xtnts(2, 2)) .AND. & + (C(3) > cell_xtnts(1, 3) .AND. C(3) < cell_xtnts(2, 3)) + D_is_inside = (D(1) > cell_xtnts(1, 1) .AND. D(1) < cell_xtnts(2, 1)) .AND. & + (D(2) > cell_xtnts(1, 2) .AND. D(2) < cell_xtnts(2, 2)) .AND. & + (D(3) > cell_xtnts(1, 3) .AND. D(3) < cell_xtnts(2, 3)) IF (.NOT. (A_is_inside .AND. B_is_inside .AND. C_is_inside .AND. D_is_inside)) THEN CALL cp_abort(__LOCATION__, & "At least one of the given vertices for defining a planar Dirichlet "// & "region is outside the simulation box.") END IF - are_coplanar = ABS(DOT_PRODUCT(vector_product(AB, AC), AD)) .LE. small_value + are_coplanar = ABS(DOT_PRODUCT(vector_product(AB, AC), AD)) <= small_value IF (.NOT. are_coplanar) THEN CPABORT("The given vertices for defining a planar Dirichlet region are not coplanar.") END IF @@ -716,9 +716,9 @@ CONTAINS dist2 = SUM((B - cm)**2) dist3 = SUM((C - cm)**2) dist4 = SUM((D - cm)**2) - is_rectangle = (ABS(dist1 - dist2) .LE. small_value) .AND. & - (ABS(dist1 - dist3) .LE. small_value) .AND. & - (ABS(dist1 - dist4) .LE. small_value) + is_rectangle = (ABS(dist1 - dist2) <= small_value) .AND. & + (ABS(dist1 - dist3) <= small_value) .AND. & + (ABS(dist1 - dist4) <= small_value) IF (.NOT. is_rectangle) THEN CALL cp_abort(__LOCATION__, "The given vertices for defining "// & "a planar Dirichlet region do not form a rectangle.") @@ -742,7 +742,7 @@ CONTAINS dirichlet_bc%vertices(1:3, 7) = B + 0.5_dp*thickness*unit_normal dirichlet_bc%vertices(1:3, 8) = C + 0.5_dp*thickness*unit_normal - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T3,A,A)') "======== verbose ", REPEAT('=', 61) DO i = 1, 8 WRITE (unit_nr, '(T10,A,I1,3F10.3)') " vertex ", i, angstrom*dirichlet_bc%vertices(:, i) @@ -832,41 +832,41 @@ CONTAINS SELECT CASE (parallel_axis) CASE (x_axis) - IF (xtnt(1) .LT. cell_xtnts(1, 1) .OR. xtnt(2) .GT. cell_xtnts(2, 1)) THEN + IF (xtnt(1) < cell_xtnts(1, 1) .OR. xtnt(2) > cell_xtnts(2, 1)) THEN CALL cp_abort(__LOCATION__, & "The length of the cylindrical Dirichlet region is larger than the "// & "x range of the simulation cell.") END IF - forb_xtnt1 = base_center(1) - base_radius .LT. cell_xtnts(1, 2) - forb_xtnt2 = base_center(1) + base_radius .GT. cell_xtnts(2, 2) - forb_xtnt3 = base_center(2) - base_radius .LT. cell_xtnts(1, 3) - forb_xtnt4 = base_center(2) + base_radius .GT. cell_xtnts(2, 3) + forb_xtnt1 = base_center(1) - base_radius < cell_xtnts(1, 2) + forb_xtnt2 = base_center(1) + base_radius > cell_xtnts(2, 2) + forb_xtnt3 = base_center(2) - base_radius < cell_xtnts(1, 3) + forb_xtnt4 = base_center(2) + base_radius > cell_xtnts(2, 3) IF (forb_xtnt1 .OR. forb_xtnt2 .OR. forb_xtnt3 .OR. forb_xtnt4) THEN CPABORT("The cylinder does not fit entirely inside the simulation cell.") END IF CASE (y_axis) - IF (xtnt(1) .LT. cell_xtnts(1, 2) .OR. xtnt(2) .GT. cell_xtnts(2, 2)) THEN + IF (xtnt(1) < cell_xtnts(1, 2) .OR. xtnt(2) > cell_xtnts(2, 2)) THEN CALL cp_abort(__LOCATION__, & "The length of the cylindrical Dirichlet region is larger than the "// & "y range of the simulation cell.") END IF - forb_xtnt1 = base_center(1) - base_radius .LT. cell_xtnts(1, 1) - forb_xtnt2 = base_center(1) + base_radius .GT. cell_xtnts(2, 1) - forb_xtnt3 = base_center(2) - base_radius .LT. cell_xtnts(1, 3) - forb_xtnt4 = base_center(2) + base_radius .GT. cell_xtnts(2, 3) + forb_xtnt1 = base_center(1) - base_radius < cell_xtnts(1, 1) + forb_xtnt2 = base_center(1) + base_radius > cell_xtnts(2, 1) + forb_xtnt3 = base_center(2) - base_radius < cell_xtnts(1, 3) + forb_xtnt4 = base_center(2) + base_radius > cell_xtnts(2, 3) IF (forb_xtnt1 .OR. forb_xtnt2 .OR. forb_xtnt3 .OR. forb_xtnt4) THEN CPABORT("The cylinder does not fit entirely inside the simulation cell.") END IF CASE (z_axis) - IF (xtnt(1) .LT. cell_xtnts(1, 3) .OR. xtnt(2) .GT. cell_xtnts(2, 3)) THEN + IF (xtnt(1) < cell_xtnts(1, 3) .OR. xtnt(2) > cell_xtnts(2, 3)) THEN CALL cp_abort(__LOCATION__, & "The length of the cylindrical Dirichlet region is larger than the "// & "z range of the simulation cell.") END IF - forb_xtnt1 = base_center(1) - base_radius .LT. cell_xtnts(1, 1) - forb_xtnt2 = base_center(1) + base_radius .GT. cell_xtnts(2, 1) - forb_xtnt3 = base_center(2) - base_radius .LT. cell_xtnts(1, 2) - forb_xtnt4 = base_center(2) + base_radius .GT. cell_xtnts(2, 2) + forb_xtnt1 = base_center(1) - base_radius < cell_xtnts(1, 1) + forb_xtnt2 = base_center(1) + base_radius > cell_xtnts(2, 1) + forb_xtnt3 = base_center(2) - base_radius < cell_xtnts(1, 2) + forb_xtnt4 = base_center(2) + base_radius > cell_xtnts(2, 2) IF (forb_xtnt1 .OR. forb_xtnt2 .OR. forb_xtnt3 .OR. forb_xtnt4) THEN CPABORT("The cylinder does not fit entirely inside the simulation cell.") END IF @@ -882,24 +882,24 @@ CONTAINS theta = twopi/n_dbcs - IF (intern_apx_type .EQ. INSCRIBED) THEN + IF (intern_apx_type == INSCRIBED) THEN h = base_radius ! inscribed uniform prism - ELSE IF (intern_apx_type .EQ. CIRCUMSCRIBED) THEN + ELSE IF (intern_apx_type == CIRCUMSCRIBED) THEN h = base_radius/COS(0.5*theta) ! circumscribed uniform prism ELSE CPABORT("Unknown approximation type for cylinder.") END IF SELECT CASE (parallel_axis) CASE (x_axis) - IF (h .GT. MINVAL([Ly, Lz])) THEN + IF (h > MINVAL([Ly, Lz])) THEN CPABORT("Reduce the base radius!") END IF CASE (y_axis) - IF (h .GT. MINVAL([Lx, Lz])) THEN + IF (h > MINVAL([Lx, Lz])) THEN CPABORT("Reduce the base radius!") END IF CASE (z_axis) - IF (h .GT. MINVAL([Lx, Ly])) THEN + IF (h > MINVAL([Lx, Ly])) THEN CPABORT("Reduce the base radius!") END IF END SELECT @@ -946,7 +946,7 @@ CONTAINS dbcs(j)%dirichlet_bc%n_tiles = 1 - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T3,A,A)') "======== verbose ", REPEAT('=', 61) WRITE (unit_nr, '(T7,A,I5,T20,A,I5,A)') "edge", j, "of the", n_dbcs, & "-gonal prism approximating the cylinder" @@ -998,7 +998,7 @@ CONTAINS dbcs(j)%dirichlet_bc%n_tiles = 1 - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T3,A,A)') "======== verbose ", REPEAT('=', 61) WRITE (unit_nr, '(T7,A,I5,T20,A,I5,A)') "edge", j, "of the", n_dbcs, & "-gonal prism approximating the cylinder" @@ -1050,7 +1050,7 @@ CONTAINS dbcs(j)%dirichlet_bc%n_tiles = 1 - IF ((unit_nr .GT. 0) .AND. verbose) THEN + IF ((unit_nr > 0) .AND. verbose) THEN WRITE (unit_nr, '(T3,A,A)') "======== verbose ", REPEAT('=', 61) WRITE (unit_nr, '(T7,A,I5,T20,A,I5,A)') "edge", j, "of the", n_dbcs, & "-gonal prism approximating the cylinder" @@ -1177,10 +1177,10 @@ CONTAINS Tpoint = 0.0_dp - IF (direction .EQ. FWROT) THEN + IF (direction == FWROT) THEN vec_tmp = MATMUL(Rmat, vec) vec_transfd = vec_tmp + Tp - ELSEIF (direction .EQ. 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) @@ -1318,7 +1318,7 @@ CONTAINS ! the larger n_prtn is assigned to the longer edge ABlength = SQRT(SUM(AB**2)) ADlength = SQRT(SUM(AD**2)) - IF (ADlength .GE. ABlength) THEN + IF (ADlength >= ABlength) THEN np1 = MAX(n_prtn(1) + 1, n_prtn(2) + 1) np2 = MIN(n_prtn(1) + 1, n_prtn(2) + 1) ELSE diff --git a/src/pw/fft/fft_lib.F b/src/pw/fft/fft_lib.F index 5d8de5b968..9fe277e57b 100644 --- a/src/pw/fft/fft_lib.F +++ b/src/pw/fft/fft_lib.F @@ -149,7 +149,7 @@ CONTAINS !$ plan%need_alt_plan = .FALSE. ! Planning only needed for FFTW3 - IF (fft_type .EQ. 3) THEN + IF (fft_type == 3) THEN CALL fftw3_create_plan_3d(plan, zin, zout, plan_style) plan%valid = .TRUE. END IF @@ -186,7 +186,7 @@ CONTAINS END SELECT END IF ! stat is set to zero on error, -1,+1 are OK - IF (stat .EQ. 0) THEN + IF (stat == 0) THEN stat = 1 ELSE stat = 0 @@ -224,7 +224,7 @@ CONTAINS !$ plan%need_alt_plan = .FALSE. ! Planning only needed for FFTW3 - IF ((fft_type .EQ. 3) .AND. (n*m .NE. 0)) THEN + IF ((fft_type == 3) .AND. (n*m /= 0)) THEN CALL fftw3_create_plan_1dm(plan, zin, zout, plan_style) plan%valid = .TRUE. ELSE @@ -242,7 +242,7 @@ CONTAINS ! Planning only needed for FFTW3 - IF (plan%valid .AND. plan%fft_type .EQ. 3) THEN + IF (plan%valid .AND. plan%fft_type == 3) THEN CALL fftw3_destroy_plan(plan) plan%valid = .FALSE. END IF @@ -275,7 +275,7 @@ CONTAINS END SELECT END IF ! stat is set to zero on error, -1,+1 are OK - IF (stat .EQ. 0) THEN + IF (stat == 0) THEN stat = 1 ELSE stat = 0 diff --git a/src/pw/fft/fftw3_lib.F b/src/pw/fft/fftw3_lib.F index ae1ca00a3a..b09f891cf2 100644 --- a/src/pw/fft/fftw3_lib.F +++ b/src/pw/fft/fftw3_lib.F @@ -569,7 +569,7 @@ CONTAINS INTEGER, INTENT(OUT) :: rows_per_thread, rows_per_thread_r, & th_planA, th_planB - IF (MOD(nrows, nt) .EQ. 0) THEN + IF (MOD(nrows, nt) == 0) THEN rows_per_thread = nrows/nt rows_per_thread_r = 0 th_planA = nt @@ -853,11 +853,11 @@ CONTAINS rows_per_thread_r, & th_planA, th_planB) - IF (th_planB .GT. 0) THEN - IF (tid .LT. th_planA) THEN + IF (th_planB > 0) THEN + IF (tid < th_planA) THEN i_off = (tid)*(istride*(rows_per_thread)) + 1 o_off = (tid)*(ostride*(rows_per_thread)) + 1 - IF (rows_per_thread .GT. 0) THEN + IF (rows_per_thread > 0) THEN CALL fftw_execute_dft(plan, input(i_off), & output(o_off)) END IF @@ -1042,7 +1042,7 @@ CONTAINS !$ END IF ! Check for total number of rows not divisible by num_threads -!$ IF (num_rows*plan%num_threads_needed .NE. plan%m) THEN +!$ IF (num_rows*plan%num_threads_needed /= plan%m) THEN !$ plan%need_alt_plan = .TRUE. !$ END IF @@ -1166,7 +1166,7 @@ CONTAINS !$ out_offset = 1 + plan%num_rows*my_id !$ END IF !$ scal_offset = 1 + plan%n*plan%num_rows*my_id -!$ IF (plan%need_alt_plan .AND. my_id .EQ. plan%num_threads_needed - 1) THEN +!$ IF (plan%need_alt_plan .AND. my_id == plan%num_threads_needed - 1) THEN !$ num_rows = plan%alt_num_rows !$ fftw_plan = plan%alt_fftw_plan !$ ELSE diff --git a/src/pw/fft/mltfftsg_tools.F b/src/pw/fft/mltfftsg_tools.F index 3f9d51c20e..81badd6671 100644 --- a/src/pw/fft/mltfftsg_tools.F +++ b/src/pw/fft/mltfftsg_tools.F @@ -105,7 +105,7 @@ CONTAINS END DO END IF END IF - IF (IC .EQ. 1) THEN + IF (IC == 1) THEN IF (TRANSB == 'N' .OR. TRANSB == 'n') THEN CALL zgetmo(Z(1, 1, id), LOT, NFFT, N, B(1, ITR), LDBX) ELSE diff --git a/src/pw/fft_tools.F b/src/pw/fft_tools.F index a913b5529d..e5225ba170 100644 --- a/src/pw/fft_tools.F +++ b/src/pw/fft_tools.F @@ -2939,7 +2939,7 @@ CONTAINS ALLOCATE (fft_scratch_new) ALLOCATE (fft_scratch_new%fft_scratch) - IF (tf_type .NE. 400) THEN + IF (tf_type /= 400) THEN fft_scratch_new%fft_scratch%sizes = fft_sizes np = fft_sizes%numtask ALLOCATE (fft_scratch_new%fft_scratch%scount(0:np - 1), fft_scratch_new%fft_scratch%rcount(0:np - 1), & diff --git a/src/pw/mt_util.F b/src/pw/mt_util.F index f9be566b10..bcfb274434 100644 --- a/src/pw/mt_util.F +++ b/src/pw/mt_util.F @@ -169,18 +169,18 @@ CONTAINS dz = grid%dr(3) kk = bo(1, 3) DO k = bo(1, 3), bo(2, 3) - z = REAL(k - glb(3), dp)*dz; IF (z .GT. box2(3)) z = box(3) - z + z = REAL(k - glb(3), dp)*dz; IF (z > box2(3)) z = box(3) - z z2 = z*z jj = bo(1, 2) DO j = bo(1, 2), bo(2, 2) - y = REAL(j - glb(2), dp)*dy; IF (y .GT. box2(2)) y = box(2) - y + y = REAL(j - glb(2), dp)*dy; IF (y > box2(2)) y = box(2) - y y2 = y*y ii = bo(1, 1) DO i = bo(1, 1), bo(2, 1) - x = REAL(i - glb(1), dp)*dx; IF (x .GT. box2(1)) x = box(1) - x + x = REAL(i - glb(1), dp)*dx; IF (x > box2(1)) x = box(1) - x r2 = x*x + y2 + z2 r = SQRT(r2) - IF (r .GT. 1.0E-10_dp) THEN + IF (r > 1.0E-10_dp) THEN Vloc%array(ii, jj, kk) = erf(alpha*r)/r*fact ELSE Vloc%array(ii, jj, kk) = 2.0_dp*alpha*oorootpi*fact diff --git a/src/pw/ps_implicit_methods.F b/src/pw/ps_implicit_methods.F index 0dae8b8651..800753ddad 100644 --- a/src/pw/ps_implicit_methods.F +++ b/src/pw/ps_implicit_methods.F @@ -151,7 +151,7 @@ CONTAINS ps_implicit_env%times_called = 0 ! dct env - IF (boundary_condition .EQ. MIXED_BC .OR. boundary_condition .EQ. NEUMANN_BC) THEN + IF (boundary_condition == MIXED_BC .OR. boundary_condition == NEUMANN_BC) THEN CALL dct_type_init(pw_pool%pw_grid, neumann_directions, ps_implicit_env%dct_env) END IF @@ -159,7 +159,7 @@ CONTAINS CALL dirichlet_boundary_region_setup(pw_pool, poisson_params, ps_implicit_env%contacts) CALL ps_implicit_prepare_blocks(pw_pool, dct_pw_grid, green, poisson_params, ps_implicit_env) ! release tiles if they are not supposed to be written into cube files - IF ((boundary_condition .EQ. MIXED_PERIODIC_BC .OR. boundary_condition .EQ. MIXED_BC) .AND. & + IF ((boundary_condition == MIXED_PERIODIC_BC .OR. boundary_condition == MIXED_BC) .AND. & (.NOT. poisson_params%dbc_params%do_dbc_cube)) THEN n_contacts = SIZE(ps_implicit_env%contacts) DO j = 1, n_contacts @@ -218,7 +218,7 @@ CONTAINS times_called = ps_implicit_env%times_called ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) + IF (times_called == 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) CALL pw_pool%create_pw(g) CALL pw_pool%create_pw(v_old) @@ -268,13 +268,13 @@ CONTAINS CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree) ps_implicit_env%ehartree = ehartree ELSE - IF (outp_unit .GT. 0) WRITE (outp_unit, '(A1,/)') + IF (outp_unit > 0) WRITE (outp_unit, '(A1,/)') END IF iter = iter + 1 - reached_max_iter = iter .GT. max_iter - reached_tol = pres_error .LE. tol - IF (pres_error .GT. large_error) & + reached_max_iter = iter > max_iter + reached_tol = pres_error <= tol + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -286,7 +286,7 @@ CONTAINS END DO CALL ps_implicit_print_convergence_msg(iter, max_iter, outp_unit) - IF ((times_called .NE. 0) .AND. (.NOT. use_zero_initial_guess)) & + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & CALL pw_copy(v_new, ps_implicit_env%initial_guess) IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree @@ -373,7 +373,7 @@ CONTAINS CALL pw_pool_create(pw_pool_xpndd, pw_grid=poisson_env%dct_pw_grid) ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool_xpndd) + IF (times_called == 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool_xpndd) CALL pw_pool_xpndd%create_pw(g) CALL pw_pool_xpndd%create_pw(v_old) @@ -433,13 +433,13 @@ CONTAINS CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree/vol_scfac) ps_implicit_env%ehartree = ehartree/vol_scfac ELSE - IF (outp_unit .GT. 0) WRITE (outp_unit, '(A1,/)') + IF (outp_unit > 0) WRITE (outp_unit, '(A1,/)') END IF iter = iter + 1 - reached_max_iter = iter .GT. max_iter - reached_tol = pres_error .LE. tol - IF (pres_error .GT. large_error) & + reached_max_iter = iter > max_iter + reached_tol = pres_error <= tol + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT @@ -454,7 +454,7 @@ 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 .NE. 0) .AND. (.NOT. use_zero_initial_guess)) & + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) & CALL pw_copy(v_new_xpndd, ps_implicit_env%initial_guess) IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree @@ -558,7 +558,7 @@ CONTAINS END IF ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) + IF (times_called == 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) ALLOCATE (B(n_tiles_tot, data_size)) ALLOCATE (Bt(data_size, n_tiles_tot)) @@ -613,7 +613,7 @@ CONTAINS CALL apply_poisson_operator_fft(pw_pool, green, dielectric, v_old, res_old) CALL pw_scale(res_old, -1.0_dp) CALL pw_axpy(g, res_old) - IF (data_size .NE. 0) THEN + IF (data_size /= 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_old, 1, 0.0_dp, Btxlambda_old, 1) END IF CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_old, Btxlambda_old3D) @@ -653,7 +653,7 @@ CONTAINS v_new%array = v_new%array + eta/ngpts ! evaluate B^t * \lambda_new - IF (data_size .NE. 0) THEN + IF (data_size /= 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_new, 1, 0.0_dp, Btxlambda_new, 1) END IF CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_new, Btxlambda_new3D) @@ -677,7 +677,7 @@ CONTAINS ps_implicit_env%ehartree = ehartree ps_implicit_env%electric_enthalpy = electric_enthalpy ELSE - IF (outp_unit .GT. 0) WRITE (outp_unit, '(A1,/)') + IF (outp_unit > 0) WRITE (outp_unit, '(A1,/)') END IF ! verbose output @@ -685,7 +685,7 @@ CONTAINS v_new1D(ps_implicit_env%idx_1dto3d) = RESHAPE(v_new%array, [data_size]) CALL DGEMV('N', n_tiles_tot, data_size, 1.0_dp, B, n_tiles_tot, v_new1D, 1, 0.0_dp, Bxv_new, 1) CALL pw_grid%para%group%sum(Bxv_new) - IF (outp_unit .GT. 0) THEN + IF (outp_unit > 0) THEN WRITE (outp_unit, '(T3,A,A)') "======== verbose ", REPEAT('=', 61) WRITE (outp_unit, '(T20,A)') "Drgn tile vhartree lambda " WRITE (outp_unit, '(T19,A)') REPEAT('-', 46) @@ -702,10 +702,10 @@ CONTAINS ! check the convergence iter = iter + 1 - reached_max_iter = iter .GT. max_iter - reached_tol = pres_error .LE. tol + 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 .GT. large_error) & + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") IF (reached_max_iter .OR. reached_tol) EXIT @@ -718,7 +718,7 @@ CONTAINS END DO CALL ps_implicit_print_convergence_msg(iter, max_iter, outp_unit) - IF ((times_called .NE. 0) .AND. (.NOT. use_zero_initial_guess)) THEN + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN CALL pw_copy(v_new, ps_implicit_env%initial_guess) ps_implicit_env%initial_lambda(:) = lambda_new END IF @@ -836,7 +836,7 @@ CONTAINS CALL pw_pool_create(pw_pool_xpndd, pw_grid=dct_pw_grid) ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool_xpndd) + IF (times_called == 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool_xpndd) ALLOCATE (B(n_tiles_tot, data_size)) ALLOCATE (Bt(data_size, n_tiles_tot)) @@ -901,7 +901,7 @@ CONTAINS CALL apply_poisson_operator_dct(pw_pool_xpndd, green, dielectric, v_old, res_old) CALL pw_scale(res_old, -1.0_dp) CALL pw_axpy(g, res_old) - IF (data_size .NE. 0) THEN + IF (data_size /= 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_old, 1, 0.0_dp, Btxlambda_old, 1) END IF CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_old, Btxlambda_old3D) @@ -941,7 +941,7 @@ CONTAINS v_new_xpndd%array = v_new_xpndd%array + eta/ngpts ! evaluate B^t * \lambda_new - IF (data_size .NE. 0) THEN + IF (data_size /= 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_new, 1, 0.0_dp, Btxlambda_new, 1) END IF CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_new, Btxlambda_new3D) @@ -966,7 +966,7 @@ CONTAINS ps_implicit_env%ehartree = ehartree/vol_scfac ps_implicit_env%electric_enthalpy = electric_enthalpy/vol_scfac ELSE - IF (outp_unit .GT. 0) WRITE (outp_unit, '(A1,/)') + IF (outp_unit > 0) WRITE (outp_unit, '(A1,/)') END IF ! verbose output @@ -974,7 +974,7 @@ CONTAINS v_new1D(ps_implicit_env%idx_1dto3d) = RESHAPE(v_new_xpndd%array, [data_size]) CALL DGEMV('N', n_tiles_tot, data_size, 1.0_dp, B, n_tiles_tot, v_new1D, 1, 0.0_dp, Bxv_new, 1) CALL pw_grid%para%group%sum(Bxv_new) - IF (outp_unit .GT. 0) THEN + IF (outp_unit > 0) THEN WRITE (outp_unit, '(T3,A)') "======== verbose "//REPEAT('=', 61) WRITE (outp_unit, '(T20,A)') "Drgn tile vhartree lambda " WRITE (outp_unit, '(T19,A)') REPEAT('-', 46) @@ -991,10 +991,10 @@ CONTAINS ! check the convergence iter = iter + 1 - reached_max_iter = iter .GT. max_iter - reached_tol = pres_error .LE. tol + 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 .GT. large_error) & + IF (pres_error > large_error) & CPABORT("Poisson solver did not converge.") IF (reached_max_iter .OR. reached_tol) EXIT @@ -1010,7 +1010,7 @@ 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 .NE. 0) .AND. (.NOT. use_zero_initial_guess)) THEN + IF ((times_called /= 0) .AND. (.NOT. use_zero_initial_guess)) THEN CALL pw_copy(v_new_xpndd, ps_implicit_env%initial_guess) ps_implicit_env%initial_lambda(:) = lambda_new END IF @@ -1231,7 +1231,7 @@ CONTAINS ps_implicit_env%B(:, :) = TRANSPOSE(ps_implicit_env%Bt) ! evaluate QS = - B*(\Delta^-1)*B^t - IF (data_size .NE. 0) THEN + IF (data_size /= 0) THEN CALL DGEMM('N', 'N', n_tiles_tot, n_tiles_tot, data_size, & -1.0_dp, ps_implicit_env%B, n_tiles_tot, QAinvxBt, & data_size, 0.0_dp, ps_implicit_env%QS, n_tiles_tot) @@ -1249,12 +1249,12 @@ 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 .NE. 0) & + 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.") CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info .NE. 0) & + IF (info /= 0) & CPABORT("Inversion of R failed!") DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) @@ -1262,7 +1262,7 @@ CONTAINS done_preparing = .TRUE. CALL pw_grid_orig%para%group%sum(done_preparing) - IF ((unit_nr .GT. 0) .AND. done_preparing) THEN + IF ((unit_nr > 0) .AND. done_preparing) THEN WRITE (unit_nr, "(T3,A,/,T3,A,/,A)") "POISSON| ... Done. ", REPEAT('-', 78) END IF @@ -1360,7 +1360,7 @@ CONTAINS ps_implicit_env%B(:, :) = TRANSPOSE(ps_implicit_env%Bt) ! evaluate QS = - B*(\Delta^-1)*B^t - IF (data_size .NE. 0) THEN + IF (data_size /= 0) THEN CALL DGEMM('N', 'N', n_tiles_tot, n_tiles_tot, data_size, & -1.0_dp, ps_implicit_env%B, n_tiles_tot, QAinvxBt, & data_size, 0.0_dp, ps_implicit_env%QS, n_tiles_tot) @@ -1378,19 +1378,19 @@ 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 .NE. 0) & + 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.") CALL DGETRI(n_tiles_tot + 1, ps_implicit_env%Rinv, n_tiles_tot + 1, ipiv, work_arr, n_tiles_tot + 1, info) - IF (info .NE. 0) & + IF (info /= 0) & CPABORT("Inversion of R failed!") DEALLOCATE (QAinvxBt, Bxunit_vec, R, work_arr, ipiv) done_preparing = .TRUE. CALL pw_grid_orig%para%group%sum(done_preparing) - IF ((unit_nr .GT. 0) .AND. done_preparing) THEN + IF ((unit_nr > 0) .AND. done_preparing) THEN WRITE (unit_nr, "(T3,A,/,T3,A,/,A)") "POISSON| ... Done. ", REPEAT('-', 78) END IF @@ -2010,13 +2010,13 @@ CONTAINS outp_unit = -1 END IF - IF (logger%iter_info%print_level .GT. low_print_level) THEN - IF ((outp_unit .GT. 0) .AND. (iter .EQ. 1)) THEN + IF (logger%iter_info%print_level > low_print_level) THEN + IF ((outp_unit > 0) .AND. (iter == 1)) THEN WRITE (outp_unit, '(T3,A)') & "POISSON| iter pres error nabs error E_hartree delta E" END IF - IF (outp_unit .GT. 0) THEN + IF (outp_unit > 0) THEN WRITE (outp_unit, '(T3,A,I6,5X,E13.4,3X,E13.4)', ADVANCE='NO') & "POISSON| ", iter, pres_error, nabs_error END IF @@ -2049,8 +2049,8 @@ CONTAINS logger => cp_get_default_logger() CALL timeset(routineN, handle) - IF (logger%iter_info%print_level .GT. low_print_level) THEN - IF (outp_unit .GT. 0) WRITE (outp_unit, '(F19.10,E10.2)') & + IF (logger%iter_info%print_level > low_print_level) THEN + IF (outp_unit > 0) WRITE (outp_unit, '(F19.10,E10.2)') & ehartree, ehartree - ps_implicit_env%ehartree END IF CALL timestop(handle) @@ -2079,13 +2079,13 @@ CONTAINS last_iter = iter - 1 - IF (outp_unit .GT. 0) THEN - IF (last_iter .EQ. max_iter) THEN + IF (outp_unit > 0) THEN + IF (last_iter == max_iter) THEN WRITE (outp_unit, '(T3,A)') & "POISSON| No convergence achieved within the maximum number of iterations." END IF - IF (last_iter .LT. max_iter) THEN - IF (last_iter .EQ. 1) THEN + IF (last_iter < max_iter) THEN + IF (last_iter == 1) THEN msg = " iteration." ELSE msg = " iterations." diff --git a/src/pw/ps_implicit_types.F b/src/pw/ps_implicit_types.F index 4b437c2169..ed53ff2c8d 100644 --- a/src/pw/ps_implicit_types.F +++ b/src/pw/ps_implicit_types.F @@ -128,7 +128,7 @@ CONTAINS CALL dielectric_release(ps_implicit_env%dielectric, pw_pool) boundary_condition = ps_implicit_params%boundary_condition - IF (boundary_condition .EQ. MIXED_BC .OR. boundary_condition .EQ. NEUMANN_BC) THEN + IF (boundary_condition == MIXED_BC .OR. boundary_condition == NEUMANN_BC) THEN CALL dct_type_release(ps_implicit_env%dct_env) END IF diff --git a/src/pw/ps_wavelet_base.F b/src/pw/ps_wavelet_base.F index 6bebdfa64a..1609d35a1e 100644 --- a/src/pw/ps_wavelet_base.F +++ b/src/pw/ps_wavelet_base.F @@ -72,22 +72,22 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :, :, :) :: zmpi1 - IF (nd1 .LT. n1/2 + 1) CPABORT("Parallel convolution:ERROR:nd1") - IF (nd2 .LT. n2/2 + 1) CPABORT("Parallel convolution:ERROR:nd2") - IF (nd3 .LT. n3/2 + 1) CPABORT("Parallel convolution:ERROR:nd3") - IF (md1 .LT. n1) CPABORT("Parallel convolution:ERROR:md1") - IF (md2 .LT. n2) CPABORT("Parallel convolution:ERROR:md2") - IF (md3 .LT. n3) CPABORT("Parallel convolution:ERROR:md3") - IF (MOD(nd3, nproc) .NE. 0) CPABORT("Parallel convolution:ERROR:nd3") - IF (MOD(md2, nproc) .NE. 0) CPABORT("Parallel convolution:ERROR:md2") + IF (nd1 < n1/2 + 1) CPABORT("Parallel convolution:ERROR:nd1") + IF (nd2 < n2/2 + 1) CPABORT("Parallel convolution:ERROR:nd2") + IF (nd3 < n3/2 + 1) CPABORT("Parallel convolution:ERROR:nd3") + IF (md1 < n1) CPABORT("Parallel convolution:ERROR:md1") + IF (md2 < n2) CPABORT("Parallel convolution:ERROR:md2") + IF (md3 < n3) CPABORT("Parallel convolution:ERROR:md3") + IF (MOD(nd3, nproc) /= 0) CPABORT("Parallel convolution:ERROR:nd3") + IF (MOD(md2, nproc) /= 0) CPABORT("Parallel convolution:ERROR:md2") !defining work arrays dimensions ncache = ncache_optimal IF (ncache <= MAX(n1, n2, n3)*4) ncache = MAX(n1, n2, n3)*4 lzt = n2 - IF (MOD(n2, 2) .EQ. 0) lzt = lzt + 1 - IF (MOD(n2, 4) .EQ. 0) lzt = lzt + 1 !maybe this is useless + IF (MOD(n2, 2) == 0) lzt = lzt + 1 + IF (MOD(n2, 4) == 0) lzt = lzt + 1 !maybe this is useless !Allocations ALLOCATE (btrig1(2, ctrig_length)) @@ -108,7 +108,7 @@ CONTAINS ALLOCATE (zw(2, ncache/4, 2)) ALLOCATE (zt(2, lzt, n1)) ALLOCATE (zmpi2(2, n1, md2/nproc, nd3)) - IF (nproc .GT. 1) ALLOCATE (zmpi1(2, n1, md2/nproc, nd3/nproc, nproc)) + IF (nproc > 1) ALLOCATE (zmpi1(2, n1, md2/nproc, nd3/nproc, nproc)) !calculating the FFT work arrays (beware on the HalFFT in n3 dimension) CALL ctrig(n3, btrig3, after3, before3, now3, 1, ic3) @@ -129,7 +129,7 @@ CONTAINS ! transform along z axis lot = ncache/(4*n3) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_off:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -138,7 +138,7 @@ CONTAINS END IF DO j2 = 1, md2/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(md2/nproc) + j2 .LE. n2) THEN + IF (iproc*(md2/nproc) + j2 <= n2) THEN DO i1 = 1, n1, lot ma = i1 mb = MIN(i1 + (lot - 1), n1) @@ -166,7 +166,7 @@ CONTAINS !Interprocessor data transposition !input: I1,J2,j3,jp3,(Jp2) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN !communication scheduling CALL mpi_group%alltoall(zmpi2, zmpi1, 2*n1*(md2/nproc)*(nd3/nproc)) END IF @@ -175,7 +175,7 @@ CONTAINS !now each process perform complete convolution of its planes DO j3 = 1, nd3/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(nd3/nproc) + j3 .LE. n3/2 + 1) THEN + IF (iproc*(nd3/nproc) + j3 <= n3/2 + 1) THEN Jp2stb = 1 J2stb = 1 Jp2stf = 1 @@ -183,7 +183,7 @@ CONTAINS ! transform along x axis lot = ncache/(4*n1) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_off:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -198,7 +198,7 @@ CONTAINS !reverse index ordering, leaving the planes to be transformed at the end !input: I1,J2,j3,Jp2,(jp3) - IF (nproc .EQ. 1) THEN + IF (nproc == 1) THEN CALL P_mpiswitch_upcorn(j3, nfft, Jp2stb, J2stb, lot, n1, md2, nd3, nproc, zmpi2, zw(1, 1, 1)) ELSE CALL P_mpiswitch_upcorn(j3, nfft, Jp2stb, J2stb, lot, n1, md2, nd3, nproc, zmpi1, zw(1, 1, 1)) @@ -223,7 +223,7 @@ CONTAINS !transform along y axis lot = ncache/(4*n2) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_off:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -294,7 +294,7 @@ CONTAINS !reverse ordering !input: J2,Jp2,I1,j3,(jp3) - IF (nproc .EQ. 1) THEN + IF (nproc == 1) THEN CALL P_unmpiswitch_downcorn(j3, nfft, Jp2stf, J2stf, lot, n1, md2, nd3, nproc, zw(1, 1, inzee), zmpi2) ELSE CALL P_unmpiswitch_downcorn(j3, nfft, Jp2stf, J2stf, lot, n1, md2, nd3, nproc, zw(1, 1, inzee), zmpi1) @@ -306,7 +306,7 @@ CONTAINS !Interprocessor data transposition !input: I1,J2,j3,Jp2,(jp3) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN !communication scheduling CALL mpi_group%alltoall(zmpi1, zmpi2, 2*n1*(md2/nproc)*(nd3/nproc)) END IF @@ -316,7 +316,7 @@ CONTAINS lot = ncache/(4*n3) DO j2 = 1, md2/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(md2/nproc) + j2 .LE. n2) THEN + IF (iproc*(md2/nproc) + j2 <= n2) THEN DO i1 = 1, n1, lot ma = i1 mb = MIN(i1 + (lot - 1), n1) @@ -363,7 +363,7 @@ CONTAINS DEALLOCATE (zmpi2) DEALLOCATE (zw) DEALLOCATE (zt) - IF (nproc .GT. 1) DEALLOCATE (zmpi1) + IF (nproc > 1) DEALLOCATE (zmpi1) ! call timing(iproc,'PSolv_comput ','OF') END SUBROUTINE P_PoissonSolver @@ -397,7 +397,7 @@ CONTAINS DO Jp2 = Jp2stb, nproc DO J2 = J2stb, md2/nproc mfft = mfft + 1 - IF (mfft .GT. nfft) THEN + IF (mfft > nfft) THEN Jp2stb = Jp2 J2stb = J2 RETURN @@ -494,7 +494,7 @@ CONTAINS DO Jp2 = Jp2stf, nproc DO J2 = J2stf, md2/nproc mfft = mfft + 1 - IF (mfft .GT. nfft) THEN + IF (mfft > nfft) THEN Jp2stf = Jp2 J2stf = J2 RETURN @@ -867,15 +867,15 @@ CONTAINS CALL timeset(routineN, handle) ! check input - IF (MOD(n3, 2) .NE. 0) CPABORT("Parallel convolution:ERROR:n3") - IF (nd1 .LT. n1/2 + 1) CPABORT("Parallel convolution:ERROR:nd1") - IF (nd2 .LT. n2/2 + 1) CPABORT("Parallel convolution:ERROR:nd2") - IF (nd3 .LT. n3/2 + 1) CPABORT("Parallel convolution:ERROR:nd3") - IF (md1 .LT. n1) CPABORT("Parallel convolution:ERROR:md1") - IF (md2 .LT. n2) CPABORT("Parallel convolution:ERROR:md2") - IF (md3 .LT. n3/2) CPABORT("Parallel convolution:ERROR:md3") - IF (MOD(nd3, nproc) .NE. 0) CPABORT("Parallel convolution:ERROR:nd3") - IF (MOD(md2, nproc) .NE. 0) CPABORT("Parallel convolution:ERROR:md2") + IF (MOD(n3, 2) /= 0) CPABORT("Parallel convolution:ERROR:n3") + IF (nd1 < n1/2 + 1) CPABORT("Parallel convolution:ERROR:nd1") + IF (nd2 < n2/2 + 1) CPABORT("Parallel convolution:ERROR:nd2") + IF (nd3 < n3/2 + 1) CPABORT("Parallel convolution:ERROR:nd3") + IF (md1 < n1) CPABORT("Parallel convolution:ERROR:md1") + IF (md2 < n2) CPABORT("Parallel convolution:ERROR:md2") + IF (md3 < n3/2) CPABORT("Parallel convolution:ERROR:md3") + IF (MOD(nd3, nproc) /= 0) CPABORT("Parallel convolution:ERROR:nd3") + IF (MOD(md2, nproc) /= 0) CPABORT("Parallel convolution:ERROR:md2") !defining work arrays dimensions ncache = ncache_optimal @@ -884,8 +884,8 @@ CONTAINS ! if (timing_flag == 1 .and. iproc ==0) print *,'parallel ncache=',ncache lzt = n2 - IF (MOD(n2, 2) .EQ. 0) lzt = lzt + 1 - IF (MOD(n2, 4) .EQ. 0) lzt = lzt + 1 !maybe this is useless + IF (MOD(n2, 2) == 0) lzt = lzt + 1 + IF (MOD(n2, 4) == 0) lzt = lzt + 1 !maybe this is useless !Allocations ALLOCATE (btrig1(2, ctrig_length)) @@ -907,7 +907,7 @@ CONTAINS ALLOCATE (zt(2, lzt, n1)) ALLOCATE (zmpi2(2, n1, md2/nproc, nd3)) ALLOCATE (cosinarr(2, n3/2)) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN ALLOCATE (zmpi1(2, n1, md2/nproc, nd3/nproc, nproc)) zmpi1 = 0.0_dp END IF @@ -944,7 +944,7 @@ CONTAINS ! transform along z axis lot = ncache/(2*n3) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_off:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -954,7 +954,7 @@ CONTAINS DO j2 = 1, md2/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(md2/nproc) + j2 .LE. n2) THEN + IF (iproc*(md2/nproc) + j2 <= n2) THEN DO i1 = 1, n1, lot ma = i1 mb = MIN(i1 + (lot - 1), n1) @@ -982,7 +982,7 @@ CONTAINS END DO !Interprocessor data transposition !input: I1,J2,j3,jp3,(Jp2) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN CALL mpi_group%alltoall(zmpi2, zmpi1, 2*n1*(md2/nproc)*(nd3/nproc)) END IF !output: I1,J2,j3,Jp2,(jp3) @@ -990,7 +990,7 @@ CONTAINS !now each process perform complete convolution of its planes DO j3 = 1, nd3/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(nd3/nproc) + j3 .LE. n3/2 + 1) THEN + IF (iproc*(nd3/nproc) + j3 <= n3/2 + 1) THEN Jp2stb = 1 J2stb = 1 Jp2stf = 1 @@ -998,7 +998,7 @@ CONTAINS ! transform along x axis lot = ncache/(4*n1) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_off:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -1013,7 +1013,7 @@ CONTAINS !reverse index ordering, leaving the planes to be transformed at the end !input: I1,J2,j3,Jp2,(jp3) - IF (nproc .EQ. 1) THEN + IF (nproc == 1) THEN CALL S_mpiswitch_upcorn(j3, nfft, Jp2stb, J2stb, lot, n1, md2, nd3, nproc, zmpi2, zw(1, 1, 1)) ELSE CALL S_mpiswitch_upcorn(j3, nfft, Jp2stb, J2stb, lot, n1, md2, nd3, nproc, zmpi1, zw(1, 1, 1)) @@ -1038,7 +1038,7 @@ CONTAINS !transform along y axis lot = ncache/(4*n2) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_off:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -1108,7 +1108,7 @@ CONTAINS !reverse ordering !input: J2,Jp2,I1,j3,(jp3) - IF (nproc .EQ. 1) THEN + IF (nproc == 1) THEN CALL S_unmpiswitch_downcorn(j3, nfft, Jp2stf, J2stf, lot, n1, md2, nd3, nproc, zw(1, 1, inzee), zmpi2) ELSE CALL S_unmpiswitch_downcorn(j3, nfft, Jp2stf, J2stf, lot, n1, md2, nd3, nproc, zw(1, 1, inzee), zmpi1) @@ -1120,7 +1120,7 @@ CONTAINS !Interprocessor data transposition !input: I1,J2,j3,Jp2,(jp3) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN !communication scheduling CALL mpi_group%alltoall(zmpi1, zmpi2, 2*n1*(md2/nproc)*(nd3/nproc)) END IF @@ -1132,7 +1132,7 @@ CONTAINS lot = ncache/(2*n3) DO j2 = 1, md2/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(md2/nproc) + j2 .LE. n2) THEN + IF (iproc*(md2/nproc) + j2 <= n2) THEN DO i1 = 1, n1, lot ma = i1 mb = MIN(i1 + (lot - 1), n1) @@ -1183,7 +1183,7 @@ CONTAINS DEALLOCATE (zw) DEALLOCATE (zt) DEALLOCATE (cosinarr) - IF (nproc .GT. 1) DEALLOCATE (zmpi1) + IF (nproc > 1) DEALLOCATE (zmpi1) ! call timing(iproc,'PSolv_comput ','OF') CALL timestop(handle) @@ -1219,7 +1219,7 @@ CONTAINS DO Jp2 = Jp2stb, nproc DO J2 = J2stb, md2/nproc mfft = mfft + 1 - IF (mfft .GT. nfft) THEN + IF (mfft > nfft) THEN Jp2stb = Jp2 J2stb = J2 RETURN @@ -1314,7 +1314,7 @@ CONTAINS DO Jp2 = Jp2stf, nproc DO J2 = J2stf, md2/nproc mfft = mfft + 1 - IF (mfft .GT. nfft) THEN + IF (mfft > nfft) THEN Jp2stf = Jp2 J2stf = J2 RETURN @@ -1611,25 +1611,25 @@ CONTAINS REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :, :, :) :: zmpi1 - IF (MOD(n1, 2) .NE. 0) CPABORT("Parallel convolution:ERROR:n1") - IF (MOD(n2, 2) .NE. 0) CPABORT("Parallel convolution:ERROR:n2") - IF (MOD(n3, 2) .NE. 0) CPABORT("Parallel convolution:ERROR:n3") - IF (nd1 .LT. n1/2 + 1) CPABORT("Parallel convolution:ERROR:nd1") - IF (nd2 .LT. n2/2 + 1) CPABORT("Parallel convolution:ERROR:nd2") - IF (nd3 .LT. n3/2 + 1) CPABORT("Parallel convolution:ERROR:nd3") - IF (md1 .LT. n1/2) CPABORT("Parallel convolution:ERROR:md1") - IF (md2 .LT. n2/2) CPABORT("Parallel convolution:ERROR:md2") - IF (md3 .LT. n3/2) CPABORT("Parallel convolution:ERROR:md3") - IF (MOD(nd3, nproc) .NE. 0) CPABORT("Parallel convolution:ERROR:nd3") - IF (MOD(md2, nproc) .NE. 0) CPABORT("Parallel convolution:ERROR:md2") + IF (MOD(n1, 2) /= 0) CPABORT("Parallel convolution:ERROR:n1") + IF (MOD(n2, 2) /= 0) CPABORT("Parallel convolution:ERROR:n2") + IF (MOD(n3, 2) /= 0) CPABORT("Parallel convolution:ERROR:n3") + IF (nd1 < n1/2 + 1) CPABORT("Parallel convolution:ERROR:nd1") + IF (nd2 < n2/2 + 1) CPABORT("Parallel convolution:ERROR:nd2") + IF (nd3 < n3/2 + 1) CPABORT("Parallel convolution:ERROR:nd3") + IF (md1 < n1/2) CPABORT("Parallel convolution:ERROR:md1") + IF (md2 < n2/2) CPABORT("Parallel convolution:ERROR:md2") + IF (md3 < n3/2) CPABORT("Parallel convolution:ERROR:md3") + IF (MOD(nd3, nproc) /= 0) CPABORT("Parallel convolution:ERROR:nd3") + IF (MOD(md2, nproc) /= 0) CPABORT("Parallel convolution:ERROR:md2") !defining work arrays dimensions ncache = ncache_optimal IF (ncache <= MAX(n1, n2, n3/2)*4) ncache = MAX(n1, n2, n3/2)*4 lzt = n2/2 - IF (MOD(n2/2, 2) .EQ. 0) lzt = lzt + 1 - IF (MOD(n2/2, 4) .EQ. 0) lzt = lzt + 1 + IF (MOD(n2/2, 2) == 0) lzt = lzt + 1 + IF (MOD(n2/2, 4) == 0) lzt = lzt + 1 !Allocations ALLOCATE (btrig1(2, ctrig_length)) @@ -1652,7 +1652,7 @@ CONTAINS ALLOCATE (zmpi2(2, n1, md2/nproc, nd3)) zmpi2 = 1.0E99_dp ! init mpi'ed buffers to silence warnings under valgrind ALLOCATE (cosinarr(2, n3/2)) - IF (nproc .GT. 1) ALLOCATE (zmpi1(2, n1, md2/nproc, nd3/nproc, nproc)) + IF (nproc > 1) ALLOCATE (zmpi1(2, n1, md2/nproc, nd3/nproc, nproc)) !calculating the FFT work arrays (beware on the HalFFT in n3 dimension) CALL ctrig(n3/2, btrig3, after3, before3, now3, 1, ic3) @@ -1680,7 +1680,7 @@ CONTAINS ! transform along z axis lot = ncache/(2*n3) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_on:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -1690,7 +1690,7 @@ CONTAINS DO j2 = 1, md2/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(md2/nproc) + j2 .LE. n2/2) THEN + IF (iproc*(md2/nproc) + j2 <= n2/2) THEN DO i1 = 1, (n1/2), lot ma = i1 mb = MIN(i1 + (lot - 1), (n1/2)) @@ -1720,7 +1720,7 @@ CONTAINS !Interprocessor data transposition !input: I1,J2,j3,jp3,(Jp2) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN !communication scheduling CALL mpi_group%alltoall(zmpi2, zmpi1, n1*(md2/nproc)*(nd3/nproc)) END IF @@ -1729,7 +1729,7 @@ CONTAINS !now each process perform complete convolution of its planes DO j3 = 1, nd3/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(nd3/nproc) + j3 .LE. n3/2 + 1) THEN + IF (iproc*(nd3/nproc) + j3 <= n3/2 + 1) THEN Jp2stb = 1 J2stb = 1 Jp2stf = 1 @@ -1737,7 +1737,7 @@ CONTAINS ! transform along x axis lot = ncache/(4*n1) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_on:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -1752,7 +1752,7 @@ CONTAINS !reverse index ordering, leaving the planes to be transformed at the end !input: I1,J2,j3,Jp2,(jp3) - IF (nproc .EQ. 1) THEN + IF (nproc == 1) THEN CALL mpiswitch_upcorn(j3, nfft, Jp2stb, J2stb, lot, n1, md2, nd3, nproc, zmpi2, zw(1, 1, 1)) ELSE CALL mpiswitch_upcorn(j3, nfft, Jp2stb, J2stb, lot, n1, md2, nd3, nproc, zmpi1, zw(1, 1, 1)) @@ -1777,7 +1777,7 @@ CONTAINS !transform along y axis lot = ncache/(4*n2) - IF (lot .LT. 1) THEN + IF (lot < 1) THEN WRITE (*, *) & 'convolxc_on:ncache has to be enlarged to be able to hold at'// & 'least one 1-d FFT of this size even though this will'// & @@ -1847,7 +1847,7 @@ CONTAINS !reverse ordering !input: J2,Jp2,I1,j3,(jp3) - IF (nproc .EQ. 1) THEN + IF (nproc == 1) THEN CALL unmpiswitch_downcorn(j3, nfft, Jp2stf, J2stf, lot, n1, md2, nd3, nproc, zw(1, 1, inzee), zmpi2) ELSE CALL unmpiswitch_downcorn(j3, nfft, Jp2stf, J2stf, lot, n1, md2, nd3, nproc, zw(1, 1, inzee), zmpi1) @@ -1859,7 +1859,7 @@ CONTAINS !Interprocessor data transposition !input: I1,J2,j3,Jp2,(jp3) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN !communication scheduling CALL mpi_group%alltoall(zmpi1, zmpi2, n1*(md2/nproc)*(nd3/nproc)) !output: I1,J2,j3,jp3,(Jp2) @@ -1870,7 +1870,7 @@ CONTAINS lot = ncache/(2*n3) DO j2 = 1, md2/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(md2/nproc) + j2 .LE. n2/2) THEN + IF (iproc*(md2/nproc) + j2 <= n2/2) THEN DO i1 = 1, (n1/2), lot ma = i1 mb = MIN(i1 + (lot - 1), (n1/2)) @@ -1921,7 +1921,7 @@ CONTAINS DEALLOCATE (zw) DEALLOCATE (zt) DEALLOCATE (cosinarr) - IF (nproc .GT. 1) DEALLOCATE (zmpi1) + IF (nproc > 1) DEALLOCATE (zmpi1) END SUBROUTINE F_PoissonSolver @@ -1988,7 +1988,7 @@ CONTAINS Main: DO Jp2 = Jp2stb, nproc DO J2 = J2stb, md2/nproc mfft = mfft + 1 - IF (mfft .GT. nfft) THEN + IF (mfft > nfft) THEN Jp2stb = Jp2 J2stb = J2 EXIT Main @@ -2063,7 +2063,7 @@ CONTAINS Main: DO Jp2 = Jp2stf, nproc DO J2 = J2stf, md2/nproc mfft = mfft + 1 - IF (mfft .GT. nfft) THEN + IF (mfft > nfft) THEN Jp2stf = Jp2 J2stf = J2 EXIT Main diff --git a/src/pw/ps_wavelet_fft3d.F b/src/pw/ps_wavelet_fft3d.F index 33c3ffc1a6..00d7e15b90 100644 --- a/src/pw/ps_wavelet_fft3d.F +++ b/src/pw/ps_wavelet_fft3d.F @@ -205,11 +205,11 @@ CONTAINS WRITE (*, 37) (idata(1, j), j=1, 149) CPABORT("") END IF - IF (n .EQ. idata(1, i)) THEN + IF (n == idata(1, i)) THEN ic = 0 DO j = 1, 6 itt = idata(1 + j, i) - IF (itt .GT. 1) THEN + IF (itt > 1) THEN ic = ic + 1 now(j) = idata(1 + j, i) ELSE @@ -229,7 +229,7 @@ CONTAINS twopi = 6.283185307179586_dp angle = isign*twopi/n - IF (MOD(n, 2) .EQ. 0) THEN + IF (MOD(n, 2) == 0) THEN nh = n/2 trig(1, 1) = 1._dp trig(2, 1) = 0._dp @@ -301,7 +301,7 @@ CONTAINS ! sqrt(.5_dp) rt2i = 0.7071067811865475_dp - IF (now .EQ. 2) THEN + IF (now == 2) THEN ia = 1 nin1 = ia - after nout1 = ia - atn @@ -322,8 +322,8 @@ CONTAINS END DO; END DO DO 2000, ia = 2, after ias = ia - 1 - IF (2*ias .EQ. after) THEN - IF (isign .EQ. 1) THEN + IF (2*ias == after) THEN + IF (isign == 1) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -360,8 +360,8 @@ CONTAINS zout(2, j, nout2) = s2 + s1 END DO; END DO END IF - ELSE IF (4*ias .EQ. after) THEN - IF (isign .EQ. 1) THEN + ELSE IF (4*ias == after) THEN + IF (isign == 1) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -402,8 +402,8 @@ CONTAINS zout(2, j, nout2) = s1 - s2 END DO; END DO END IF - ELSE IF (4*ias .EQ. 3*after) THEN - IF (isign .EQ. 1) THEN + ELSE IF (4*ias == 3*after) THEN + IF (isign == 1) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -469,8 +469,8 @@ CONTAINS END DO; END DO END IF 2000 CONTINUE - ELSE IF (now .EQ. 4) THEN - IF (isign .EQ. 1) THEN + ELSE IF (now == 4) THEN + IF (isign == 1) THEN ia = 1 nin1 = ia - after nout1 = ia - atn @@ -511,7 +511,7 @@ CONTAINS END DO; END DO DO 4000, ia = 2, after ias = ia - 1 - IF (2*ias .EQ. after) THEN + IF (2*ias == after) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -650,7 +650,7 @@ CONTAINS END DO; END DO DO 4100, ia = 2, after ias = ia - 1 - IF (2*ias .EQ. after) THEN + IF (2*ias == after) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -749,8 +749,8 @@ CONTAINS END IF 4100 CONTINUE END IF - ELSE IF (now .EQ. 8) THEN - IF (isign .EQ. -1) THEN + ELSE IF (now == 8) THEN + IF (isign == -1) THEN ia = 1 nin1 = ia - after nout1 = ia - atn @@ -1192,7 +1192,7 @@ CONTAINS 8001 CONTINUE END IF - ELSE IF (now .EQ. 3) THEN + ELSE IF (now == 3) THEN ! .5_dp*sqrt(3._dp) bb = isign*0.8660254037844387_dp ia = 1 @@ -1227,8 +1227,8 @@ CONTAINS END DO; END DO DO 3000, ia = 2, after ias = ia - 1 - IF (4*ias .EQ. 3*after) THEN - IF (isign .EQ. 1) THEN + IF (4*ias == 3*after) THEN + IF (isign == 1) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -1289,8 +1289,8 @@ CONTAINS zout(2, j, nout3) = s1 - r2 END DO; END DO END IF - ELSE IF (8*ias .EQ. 3*after) THEN - IF (isign .EQ. 1) THEN + ELSE IF (8*ias == 3*after) THEN + IF (isign == 1) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -1398,7 +1398,7 @@ CONTAINS END DO; END DO END IF 3000 CONTINUE - ELSE IF (now .EQ. 5) THEN + ELSE IF (now == 5) THEN ! cos(2._dp*pi/5._dp) cos2 = 0.3090169943749474_dp ! cos(4._dp*pi/5._dp) @@ -1461,8 +1461,8 @@ CONTAINS END DO; END DO DO 5000, ia = 2, after ias = ia - 1 - IF (8*ias .EQ. 5*after) THEN - IF (isign .EQ. 1) THEN + IF (8*ias == 5*after) THEN + IF (isign == 1) THEN nin1 = ia - after nout1 = ia - atn DO ib = 1, before @@ -1651,7 +1651,7 @@ CONTAINS END DO; END DO END IF 5000 CONTINUE - ELSE IF (now .EQ. 6) THEN + ELSE IF (now == 6) THEN ! .5_dp*sqrt(3._dp) bb = isign*0.8660254037844387_dp diff --git a/src/pw/ps_wavelet_kernel.F b/src/pw/ps_wavelet_kernel.F index b1237f4867..9776315a1d 100644 --- a/src/pw/ps_wavelet_kernel.F +++ b/src/pw/ps_wavelet_kernel.F @@ -901,7 +901,7 @@ CONTAINS iend = MIN((iproc + 1)*nker2/nproc, n2h + n03) istart1 = istart - IF (iproc .EQ. 0) istart1 = n2h - n03 + 2 + IF (iproc == 0) istart1 = n2h - n03 + 2 !Allocations ALLOCATE (x_scf(0:n_scf)) @@ -992,7 +992,7 @@ CONTAINS ! This seems to happen with large MPI processor counts if the size of the ! RS grid is not directly compatible with the allowed FFT dimensions in ! subroutine fourier_dim (ps_wavelet_fft3d.F) - IF (i03 .LT. -n_range .OR. i03 .GT. n_range) THEN + IF (i03 < -n_range .OR. i03 > n_range) THEN CALL cp_abort(__LOCATION__, "Index out of range in wavelet solver. "// & "Try decreasing the number of MPI processors, or adjust the PW_CUTOFF or cell size "// & "so that 2*(number of RS grid points) matches the allowed FFT dimensions "// & @@ -1127,19 +1127,19 @@ CONTAINS !Body !check input - CPASSERT(nd1 .GE. n1) - CPASSERT(nd2 .GE. n2) - CPASSERT(nd3 .GE. n3/2 + 1) - CPASSERT(MOD(nd3, nproc) .EQ. 0) - CPASSERT(MOD(nd2, nproc) .EQ. 0) + CPASSERT(nd1 >= n1) + CPASSERT(nd2 >= n2) + CPASSERT(nd3 >= n3/2 + 1) + CPASSERT(MOD(nd3, nproc) == 0) + CPASSERT(MOD(nd2, nproc) == 0) MARK_USED(nd1) !defining work arrays dimensions ncache = ncache_optimal IF (ncache <= MAX(n1, n2, n3/2)*4) ncache = MAX(n1, n2, n3/2)*4 lzt = n2 - IF (MOD(n2, 2) .EQ. 0) lzt = lzt + 1 - IF (MOD(n2, 4) .EQ. 0) lzt = lzt + 1 + IF (MOD(n2, 2) == 0) lzt = lzt + 1 + IF (MOD(n2, 4) == 0) lzt = lzt + 1 !Allocations ALLOCATE (trig1(2, ctrig_length)) @@ -1158,7 +1158,7 @@ CONTAINS ALLOCATE (zt(2, lzt, n1)) ALLOCATE (zmpi2(2, n1, nd2/nproc, nd3)) ALLOCATE (cosinarr(2, n3/2)) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN ALLOCATE (zmpi1(2, n1, nd2/nproc, nd3/nproc, nproc)) zmpi1 = 0.0_dp END IF @@ -1179,11 +1179,11 @@ CONTAINS !transform along z axis lot = ncache/(2*n3) - CPASSERT(lot .GE. 1) + CPASSERT(lot >= 1) DO j2 = 1, nd2/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(nd2/nproc) + j2 .LE. n2) THEN + IF (iproc*(nd2/nproc) + j2 <= n2) THEN DO i1 = 1, n1, lot ma = i1 mb = MIN(i1 + (lot - 1), n1) @@ -1214,7 +1214,7 @@ CONTAINS !Interprocessor data transposition !input: I1,J2,j3,jp3,(Jp2) - IF (nproc .GT. 1) THEN + IF (nproc > 1) THEN !communication scheduling CALL mpi_group%alltoall(zmpi2, &!2*n1*(nd2/nproc)*(nd3/nproc), & zmpi1, 2*n1*(nd2/nproc)*(nd3/nproc)) @@ -1223,13 +1223,13 @@ CONTAINS DO j3 = 1, nd3/nproc !this condition ensures that we manage only the interesting part for the FFT - IF (iproc*(nd3/nproc) + j3 .LE. n3/2 + 1) THEN + IF (iproc*(nd3/nproc) + j3 <= n3/2 + 1) THEN Jp2st = 1 J2st = 1 !transform along x axis lot = ncache/(4*n1) - CPASSERT(lot .GE. 1) + CPASSERT(lot >= 1) DO j = 1, n2, lot ma = j @@ -1238,7 +1238,7 @@ CONTAINS !reverse ordering !input: I1,J2,j3,Jp2,(jp3) - IF (nproc .EQ. 1) THEN + IF (nproc == 1) THEN CALL mpiswitch(j3, nfft, Jp2st, J2st, lot, n1, nd2, nd3, nproc, zmpi2, zw(1, 1, 1)) ELSE CALL mpiswitch(j3, nfft, Jp2st, J2st, lot, n1, nd2, nd3, nproc, zmpi1, zw(1, 1, 1)) @@ -1262,7 +1262,7 @@ CONTAINS !transform along y axis, and taking only the first half lot = ncache/(4*n2) - CPASSERT(lot .GE. 1) + CPASSERT(lot >= 1) DO j = 1, nk1, lot ma = j @@ -1307,7 +1307,7 @@ CONTAINS DEALLOCATE (zw) DEALLOCATE (zt) DEALLOCATE (cosinarr) - IF (nproc .GT. 1) DEALLOCATE (zmpi1) + IF (nproc > 1) DEALLOCATE (zmpi1) END SUBROUTINE kernelfft @@ -1386,7 +1386,7 @@ CONTAINS DO 300, Jp2 = Jp2st, nproc DO 200, J2 = J2st, nd2/nproc mfft = mfft + 1 - IF (mfft .GT. nfft) THEN + IF (mfft > nfft) THEN Jp2st = Jp2 J2st = J2 RETURN diff --git a/src/pw/ps_wavelet_methods.F b/src/pw/ps_wavelet_methods.F index 159ff2343b..d8970a4c16 100644 --- a/src/pw/ps_wavelet_methods.F +++ b/src/pw/ps_wavelet_methods.F @@ -96,9 +96,9 @@ CONTAINS wavelet%datacode = "D" IF (poisson_params%wavelet_method == WAVELET0D) THEN - IF (hx .NE. hy) & + IF (hx /= hy) & CPABORT("Poisson solver for non cubic cells not yet implemented") - IF (hz .NE. hy) & + IF (hz /= hy) & CPABORT("Poisson solver for non cubic cells not yet implemented") END IF @@ -215,21 +215,21 @@ CONTAINS max_val_up = 0._dp IF (lb(2) == pw_grid%bounds(1, 2)) max_val_low = MAXVAL(ABS(density%array(:, lb(2), :))) IF (ub(2) == pw_grid%bounds(2, 2)) max_val_up = MAXVAL(ABS(density%array(:, ub(2), :))) - IF (max_val_low .GE. 0.0001_dp) should_warn = 1 - IF (max_val_up .GE. 0.0001_dp) should_warn = 1 + IF (max_val_low >= 0.0001_dp) should_warn = 1 + IF (max_val_up >= 0.0001_dp) should_warn = 1 IF (wavelet%geocode == 'F') THEN max_val_low = 0._dp max_val_up = 0._dp IF (lb(1) == pw_grid%bounds(1, 1)) max_val_low = MAXVAL(ABS(density%array(lb(1), :, :))) IF (ub(1) == pw_grid%bounds(2, 1)) max_val_up = MAXVAL(ABS(density%array(ub(1), :, :))) - IF (max_val_low .GE. 0.0001_dp) should_warn = 1 - IF (max_val_up .GE. 0.0001_dp) should_warn = 1 + IF (max_val_low >= 0.0001_dp) should_warn = 1 + IF (max_val_up >= 0.0001_dp) should_warn = 1 max_val_low = 0._dp max_val_up = 0._dp IF (lb(3) == pw_grid%bounds(1, 3)) max_val_low = MAXVAL(ABS(density%array(:, :, lb(3)))) IF (ub(3) == pw_grid%bounds(2, 3)) max_val_up = MAXVAL(ABS(density%array(:, :, ub(3)))) - IF (max_val_low .GE. 0.0001_dp) should_warn = 1 - IF (max_val_up .GE. 0.0001_dp) should_warn = 1 + IF (max_val_low >= 0.0001_dp) should_warn = 1 + IF (max_val_up >= 0.0001_dp) should_warn = 1 END IF END IF @@ -241,9 +241,9 @@ CONTAINS DO j = 0, pw_grid%para%group%num_pe_cart(2) - 1 cart_pos = [i, j] CALL pw_grid%para%group%rank_cart(cart_pos, dest) - IF ((ub(1) .GE. lb(1)) .AND. (ub(2) .GE. lb(2))) THEN - IF (dest*local_z_dim .LE. m2) THEN - IF ((dest + 1)*local_z_dim .LE. m2) THEN + IF ((ub(1) >= lb(1)) .AND. (ub(2) >= lb(2))) THEN + IF (dest*local_z_dim <= m2) THEN + IF ((dest + 1)*local_z_dim <= m2) THEN scount(dest + 1) = ABS((ub(1) - lb(1) + 1)*(ub(2) - lb(2) + 1)*local_z_dim) ELSE scount(dest + 1) = ABS((ub(1) - lb(1) + 1)*(ub(2) - lb(2) + 1)*MOD(m2, local_z_dim)) @@ -256,9 +256,9 @@ CONTAINS END IF lox = get_limit(pw_grid%npts(1), pw_grid%para%group%num_pe_cart(1), i) loy = get_limit(pw_grid%npts(2), pw_grid%para%group%num_pe_cart(2), j) - IF ((lox(2) .GE. lox(1)) .AND. (loy(2) .GE. loy(1))) THEN - IF (iproc*local_z_dim .LE. m2) THEN - IF ((iproc + 1)*local_z_dim .LE. m2) THEN + IF ((lox(2) >= lox(1)) .AND. (loy(2) >= loy(1))) THEN + IF (iproc*local_z_dim <= m2) THEN + IF ((iproc + 1)*local_z_dim <= m2) THEN rcount(dest + 1) = ABS((lox(2) - lox(1) + 1)*(loy(2) - loy(1) + 1)*local_z_dim) ELSE rcount(dest + 1) = ABS((lox(2) - lox(1) + 1)*(loy(2) - loy(1) + 1)*MOD(m2, local_z_dim)) @@ -290,8 +290,8 @@ CONTAINS lox = get_limit(pw_grid%npts(1), pw_grid%para%group%num_pe_cart(1), i) loy = get_limit(pw_grid%npts(2), pw_grid%para%group%num_pe_cart(2), j) - IF (iproc*local_z_dim .LE. m2) THEN - IF ((iproc + 1)*local_z_dim .LE. m2) THEN + IF (iproc*local_z_dim <= m2) THEN + IF ((iproc + 1)*local_z_dim <= m2) THEN loz = local_z_dim ELSE loz = MOD(m2, local_z_dim) @@ -353,8 +353,8 @@ CONTAINS rcount = 0 rbuf = 0.0_dp ii = 1 - IF (iproc*local_z_dim .LE. m2) THEN - IF ((iproc + 1)*local_z_dim .LE. m2) THEN + IF (iproc*local_z_dim <= m2) THEN + IF ((iproc + 1)*local_z_dim <= m2) THEN loz = local_z_dim ELSE loz = MOD(m2, local_z_dim) @@ -369,9 +369,9 @@ CONTAINS DO j = 0, pw_grid%para%group%num_pe_cart(2) - 1 cart_pos = [i, j] CALL pw_grid%para%group%rank_cart(cart_pos, dest) - IF ((ub(1) .GE. lb(1)) .AND. (ub(2) .GE. lb(2))) THEN - IF (dest*local_z_dim .LE. m2) THEN - IF ((dest + 1)*local_z_dim .LE. m2) THEN + IF ((ub(1) >= lb(1)) .AND. (ub(2) >= lb(2))) THEN + IF (dest*local_z_dim <= m2) THEN + IF ((dest + 1)*local_z_dim <= m2) THEN rcount(dest + 1) = ABS((ub(1) - lb(1) + 1)*(ub(2) - lb(2) + 1)*local_z_dim) ELSE rcount(dest + 1) = ABS((ub(1) - lb(1) + 1)*(ub(2) - lb(2) + 1)*MOD(m2, local_z_dim)) @@ -384,7 +384,7 @@ CONTAINS END IF lox = get_limit(pw_grid%npts(1), pw_grid%para%group%num_pe_cart(1), i) loy = get_limit(pw_grid%npts(2), pw_grid%para%group%num_pe_cart(2), j) - IF ((lox(2) .GE. lox(1)) .AND. (loy(2) .GE. loy(1))) THEN + IF ((lox(2) >= lox(1)) .AND. (loy(2) >= loy(1))) THEN scount(dest + 1) = ABS((lox(2) - lox(1) + 1)*(loy(2) - loy(1) + 1)*loz) DO k = lox(1) - min_x(1) + 1, lox(2) - min_x(1) + 1 DO l = loy(1) - min_y(1) + 1, loy(2) - min_y(1) + 1 @@ -413,14 +413,14 @@ CONTAINS DO j = 0, pw_grid%para%group%num_pe_cart(2) - 1 cart_pos = [i, j] CALL pw_grid%para%group%rank_cart(cart_pos, dest) - IF (dest*local_z_dim .LE. m2) THEN - IF ((dest + 1)*local_z_dim .LE. m2) THEN + IF (dest*local_z_dim <= m2) THEN + IF ((dest + 1)*local_z_dim <= m2) THEN loz = local_z_dim ELSE loz = MOD(m2, local_z_dim) END IF ii = 1 - IF (lb(3) + (dest*local_z_dim) .LE. ub(3)) THEN + IF (lb(3) + (dest*local_z_dim) <= ub(3)) THEN DO m = lb(1), ub(1) DO l = lb(2), ub(2) DO k = lb(3) + (dest*local_z_dim), lb(3) + (dest*local_z_dim) + loz - 1 diff --git a/src/pw/ps_wavelet_scaling_function.F b/src/pw/ps_wavelet_scaling_function.F index c468fb68e9..b7b970827b 100644 --- a/src/pw/ps_wavelet_scaling_function.F +++ b/src/pw/ps_wavelet_scaling_function.F @@ -67,7 +67,7 @@ CONTAINS CALL back_trans(nd, nt, x, y, m, ch, cg) CALL dcopy(nt, y, 1, x, 1) - IF (nt .EQ. nd) THEN + IF (nt == nd) THEN EXIT loop1 END IF END DO loop1 @@ -122,7 +122,7 @@ CONTAINS !WRITE(*,*) 'nd,nt',nd,nt CALL back_trans(nd, nt, x, y, m, ch, cg) CALL dcopy(nd, y, 1, x, 1) - IF (nt .EQ. nd) THEN + IF (nt == nd) THEN EXIT loop3 END IF END DO loop3 @@ -212,11 +212,11 @@ CONTAINS ! periodically wrap index if necessary ind = j + 2*i loop99: DO - IF (ind .LT. 0) THEN + IF (ind < 0) THEN ind = ind + nt CYCLE loop99 END IF - IF (ind .GE. nt) THEN + IF (ind >= nt) THEN ind = ind - nt CYCLE loop99 END IF @@ -266,11 +266,11 @@ CONTAINS ! periodically wrap index if necessary ind = i - j loop99: DO - IF (ind .LT. 0) THEN + IF (ind < 0) THEN ind = ind + nt/2 CYCLE loop99 END IF - IF (ind .GE. nt/2) THEN + IF (ind >= nt/2) THEN ind = ind - nt/2 CYCLE loop99 END IF @@ -313,8 +313,8 @@ CONTAINS t3 = 0._dp t4 = 0._dp DO l = -3*m, 3*m - IF (l - 2*i .GE. -m .AND. l - 2*i .LE. m .AND. & - l - 2*j .GE. -m .AND. l - 2*j .LE. m) THEN + IF (l - 2*i >= -m .AND. l - 2*i <= m .AND. & + l - 2*j >= -m .AND. l - 2*j <= m) THEN t1 = t1 + ch(l - 2*i)*cht(l - 2*j) t2 = t2 + cg(l - 2*i)*cgt(l - 2*j) t3 = t3 + ch(l - 2*i)*cgt(l - 2*j) @@ -322,14 +322,14 @@ CONTAINS END IF END DO eps = 1.e-10_dp - IF (i .EQ. j) THEN - IF (ABS(t1 - 1._dp) .GT. eps .OR. ABS(t2 - 1._dp) .GT. eps .OR. & - ABS(t3) .GT. eps .OR. ABS(t4) .GT. eps) THEN + IF (i == j) THEN + IF (ABS(t1 - 1._dp) > eps .OR. ABS(t2 - 1._dp) > eps .OR. & + ABS(t3) > eps .OR. ABS(t4) > eps) THEN WRITE (*, fmt22) 'Orthogonality ERROR', i, j, t1, t2, t3, t4 END IF ELSE - IF (ABS(t1) .GT. eps .OR. ABS(t2) .GT. eps .OR. & - ABS(t3) .GT. eps .OR. ABS(t4) .GT. eps) THEN + IF (ABS(t1) > eps .OR. ABS(t2) > eps .OR. & + ABS(t3) > eps .OR. ABS(t4) > eps) THEN WRITE (*, fmt22) 'Orthogonality ERROR', i, j, t1, t2, t3, t4 END IF END IF diff --git a/src/pw/ps_wavelet_util.F b/src/pw/ps_wavelet_util.F index ea970ef4a9..318f3dab2b 100644 --- a/src/pw/ps_wavelet_util.F +++ b/src/pw/ps_wavelet_util.F @@ -280,7 +280,7 @@ CONTAINS md1 = n1 md2 = n2 md3 = n3 - DO WHILE (nproc*(md2/nproc) .LT. n2) + DO WHILE (nproc*(md2/nproc) < n2) md2 = md2 + 1 END DO @@ -289,7 +289,7 @@ CONTAINS nd1 = n1/2 + 1 nd2 = n2/2 + 1 nd3 = n3/2 + 1 - DO WHILE (MODULO(nd3, nproc) .NE. 0) + DO WHILE (MODULO(nd3, nproc) /= 0) nd3 = nd3 + 1 END DO @@ -380,7 +380,7 @@ CONTAINS md1 = n1 md2 = n2 md3 = n3/2 - DO WHILE (nproc*(md2/nproc) .LT. n2) + DO WHILE (nproc*(md2/nproc) < n2) md2 = md2 + 1 END DO @@ -392,7 +392,7 @@ CONTAINS nd2 = n2/2 + 1 nd3 = n3/2 + 1 - DO WHILE (MODULO(nd3, nproc) .NE. 0) + DO WHILE (MODULO(nd3, nproc) /= 0) nd3 = nd3 + 1 END DO CALL timestop(handle) @@ -482,7 +482,7 @@ CONTAINS md1 = n1/2 md2 = n2/2 md3 = n3/2 - DO WHILE (nproc*(md2/nproc) .LT. n2/2) + DO WHILE (nproc*(md2/nproc) < n2/2) md2 = md2 + 1 END DO @@ -492,7 +492,7 @@ CONTAINS nd2 = n2/2 + 1 nd3 = n3/2 + 1 - DO WHILE (MODULO(nd3, nproc) .NE. 0) + DO WHILE (MODULO(nd3, nproc) /= 0) nd3 = nd3 + 1 END DO @@ -526,7 +526,7 @@ CONTAINS CALL timeset(routineN, handle) - IF (nxc .GE. 1) THEN + IF (nxc >= 1) THEN DO jp2 = 1, nxc DO j3 = 1, m3 DO j1 = 1, m1 diff --git a/src/pw/pw_grid_info.F b/src/pw/pw_grid_info.F index 2120459cec..f05352ca41 100644 --- a/src/pw/pw_grid_info.F +++ b/src/pw/pw_grid_info.F @@ -166,7 +166,7 @@ CONTAINS ! final check if all went fine ... IF (my_ncommensurate > 0) THEN DO my_icommensurate = 1, my_ncommensurate - ftest = ANY(MODULO(n, 2**(my_ncommensurate - my_icommensurate)) .NE. 0) + ftest = ANY(MODULO(n, 2**(my_ncommensurate - my_icommensurate)) /= 0) CPASSERT(.NOT. ftest) END DO END IF diff --git a/src/pw/pw_grids.F b/src/pw/pw_grids.F index 080bac3404..9fbd65dccf 100644 --- a/src/pw/pw_grids.F +++ b/src/pw/pw_grids.F @@ -879,7 +879,7 @@ CONTAINS END IF END IF ! reset if the distribution can not be fulfilled - IF (PRODUCT(my_rs_dims) .NE. np) my_rs_dims = [0, 0] + IF (PRODUCT(my_rs_dims) /= np) my_rs_dims = [0, 0] ! reset if the distribution can not be dealt with [1,np] IF (ALL(my_rs_dims == [1, np])) my_rs_dims = [0, 0] @@ -1151,7 +1151,7 @@ CONTAINS ! pos_of_x(i) tells on which cpu pw%array(i,:,:) is located ! should be computable in principle, without the need for communication - IF (pw_grid%para%mode .EQ. PW_MODE_DISTRIBUTED) THEN + IF (pw_grid%para%mode == PW_MODE_DISTRIBUTED) THEN ALLOCATE (pw_grid%para%pos_of_x(pw_grid%bounds(1, 1):pw_grid%bounds(2, 1))) pw_grid%para%pos_of_x = 0 pw_grid%para%pos_of_x(pw_grid%bounds_local(1, 1):pw_grid%bounds_local(2, 1)) = pw_grid%para%group%mepos diff --git a/src/pw/pw_poisson_types.F b/src/pw/pw_poisson_types.F index f8300b5a28..a73a3df6c8 100644 --- a/src/pw/pw_poisson_types.F +++ b/src/pw/pw_poisson_types.F @@ -294,8 +294,8 @@ CONTAINS special_dimension=green%special_dimension, slab_size=green%slab_size, & super_ref_pw_grid=mt_super_ref_pw_grid) CASE (PS_IMPLICIT) - IF ((poisson_params%ps_implicit_params%boundary_condition .EQ. MIXED_BC) .OR. & - (poisson_params%ps_implicit_params%boundary_condition .EQ. NEUMANN_BC)) THEN + IF ((poisson_params%ps_implicit_params%boundary_condition == MIXED_BC) .OR. & + (poisson_params%ps_implicit_params%boundary_condition == NEUMANN_BC)) THEN CALL pw_pool_create(pw_pool_xpndd, pw_grid=dct_pw_grid) NULLIFY (green%dct_influence_fn) ALLOCATE (green%dct_influence_fn) diff --git a/src/pw/realspace_grid_cube.F b/src/pw/realspace_grid_cube.F index 3403f4d250..eb3768fdbe 100644 --- a/src/pw/realspace_grid_cube.F +++ b/src/pw/realspace_grid_cube.F @@ -162,7 +162,7 @@ CONTAINS DO I2 = L2, U2, my_stride(2) ! cycling through the CPUs, check if the current ray (I1,I2) is local to that CPU - IF (pw%pw_grid%para%mode .NE. PW_MODE_LOCAL) THEN + IF (pw%pw_grid%para%mode /= PW_MODE_LOCAL) THEN DO ip = 0, num_pe - 1 IF (pw%pw_grid%para%bo(1, 1, ip, 1) <= I1 - L1 + 1 .AND. pw%pw_grid%para%bo(2, 1, ip, 1) >= I1 - L1 + 1 .AND. & pw%pw_grid%para%bo(1, 2, ip, 1) <= I2 - L2 + 1 .AND. pw%pw_grid%para%bo(2, 2, ip, 1) >= I2 - L2 + 1) THEN @@ -320,14 +320,14 @@ CONTAINS !master sends all data to everyone DO i = lbounds(1), ubounds(1) DO j = lbounds(2), ubounds(2) - IF (my_rank .EQ. 0) THEN + IF (my_rank == 0) THEN READ (extunit, *) (buffer(k), k=lbounds(3), ubounds(3)) END IF CALL gid%bcast(buffer(lbounds(3):ubounds(3)), 0) !only use data that is local to me - i.e. in slice of pencil I own - IF ((lbounds_local(1) .LE. i) .AND. (i .LE. ubounds_local(1)) .AND. (lbounds_local(2) .LE. j) & - .AND. (j .LE. ubounds_local(2))) THEN + 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) grid%array(i, j, lbounds(3):ubounds(3)) = buffer(lbounds(3):ubounds(3))*scaling END IF @@ -465,14 +465,14 @@ CONTAINS displacements = 0 DO i = lbounds(1), ubounds(1) should_read(:) = .TRUE. - IF (i .LT. lbounds_local(1)) THEN + IF (i < lbounds_local(1)) THEN should_read(1) = .FALSE. - ELSE IF (i .GT. ubounds_local(1)) THEN + ELSE IF (i > ubounds_local(1)) THEN EXIT END IF DO j = lbounds(2), ubounds(2) should_read(2) = .TRUE. - IF (j .LT. lbounds_local(2) .OR. j .GT. ubounds_local(2)) THEN + IF (j < lbounds_local(2) .OR. j > ubounds_local(2)) THEN should_read(2) = .FALSE. END IF IF (ALL(should_read .EQV. .TRUE.)) THEN @@ -582,14 +582,14 @@ CONTAINS !master sends all data to everyone DO i = lbounds(1), ubounds(1) DO j = lbounds(2), ubounds(2) - IF (my_rank .EQ. 0) THEN + IF (my_rank == 0) THEN READ (extunit_handle, *) (buffer(k), k=lbounds(3), ubounds(3)) END IF CALL gid%bcast(buffer(lbounds(3):ubounds(3)), 0) !only use data that is local to me - i.e. in slice of pencil I own - IF ((lbounds_local(1) .LE. i) .AND. (i .LE. ubounds_local(1)) .AND. (lbounds_local(2) .LE. j) & - .AND. (j .LE. ubounds_local(2))) THEN + 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)) & CALL cp_abort(__LOCATION__, & @@ -667,14 +667,14 @@ CONTAINS islice = 1 DO i = lbounds(1), ubounds(1), stride(1) should_write(:) = .TRUE. - IF (i .LT. lbounds_local(1)) THEN + IF (i < lbounds_local(1)) THEN should_write(1) = .FALSE. - ELSE IF (i .GT. ubounds_local(1)) THEN + ELSE IF (i > ubounds_local(1)) THEN EXIT END IF DO j = lbounds(2), ubounds(2), stride(2) should_write(2) = .TRUE. - IF (j .LT. lbounds_local(2) .OR. j .GT. ubounds_local(2)) THEN + IF (j < lbounds_local(2) .OR. j > ubounds_local(2)) THEN should_write(2) = .FALSE. END IF IF (ALL(should_write .EQV. .TRUE.)) THEN @@ -752,14 +752,14 @@ CONTAINS writebuffer(:) = '' DO i = lbounds(1), ubounds(1), stride(1) should_write(:) = .TRUE. - IF (i .LT. lbounds_local(1)) THEN + IF (i < lbounds_local(1)) THEN should_write(1) = .FALSE. - ELSE IF (i .GT. ubounds_local(1)) THEN + ELSE IF (i > ubounds_local(1)) THEN EXIT END IF DO j = lbounds(2), ubounds(2), stride(2) should_write(2) = .TRUE. - IF (j .LT. lbounds_local(2) .OR. j .GT. ubounds_local(2)) THEN + IF (j < lbounds_local(2) .OR. j > ubounds_local(2)) THEN should_write(2) = .FALSE. END IF IF (ALL(should_write .EQV. .TRUE.)) THEN @@ -895,7 +895,7 @@ CONTAINS DO I2 = L2, U2, my_stride(2) ! cycling through the CPUs, check if the current ray (I1,I2) is local to that CPU - IF (pw%pw_grid%para%mode .NE. PW_MODE_LOCAL) THEN + IF (pw%pw_grid%para%mode /= PW_MODE_LOCAL) THEN DO ip = 0, num_pe - 1 IF (pw%pw_grid%para%bo(1, 1, ip, 1) <= I1 - L1 + 1 .AND. pw%pw_grid%para%bo(2, 1, ip, 1) >= I1 - L1 + 1 .AND. & pw%pw_grid%para%bo(1, 2, ip, 1) <= I2 - L2 + 1 .AND. pw%pw_grid%para%bo(2, 2, ip, 1) >= I2 - L2 + 1) THEN diff --git a/src/pw/realspace_grid_types.F b/src/pw/realspace_grid_types.F index f3f67c599c..b14ca1e20b 100644 --- a/src/pw/realspace_grid_types.F +++ b/src/pw/realspace_grid_types.F @@ -292,7 +292,7 @@ CONTAINS n_slices_tmp = [i, j, k] ! we don't match the actual number of CPUs - IF (PRODUCT(n_slices_tmp) .NE. desc%group_size) CYCLE + IF (PRODUCT(n_slices_tmp) /= desc%group_size) CYCLE ! we see if there has been a input constraint ! i.e. if the layout is not -1 we need to fullfil it @@ -409,7 +409,7 @@ CONTAINS desc%lb_global(:, i) = desc%lb desc%ub_global(:, i) = desc%ub DO dir = 1, 3 - IF (desc%group_dim(dir) .GT. 1) THEN + IF (desc%group_dim(dir) > 1) THEN lb = get_limit(desc%npts(dir), desc%group_dim(dir), desc%rank2coord(dir, i)) desc%lb_global(dir, i) = lb(1) + desc%lb(dir) - 1 desc%ub_global(dir, i) = lb(2) + desc%lb(dir) - 1 @@ -420,7 +420,7 @@ CONTAINS ! map a grid point to a CPU coord DO dir = 1, 3 DO l = 0, desc%group_dim(dir) - 1 - IF (desc%group_dim(dir) .GT. 1) THEN + IF (desc%group_dim(dir) > 1) THEN lb = get_limit(desc%npts(dir), desc%group_dim(dir), l) lb = lb + desc%lb(dir) - 1 ELSE @@ -670,7 +670,7 @@ CONTAINS IF (rs%desc%border == 0) THEN CALL dcopy(SIZE(rs%r), rs%r, 1, pw%array, 1) ELSE - CPASSERT(LBOUND(pw%array, 3) .EQ. rs%lb_real(3)) + CPASSERT(LBOUND(pw%array, 3) == rs%lb_real(3)) !$OMP PARALLEL DO DEFAULT(NONE) SHARED(pw,rs) DO i = rs%lb_real(3), rs%ub_real(3) pw%array(:, :, i) = rs%r(rs%lb_real(1):rs%ub_real(1), & @@ -805,7 +805,7 @@ CONTAINS END DO END DO END DO - IF (ip .EQ. np) EXIT + IF (ip == np) EXIT CALL group%sendrecv(sendbuf, dest, recvbuf, source, 13) CALL MOVE_ALLOC(sendbuf, swaparray) CALL MOVE_ALLOC(recvbuf, sendbuf) @@ -860,7 +860,7 @@ CONTAINS DO ip = 0, np - 1 ! we must shift the buffer only np-1 times around - IF (ip .NE. np - 1) THEN + IF (ip /= np - 1) THEN CALL group%isendrecv(sendbuf, dest, recvbuf, source, & req(1), req(2), 13) END IF @@ -877,7 +877,7 @@ CONTAINS END DO END DO END DO - IF (ip .NE. np - 1) THEN + IF (ip /= np - 1) THEN CALL mp_waitall(req) END IF CALL MOVE_ALLOC(sendbuf, swaparray) @@ -985,7 +985,7 @@ CONTAINS DO idir = 3, 1, -1 - IF (rs%desc%perd(idir) .NE. 1) THEN + IF (rs%desc%perd(idir) /= 1) THEN ALLOCATE (dshifts(0:rs%desc%neighbours(idir))) ALLOCATE (ushifts(0:rs%desc%neighbours(idir))) @@ -1017,7 +1017,7 @@ CONTAINS ub_recv_down(:) = rs%ub_local(:) ub_send_down(:) = rs%ub_local(:) - IF (dshifts(n_shifts - 1) .LE. rs%desc%border) THEN + IF (dshifts(n_shifts - 1) <= rs%desc%border) THEN ub_send_down(idir) = lb_send_down(idir) + rs%desc%border - 1 - dshifts(n_shifts - 1) lb_send_down(idir) = MAX(lb_send_down(idir), & lb_send_down(idir) + rs%desc%border - dshifts(n_shifts)) @@ -1076,7 +1076,7 @@ CONTAINS ub_recv_up(:) = rs%ub_local(:) ub_send_up(:) = rs%ub_local(:) - IF (ushifts(n_shifts - 1) .LE. rs%desc%border) THEN + IF (ushifts(n_shifts - 1) <= rs%desc%border) THEN lb_send_up(idir) = ub_send_up(idir) - rs%desc%border + 1 + ushifts(n_shifts - 1) ub_send_up(idir) = MIN(ub_send_up(idir), & @@ -1134,10 +1134,10 @@ CONTAINS CALL mp_waitany(req(1:2), completed) - IF (completed .EQ. 1) THEN + IF (completed == 1) THEN ! only some procs may need later shifts - IF (ub_recv_down(idir) .GE. lb_recv_down(idir)) THEN + IF (ub_recv_down(idir) >= lb_recv_down(idir)) THEN ! Sum the data in the RS Grid !$OMP PARALLEL DEFAULT(NONE), & !$OMP PRIVATE(lb,ub,my_id,NUM_THREADS), & @@ -1160,7 +1160,7 @@ CONTAINS ELSE ! only some procs may need later shifts - IF (ub_recv_up(idir) .GE. lb_recv_up(idir)) THEN + IF (ub_recv_up(idir) >= lb_recv_up(idir)) THEN ! Sum the data in the RS Grid !$OMP PARALLEL DEFAULT(NONE), & !$OMP PRIVATE(lb,ub,my_id,NUM_THREADS), & @@ -1251,10 +1251,10 @@ CONTAINS ub_send(idir) = pos(2) END DO - IF (lb_send(1) .GT. bounds(my_rs_rank, 2)) CYCLE - IF (ub_send(1) .LT. bounds(my_rs_rank, 1)) CYCLE - IF (lb_send(2) .GT. bounds(my_rs_rank, 4)) CYCLE - IF (ub_send(2) .LT. bounds(my_rs_rank, 3)) CYCLE + IF (lb_send(1) > bounds(my_rs_rank, 2)) CYCLE + IF (ub_send(1) < bounds(my_rs_rank, 1)) CYCLE + IF (lb_send(2) > bounds(my_rs_rank, 4)) CYCLE + IF (ub_send(2) < bounds(my_rs_rank, 3)) CYCLE recv_tasks(i, 1) = MAX(lb_send(1), bounds(my_rs_rank, 1)) recv_tasks(i, 2) = MIN(ub_send(1), bounds(my_rs_rank, 2)) @@ -1282,10 +1282,10 @@ CONTAINS !$OMP SHARED(pw,lb_send,ub_send,bounds,send_tasks,send_sizes) DO j = 0, pw%pw_grid%para%group%num_pe - 1 - IF (lb_send(1) .GT. bounds(j, 2)) CYCLE - IF (ub_send(1) .LT. bounds(j, 1)) CYCLE - IF (lb_send(2) .GT. bounds(j, 4)) CYCLE - IF (ub_send(2) .LT. bounds(j, 3)) CYCLE + IF (lb_send(1) > bounds(j, 2)) CYCLE + IF (ub_send(1) < bounds(j, 1)) CYCLE + IF (lb_send(2) > bounds(j, 4)) CYCLE + IF (ub_send(2) < bounds(j, 3)) CYCLE send_tasks(j, 1) = MAX(lb_send(1), bounds(j, 1)) send_tasks(j, 2) = MIN(ub_send(1), bounds(j, 2)) @@ -1312,12 +1312,12 @@ CONTAINS ALLOCATE (recv_bufs(0:rs%desc%group_size - 1)) DO i = 0, rs%desc%group_size - 1 - IF (send_sizes(i) .NE. 0) THEN + IF (send_sizes(i) /= 0) THEN ALLOCATE (send_bufs(i)%array(send_sizes(i))) ELSE NULLIFY (send_bufs(i)%array) END IF - IF (recv_sizes(i) .NE. 0) THEN + IF (recv_sizes(i) /= 0) THEN ALLOCATE (recv_bufs(i)%array(recv_sizes(i))) ELSE NULLIFY (recv_bufs(i)%array) @@ -1328,7 +1328,7 @@ CONTAINS recv_reqs = mp_request_null DO i = 0, rs%desc%group_size - 1 - IF (recv_sizes(i) .NE. 0) THEN + IF (recv_sizes(i) /= 0) THEN CALL rs%desc%group%irecv(recv_bufs(i)%array, i, recv_reqs(i)) END IF END DO @@ -1354,7 +1354,7 @@ CONTAINS send_reqs = mp_request_null DO i = 0, rs%desc%group_size - 1 - IF (send_sizes(i) .NE. 0) THEN + IF (send_sizes(i) /= 0) THEN CALL rs%desc%group%isend(send_bufs(i)%array, i, send_reqs(i)) END IF END DO @@ -1362,7 +1362,7 @@ CONTAINS ! do unpacking ! no OMP here so we can unpack each message as it arrives DO i = 0, rs%desc%group_size - 1 - IF (recv_sizes(i) .EQ. 0) CYCLE + IF (recv_sizes(i) == 0) CYCLE CALL mp_waitany(recv_reqs, completed) k = 0 @@ -1521,10 +1521,10 @@ CONTAINS ub_send(idir) = pos(2) END DO - IF (ub_send(1) .LT. bounds(my_rs_rank, 1)) CYCLE - IF (lb_send(1) .GT. bounds(my_rs_rank, 2)) CYCLE - IF (ub_send(2) .LT. bounds(my_rs_rank, 3)) CYCLE - IF (lb_send(2) .GT. bounds(my_rs_rank, 4)) CYCLE + IF (ub_send(1) < bounds(my_rs_rank, 1)) CYCLE + IF (lb_send(1) > bounds(my_rs_rank, 2)) CYCLE + IF (ub_send(2) < bounds(my_rs_rank, 3)) CYCLE + IF (lb_send(2) > bounds(my_rs_rank, 4)) CYCLE send_tasks(i, 1) = MAX(lb_send(1), bounds(my_rs_rank, 1)) send_tasks(i, 2) = MIN(ub_send(1), bounds(my_rs_rank, 2)) @@ -1553,10 +1553,10 @@ CONTAINS !$OMP SHARED(pw,lb_send,ub_send,bounds,recv_tasks,recv_sizes) DO j = 0, pw%pw_grid%para%group%num_pe - 1 - IF (ub_send(1) .LT. bounds(j, 1)) CYCLE - IF (lb_send(1) .GT. bounds(j, 2)) CYCLE - IF (ub_send(2) .LT. bounds(j, 3)) CYCLE - IF (lb_send(2) .GT. bounds(j, 4)) CYCLE + IF (ub_send(1) < bounds(j, 1)) CYCLE + IF (lb_send(1) > bounds(j, 2)) CYCLE + IF (ub_send(2) < bounds(j, 3)) CYCLE + IF (lb_send(2) > bounds(j, 4)) CYCLE recv_tasks(j, 1) = MAX(lb_send(1), bounds(j, 1)) recv_tasks(j, 2) = MIN(ub_send(1), bounds(j, 2)) @@ -1583,12 +1583,12 @@ CONTAINS ALLOCATE (recv_bufs(0:rs%desc%group_size - 1)) DO i = 0, rs%desc%group_size - 1 - IF (send_sizes(i) .NE. 0) THEN + IF (send_sizes(i) /= 0) THEN ALLOCATE (send_bufs(i)%array(send_sizes(i))) ELSE NULLIFY (send_bufs(i)%array) END IF - IF (recv_sizes(i) .NE. 0) THEN + IF (recv_sizes(i) /= 0) THEN ALLOCATE (recv_bufs(i)%array(recv_sizes(i))) ELSE NULLIFY (recv_bufs(i)%array) @@ -1599,7 +1599,7 @@ CONTAINS recv_reqs = mp_request_null DO i = 0, rs%desc%group_size - 1 - IF (recv_sizes(i) .NE. 0) THEN + IF (recv_sizes(i) /= 0) THEN CALL rs%desc%group%irecv(recv_bufs(i)%array, i, recv_reqs(i)) END IF END DO @@ -1625,7 +1625,7 @@ CONTAINS send_reqs = mp_request_null DO i = 0, rs%desc%group_size - 1 - IF (send_sizes(i) .NE. 0) THEN + IF (send_sizes(i) /= 0) THEN CALL rs%desc%group%isend(send_bufs(i)%array, i, send_reqs(i)) END IF END DO @@ -1634,7 +1634,7 @@ CONTAINS ! no OMP here so we can unpack each message as it arrives DO i = 0, rs%desc%group_size - 1 - IF (recv_sizes(i) .EQ. 0) CYCLE + IF (recv_sizes(i) == 0) CYCLE CALL mp_waitany(recv_reqs, completed) k = 0 @@ -1707,7 +1707,7 @@ CONTAINS lb_recv_down(:) = rs%lb_local(:) ub_recv_down(:) = rs%ub_local(:) - IF (dshifts(n_shifts - 1) .LE. rs%desc%border) THEN + IF (dshifts(n_shifts - 1) <= rs%desc%border) THEN lb_send_down(idir) = lb_send_down(idir) + rs%desc%border ub_send_down(idir) = MIN(ub_send_down(idir) - rs%desc%border, & lb_send_down(idir) + rs%desc%border - 1 - dshifts(n_shifts - 1)) @@ -1723,7 +1723,7 @@ CONTAINS END IF DO i = 1, 3 - IF (.NOT. (halo_swapped(i) .OR. i .EQ. idir)) THEN + IF (.NOT. (halo_swapped(i) .OR. i == idir)) THEN lb_send_down(i) = rs%lb_real(i) ub_send_down(i) = rs%ub_real(i) lb_recv_down(i) = rs%lb_real(i) @@ -1770,7 +1770,7 @@ CONTAINS lb_recv_up(:) = rs%lb_local(:) ub_recv_up(:) = rs%ub_local(:) - IF (ushifts(n_shifts - 1) .LE. rs%desc%border) THEN + IF (ushifts(n_shifts - 1) <= rs%desc%border) THEN ub_send_up(idir) = ub_send_up(idir) - rs%desc%border lb_send_up(idir) = MAX(lb_send_up(idir) + rs%desc%border, & ub_send_up(idir) - rs%desc%border + 1 + ushifts(n_shifts - 1)) @@ -1786,7 +1786,7 @@ CONTAINS END IF DO i = 1, 3 - IF (.NOT. (halo_swapped(i) .OR. i .EQ. idir)) THEN + IF (.NOT. (halo_swapped(i) .OR. i == idir)) THEN lb_send_up(i) = rs%lb_real(i) ub_send_up(i) = rs%ub_real(i) lb_recv_up(i) = rs%lb_real(i) @@ -1831,10 +1831,10 @@ CONTAINS CALL mp_waitany(req(1:2), completed) - IF (completed .EQ. 1) THEN + IF (completed == 1) THEN ! only some procs may need later shifts - IF (ub_recv_down(idir) .GE. lb_recv_down(idir)) THEN + IF (ub_recv_down(idir) >= lb_recv_down(idir)) THEN ! Add the data to the RS Grid !$OMP PARALLEL DEFAULT(NONE), & @@ -1856,7 +1856,7 @@ CONTAINS ELSE ! only some procs may need later shifts - IF (ub_recv_up(idir) .GE. lb_recv_up(idir)) THEN + IF (ub_recv_up(idir) >= lb_recv_up(idir)) THEN ! Add the data to the RS Grid !$OMP PARALLEL DEFAULT(NONE), & @@ -1949,7 +1949,7 @@ CONTAINS !-----------------------------------------------------------------------------! CALL timeset(routineN, handle) - IF (scalar .NE. 0.0_dp) THEN + IF (scalar /= 0.0_dp) THEN l(1) = LBOUND(rs1%r, 1); l(2) = LBOUND(rs1%r, 2); l(3) = LBOUND(rs1%r, 3) u(1) = UBOUND(rs1%r, 1); u(2) = UBOUND(rs1%r, 2); u(3) = UBOUND(rs1%r, 3) !$OMP PARALLEL DO DEFAULT(NONE) COLLAPSE(3) & @@ -2155,7 +2155,7 @@ CONTAINS ! bounds of local grid (i.e. removing the 'wings'), if periodic tp(dir) = FLOOR(DOT_PRODUCT(h_inv(dir, :), ra)*rs_grid%desc%npts(dir)) tp(dir) = MODULO(tp(dir), rs_grid%desc%npts(dir)) - IF (rs_grid%desc%perd(dir) .NE. 1) THEN + IF (rs_grid%desc%perd(dir) /= 1) THEN lb(dir) = rs_grid%lb_local(dir) + rs_grid%desc%border ub(dir) = rs_grid%ub_local(dir) - rs_grid%desc%border ELSE diff --git a/src/pw/rs_methods.F b/src/pw/rs_methods.F index f53f713627..3f5bebedb1 100644 --- a/src/pw/rs_methods.F +++ b/src/pw/rs_methods.F @@ -318,17 +318,17 @@ CONTAINS z_glbl(:) = gindz*dr(3) ! map [0 .. (npts_local-1)] --> [lb .. ub] - IF (lb1 .EQ. ub1) THEN + IF (lb1 == ub1) THEN lindx(:) = lb1 ELSE lindx(:) = lindx(:)*((ub1 - lb1)/(npts_local(1) - 1)) + lb1 END IF - IF (lb2 .EQ. ub2) THEN + IF (lb2 == ub2) THEN lindy(:) = lb2 ELSE lindy(:) = lindy(:)*((ub2 - lb2)/(npts_local(2) - 1)) + lb2 END IF - IF (lb3 .EQ. ub3) THEN + IF (lb3 == ub3) THEN lindz(:) = lb3 ELSE lindz(:) = lindz(:)*((ub3 - lb3)/(npts_local(3) - 1)) + lb3 @@ -407,21 +407,21 @@ CONTAINS DO j = lb2, ub2 DO i = lb1, ub1 xi = x_glbl(i); yj = y_glbl(j); zk = z_glbl(k) - IF (norm2([(xi - xmin), (yj - ymin), (zk - zmin)]) .LT. zeta - small_value) THEN + IF (norm2([(xi - xmin), (yj - ymin), (zk - zmin)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmin), (yj - ymin), (zk - zmin)]/zeta)**2 - 1)) - ELSE IF (norm2([(xi - xmax), (yj - ymax), (zk - zmax)]) .LT. zeta - small_value) THEN + ELSE IF (norm2([(xi - xmax), (yj - ymax), (zk - zmax)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmax), (yj - ymax), (zk - zmax)]/zeta)**2 - 1)) - ELSE IF (norm2([(xi - xmin), (yj - ymax), (zk - zmax)]) .LT. zeta - small_value) THEN + ELSE IF (norm2([(xi - xmin), (yj - ymax), (zk - zmax)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmin), (yj - ymax), (zk - zmax)]/zeta)**2 - 1)) - ELSE IF (norm2([(xi - xmax), (yj - ymin), (zk - zmax)]) .LT. zeta - small_value) THEN + ELSE IF (norm2([(xi - xmax), (yj - ymin), (zk - zmax)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmax), (yj - ymin), (zk - zmax)]/zeta)**2 - 1)) - ELSE IF (norm2([(xi - xmax), (yj - ymax), (zk - zmin)]) .LT. zeta - small_value) THEN + ELSE IF (norm2([(xi - xmax), (yj - ymax), (zk - zmin)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmax), (yj - ymax), (zk - zmin)]/zeta)**2 - 1)) - ELSE IF (norm2([(xi - xmin), (yj - ymin), (zk - zmax)]) .LT. zeta - small_value) THEN + ELSE IF (norm2([(xi - xmin), (yj - ymin), (zk - zmax)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmin), (yj - ymin), (zk - zmax)]/zeta)**2 - 1)) - ELSE IF (norm2([(xi - xmin), (yj - ymax), (zk - zmin)]) .LT. zeta - small_value) THEN + ELSE IF (norm2([(xi - xmin), (yj - ymax), (zk - zmin)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmin), (yj - ymax), (zk - zmin)]/zeta)**2 - 1)) - ELSE IF (norm2([(xi - xmax), (yj - ymin), (zk - zmin)]) .LT. zeta - small_value) THEN + ELSE IF (norm2([(xi - xmax), (yj - ymin), (zk - zmin)]) < zeta - small_value) THEN G%array(i, j, k) = EXP(1.0_dp/(norm2([(xi - xmax), (yj - ymin), (zk - zmin)]/zeta)**2 - 1)) END IF END DO @@ -444,7 +444,7 @@ CONTAINS DO k = lb3, ub3 DO j = lb2, ub2 DO i = lb1, ub1 - IF (ABS(pw_out%array(i, j, k)) .LE. 1.0E-10_dp) pw_out%array(i, j, k) = 0.0_dp + IF (ABS(pw_out%array(i, j, k)) <= 1.0E-10_dp) pw_out%array(i, j, k) = 0.0_dp END DO END DO END DO diff --git a/src/pw_env/gaussian_gridlevels.F b/src/pw_env/gaussian_gridlevels.F index 29d675e131..b4f048992f 100644 --- a/src/pw_env/gaussian_gridlevels.F +++ b/src/pw_env/gaussian_gridlevels.F @@ -155,7 +155,7 @@ CONTAINS gridlevel = 1 needed_cutoff = ABS(exponent)*gridlevel_info%rel_cutoff DO i = 1, gridlevel_info%ngrid_levels - IF ((gridlevel_info%cutoff(i) + 1E-6_dp) .GE. needed_cutoff) THEN + IF ((gridlevel_info%cutoff(i) + 1E-6_dp) >= needed_cutoff) THEN gridlevel = i END IF END DO diff --git a/src/pw_env_methods.F b/src/pw_env_methods.F index 3f004e97db..6c58f4e45d 100644 --- a/src/pw_env_methods.F +++ b/src/pw_env_methods.F @@ -521,24 +521,24 @@ CONTAINS dct_pw_grid=dct_pw_grid, use_level=pw_env%auxbas_grid) END IF - IF ((poisson_params%ps_implicit_params%boundary_condition .EQ. MIXED_PERIODIC_BC) .OR. & - (poisson_params%ps_implicit_params%boundary_condition .EQ. MIXED_BC)) THEN + IF ((poisson_params%ps_implicit_params%boundary_condition == MIXED_PERIODIC_BC) .OR. & + (poisson_params%ps_implicit_params%boundary_condition == MIXED_BC)) THEN pw_env%poisson_env%parameters%dbc_params%do_dbc_cube = & BTEST(cp_print_key_should_output(logger%iter_info, input, & "DFT%PRINT%IMPLICIT_PSOLVER%DIRICHLET_BC_CUBE"), cp_p_file) END IF ! setup dct_pw_grid (an extended pw_grid) for Discrete Cosine Transformation (DCT) - IF ((poisson_params%ps_implicit_params%boundary_condition .EQ. NEUMANN_BC) .OR. & - (poisson_params%ps_implicit_params%boundary_condition .EQ. MIXED_BC)) THEN + IF ((poisson_params%ps_implicit_params%boundary_condition == NEUMANN_BC) .OR. & + (poisson_params%ps_implicit_params%boundary_condition == MIXED_BC)) THEN CALL setup_dct_pw_grids(pw_env%poisson_env%pw_pools(pw_env%poisson_env%pw_level)%pool%pw_grid, & my_cell%hmat, poisson_params%ps_implicit_params%neumann_directions, & pw_env%poisson_env%dct_pw_grid) END IF ! setup real space grid for finite difference derivatives of dielectric constant function IF (poisson_params%has_dielectric .AND. & - ((poisson_params%dielectric_params%derivative_method .EQ. derivative_cd3) .OR. & - (poisson_params%dielectric_params%derivative_method .EQ. derivative_cd5) .OR. & - (poisson_params%dielectric_params%derivative_method .EQ. derivative_cd7))) THEN + ((poisson_params%dielectric_params%derivative_method == derivative_cd3) .OR. & + (poisson_params%dielectric_params%derivative_method == derivative_cd5) .OR. & + (poisson_params%dielectric_params%derivative_method == derivative_cd7))) THEN SELECT CASE (poisson_params%ps_implicit_params%boundary_condition) CASE (NEUMANN_BC, MIXED_BC) @@ -652,7 +652,7 @@ CONTAINS WRITE (UNIT=iounit, FMT="(T2,A,T51,A30)") & "POISSON| Boundary Condition", "PERIODIC" CASE (NEUMANN_BC, MIXED_BC) - IF (boundary_condition .EQ. NEUMANN_BC) THEN + IF (boundary_condition == NEUMANN_BC) THEN WRITE (UNIT=iounit, FMT="(T2,A,T51,A30)") & "POISSON| Boundary Condition", "NEUMANN" ELSE @@ -694,7 +694,7 @@ CONTAINS "POISSON| Maximum number of iterations", poisson_params%ps_implicit_params%max_iter WRITE (UNIT=iounit, FMT="(T2,A,T51,ES30.2)") & "POISSON| Convergence threshold", poisson_params%ps_implicit_params%tol - IF (poisson_params%dielectric_params%dielec_functiontype .EQ. rho_dependent) THEN + IF (poisson_params%dielectric_params%dielec_functiontype == rho_dependent) THEN WRITE (UNIT=iounit, FMT="(T2,A,T51,F30.2)") & "POISSON| Dielectric Constant", poisson_params%dielectric_params%eps0 ELSE @@ -846,7 +846,7 @@ CONTAINS IF (ASSOCIATED(cneo_potential)) CYCLE CALL get_qs_kind(qs_kind_set(ikind), & alpha_core_charge=alpha, ccore_charge=core_charge) - IF (alpha > 0.0_dp .AND. core_charge .NE. 0.0_dp) THEN + IF (alpha > 0.0_dp .AND. core_charge /= 0.0_dp) THEN maxradius = MAX(maxradius, exp_radius(0, alpha, eps_rho, core_charge, rlow=maxradius)) ! forces maxradius = MAX(maxradius, exp_radius(1, alpha, eps_rho, core_charge, rlow=maxradius)) @@ -870,7 +870,7 @@ CONTAINS zetp = zeta(ipgf, iset) la = lshella(ishell, iset) lgrid_level = gaussian_gridlevel(pw_env%gridlevel_info, zetp) - IF (lgrid_level .EQ. igrid_level) THEN + IF (lgrid_level == igrid_level) THEN maxradius = MAX(maxradius, exp_radius(la, zetp, eps_rho, 1.0_dp, rlow=maxradius)) END IF END DO @@ -906,7 +906,7 @@ CONTAINS zetp = zeta(ipgf, iset) + zetb(jpgf, jset) lb = lshellb(jshell, jset) + la lgrid_level = gaussian_gridlevel(pw_env%gridlevel_info, zetp) - IF (lgrid_level .EQ. igrid_level) THEN + IF (lgrid_level == igrid_level) THEN ! density (scale is at most 2) maxradius = MAX(maxradius, exp_radius(lb, zetp, eps_rho, 2.0_dp, rlow=maxradius)) ! tau, properties? diff --git a/src/pw_poisson_read_input.F b/src/pw_poisson_read_input.F index 39ac5d41d3..05f1507ae1 100644 --- a/src/pw_poisson_read_input.F +++ b/src/pw_poisson_read_input.F @@ -243,7 +243,7 @@ CONTAINS CALL section_vals_get(aa_cuboidal_section, explicit=aa_cuboidal_explicit, n_repetition=n_aac_rep) CALL section_vals_get(xaa_annular_section, explicit=xaa_annular_explicit, n_repetition=n_xaaa_rep) - IF (params%solver .EQ. pw_poisson_implicit) THEN + IF (params%solver == pw_poisson_implicit) THEN IF (aa_cuboidal_explicit) THEN params%dielectric_params%n_aa_cuboidal = n_aac_rep @@ -340,7 +340,7 @@ CONTAINS CALL section_vals_get(aa_cylindrical_section, explicit=aa_cylindrical_explicit, n_repetition=n_aacyl_rep) CALL section_vals_get(aa_cuboidal_section, explicit=aa_cuboidal_explicit, n_repetition=n_aac_rep) - IF (params%solver .EQ. pw_poisson_implicit) THEN + IF (params%solver == pw_poisson_implicit) THEN IF (aa_planar_explicit) THEN params%dbc_params%n_aa_planar = n_aap_rep diff --git a/src/qmmm_elpot.F b/src/qmmm_elpot.F index a195c82540..7943a4ca4d 100644 --- a/src/qmmm_elpot.F +++ b/src/qmmm_elpot.F @@ -101,7 +101,7 @@ CONTAINS Loop_on_all_values: DO I = 2, SIZE(mm_el_pot_radius) Found = .FALSE. Loop_on_found_values: DO J = 1, SIZE(radius) - IF (mm_el_pot_radius(i) .EQ. radius(j)) THEN + IF (mm_el_pot_radius(i) == radius(j)) THEN Found = .TRUE. EXIT Loop_on_found_values END IF @@ -213,7 +213,7 @@ CONTAINS ALLOCATE (mm_atom_index(1)) ! Build mm_atom_index List DO J = 1, SIZE(mm_el_pot_radius) - IF (rc .EQ. mm_el_pot_radius(J)) THEN + IF (rc == mm_el_pot_radius(J)) THEN Ndim = SIZE(mm_atom_index) mm_atom_index(Ndim) = J CALL reallocate(mm_atom_index, 1, Ndim + 1) diff --git a/src/qmmm_gaussian_init.F b/src/qmmm_gaussian_init.F index 894bf39983..6fd722f57a 100644 --- a/src/qmmm_gaussian_init.F +++ b/src/qmmm_gaussian_init.F @@ -114,7 +114,7 @@ CONTAINS Loop_on_all_values: DO I = 1, SIZE(mm_el_pot_radius) Found = .FALSE. Loop_on_found_values: DO J = 1, SIZE(radius) - 1 - IF (mm_el_pot_radius(i) .EQ. radius(j)) THEN + IF (mm_el_pot_radius(i) == radius(j)) THEN Found = .TRUE. EXIT Loop_on_found_values END IF diff --git a/src/qmmm_gaussian_input.F b/src/qmmm_gaussian_input.F index 96c610a3ed..5b8a34d304 100644 --- a/src/qmmm_gaussian_input.F +++ b/src/qmmm_gaussian_input.F @@ -142,7 +142,7 @@ CONTAINS search_loop: DO Ftarget = "&MM_FIT_POT" - IF (Ival .EQ. Nval) EXIT search_loop + IF (Ival == Nval) EXIT search_loop CALL parser_search_string(parser, Ftarget, .TRUE., found, line) IF (Found) THEN ! @@ -166,11 +166,11 @@ CONTAINS CALL parser_get_object(parser, units) CALL uppercase(units) fconv = 1.0_dp - IF (TRIM(units) .EQ. "ANGSTROM") fconv = bohr + IF (TRIM(units) == "ANGSTROM") fconv = bohr Found_Radius = .FALSE. radius = radius*fconv Radius_Loop: DO J = 1, SIZE(qmmm_gaussian_fns) - IF (ABS(radius - qmmm_gaussian_fns(J)%pgf%Elp_Radius) .LT. EPSILON(0.0_dp)) THEN + IF (ABS(radius - qmmm_gaussian_fns(J)%pgf%Elp_Radius) < EPSILON(0.0_dp)) THEN Found_Radius = .TRUE. EXIT Radius_Loop END IF @@ -202,7 +202,7 @@ CONTAINS CALL parser_get_object(parser, units) CALL uppercase(units) fconv = 1.0_dp - IF (TRIM(units) .EQ. "ANGSTROM") fconv = bohr + IF (TRIM(units) == "ANGSTROM") fconv = bohr qmmm_gaussian_fns(IRad)%pgf%Ak(J) = qmmm_gaussian_fns(IRad)%pgf%Ak(J)*fconv qmmm_gaussian_fns(IRad)%pgf%Gk(J) = qmmm_gaussian_fns(IRad)%pgf%Gk(J)*fconv END DO diff --git a/src/qmmm_gpw_energy.F b/src/qmmm_gpw_energy.F index 4083f9f0ec..45c5b5eaee 100644 --- a/src/qmmm_gpw_energy.F +++ b/src/qmmm_gpw_energy.F @@ -292,7 +292,7 @@ CONTAINS per_potentials=qmmm_env%added_charges%per_potentials, par_scheme=qmmm_env%par_scheme, & qmmm_spherical_cutoff=qmmm_env%spherical_cutoff, shells=shells) END IF - IF (qmmm_env%added_shells%num_mm_atoms .GT. 0) THEN + IF (qmmm_env%added_shells%num_mm_atoms > 0) THEN shells = .TRUE. CALL qmmm_elec_with_gaussian_low(grids, qmmm_env%added_shells%added_particles, & qmmm_env%added_shells%mm_core_chrg, & diff --git a/src/qmmm_gpw_forces.F b/src/qmmm_gpw_forces.F index af400bab8d..2604a40df6 100644 --- a/src/qmmm_gpw_forces.F +++ b/src/qmmm_gpw_forces.F @@ -338,7 +338,7 @@ CONTAINS IF (qmmm_env%image_charge) THEN DO iatom = 1, qmmm_env%num_image_mm_atoms image_IndMM = qmmm_env%image_charge_pot%image_mm_list(iatom) - IF (image_IndMM .EQ. IndMM) THEN + IF (image_IndMM == IndMM) THEN Forces(:, Imm) = Forces(:, Imm) & + qmmm_env%image_charge_pot%image_forcesMM(:, iatom) END IF @@ -359,7 +359,7 @@ CONTAINS END DO END IF DEALLOCATE (Forces_added_charges) - IF (qmmm_env%added_shells%num_mm_atoms .GT. 0) THEN + IF (qmmm_env%added_shells%num_mm_atoms > 0) THEN DO Imm = 1, qmmm_env%added_shells%num_mm_atoms IndMM = qmmm_env%added_shells%mm_core_index(Imm) ! Hack: In Forces there the gradients indeed... @@ -470,7 +470,7 @@ CONTAINS me = grids(auxbas_grid)%pw_grid%para%group%mepos glb = rho%pw_grid%bounds(1, :) gub = rho%pw_grid%bounds(2, :) - IF ((pos_of_x(glb(1)) .EQ. me) .AND. (pos_of_x(gub(1)) .EQ. me)) THEN + IF ((pos_of_x(glb(1)) == me) .AND. (pos_of_x(gub(1)) == me)) THEN DO k = lb(3), ub(3) DO j = lb(2), ub(2) grids(auxbas_grid)%array(ub(1) + 1, j, k) = rho%array(lb(1), j, k) @@ -481,14 +481,14 @@ CONTAINS grids(auxbas_grid)%array(ub(1) + 1, j, ub(3) + 1) = rho%array(lb(1), j, lb(3)) END DO grids(auxbas_grid)%array(ub(1) + 1, ub(2) + 1, ub(3) + 1) = rho%array(lb(1), lb(2), lb(3)) - ELSE IF (pos_of_x(glb(1)) .EQ. me) THEN + ELSE IF (pos_of_x(glb(1)) == me) THEN ALLOCATE (tmp(rho%pw_grid%bounds_local(1, 2):rho%pw_grid%bounds_local(2, 2), & rho%pw_grid%bounds_local(1, 3):rho%pw_grid%bounds_local(2, 3))) tmp = rho%array(lb(1), :, :) CALL group%isend(msgin=tmp, dest=pos_of_x(rho%pw_grid%bounds(2, 1)), & request=request, tag=112) CALL request%wait() - ELSE IF (pos_of_x(gub(1)) .EQ. me) THEN + ELSE IF (pos_of_x(gub(1)) == me) THEN ALLOCATE (tmp(rho%pw_grid%bounds_local(1, 2):rho%pw_grid%bounds_local(2, 2), & rho%pw_grid%bounds_local(1, 3):rho%pw_grid%bounds_local(2, 3))) CALL group%irecv(msgout=tmp, source=pos_of_x(rho%pw_grid%bounds(1, 1)), & @@ -546,7 +546,7 @@ CONTAINS qmmm_env%spherical_cutoff, shells) END IF - IF (qmmm_env%added_shells%num_mm_atoms .GT. 0) THEN + IF (qmmm_env%added_shells%num_mm_atoms > 0) THEN shells = .TRUE. CALL qmmm_force_with_gaussian_low(grids, qmmm_env%added_shells%added_particles, & qmmm_env%added_shells%mm_core_chrg, & diff --git a/src/qmmm_image_charge.F b/src/qmmm_image_charge.F index e998005767..73aee3e194 100644 --- a/src/qmmm_image_charge.F +++ b/src/qmmm_image_charge.F @@ -305,7 +305,7 @@ CONTAINS CALL cp_print_key_finished_output(output_unit, logger, input, & "QMMM%PRINT%PROGRAM_RUN_INFO") - IF (iter_steps .LT. 25) THEN + IF (iter_steps < 25) THEN qs_env%calc_image_preconditioner = .FALSE. ELSE qs_env%calc_image_preconditioner = .TRUE. diff --git a/src/qmmm_init.F b/src/qmmm_init.F index 1bf8102c0f..89ca54ebf2 100644 --- a/src/qmmm_init.F +++ b/src/qmmm_init.F @@ -136,7 +136,7 @@ CONTAINS shell_particles=shell_particles) particle_set => particles%els - IF (ALL(particle_set(:)%shell_index .EQ. 0)) THEN + IF (ALL(particle_set(:)%shell_index == 0)) THEN shell_model = .FALSE. CALL create_add_shell_type(added_shells, ndim=0) ELSE @@ -420,7 +420,7 @@ CONTAINS IF (ASSOCIATED(maxradius2)) DEALLOCATE (maxradius2) END IF - IF (qmmm_env_qm%added_shells%num_mm_atoms .GT. 0) THEN + IF (qmmm_env_qm%added_shells%num_mm_atoms > 0) THEN maxchrg = MAXVAL(ABS(added_shells%mm_core_chrg(:))) CALL qmmm_gaussian_initialize(qmmm_gaussian_fns=added_shells%pgfs, & @@ -489,7 +489,7 @@ CONTAINS print_section=print_section) END IF - IF (qmmm_env_qm%added_shells%num_mm_atoms .GT. 0) THEN + IF (qmmm_env_qm%added_shells%num_mm_atoms > 0) THEN CALL qmmm_potential_init(qmmm_coupl_type=qmmm_env_qm%qmmm_coupl_type, & mm_el_pot_radius=added_shells%mm_el_pot_radius, & @@ -584,7 +584,7 @@ CONTAINS ncpl=qmmm_env_qm%aug_pools(SIZE(qmmm_env_qm%aug_pools))%pool%pw_grid%npts_local) END IF - IF (qmmm_env_qm%added_shells%num_mm_atoms .GT. 0) THEN + IF (qmmm_env_qm%added_shells%num_mm_atoms > 0) THEN CALL qmmm_per_potential_init(qmmm_coupl_type=qmmm_env_qm%qmmm_coupl_type, & per_potentials=added_shells%per_potentials, & @@ -817,7 +817,7 @@ CONTAINS CALL section_vals_val_get(image_charge_section, "IMAGE_MATRIX_METHOD", & i_val=qmmm_env%image_charge_pot%image_matrix_method) - IF (qmmm_env%image_charge_pot%image_matrix_method .EQ. do_eri_mme) THEN + IF (qmmm_env%image_charge_pot%image_matrix_method == do_eri_mme) THEN eri_mme_section => section_vals_get_subs_vals(image_charge_section, "ERI_MME") CALL cp_eri_mme_init_read_input(eri_mme_section, qmmm_env%image_charge_pot%eri_mme_param) CALL cp_eri_mme_set_params(qmmm_env%image_charge_pot%eri_mme_param, & diff --git a/src/qmmm_pw_grid.F b/src/qmmm_pw_grid.F index 5f0f1788ce..3392f15aed 100644 --- a/src/qmmm_pw_grid.F +++ b/src/qmmm_pw_grid.F @@ -88,8 +88,8 @@ CONTAINS Maxdr = MAX(Maxdr, el_struct%dr) Mindr = MIN(Mindr, el_struct%dr) - IF (ALL(Maxdr .EQ. el_struct%dr)) qmmm_env%gridlevel_info%coarser_grid = Ilevel - IF (ALL(Mindr .EQ. el_struct%dr)) qmmm_env%gridlevel_info%auxbas_grid = Ilevel + IF (ALL(Maxdr == el_struct%dr)) qmmm_env%gridlevel_info%coarser_grid = Ilevel + IF (ALL(Mindr == el_struct%dr)) qmmm_env%gridlevel_info%auxbas_grid = Ilevel CALL pw_grid_release(el_struct) diff --git a/src/qmmm_types_low.F b/src/qmmm_types_low.F index 4b5c0c6334..3f56d94647 100644 --- a/src/qmmm_types_low.F +++ b/src/qmmm_types_low.F @@ -397,7 +397,7 @@ CONTAINS END IF IF (ASSOCIATED(qmmm_env%image_charge_pot)) THEN IF (qmmm_env%image_charge) THEN - IF (qmmm_env%image_charge_pot%image_matrix_method .EQ. do_eri_mme) THEN + IF (qmmm_env%image_charge_pot%image_matrix_method == do_eri_mme) THEN CALL cp_eri_mme_finalize(qmmm_env%image_charge_pot%eri_mme_param) END IF END IF diff --git a/src/qmmm_util.F b/src/qmmm_util.F index 9a1957afc0..bf05cd41dd 100644 --- a/src/qmmm_util.F +++ b/src/qmmm_util.F @@ -484,7 +484,7 @@ CONTAINS DO ip = 1, subsys_mm%particles%n_els particles_mm(ip)%r = particles_mm(ip)%r - transl_v END DO - IF (qmmm_env%qm%added_shells%num_mm_atoms .GT. 0) THEN + IF (qmmm_env%qm%added_shells%num_mm_atoms > 0) THEN DO ip = 1, qmmm_env%qm%added_shells%num_mm_atoms qmmm_env%qm%added_shells%added_particles(ip)%r = qmmm_env%qm%added_shells%added_particles(ip)%r - transl_v qmmm_env%qm%added_shells%added_cores(ip)%r = qmmm_env%qm%added_shells%added_cores(ip)%r - transl_v diff --git a/src/qs_atomic_block.F b/src/qs_atomic_block.F index eadbb6aca8..072cfcd72f 100644 --- a/src/qs_atomic_block.F +++ b/src/qs_atomic_block.F @@ -113,7 +113,7 @@ CONTAINS DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, irow, icol, pdata) ikind = kind_of(irow) - IF (icol .EQ. irow) THEN + IF (icol == irow) THEN IF (ispin == 1) THEN pdata(:, :) = pmat(ikind)%mat(:, :, 1)*rscale + & pmat(ikind)%mat(:, :, 2)*rscale diff --git a/src/qs_cdft_methods.F b/src/qs_cdft_methods.F index 3e1f71e3ee..abd21ab097 100644 --- a/src/qs_cdft_methods.F +++ b/src/qs_cdft_methods.F @@ -330,7 +330,7 @@ CONTAINS CYCLE END IF IF (becke_control%vector_buffer%store_vectors) THEN - IF (becke_control%vector_buffer%distances(iatom) .EQ. 0.0_dp) THEN + IF (becke_control%vector_buffer%distances(iatom) == 0.0_dp) THEN r = becke_control%vector_buffer%position_vecs(:, iatom) dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) @@ -348,13 +348,13 @@ CONTAINS dist_vec = (r - grid_p) - ANINT((r - grid_p)/cell_v)*cell_v dist1 = SQRT(DOT_PRODUCT(dist_vec, dist_vec)) END IF - IF (dist1 .LE. cutoffs(iatom)) THEN + IF (dist1 <= cutoffs(iatom)) THEN IF (in_memory) THEN - IF (dist1 .LE. th) dist1 = th + IF (dist1 <= th) dist1 = th dr_i_dR(:) = dist_vec(:)/dist1 END IF DO jatom = 1, natom - IF (jatom .NE. iatom) THEN + IF (jatom /= iatom) THEN ! Using pairwise symmetry, execute block only for such j 0.0_dp) THEN DO igroup = 1, SIZE(group) DO iatom = 1, natom group(igroup)%gradients(3*(iatom - 1) + 1:3*(iatom - 1) + 3, k, j, i) = & @@ -533,7 +533,7 @@ CONTAINS END DO END IF ! Weight function(s) at (k,j,i) - IF (.NOT. my_just_gradients .AND. ABS(sum_cell_f_all) .GT. 0.000001) THEN + IF (.NOT. my_just_gradients .AND. ABS(sum_cell_f_all) > 0.000001) THEN DO igroup = 1, SIZE(group) group(igroup)%weight%array(k, j, i) = sum_cell_f_group(igroup)/sum_cell_f_all END DO diff --git a/src/qs_cdft_opt_types.F b/src/qs_cdft_opt_types.F index a9f772a04a..0ad4cad775 100644 --- a/src/qs_cdft_opt_types.F +++ b/src/qs_cdft_opt_types.F @@ -187,8 +187,8 @@ CONTAINS l_val=cdft_opt_control%continue_ls) CALL section_vals_val_get(cdft_opt_section, "FACTOR_LS", & r_val=cdft_opt_control%factor_ls) - IF (cdft_opt_control%factor_ls .LE. 0.0_dp .OR. & - cdft_opt_control%factor_ls .GE. 1.0_dp) & + IF (cdft_opt_control%factor_ls <= 0.0_dp .OR. & + cdft_opt_control%factor_ls >= 1.0_dp) & CALL cp_abort(__LOCATION__, & "Keyword FACTOR_LS must be between 0.0 and 1.0.") CALL section_vals_val_get(cdft_opt_section, "JACOBIAN_FREQ", explicit=exists) @@ -198,10 +198,10 @@ CONTAINS IF (SIZE(tmplist) /= 2) & CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes exactly two input values.") - IF (ANY(tmplist .LT. 0)) & + IF (ANY(tmplist < 0)) & CALL cp_abort(__LOCATION__, & "Keyword JACOBIAN_FREQ takes only positive values.") - IF (ALL(tmplist .EQ. 0)) & + IF (ALL(tmplist == 0)) & CALL cp_abort(__LOCATION__, & "Both values to keyword JACOBIAN_FREQ cannot be zero.") cdft_opt_control%jacobian_freq(:) = tmplist(1:2) diff --git a/src/qs_cdft_scf_utils.F b/src/qs_cdft_scf_utils.F index 9f6bd158da..d79e012afc 100644 --- a/src/qs_cdft_scf_utils.F +++ b/src/qs_cdft_scf_utils.F @@ -221,7 +221,7 @@ CONTAINS outer_scf_ihistory=outer_scf_ihistory) ihistory = scf_env%outer_scf%iter_count - IF (outer_scf_ihistory .GE. 3 .AND. .NOT. used_history) THEN + IF (outer_scf_ihistory >= 3 .AND. .NOT. used_history) THEN ! First, lets try using the history from previous energy evaluations CALL get_qs_env(qs_env, gradient_history=gradient_history, & variable_history=variable_history) @@ -229,7 +229,7 @@ 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)) .LT. 1.0E-12_dp) & + IF (ABS(variable_history(i, 2) - variable_history(i, 1)) < 1.0E-12_dp) & use_md_history = .FALSE. END DO IF (use_md_history) THEN @@ -250,10 +250,10 @@ CONTAINS used_history = .TRUE. END IF END IF - IF (ihistory .GE. 2 .AND. .NOT. ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN + 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) .LT. 3) & + 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.") @@ -428,14 +428,14 @@ CONTAINS ! Check if an old Jacobian can be reused avoiding a rebuild IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN ! Rebuild if number of previous energy evaluations exceeds limit - IF (scf_control%outer_scf%cdft_opt_control%ijacobian(2) .GE. & + IF (scf_control%outer_scf%cdft_opt_control%ijacobian(2) >= & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) .AND. .NOT. used_history .AND. & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) THEN should_build = .TRUE. ! Zero the corresponding counters scf_control%outer_scf%cdft_opt_control%ijacobian(:) = 0 ! Rebuild if number of previous SCF iterations exceeds limit (on this energy eval) - ELSE IF (scf_control%outer_scf%cdft_opt_control%ijacobian(1) .GE. & + ELSE IF (scf_control%outer_scf%cdft_opt_control%ijacobian(1) >= & scf_control%outer_scf%cdft_opt_control%jacobian_freq(1) .AND. & scf_control%outer_scf%cdft_opt_control%jacobian_freq(1) > 0) THEN should_build = .TRUE. diff --git a/src/qs_cdft_utils.F b/src/qs_cdft_utils.F index 0a37120187..2410fe1fce 100644 --- a/src/qs_cdft_utils.F +++ b/src/qs_cdft_utils.F @@ -246,13 +246,13 @@ CONTAINS ircov = becke_control%radii(ikind) CALL get_atomic_kind(atomic_kind=particle_set(jatom)%atomic_kind, kind_number=ikind) jrcov = becke_control%radii(ikind) - IF (ircov .NE. jrcov) THEN + IF (ircov /= jrcov) THEN chi = ircov/jrcov uij = (chi - 1.0_dp)/(chi + 1.0_dp) becke_control%aij(iatom, jatom) = uij/(uij**2 - 1.0_dp) - IF (becke_control%aij(iatom, jatom) .GT. 0.5_dp) THEN + IF (becke_control%aij(iatom, jatom) > 0.5_dp) THEN becke_control%aij(iatom, jatom) = 0.5_dp - ELSE IF (becke_control%aij(iatom, jatom) .LT. -0.5_dp) THEN + ELSE IF (becke_control%aij(iatom, jatom) < -0.5_dp) THEN becke_control%aij(iatom, jatom) = -0.5_dp END IF ELSE @@ -399,12 +399,12 @@ CONTAINS CALL hfun_zero(becke_control%cavity%array, eps_cavity, just_bounds=.TRUE., bounds=bounds) ! Save bounds (first nonzero grid point indices) bo = group(1)%weight%pw_grid%bounds_local - IF (bounds(2) .LT. bo(2, 3)) THEN + IF (bounds(2) < bo(2, 3)) THEN bounds(2) = bounds(2) - 1 ELSE bounds(2) = bo(2, 3) END IF - IF (bounds(1) .GT. bo(1, 3)) THEN + IF (bounds(1) > bo(1, 3)) THEN ! In the special case bounds(1) == bounds(2) == bo(2, 3), after this check ! bounds(1) > bounds(2) and the subsequent gradient allocation (:, :, :, bounds(1):bounds(2)) ! will correctly allocate a 0-sized array @@ -425,7 +425,7 @@ 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 .LT. 1) & + IF (para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print cavity") CALL get_qs_env(qs_env, subsys=subsys) @@ -1290,7 +1290,7 @@ 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 .LT. 1) & + IF (para_env%is_source() .AND. unit_nr < 1) & CALL cp_abort(__LOCATION__, & "Please turn on PROGRAM_RUN_INFO to print CDFT weight function.") diff --git a/src/qs_cneo_methods.F b/src/qs_cneo_methods.F index be5cff0908..962aafa9d3 100644 --- a/src/qs_cneo_methods.F +++ b/src/qs_cneo_methods.F @@ -393,7 +393,7 @@ CONTAINS CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) DO ipgf1 = 1, npgf(iset1) g1(1:nr) = EXP(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr)) @@ -442,7 +442,7 @@ CONTAINS vgg(:, :, :, j) = 0.0_dp done_vgg = .FALSE. ! reduce the number of terms in the expansion local densities - IF (lmin12 .LE. lmax_expansion) THEN + IF (lmin12 <= lmax_expansion) THEN IF (lmin12 == 0) THEN gg(1:nr, lmin12, j) = g1(1:nr)*g2(1:nr) gg0(1:nr) = gg(1:nr, lmin12, j) @@ -452,7 +452,7 @@ CONTAINS END IF ! reduce the number of terms in the expansion local densities - IF (lmax12 .GT. lmax_expansion) lmax12 = lmax_expansion + IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion DO l = lmin12 + 1, lmax12 gg(1:nr, l, j) = grid_atom%rad(1:nr)*gg(1:nr, l - 1, j) @@ -1199,7 +1199,7 @@ CONTAINS CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) n2s = nsoset(lmax(iset2)) DO ipgf1 = 1, npgf(iset1) diff --git a/src/qs_collocate_density.F b/src/qs_collocate_density.F index bbce034763..2f7c6d903d 100644 --- a/src/qs_collocate_density.F +++ b/src/qs_collocate_density.F @@ -460,7 +460,7 @@ CONTAINS END IF END DO - IF (npme .GT. 0) THEN + IF (npme > 0) THEN DO j = 1, npme iatom = cores(j) @@ -881,7 +881,7 @@ CONTAINS END IF END DO - IF (npme .GT. 0) THEN + IF (npme > 0) THEN DO j = 1, npme iatom = cores(j) @@ -1015,7 +1015,7 @@ CONTAINS END IF END DO - IF (npme .GT. 0) THEN + IF (npme > 0) THEN DO j = 1, npme iatom = cores(j) @@ -1113,7 +1113,7 @@ CONTAINS npme = npme + 1 END IF - IF (npme .GT. 0) THEN + IF (npme > 0) THEN atom_a = qs_env%qmmm_env_qm%image_charge_pot%image_mm_list(iatom) ra(:) = pbc(qs_env%qmmm_env_qm%image_charge_pot%particles_all(atom_a)%r, cell) subpatch_pattern = 0 @@ -1213,7 +1213,7 @@ CONTAINS END IF END DO - IF (npme .GT. 0) THEN + IF (npme > 0) THEN DO j = 1, npme iatom = cores(j) atom_a = qs_env%qmmm_env_qm%image_charge_pot%image_mm_list(iatom) @@ -1312,7 +1312,7 @@ CONTAINS npme = npme + 1 END IF - IF (npme .GT. 0) THEN + IF (npme > 0) THEN ra(:) = pbc(particle_set(iatom)%r, cell) subpatch_pattern = 0 radius = exp_radius_very_extended(la_min=0, la_max=0, & @@ -1413,7 +1413,7 @@ CONTAINS END IF END DO - IF (npme .GT. 0) THEN + IF (npme > 0) THEN DO j = 1, npme iatom = cores(j) ra(:) = pbc(particle_set(iatom)%r, cell) @@ -1823,9 +1823,9 @@ CONTAINS ikind = particle_set(iatom)%atomic_kind%kind_number jkind = particle_set(jatom)%atomic_kind%kind_number - IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old .OR. img .NE. img_old) THEN + IF (iatom /= iatom_old .OR. jatom /= jatom_old .OR. img /= img_old) THEN - IF (iatom .NE. iatom_old) ra(:) = pbc(particle_set(iatom)%r, cell) + IF (iatom /= iatom_old) ra(:) = pbc(particle_set(iatom)%r, cell) IF (iatom <= jatom) THEN brow = iatom @@ -1835,7 +1835,7 @@ CONTAINS bcol = iatom END IF - IF (ikind .NE. ikind_old) THEN + IF (ikind /= ikind_old) THEN IF (my_soft) THEN CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, & basis_type="ORB_SOFT") @@ -1854,7 +1854,7 @@ CONTAINS zet=zeta) END IF - IF (jkind .NE. jkind_old) THEN + IF (jkind /= jkind_old) THEN IF (my_soft) THEN CALL get_qs_kind(qs_kind_set(jkind), basis_set=orb_basis_set, & basis_type="ORB_SOFT") @@ -1890,7 +1890,7 @@ CONTAINS END IF - IF (atom_pair_changed .OR. iset_old .NE. iset .OR. jset_old .NE. jset) THEN + IF (atom_pair_changed .OR. iset_old /= iset .OR. jset_old /= jset) THEN ncoa = npgfa(iset)*ncoset(la_max(iset)) sgfa = first_sgfa(1, iset) @@ -1950,7 +1950,7 @@ CONTAINS ! check whether we need to use fawzi's generalised collocation scheme IF (rs_rho(igrid_level)%desc%distributed) THEN !tasks(4,:) is 0 for replicated, 1 for distributed 2 for exceptional distributed tasks - IF (tasks(itask)%dist_type .EQ. 2) THEN + IF (tasks(itask)%dist_type == 2) THEN use_subpatch = .TRUE. ELSE use_subpatch = .FALSE. @@ -2206,9 +2206,9 @@ CONTAINS ikind = particle_set(iatom)%atomic_kind%kind_number jkind = particle_set(jatom)%atomic_kind%kind_number - IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old .OR. img .NE. img_old) THEN + IF (iatom /= iatom_old .OR. jatom /= jatom_old .OR. img /= img_old) THEN - IF (iatom .NE. iatom_old) ra(:) = pbc(particle_set(iatom)%r, cell) + IF (iatom /= iatom_old) ra(:) = pbc(particle_set(iatom)%r, cell) IF (iatom <= jatom) THEN brow = iatom @@ -2218,7 +2218,7 @@ CONTAINS bcol = iatom END IF - IF (ikind .NE. ikind_old) THEN + IF (ikind /= ikind_old) THEN IF (my_soft) THEN CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, & basis_type="ORB_SOFT") @@ -2237,7 +2237,7 @@ CONTAINS zet=zeta) END IF - IF (jkind .NE. jkind_old) THEN + IF (jkind /= jkind_old) THEN IF (my_soft) THEN CALL get_qs_kind(qs_kind_set(jkind), basis_set=orb_basis_set, & basis_type="ORB_SOFT") @@ -2273,7 +2273,7 @@ CONTAINS END IF - IF (atom_pair_changed .OR. iset_old .NE. iset .OR. jset_old .NE. jset) THEN + IF (atom_pair_changed .OR. iset_old /= iset .OR. jset_old /= jset) THEN ncoa = npgfa(iset)*ncoset(la_max(iset)) sgfa = first_sgfa(1, iset) @@ -2333,7 +2333,7 @@ CONTAINS ! check whether we need to use fawzi's generalised collocation scheme IF (rs_rho(igrid_level)%desc%distributed) THEN !tasks(4,:) is 0 for replicated, 1 for distributed 2 for exceptional distributed tasks - IF (tasks(itask)%dist_type .EQ. 2) THEN + IF (tasks(itask)%dist_type == 2) THEN use_subpatch = .TRUE. ELSE use_subpatch = .FALSE. diff --git a/src/qs_condnum.F b/src/qs_condnum.F index 108430f009..d76cd406b5 100644 --- a/src/qs_condnum.F +++ b/src/qs_condnum.F @@ -100,7 +100,7 @@ CONTAINS END IF ! IF (ASSOCIATED(smat)) THEN - CPASSERT(dbcsr_get_matrix_type(smat) .EQ. dbcsr_type_symmetric) + CPASSERT(dbcsr_get_matrix_type(smat) == dbcsr_type_symmetric) IF (norml1) THEN ! norm of S anorm = dbcsr_gershgorin_norm(smat) diff --git a/src/qs_core_hamiltonian.F b/src/qs_core_hamiltonian.F index 8bde5125ec..c802ce14f6 100644 --- a/src/qs_core_hamiltonian.F +++ b/src/qs_core_hamiltonian.F @@ -361,7 +361,7 @@ CONTAINS ! *** Overlap condition number IF (.NOT. calculate_forces) THEN IF (cp_print_key_should_output(logger%iter_info, qs_env%input, & - "DFT%PRINT%OVERLAP_CONDITION") .NE. 0) THEN + "DFT%PRINT%OVERLAP_CONDITION") /= 0) THEN iw = cp_print_key_unit_nr(logger, qs_env%input, "DFT%PRINT%OVERLAP_CONDITION", & extension=".Log") CALL section_vals_val_get(qs_env%input, "DFT%PRINT%OVERLAP_CONDITION%1-NORM", l_val=norml1) @@ -588,7 +588,7 @@ CONTAINS nimages = dft_control%nimages - CPASSERT(nimages .EQ. SIZE(matrix_h, 2)) + CPASSERT(nimages == SIZE(matrix_h, 2)) CALL dbcsr_allocate_matrix_set(matrix_h_im, 1, nimages) diff --git a/src/qs_dcdr_utils.F b/src/qs_dcdr_utils.F index 9e0f3c9a63..7a84ba1a7f 100644 --- a/src/qs_dcdr_utils.F +++ b/src/qs_dcdr_utils.F @@ -239,14 +239,14 @@ CONTAINS ! check that the number nao, nmo and nspins are ! the same as in the current mos - IF (nspins_tmp .NE. nspins) THEN + IF (nspins_tmp /= nspins) THEN CPABORT("nspins not consistent") END IF - IF (nao_tmp .NE. nao) CPABORT("nao not consistent") + IF (nao_tmp /= nao) CPABORT("nao not consistent") ! check that it's the right file ! the same as in the current mos - IF (lambda_tmp .NE. lambda) CPABORT("lambda not consistent") - IF (beta_tmp .NE. beta) CPABORT("beta not consistent") + IF (lambda_tmp /= lambda) CPABORT("lambda not consistent") + IF (beta_tmp /= beta) CPABORT("beta not consistent") ! DO ispin = 1, nspins CALL get_mo_set(mos(ispin), mo_coeff=mo_coeff) @@ -254,7 +254,7 @@ CONTAINS ! IF (rst_unit > 0) READ (rst_unit) nmo_tmp CALL para_env%bcast(nmo_tmp) - IF (nmo_tmp .NE. nmo) CPABORT("nmo not consistent") + IF (nmo_tmp /= nmo) CPABORT("nmo not consistent") ! ! read the response DO i = 1, nmo, MAX(max_block, 1) @@ -579,7 +579,7 @@ CONTAINS ! check that the number of localized states is equal to the number of states nmoloc = SIZE(linres_control%qs_loc_env%localized_wfn_control%centers_set(1)%array, 2) - IF (nmoloc .NE. nmo) THEN + IF (nmoloc /= nmo) THEN CPABORT("The number of localized functions is not equal to the number of states.") END IF diff --git a/src/qs_dftb_matrices.F b/src/qs_dftb_matrices.F index fd965581d3..50b49ac135 100644 --- a/src/qs_dftb_matrices.F +++ b/src/qs_dftb_matrices.F @@ -763,7 +763,7 @@ CONTAINS row=irow, col=icol, BLOCK=sblock, found=found) CPASSERT(found) - IF (nderivative .GT. 0) THEN + IF (nderivative > 0) THEN DO i = 2, SIZE(matrix_s, 1) NULLIFY (dsblocks(i)%block) CALL dbcsr_get_block_p(matrix=matrix_s(i)%matrix, & @@ -781,7 +781,7 @@ CONTAINS CALL compute_block_sk(sblock, smatij, smatji, rij, ngrd, ngrdcut, dgrd, & llm, lmaxi, lmaxj, irow, iatom) - IF (nderivative .GE. 1) THEN + IF (nderivative >= 1) THEN n1 = SIZE(sblock, 1); n2 = SIZE(sblock, 2) indder = 1 ! used to put the 2nd derivatives in the correct matric (5=xx,8=yy,10=zz) @@ -806,7 +806,7 @@ CONTAINS CPASSERT(ASSOCIATED(dsblocks(i + 1)%block)) dsblocks(i + 1)%block = dsblocks(i + 1)%block + dsblock - IF (nderivative .GT. 1) THEN + IF (nderivative > 1) THEN indder = indder + 5 - i dsblocks(indder)%block = 0.0_dp dsblocks(indder)%block = dsblocks(indder)%block + & @@ -814,7 +814,7 @@ CONTAINS END IF END DO - IF (nderivative .GT. 1) THEN + IF (nderivative > 1) THEN DO i = 1, 2 DO j = i + 1, 3 dsblock = 0._dp; dsblockm = 0.0_dp @@ -915,10 +915,10 @@ CONTAINS ! Up to 2nd derivative take care to get the symmetries correct DO i = 1, nmat - IF (i .GT. 1) THEN + IF (i > 1) THEN matnames = TRIM(mnames)//" DERIVATIVE MATRIX DFTB" symmetry_type = dbcsr_type_antisymmetric - IF (i .GT. 4) symmetry_type = dbcsr_type_symmetric + IF (i > 4) symmetry_type = dbcsr_type_symmetric ELSE symmetry_type = dbcsr_type_symmetric matnames = TRIM(mnames)//" MATRIX DFTB" @@ -1003,10 +1003,10 @@ CONTAINS ! Up to 2nd derivative take care to get the symmetries correct DO img = 1, nimg DO i = 1, nmat - IF (i .GT. 1) THEN + IF (i > 1) THEN matnames = TRIM(mnames)//" DERIVATIVE MATRIX DFTB" symmetry_type = dbcsr_type_antisymmetric - IF (i .GT. 4) symmetry_type = dbcsr_type_symmetric + IF (i > 4) symmetry_type = dbcsr_type_symmetric ELSE symmetry_type = dbcsr_type_symmetric matnames = TRIM(mnames)//" MATRIX DFTB" diff --git a/src/qs_dftb_utils.F b/src/qs_dftb_utils.F index 0228ec4fb7..f3a8642771 100644 --- a/src/qs_dftb_utils.F +++ b/src/qs_dftb_utils.F @@ -453,14 +453,14 @@ CONTAINS lmaxab = MAX(lmaxa, lmaxb) ! Determine l quantum limits. - IF (lmaxab .GT. 2) CPABORT('lmax=2') + IF (lmaxab > 2) CPABORT('lmax=2') minlmaxab = MIN(lmaxa, lmaxb) ! ! s-s interaction ! CALL skss(skab1, mat) ! - IF (lmaxab .LE. 0) RETURN + IF (lmaxab <= 0) RETURN ! rr2(1:3) = dxv(1:3)**2 rr(1:3) = dxv(1:3) @@ -473,12 +473,12 @@ CONTAINS ! ! s-p, p-s and p-p interaction ! - IF (minlmaxab .GE. 1) THEN + IF (minlmaxab >= 1) THEN CALL skpp(skab1, mat, iptr(:, :, :, lmaxa, lmaxb)) CALL sksp(skab2, mat, iptr(:, :, :, lmaxa, lmaxb), .TRUE.) CALL sksp(skab1, mat, iptr(:, :, :, lmaxa, lmaxb), .FALSE.) ELSE - IF (lmaxb .GE. 1) THEN + IF (lmaxb >= 1) THEN CALL sksp(skab2, mat, iptr(:, :, :, lmaxa, lmaxb), .TRUE.) ELSE CALL sksp(skab1, mat, iptr(:, :, :, lmaxa, lmaxb), .FALSE.) @@ -487,11 +487,11 @@ CONTAINS ! ! If there is only s-p interaction we have finished ! - IF (lmaxab .LE. 1) RETURN + IF (lmaxab <= 1) RETURN ! ! at least one atom has d functions ! - IF (minlmaxab .EQ. 2) THEN + IF (minlmaxab == 2) THEN ! ! in case both atoms have d functions ! @@ -504,12 +504,12 @@ CONTAINS ! ! One atom has d functions, the other has s or s and p functions ! - IF (lmaxa .EQ. 0) THEN + IF (lmaxa == 0) THEN ! ! atom b has d, the atom a only s functions ! CALL sksd(skab2, mat, iptr(:, :, :, lmaxa, lmaxb), .TRUE.) - ELSE IF (lmaxa .EQ. 1) THEN + ELSE IF (lmaxa == 1) THEN ! ! atom b has d, the atom a s and p functions ! @@ -519,7 +519,7 @@ CONTAINS ! ! atom a has d functions ! - IF (lmaxb .EQ. 0) THEN + IF (lmaxb == 0) THEN ! ! atom a has d, atom b has only s functions ! @@ -849,7 +849,7 @@ CONTAINS dif = ABS(x - xa(1)) DO i = 1, n dift = ABS(x - xa(i)) - IF (dift .LT. dif) THEN + IF (dift < dif) THEN ns = i dif = dift END IF @@ -870,7 +870,7 @@ CONTAINS d(i) = hp*den c(i) = ho*den END DO - IF (2*ns .LT. n - m) THEN + IF (2*ns < n - m) THEN dy = c(ns + 1) ELSE dy = d(ns) diff --git a/src/qs_diis.F b/src/qs_diis.F index 40cdf7730a..aafd924ab4 100644 --- a/src/qs_diis.F +++ b/src/qs_diis.F @@ -717,7 +717,7 @@ CONTAINS ev(1:nb) = MATMUL(a(1:nb, 1:nb1), b(nb1, 1:nb1)) ! Update Kohn-Sham matrix - IF (iscf .GE. ls_scf_env%iter_ini_diis) THEN ! if-iscf-to-updateKS------ START + IF (iscf >= ls_scf_env%iter_ini_diis) THEN ! if-iscf-to-updateKS------ START IF (unit_nr > 0) THEN WRITE (unit_nr, '(A40,I3)') 'DIIS: Updating Kohn-Sham matrix at iscf=', iscf diff --git a/src/qs_dispersion_d3.F b/src/qs_dispersion_d3.F index b220584ef3..9bf9145503 100644 --- a/src/qs_dispersion_d3.F +++ b/src/qs_dispersion_d3.F @@ -392,7 +392,7 @@ CONTAINS ELSE CPABORT("Unknown DFT-D3 damping function:") END IF - IF (dispersion_env%srb .AND. dr .LT. 30.0d0) THEN + IF (dispersion_env%srb .AND. dr < 30.0d0) THEN srbe = ssrb*(REAL((za*zb), KIND=dp))**t1srb*EXP(-gsrb*dr*dispersion_env%r0ab(za, zb)**t2srb) esrb = esrb + srbe evdw = evdw - srbe @@ -424,7 +424,7 @@ CONTAINS CPABORT("Unknown DFT-D3 damping function:") END IF fdij(:) = (de6 + de8)*rij(:)/dr*fac - IF (dispersion_env%srb .AND. dr .LT. 30.0d0) THEN + IF (dispersion_env%srb .AND. dr < 30.0d0) THEN fdij(:) = fdij(:) + srbe*gsrb*dispersion_env%r0ab(za, zb)**t2srb*rij(:)/dr END IF atom_a = atom_of_kind(iatom) @@ -925,13 +925,13 @@ CONTAINS iadr = 1 jadr = 1 i = 100 - DO WHILE (iat .GT. 100) + DO WHILE (iat > 100) iat = iat - 100 iadr = iadr + 1 END DO i = 100 - DO WHILE (jat .GT. 100) + DO WHILE (jat > 100) jat = jat - 100 jadr = jadr + 1 END DO diff --git a/src/qs_dispersion_nonloc.F b/src/qs_dispersion_nonloc.F index 77fa1bf7cc..9ac1e1c1fa 100644 --- a/src/qs_dispersion_nonloc.F +++ b/src/qs_dispersion_nonloc.F @@ -359,7 +359,7 @@ CONTAINS !$OMP PARALLEL DO DEFAULT( NONE ) & !$OMP SHARED( np, rho, dispersion_env, thetas, const ) & !$OMP PRIVATE( i ) & -!$OMP SCHEDULE(DYNAMIC) ! use dynamic to allow for possibility of cases having (rho(i_grid) .LE. epsr) +!$OMP SCHEDULE(DYNAMIC) ! use dynamic to allow for possibility of cases having (rho(i_grid) <= epsr) DO i_grid = 1, np IF (rho(i_grid) > epsr) THEN DO i = 1, dispersion_env%nqs @@ -839,7 +839,7 @@ CONTAINS prefactor = 0.0_dp END IF END SELECT - IF (q0(i_grid) .NE. q_mesh(nqs)) THEN + IF (q0(i_grid) /= q_mesh(nqs)) THEN h_prefactor(i_grid) = h_prefactor(i_grid) + prefactor END IF diff --git a/src/qs_dispersion_pairpot.F b/src/qs_dispersion_pairpot.F index 0ca7c23b92..a56dfa62e2 100644 --- a/src/qs_dispersion_pairpot.F +++ b/src/qs_dispersion_pairpot.F @@ -400,7 +400,7 @@ CONTAINS ! make valgrind happy use_virial = .FALSE. - IF (dispersion_env%type .NE. xc_vdw_fun_pairpot) THEN + IF (dispersion_env%type /= xc_vdw_fun_pairpot) THEN RETURN END IF diff --git a/src/qs_efield_berry.F b/src/qs_efield_berry.F index 644141b609..533b6c649a 100644 --- a/src/qs_efield_berry.F +++ b/src/qs_efield_berry.F @@ -369,7 +369,7 @@ CONTAINS DO idir = 1, 3 ci(idir) = 0.0_dp zi(idir) = z_zero - IF (ABS(fpolvec(idir)) .GT. 1.0E-12_dp) THEN + IF (ABS(fpolvec(idir)) > 1.0E-12_dp) THEN cosmat => efield%cosmat(idir)%matrix sinmat => efield%sinmat(idir)%matrix !evaluate the expression needed for the derivative (S_berry * C and [C^T S_berry C]^-1) diff --git a/src/qs_electric_field_gradient.F b/src/qs_electric_field_gradient.F index bc79238e4b..81be8927f1 100644 --- a/src/qs_electric_field_gradient.F +++ b/src/qs_electric_field_gradient.F @@ -458,7 +458,7 @@ CONTAINS DO iset2 = 1, nset CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, llmax, cg_list, cg_n_list, max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) n1s = nsoset(lmax(iset1)) DO ipgf1 = 1, npgf(iset1) diff --git a/src/qs_environment.F b/src/qs_environment.F index f34c0c58b1..d6fbb96f29 100644 --- a/src/qs_environment.F +++ b/src/qs_environment.F @@ -1095,7 +1095,7 @@ CONTAINS maxlgto = MAX(maxlgto, maxlgto_nuc) END IF lmax_sphere = dft_control%qs_control%gapw_control%lmax_sphere - IF (lmax_sphere .LT. 0) THEN + IF (lmax_sphere < 0) THEN lmax_sphere = 2*maxlgto dft_control%qs_control%gapw_control%lmax_sphere = lmax_sphere END IF diff --git a/src/qs_epr_hyp.F b/src/qs_epr_hyp.F index 4a2fbd0e5c..267820bf44 100644 --- a/src/qs_epr_hyp.F +++ b/src/qs_epr_hyp.F @@ -229,7 +229,7 @@ CONTAINS ! Now calculate hard-soft anisotropic contributions for the other nuclei DO jatom = 1, natom - IF (jatom .EQ. iatom) CYCLE ! iatom already done + IF (jatom == iatom) CYCLE ! iatom already done rab = pbc(particle_set(iatom)%r, particle_set(jatom)%r, cell) rab2 = DOT_PRODUCT(rab, rab) ! SQRT(rab2) <= int_radius diff --git a/src/qs_external_density.F b/src/qs_external_density.F index b86263487d..bff0dec8bd 100644 --- a/src/qs_external_density.F +++ b/src/qs_external_density.F @@ -162,13 +162,13 @@ CONTAINS DO i = lbounds(1), ubounds(1) DO j = lbounds(2), ubounds(2) - IF (my_rank .EQ. 0) THEN + IF (my_rank == 0) THEN READ (extunit, *) (buffer(k), k=lbounds(3), ubounds(3)) END IF CALL gid%bcast(buffer(lbounds(3):ubounds(3)), 0) - IF ((lbounds_local(1) .LE. i) .AND. (i .LE. ubounds_local(1)) .AND. (lbounds_local(2) .LE. j) & - .AND. (j .LE. ubounds_local(2))) THEN + IF ((lbounds_local(1) <= i) .AND. (i <= ubounds_local(1)) .AND. (lbounds_local(2) <= j) & + .AND. (j <= ubounds_local(2))) THEN rs_rho_ext(igrid_level)%r(i, j, lbounds(3):ubounds(3)) = buffer(lbounds(3):ubounds(3)) END IF diff --git a/src/qs_external_potential.F b/src/qs_external_potential.F index 9f3ec2a252..66581ce135 100644 --- a/src/qs_external_potential.F +++ b/src/qs_external_potential.F @@ -436,7 +436,7 @@ CONTAINS ! Find the process that has the data for indices i_pbc and j_pbc ! and store the data to bcast_buffer. Assuming that each process has full z data - IF (grid%pw_grid%para%mode .NE. PW_MODE_LOCAL) THEN + IF (grid%pw_grid%para%mode /= PW_MODE_LOCAL) THEN DO ip = 0, num_pe - 1 IF (grid%pw_grid%para%bo(1, 1, ip, 1) <= i_pbc - lbounds(1) + 1 .AND. & grid%pw_grid%para%bo(2, 1, ip, 1) >= i_pbc - lbounds(1) + 1 .AND. & diff --git a/src/qs_fb_atomic_halo_types.F b/src/qs_fb_atomic_halo_types.F index 7ebd85e91d..4f445e58b1 100644 --- a/src/qs_fb_atomic_halo_types.F +++ b/src/qs_fb_atomic_halo_types.F @@ -503,7 +503,7 @@ CONTAINS rij_pbc(2)*rij_pbc(2) + & rij_pbc(3)*rij_pbc(3) rij = SQRT(rij) - IF (rij .LE. pair_radii(ikind, jkind)) THEN + IF (rij <= pair_radii(ikind, jkind)) THEN ! jatom is in iatom's halo nhalo_atoms = nhalo_atoms + 1 halo_atoms(nhalo_atoms) = jatom diff --git a/src/qs_fb_atomic_matrix_methods.F b/src/qs_fb_atomic_matrix_methods.F index ae82280e95..d64063b612 100644 --- a/src/qs_fb_atomic_matrix_methods.F +++ b/src/qs_fb_atomic_matrix_methods.F @@ -84,9 +84,9 @@ CONTAINS CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & natoms=natoms_in_halo, & halo_atoms=halo_atoms) - check_ok = SIZE(blk_row_start) .GE. (natoms_in_halo + 1) + check_ok = SIZE(blk_row_start) >= (natoms_in_halo + 1) CPASSERT(check_ok) - check_ok = SIZE(blk_col_start) .GE. (natoms_in_halo + 1) + check_ok = SIZE(blk_col_start) >= (natoms_in_halo + 1) CPASSERT(check_ok) blk_row_start = 0 blk_col_start = 0 @@ -378,7 +378,7 @@ CONTAINS jatom_global = halo_atoms(jatom) ! atomic matrices are symmetric, fill only the top ! triangular part - IF (jatom_global .GE. iatom_global) THEN + IF (jatom_global >= iatom_global) THEN CALL fb_matrix_data_get(matrix_storage, & iatom_global, & jatom_global, & @@ -494,7 +494,7 @@ CONTAINS jatom_global = halo_atoms(jatom) ! atomic matrix is symmetric, and only upper triangular part ! is stored in DBCSR matrix - IF (jatom_global .GE. iatom_global) THEN + IF (jatom_global >= iatom_global) THEN ! find the source proc that supposed to own the block ! (iatom_global, jatom_global) CALL dbcsr_get_stored_coordinates(dbcsr_mat, & @@ -564,12 +564,12 @@ CONTAINS ! we can do this here, because essencially we are inspecting ! the send tasks one by one, and then omit ones which the ! block is not found in the DBCSR matrix. itask is always - ! .GE. counter + ! >= counter tasks_send(1:TASK_N_RECORDS, counter) = tasks_send(1:TASK_N_RECORDS, itask) END IF END DO ! the new send task list should have size counter. counter - ! .LE. the old ntasks_send, thus the task list does not really + ! <= the old ntasks_send, thus the task list does not really ! need to be reallocated (as it is just a temporary array), and ! the useful data will cutoff at counter, and the rest of the ! array will just be garbage @@ -691,7 +691,7 @@ CONTAINS jatom_global = halo_atoms(jatom) ! atomic matrices are always symmetric, treat it as such. ! so only deal with upper triangular parts - IF (jatom_global .GE. iatom_global) THEN + IF (jatom_global >= iatom_global) THEN ! find the source proc that supposed to own the block ! (iatom_global, jatom_global) CALL dbcsr_get_stored_coordinates(dbcsr_mat, & @@ -761,12 +761,12 @@ CONTAINS ! we can do this here, because essencially we are inspecting ! the send tasks one by one, and then omit ones which the ! block is not found in the DBCSR matrix. itask is always - ! .GE. counter + ! >= counter tasks_send(1:TASK_N_RECORDS, counter) = tasks_send(1:TASK_N_RECORDS, itask) END IF END DO ! the new send task list should have size counter. counter - ! .LE. the old ntasks_send, thus the task list does not really + ! <= the old ntasks_send, thus the task list does not really ! need to be reallocated (as it is just a temporary array), and ! the useful data will cutoff at counter, and the rest of the ! array will just be garbage diff --git a/src/qs_fb_buffer_types.F b/src/qs_fb_buffer_types.F index 197c54e348..754246911b 100644 --- a/src/qs_fb_buffer_types.F +++ b/src/qs_fb_buffer_types.F @@ -276,7 +276,7 @@ CONTAINS END IF ! copy data IF (PRESENT(data_1d)) THEN - check_ok = SIZE(data_1d) .GE. my_max_size .AND. & + check_ok = SIZE(data_1d) >= my_max_size .AND. & PRESENT(sizes) CPASSERT(check_ok) buffer%obj%data_1d(1:my_ndata) = data_1d(1:my_ndata) @@ -304,14 +304,14 @@ CONTAINS new_n = buffer%obj%n + 1 new_data_size = buffer%obj%disps(new_n) + this_size ! resize when needed - IF (SIZE(buffer%obj%disps) .LT. new_n + 1) THEN + IF (SIZE(buffer%obj%disps) < new_n + 1) THEN ALLOCATE (new_disps(new_n*2)) new_disps = 0 new_disps(1:buffer%obj%n + 1) = buffer%obj%disps(1:buffer%obj%n + 1) DEALLOCATE (buffer%obj%disps) buffer%obj%disps => new_disps END IF - IF (SIZE(buffer%obj%data_1d) .LT. new_data_size) THEN + IF (SIZE(buffer%obj%data_1d) < new_data_size) THEN ALLOCATE (new_data(new_data_size*2)) new_data = 0 new_data(1:buffer%obj%disps(new_n)) = & @@ -339,7 +339,7 @@ CONTAINS INTEGER :: ii - CPASSERT(SIZE(sizes) .GE. buffer%obj%n) + CPASSERT(SIZE(sizes) >= buffer%obj%n) buffer%obj%disps(1) = 0 DO ii = 2, buffer%obj%n + 1 buffer%obj%disps(ii) = buffer%obj%disps(ii - 1) + sizes(ii - 1) @@ -358,7 +358,7 @@ CONTAINS INTEGER :: ii - CPASSERT(SIZE(sizes) .GE. buffer%obj%n) + CPASSERT(SIZE(sizes) >= buffer%obj%n) DO ii = 1, buffer%obj%n sizes(ii) = buffer%obj%disps(ii + 1) - buffer%obj%disps(ii) END DO @@ -407,12 +407,12 @@ CONTAINS CALL fb_buffer_calc_sizes(buffer, sizes) END IF IF (PRESENT(disps)) THEN - CPASSERT(SIZE(disps) .GE. buffer%obj%n) + CPASSERT(SIZE(disps) >= buffer%obj%n) disps(1:buffer%obj%n) = buffer%obj%disps(1:buffer%obj%n) END IF IF (PRESENT(data_1d)) THEN IF (PRESENT(i_slice)) THEN - CPASSERT(i_slice .LE. buffer%obj%n) + CPASSERT(i_slice <= buffer%obj%n) data_1d => buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: & buffer%obj%disps(i_slice + 1)) ELSE @@ -593,7 +593,7 @@ CONTAINS END IF ! copy data IF (PRESENT(data_1d)) THEN - check_ok = SIZE(data_1d) .GE. my_max_size .AND. & + check_ok = SIZE(data_1d) >= my_max_size .AND. & PRESENT(sizes) CPASSERT(check_ok) buffer%obj%data_1d(1:my_ndata) = data_1d(1:my_ndata) @@ -622,14 +622,14 @@ CONTAINS new_n = buffer%obj%n + 1 new_data_size = buffer%obj%disps(new_n) + this_size ! resize when needed - IF (SIZE(buffer%obj%disps) .LT. new_n + 1) THEN + IF (SIZE(buffer%obj%disps) < new_n + 1) THEN ALLOCATE (new_disps(new_n*2)) new_disps = 0 new_disps(1:buffer%obj%n + 1) = buffer%obj%disps(1:buffer%obj%n + 1) DEALLOCATE (buffer%obj%disps) buffer%obj%disps => new_disps END IF - IF (SIZE(buffer%obj%data_1d) .LT. new_data_size) THEN + IF (SIZE(buffer%obj%data_1d) < new_data_size) THEN ALLOCATE (new_data(new_data_size*2)) new_data = 0.0_dp new_data(1:buffer%obj%disps(new_n)) = & @@ -657,7 +657,7 @@ CONTAINS INTEGER :: ii - CPASSERT(SIZE(sizes) .GE. buffer%obj%n) + CPASSERT(SIZE(sizes) >= buffer%obj%n) buffer%obj%disps(1) = 0 DO ii = 2, buffer%obj%n + 1 buffer%obj%disps(ii) = buffer%obj%disps(ii - 1) + sizes(ii - 1) @@ -676,7 +676,7 @@ CONTAINS INTEGER :: ii - CPASSERT(SIZE(sizes) .GE. buffer%obj%n) + CPASSERT(SIZE(sizes) >= buffer%obj%n) DO ii = 1, buffer%obj%n sizes(ii) = buffer%obj%disps(ii + 1) - buffer%obj%disps(ii) END DO @@ -725,12 +725,12 @@ CONTAINS CALL fb_buffer_calc_sizes(buffer, sizes) END IF IF (PRESENT(disps)) THEN - CPASSERT(SIZE(disps) .GE. buffer%obj%n) + CPASSERT(SIZE(disps) >= buffer%obj%n) disps(1:buffer%obj%n) = buffer%obj%disps(1:buffer%obj%n) END IF IF (PRESENT(data_1d)) THEN IF (PRESENT(i_slice)) THEN - CPASSERT(i_slice .LE. buffer%obj%n) + CPASSERT(i_slice <= buffer%obj%n) data_1d => buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: & buffer%obj%disps(i_slice + 1)) ELSE diff --git a/src/qs_fb_distribution_methods.F b/src/qs_fb_distribution_methods.F index a22da22f74..f032e3133f 100644 --- a/src/qs_fb_distribution_methods.F +++ b/src/qs_fb_distribution_methods.F @@ -250,7 +250,7 @@ CONTAINS ! to the average cost lowest_cost_ind = 1 DO ipe = nprocs, 1, -1 - redistribute: DO WHILE (dist(pe(ipe))%cost .GT. average_cost) + redistribute: DO WHILE (dist(pe(ipe))%cost > average_cost) iatom = dist(pe(ipe))%list(lowest_cost_ind)%id move_happened = .FALSE. ! first try to move to a preferred process @@ -261,7 +261,7 @@ CONTAINS dist(pe(ipe))%list(lowest_cost_ind), & dist(pref_pe), & average_cost) - IF ((pref_pe .NE. pe(ipe)) .AND. acceptable_move) THEN + IF ((pref_pe /= pe(ipe)) .AND. acceptable_move) THEN CALL fb_distribution_move(dist(pe(ipe)), & lowest_cost_ind, & dist(pref_pe)) @@ -281,7 +281,7 @@ CONTAINS dist(pe(ipe))%list(lowest_cost_ind), & dist(pe(ii)), & average_cost) - IF ((pe(ii) .NE. pe(ipe)) .AND. acceptable_move) THEN + IF ((pe(ii) /= pe(ipe)) .AND. acceptable_move) THEN CALL fb_distribution_move(dist(pe(ipe)), & lowest_cost_ind, & dist(pe(ii))) @@ -360,8 +360,8 @@ CONTAINS REAL(KIND=dp), INTENT(IN) :: threshold LOGICAL :: acceptable - acceptable = (dist_to%cost + element%cost .LT. dist_from%cost) .AND. & - (dist_to%cost .LT. threshold) + acceptable = (dist_to%cost + element%cost < dist_from%cost) .AND. & + (dist_to%cost < threshold) END FUNCTION fb_distribution_acceptable_move ! ************************************************************************************************** @@ -523,9 +523,9 @@ CONTAINS n_procs = SIZE(dist_set) - check_ok = SIZE(local_atoms_starts) .GE. n_procs + check_ok = SIZE(local_atoms_starts) >= n_procs CPASSERT(check_ok) - check_ok = SIZE(local_atoms_sizes) .GE. n_procs + check_ok = SIZE(local_atoms_sizes) >= n_procs CPASSERT(check_ok) local_atoms(:) = 0 @@ -561,7 +561,7 @@ CONTAINS DEALLOCATE (dist%list) END IF NULLIFY (dist%list) - IF (my_nmax .GT. 0) THEN + IF (my_nmax > 0) THEN ALLOCATE (dist%list(my_nmax)) DO ii = 1, SIZE(dist%list) dist%list(ii)%id = 0 @@ -621,7 +621,7 @@ CONTAINS ! resize list if necessary IF (.NOT. ASSOCIATED(dist%list)) THEN CALL fb_distribution_resize(dist, new_nelements) - ELSE IF (new_nelements*ENLARGE_RATIO .GT. SIZE(dist%list)) THEN + ELSE IF (new_nelements*ENLARGE_RATIO > SIZE(dist%list)) THEN CALL fb_distribution_resize(dist, SIZE(dist%list)*EXPAND_FACTOR) END IF ! assuming the list of elements is always sorted with respect to cost @@ -655,19 +655,19 @@ CONTAINS INTEGER :: lower, middle, N, upper N = dist%nelements - IF (element%cost .LT. dist%list(1)%cost) THEN + IF (element%cost < dist%list(1)%cost) THEN pos = 1 RETURN END IF - IF (element%cost .GE. dist%list(N)%cost) THEN + IF (element%cost >= dist%list(N)%cost) THEN pos = N + 1 RETURN END IF lower = 1 upper = N - DO WHILE ((upper - lower) .GT. 1) + DO WHILE ((upper - lower) > 1) middle = (lower + upper)/2 - IF (element%cost .LT. dist%list(middle)%cost) THEN + IF (element%cost < dist%list(middle)%cost) THEN upper = middle ELSE lower = middle @@ -689,9 +689,9 @@ CONTAINS INTEGER :: ii LOGICAL :: check_ok - check_ok = pos .GT. 0 + check_ok = pos > 0 CPASSERT(check_ok) - IF (pos .LE. dist%nelements) THEN + IF (pos <= dist%nelements) THEN dist%cost = dist%cost - dist%list(pos)%cost DO ii = pos, dist%nelements - 1 dist%list(ii) = dist%list(ii + 1) @@ -700,7 +700,7 @@ CONTAINS dist%list(dist%nelements)%cost = 0.0_dp dist%nelements = dist%nelements - 1 ! auto resize if required - IF (dist%nelements*REDUCE_RATIO .LT. SIZE(dist%list)) THEN + IF (dist%nelements*REDUCE_RATIO < SIZE(dist%list)) THEN CALL fb_distribution_resize(dist, dist%nelements/SHRINK_FACTOR) END IF END IF @@ -745,7 +745,7 @@ CONTAINS check_ok = ASSOCIATED(dist_from%list) CPASSERT(check_ok) - check_ok = pos .LE. dist_from%nelements + check_ok = pos <= dist_from%nelements CPASSERT(check_ok) element = dist_from%list(pos) CALL fb_distribution_add(dist_to, element) diff --git a/src/qs_fb_env_methods.F b/src/qs_fb_env_methods.F index 0256a730da..a043b1a834 100644 --- a/src/qs_fb_env_methods.F +++ b/src/qs_fb_env_methods.F @@ -627,10 +627,10 @@ CONTAINS ndep = 0 ! first, obtain orthogonalisation (ortho) matrix - IF (my_method .NE. cholesky_off) THEN + IF (my_method /= cholesky_off) THEN CALL cp_fm_to_fm(fm_S, fm_ortho) CALL cp_fm_cholesky_decompose(fm_ortho, info_out=info) - IF (info .NE. 0) THEN + IF (info /= 0) THEN CALL cp_warn(__LOCATION__, & "Unable to perform Cholesky decomposition on the overlap "// & "matrix. The new filtered basis may not be linearly "// & @@ -1028,7 +1028,7 @@ CONTAINS DO ico = ncoset(lshell - 1) + 1, ncoset(lshell) counter = counter + 1 ! only include the first zeta orbitals - IF ((lshell .GT. old_lshell) .AND. (counter .LE. nco(lshell))) THEN + IF ((lshell > old_lshell) .AND. (counter <= nco(lshell))) THEN nfunctions(ikind) = nfunctions(ikind) + 1 END IF END DO @@ -1036,8 +1036,8 @@ CONTAINS ! basis functions to accommodate the number of electrons, ! AND that that we have included all the first zeta ! orbitals of an angular momentum quantum number l - IF (((lshell .GT. old_lshell) .OR. (lshell .EQ. lmax(iset))) .AND. & - (maxocc*REAL(nfunctions(ikind), dp) .GE. zeff)) THEN + IF (((lshell > old_lshell) .OR. (lshell == lmax(iset))) .AND. & + (maxocc*REAL(nfunctions(ikind), dp) >= zeff)) THEN EXIT bset1 END IF old_lshell = lshell @@ -1072,7 +1072,7 @@ CONTAINS icgf = icgf + 1 counter = counter + 1 ! only include the first zeta orbitals - IF ((lshell .GT. old_lshell) .AND. (counter .LE. nco(lshell))) THEN + IF ((lshell > old_lshell) .AND. (counter <= nco(lshell))) THEN itrial = itrial + 1 functions(itrial, ikind) = icgf END IF @@ -1082,8 +1082,8 @@ CONTAINS ! from atomic z), AND that that we have included all the ! first zeta orbitals of an angular momentum quantum ! number l - IF (((lshell .GT. old_lshell) .OR. (lshell .EQ. lmax(iset))) .AND. & - (maxocc*REAL(itrial, dp) .GE. zeff)) THEN + IF (((lshell > old_lshell) .OR. (lshell == lmax(iset))) .AND. & + (maxocc*REAL(itrial, dp) >= zeff)) THEN EXIT bset2 END IF old_lshell = lshell diff --git a/src/qs_fb_filter_matrix_methods.F b/src/qs_fb_filter_matrix_methods.F index 15ddcdc1f7..e04b55c520 100644 --- a/src/qs_fb_filter_matrix_methods.F +++ b/src/qs_fb_filter_matrix_methods.F @@ -1315,7 +1315,7 @@ CONTAINS atomic_S_copy, mat_dim, eigenvalues, & work, work_array_size, info) ! check if diagonalisation is successful - IF (info .NE. 0) THEN + IF (info /= 0) THEN WRITE (*, *) "DSYGV ERROR MESSAGE: ", info CPABORT("DSYGV failed") END IF diff --git a/src/qs_fb_hash_table_types.F b/src/qs_fb_hash_table_types.F index 9ff3c9e437..715f725f88 100644 --- a/src/qs_fb_hash_table_types.F +++ b/src/qs_fb_hash_table_types.F @@ -113,7 +113,7 @@ CONTAINS check_ok = fb_hash_table_has_data(hash_table) CPASSERT(check_ok) ! check hash table size, if too small rehash in a larger table - IF (hash_table%obj%nelements*ENLARGE_RATIO .GE. & + IF (hash_table%obj%nelements*ENLARGE_RATIO >= & hash_table%obj%nmax) THEN CALL fb_hash_table_rehash(hash_table=hash_table, & nmax=hash_table%obj%nmax*EXPAND_FACTOR) @@ -224,12 +224,12 @@ CONTAINS ! table length should always be power of 2. Find the least ! power that is greater or equal to my_nmax power = 0 - DO WHILE (2**power .LT. my_nmax) + DO WHILE (2**power < my_nmax) power = power + 1 END DO my_nmax = 2**power IF (ASSOCIATED(hash_table%obj%table)) THEN - IF (SIZE(hash_table%obj%table) .NE. my_nmax) THEN + IF (SIZE(hash_table%obj%table) /= my_nmax) THEN DEALLOCATE (hash_table%obj%table) ALLOCATE (hash_table%obj%table(my_nmax)) END IF @@ -287,7 +287,7 @@ CONTAINS CALL fb_hash_table_create(hash_table=hash_table, & nmax=my_nmax) DO ii = 1, SIZE(tmp_table) - IF (tmp_table(ii)%key .NE. EMPTY_KEY) THEN + IF (tmp_table(ii)%key /= EMPTY_KEY) THEN CALL fb_hash_table_add(hash_table=hash_table, & key=tmp_table(ii)%key, & val=tmp_table(ii)%val) @@ -337,7 +337,7 @@ CONTAINS hash_table%obj%nelements = hash_table%obj%nelements - 1 ! must rehash after setting a filled slot to empty, otherwise the ! table will not work. Automatic resize if required - IF (hash_table%obj%nelements*REDUCE_RATIO .LT. & + IF (hash_table%obj%nelements*REDUCE_RATIO < & hash_table%obj%nmax) THEN CALL fb_hash_table_rehash(hash_table=hash_table, & nmax=hash_table%obj%nmax/SHRINK_FACTOR) diff --git a/src/qs_fb_matrix_data_types.F b/src/qs_fb_matrix_data_types.F index 593d969f8b..7d9f9fe0ba 100644 --- a/src/qs_fb_matrix_data_types.F +++ b/src/qs_fb_matrix_data_types.F @@ -113,7 +113,7 @@ CONTAINS matrix_data%obj%nblks = old_nblks + 1 ii = matrix_data%obj%nblks ! resize lds if necessary - IF (SIZE(matrix_data%obj%lds) .LT. ii) THEN + IF (SIZE(matrix_data%obj%lds) < ii) THEN ALLOCATE (new_lds(ii*EXPAND_FACTOR)) new_lds = 0 new_lds(1:old_nblks) = matrix_data%obj%lds(1:old_nblks) @@ -311,8 +311,8 @@ CONTAINS IF (PRESENT(nblks)) nblks = matrix_data%obj%nblks IF (PRESENT(nencode)) nencode = matrix_data%obj%nencode IF (PRESENT(blk_sizes)) THEN - check_ok = (SIZE(blk_sizes, 1) .GE. matrix_data%obj%nblks .AND. & - SIZE(blk_sizes, 2) .GE. 2) + check_ok = (SIZE(blk_sizes, 1) >= matrix_data%obj%nblks .AND. & + SIZE(blk_sizes, 2) >= 2) CPASSERT(check_ok) blk_sizes(:, :) = 0 ALLOCATE (buffer_sizes(matrix_data%obj%nblks)) diff --git a/src/qs_gapw_densities.F b/src/qs_gapw_densities.F index 853fb22fe6..3e165964de 100644 --- a/src/qs_gapw_densities.F +++ b/src/qs_gapw_densities.F @@ -184,8 +184,8 @@ CONTAINS CALL put_rho0_on_grid(qs_env, rho0_mpole, tot_rs_int) END IF - IF (ABS(rho0_h_tot) .GE. 1.0E-5_dp) THEN - IF (ABS(1.0_dp - ABS(tot_rs_int/rho0_h_tot)) .GT. 1.0E-3_dp) THEN + IF (ABS(rho0_h_tot) >= 1.0E-5_dp) THEN + IF (ABS(1.0_dp - ABS(tot_rs_int/rho0_h_tot)) > 1.0E-3_dp) THEN IF (output_unit > 0) THEN WRITE (output_unit, '(/,72("*"))') WRITE (output_unit, '(T2,A,T66,1E20.8)') & @@ -202,8 +202,8 @@ CONTAINS IF (rho0_mpole%do_cneo) THEN ! put soft tails of quantum nuclear charge densities on the global grid CALL put_rhoz_cneo_s_on_grid(qs_env, rho0_mpole, rhoz_cneo_set, tot_rs_int) - IF (ABS(rho0_mpole%tot_rhoz_cneo_s) .GE. 1.0E-5_dp) THEN - IF (ABS(1.0_dp - ABS(tot_rs_int/rho0_mpole%tot_rhoz_cneo_s)) .GT. 1.0E-3_dp) THEN + IF (ABS(rho0_mpole%tot_rhoz_cneo_s) >= 1.0E-5_dp) THEN + IF (ABS(1.0_dp - ABS(tot_rs_int/rho0_mpole%tot_rhoz_cneo_s)) > 1.0E-3_dp) THEN IF (output_unit > 0) THEN WRITE (output_unit, '(/,72("*"))') WRITE (output_unit, '(T2,A,T66,1E20.8)') & diff --git a/src/qs_harmonics_atom.F b/src/qs_harmonics_atom.F index 98bc55ce59..858ebda547 100644 --- a/src/qs_harmonics_atom.F +++ b/src/qs_harmonics_atom.F @@ -464,11 +464,11 @@ CONTAINS INTEGER :: iso, iso1, iso2, l1, l2, nlist - CPASSERT(nsoset(lmax1) .LE. SIZE(cgc, 2)) - CPASSERT(nsoset(lmax2) .LE. SIZE(cgc, 3)) - CPASSERT(max_s_harm .LE. SIZE(cgc, 4)) + CPASSERT(nsoset(lmax1) <= SIZE(cgc, 2)) + CPASSERT(nsoset(lmax2) <= SIZE(cgc, 3)) + CPASSERT(max_s_harm <= SIZE(cgc, 4)) IF (PRESENT(n_list) .AND. PRESENT(list)) THEN - CPASSERT(max_s_harm .LE. SIZE(list, 3)) + CPASSERT(max_s_harm <= SIZE(list, 3)) END IF max_iso_not0 = 0 IF (PRESENT(n_list) .AND. PRESENT(list)) n_list = 0 @@ -522,11 +522,11 @@ CONTAINS INTEGER :: iso, iso1, iso2, l1, l2, nlist - CPASSERT(nsoset(lmax1) .LE. SIZE(cgc, 1)) - CPASSERT(nsoset(lmax2) .LE. SIZE(cgc, 2)) - CPASSERT(max_s_harm .LE. SIZE(cgc, 3)) + CPASSERT(nsoset(lmax1) <= SIZE(cgc, 1)) + CPASSERT(nsoset(lmax2) <= SIZE(cgc, 2)) + CPASSERT(max_s_harm <= SIZE(cgc, 3)) IF (PRESENT(n_list) .AND. PRESENT(list)) THEN - CPASSERT(max_s_harm .LE. SIZE(list, 3)) + CPASSERT(max_s_harm <= SIZE(list, 3)) END IF max_iso_not0 = 0 IF (PRESENT(n_list) .AND. PRESENT(list)) n_list = 0 diff --git a/src/qs_hash_table_functions.F b/src/qs_hash_table_functions.F index ed08036b12..a858df7dab 100644 --- a/src/qs_hash_table_functions.F +++ b/src/qs_hash_table_functions.F @@ -53,7 +53,7 @@ CONTAINS INTEGER :: ii - IF (num .LE. 3) THEN + IF (num <= 3) THEN res = .FALSE. RETURN END IF @@ -66,7 +66,7 @@ CONTAINS ! (although not all 6*kk +/- 1 is a prime); ! and we only have to check factors less than and equal to SQRT(num) ii = 5 - DO WHILE (ii*ii .LE. num) + DO WHILE (ii*ii <= num) IF (MOD(num, ii) == 0 .OR. MOD(num, ii + 2) == 0) THEN res = .FALSE. RETURN diff --git a/src/qs_initial_guess.F b/src/qs_initial_guess.F index 4d9bf146b4..4170da6362 100644 --- a/src/qs_initial_guess.F +++ b/src/qs_initial_guess.F @@ -826,7 +826,7 @@ CONTAINS DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, irow, icol, pdata) ikind = kind_of(irow) - IF (icol .EQ. irow) THEN + IF (icol == irow) THEN IF (ispin == 1) THEN pdata(:, :) = pmat(ikind)%mat(:, :, 1)*rscale + & pmat(ikind)%mat(:, :, 2)*rscale @@ -906,11 +906,11 @@ CONTAINS ! ! compute the "potential" nbr of states for this atom n_cols = MAX(INT(REAL(nmo_tmp, dp)/REAL(natoms_tmp, dp)), 1) - IF (n_cols .GT. n_rows) n_cols = n_rows + IF (n_cols > n_rows) n_cols = n_rows ! nmo_tmp = nmo_tmp - n_cols natoms_tmp = natoms_tmp - 1 - IF (nmo_tmp .LT. 0 .OR. natoms_tmp .LT. 0) THEN + IF (nmo_tmp < 0 .OR. natoms_tmp < 0) THEN CPABORT("Wrong1!") END IF DO j = 1, n_cols @@ -922,7 +922,7 @@ CONTAINS END DO END DO - IF (istart_col .LE. nmo) THEN + IF (istart_col <= nmo) THEN CPABORT("Wrong2!") END IF @@ -932,7 +932,7 @@ CONTAINS ALLOCATE (buff(nao, 1), buff2(nao, 1)) DO i = 1, nmo CALL cp_fm_get_submatrix(mo_coeff, buff, 1, i, nao, 1) - IF (SUM(buff**2) .LT. 1E-10_dp) THEN + IF (SUM(buff**2) < 1E-10_dp) THEN WRITE (*, *) 'wrong', i, SUM(buff**2) END IF length = SQRT(DOT_PRODUCT(buff(:, 1), buff(:, 1))) @@ -941,13 +941,13 @@ CONTAINS CALL cp_fm_get_submatrix(mo_coeff, buff2, 1, j, nao, 1) length = SQRT(DOT_PRODUCT(buff2(:, 1), buff2(:, 1))) buff2(:, :) = buff2(:, :)/length - IF (ABS(DOT_PRODUCT(buff(:, 1), buff2(:, 1)) - 1.0_dp) .LT. 1E-10_dp) THEN + IF (ABS(DOT_PRODUCT(buff(:, 1), buff2(:, 1)) - 1.0_dp) < 1E-10_dp) THEN WRITE (*, *) 'wrong2', i, j, DOT_PRODUCT(buff(:, 1), buff2(:, 1)) DO ikind = 1, nao - IF (ABS(mo_coeff%local_data(ikind, i)) .GT. 1e-10_dp) THEN + IF (ABS(mo_coeff%local_data(ikind, i)) > 1e-10_dp) THEN WRITE (*, *) 'c1', ikind, mo_coeff%local_data(ikind, i) END IF - IF (ABS(mo_coeff%local_data(ikind, j)) .GT. 1e-10_dp) THEN + IF (ABS(mo_coeff%local_data(ikind, j)) > 1e-10_dp) THEN WRITE (*, *) 'c2', ikind, mo_coeff%local_data(ikind, j) END IF END DO @@ -1163,7 +1163,7 @@ CONTAINS DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, irow, icol, block) ikind = kind_of(irow) - IF (icol .EQ. irow) block(:, :) = fmat(ikind)%mat(:, :, 1) + IF (icol == irow) block(:, :) = fmat(ikind)%mat(:, :, 1) END DO CALL dbcsr_iterator_stop(iter) diff --git a/src/qs_integrate_potential_product.F b/src/qs_integrate_potential_product.F index a0a096d35e..a5ac2d6360 100644 --- a/src/qs_integrate_potential_product.F +++ b/src/qs_integrate_potential_product.F @@ -284,7 +284,7 @@ CONTAINS jpgf = tasks(itask)%jpgf ! At the start of a block of tasks, get atom data (and kind data, if needed) - IF (itask .EQ. task_list%taskstart(ipair, igrid_level)) THEN + IF (itask == task_list%taskstart(ipair, igrid_level)) THEN ikind = particle_set(iatom)%atomic_kind%kind_number jkind = particle_set(jatom)%atomic_kind%kind_number @@ -299,7 +299,7 @@ CONTAINS bcol = iatom END IF - IF (ikind .NE. ikind_old) THEN + IF (ikind /= ikind_old) THEN CALL get_qs_kind(qs_kind_set(ikind), & basis_set=orb_basis_set, basis_type="ORB") @@ -316,7 +316,7 @@ CONTAINS zet=zeta) END IF - IF (jkind .NE. jkind_old) THEN + IF (jkind /= jkind_old) THEN CALL get_qs_kind(qs_kind_set(jkind), & basis_set=orb_basis_set, basis_type="ORB") CALL get_gto_basis_set(gto_basis_set=orb_basis_set, & @@ -354,7 +354,7 @@ CONTAINS END IF - IF (atom_pair_changed .OR. iset_old .NE. iset .OR. jset_old .NE. jset) THEN + IF (atom_pair_changed .OR. iset_old /= iset .OR. jset_old /= jset) THEN ncoa = npgfa(iset)*ncoset(la_max(iset)) sgfa = first_sgfa(1, iset) @@ -407,7 +407,7 @@ CONTAINS ! check whether we need to use fawzi's generalised collocation scheme IF (rs_rho(igrid_level)%desc%distributed) THEN !tasks(4,:) is 0 for replicated, 1 for distributed 2 for exceptional distributed tasks - IF (tasks(itask)%dist_type .EQ. 2) THEN + IF (tasks(itask)%dist_type == 2) THEN use_subpatch = .TRUE. ELSE use_subpatch = .FALSE. @@ -478,7 +478,7 @@ CONTAINS jset_new = tasks(itask + 1)%jset ipgf_new = tasks(itask + 1)%ipgf jpgf_new = tasks(itask + 1)%jpgf - IF (iset_new .NE. iset .OR. jset_new .NE. jset) THEN + IF (iset_new /= iset .OR. jset_new /= jset) THEN new_set_pair_coming = .TRUE. END IF ELSE diff --git a/src/qs_ks_atom.F b/src/qs_ks_atom.F index 6d3f23452b..4bddcf3a3d 100644 --- a/src/qs_ks_atom.F +++ b/src/qs_ks_atom.F @@ -432,7 +432,7 @@ CONTAINS IF (ALL(cell_b + alist_bc%clist(kbc)%cell - alist_ac%clist(kac)%cell == 0)) THEN n_cont_a = alist_ac%clist(kac)%nsgf_cnt n_cont_b = alist_bc%clist(kbc)%nsgf_cnt - IF (n_cont_a .EQ. 0 .OR. n_cont_b .EQ. 0) CYCLE + IF (n_cont_a == 0 .OR. n_cont_b == 0) CYCLE list_a => alist_ac%clist(kac)%sgf_list list_b => alist_bc%clist(kbc)%sgf_list diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index 12662de2b8..febf57e2ab 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -336,7 +336,7 @@ CONTAINS ! gets the tmp grids CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, poisson_env=poisson_env) - IF (gapw .AND. (poisson_env%parameters%solver .EQ. pw_poisson_implicit)) THEN + IF (gapw .AND. (poisson_env%parameters%solver == pw_poisson_implicit)) THEN CPABORT("The implicit Poisson solver cannot be used in conjunction with GAPW.") END IF @@ -354,7 +354,7 @@ CONTAINS "PRINT%DETAILED_ENERGY"), & cp_p_file) .AND. & (.NOT. gapw) .AND. (.NOT. gapw_xc) .AND. & - (.NOT. (poisson_env%parameters%solver .EQ. pw_poisson_implicit))) THEN + (.NOT. (poisson_env%parameters%solver == pw_poisson_implicit))) THEN CALL pw_zero(rho_tot_gspace) CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, skip_nuclear_density=.TRUE.) CALL pw_poisson_solve(poisson_env, rho_tot_gspace, energy%e_hartree, & @@ -376,7 +376,7 @@ CONTAINS ALLOCATE (v_sccs_rspace) CALL auxbas_pw_pool%create_pw(v_sccs_rspace) - IF (poisson_env%parameters%solver .EQ. pw_poisson_implicit) THEN + IF (poisson_env%parameters%solver == pw_poisson_implicit) THEN CPABORT("The implicit Poisson solver cannot be used together with SCCS.") END IF @@ -662,7 +662,7 @@ CONTAINS IF (.NOT. just_energy) THEN IF (calculate_forces) THEN ! Getting nuclear force contribution from the core charge density - IF ((poisson_env%parameters%solver .EQ. pw_poisson_implicit) .AND. & + IF ((poisson_env%parameters%solver == pw_poisson_implicit) .AND. & (poisson_env%parameters%dielectric_params%dielec_core_correction)) THEN BLOCK TYPE(pw_r3d_rs_type) :: v_minus_veps @@ -1375,8 +1375,8 @@ CONTAINS IF (is_complex) THEN IF (.NOT. ASSOCIATED(matrixkp_im_ks)) THEN - CPASSERT(nspins .EQ. SIZE(matrixkp_ks, 1)) - CPASSERT(nimages .EQ. SIZE(matrixkp_ks, 2)) + CPASSERT(nspins == SIZE(matrixkp_ks, 1)) + CPASSERT(nimages == SIZE(matrixkp_ks, 2)) CALL dbcsr_allocate_matrix_set(matrixkp_im_ks, nspins, nimages) DO ispin = 1, nspins DO ic = 1, nimages diff --git a/src/qs_ks_utils.F b/src/qs_ks_utils.F index 2f7cde5e18..1e23e06cd5 100644 --- a/src/qs_ks_utils.F +++ b/src/qs_ks_utils.F @@ -500,7 +500,7 @@ CONTAINS TYPE(section_vals_type), POINTER :: input, xc_section TYPE(virial_type), POINTER :: virial - IF (dft_control%sic_method_id .NE. sic_eo) RETURN + IF (dft_control%sic_method_id /= sic_eo) RETURN CALL timeset(routineN, handle) @@ -1054,7 +1054,7 @@ CONTAINS END IF END IF IF (dft_control%do_admm) THEN - IF (psolver .EQ. pw_poisson_implicit) THEN + IF (psolver == pw_poisson_implicit) THEN implicit_ps_ehartree = pw_env%poisson_env%implicit_env%ehartree bc = pw_env%poisson_env%parameters%ps_implicit_params%boundary_condition SELECT CASE (bc) @@ -1091,7 +1091,7 @@ CONTAINS "Core Hamiltonian energy: ", energy%core, & "Hartree energy: ", energy%hartree ELSE - IF (psolver .EQ. pw_poisson_implicit) THEN + IF (psolver == pw_poisson_implicit) THEN implicit_ps_ehartree = pw_env%poisson_env%implicit_env%ehartree bc = pw_env%poisson_env%parameters%ps_implicit_params%boundary_condition SELECT CASE (bc) @@ -1403,7 +1403,7 @@ CONTAINS ! functional derivative of the Hartree energy wrt the density in the presence of dielectric ! (vhartree + v_eps); v_eps is nonzero only if the dielectric constant is defind as a function ! of the charge density - IF (poisson_env%parameters%solver .EQ. pw_poisson_implicit) THEN + IF (poisson_env%parameters%solver == pw_poisson_implicit) THEN dvol = poisson_env%implicit_env%v_eps%pw_grid%dvol CALL pw_axpy(poisson_env%implicit_env%v_eps, v_rspace_new(ispin), dvol) END IF @@ -1498,7 +1498,7 @@ CONTAINS CPASSERT(.NOT. dft_control%qs_control%ddapc_restraint_is_spin) DO ispin = 1, nspins ! extra contribution attributed to the dependency of the dielectric constant to the charge density - IF (poisson_env%parameters%solver .EQ. pw_poisson_implicit) THEN + IF (poisson_env%parameters%solver == pw_poisson_implicit) THEN dvol = poisson_env%implicit_env%v_eps%pw_grid%dvol CALL pw_axpy(poisson_env%implicit_env%v_eps, v_rspace, dvol) END IF @@ -1619,7 +1619,7 @@ CONTAINS ! Add potential to ks_matrix aux_fit, skip integration if no DFT correction - IF (admm_env%aux_exch_func .NE. do_admm_aux_exch_func_none) THEN + IF (admm_env%aux_exch_func /= do_admm_aux_exch_func_none) THEN !GPW by default. IF GAPW, then take relevant task list and basis CALL get_admm_env(admm_env, task_list_aux_fit=task_list) @@ -1840,9 +1840,9 @@ CONTAINS embed_corr_local = 0.0_dp ! Spin embedding potential in open-shell case - IF (dft_control%nspins .EQ. 2) THEN - IF (ispin .EQ. 1) CALL pw_axpy(qs_env%spin_embed_pot, v_rspace_embed(ispin), 1.0_dp) - IF (ispin .EQ. 2) CALL pw_axpy(qs_env%spin_embed_pot, v_rspace_embed(ispin), -1.0_dp) + IF (dft_control%nspins == 2) THEN + IF (ispin == 1) CALL pw_axpy(qs_env%spin_embed_pot, v_rspace_embed(ispin), 1.0_dp) + IF (ispin == 2) CALL pw_axpy(qs_env%spin_embed_pot, v_rspace_embed(ispin), -1.0_dp) END IF ! Integrate the density*potential embed_corr_local = pw_integral_ab(v_rspace_embed(ispin), rho_r(ispin)) diff --git a/src/qs_linres_atom_current.F b/src/qs_linres_atom_current.F index af132e597a..332d95b3a3 100644 --- a/src/qs_linres_atom_current.F +++ b/src/qs_linres_atom_current.F @@ -170,7 +170,7 @@ CONTAINS eps_cpc = dft_control%qs_control%gapw_control%eps_cpc idir2 = 1 - IF (idir .NE. iB) THEN + IF (idir /= iB) THEN CALL set_vecp_rev(idir, iB, idir2) END IF CALL set_vecp(iB, ii, iii) @@ -368,7 +368,7 @@ CONTAINS n_cont_b = alist_bc%clist(kbc)%nsgf_cnt sgf_soft_only_a = alist_ac%clist(kac)%sgf_soft_only sgf_soft_only_b = alist_bc%clist(kbc)%sgf_soft_only - IF (n_cont_a .EQ. 0 .OR. n_cont_b .EQ. 0) CYCLE + IF (n_cont_a == 0 .OR. n_cont_b == 0) CYCLE ! thanks to the linearity of the response, we ! can avoid computing soft-soft interactions. @@ -544,7 +544,7 @@ CONTAINS iatom = atom_list(iat) is_not_associated = .NOT. ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(1)%r_coef) - IF (iat .GE. bo(1) .AND. iat .LE. bo(2) .AND. is_not_associated) THEN + IF (iat >= bo(1) .AND. iat <= bo(2) .AND. is_not_associated) THEN CALL allocate_jrho_coeff(jrho1_atom_set, iatom, nsoctot) END IF @@ -754,7 +754,7 @@ CONTAINS ! step function gauge_h(1:nr) = 0e0_dp DO ir = 1, nr - IF (grid_atom%rad(ir) .LE. hard_radius) THEN + IF (grid_atom%rad(ir) <= hard_radius) THEN gauge_s(ir) = grid_atom%rad(ir) ELSE gauge_s(ir) = gauge_h(ir) @@ -775,10 +775,10 @@ CONTAINS DO iset2 = 1, nset CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) CALL get_none0_cg_list(my_CG_dxyz_asym, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, dacg_list, dacg_n_list, damax_iso_not0_local) - CPASSERT(damax_iso_not0_local .LE. damax_iso_not0) + CPASSERT(damax_iso_not0_local <= damax_iso_not0) n1s = nsoset(lmax(iset1)) DO ipgf1 = 1, npgf(iset1) @@ -814,9 +814,9 @@ CONTAINS dgg_1 = 0.0_dp ! ! Take only the terms of expansion for L < lmax_expansion - IF (lmin12 .LE. lmax_expansion) THEN + IF (lmin12 <= lmax_expansion) THEN ! - IF (lmax12 .GT. lmax_expansion) lmax12 = lmax_expansion + IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion ! IF (lmin12 == 0) THEN gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr) @@ -954,7 +954,7 @@ CONTAINS CPASSERT(iso2 > 0 .AND. iso1 > 0) ! l = indso(1, iso1) + indso(1, iso2) - IF (l .GT. lmax_expansion .OR. l .LT. .0) THEN + IF (l > lmax_expansion .OR. l < .0) THEN WRITE (*, *) 'calculate_jrho_atom_rad: 1 l', l WRITE (*, *) 'calculate_jrho_atom_rad: 1 lmax_expansion', lmax_expansion WRITE (*, *) '.... will stop!' @@ -963,7 +963,7 @@ CONTAINS !------------------------------------------------------------------ ! P0 ! - IF (current_env%gauge .EQ. current_gauge_atom) THEN + IF (current_env%gauge == current_gauge_atom) THEN ! Hard term Fr_h(1:nr, iso) = Fr_h(1:nr, iso) + & gg(1:nr, l)*cjc0_h_block(iso1, iso2)* & @@ -997,7 +997,7 @@ CONTAINS !------------------------------------------------------------------ ! Rci ! - IF (current_env%gauge .EQ. current_gauge_atom) THEN + IF (current_env%gauge == current_gauge_atom) THEN ! Hard term Fr_a_h_ii(1:nr, iso) = Fr_a_h_ii(1:nr, iso) + & dgg_1(1:nr, l)* & @@ -1023,7 +1023,7 @@ CONTAINS !------------------------------------------------------------------ ! Rbi ! - IF (current_env%gauge .EQ. current_gauge_atom) THEN + IF (current_env%gauge == current_gauge_atom) THEN ! Hard term Fr_a_h_iii(1:nr, iso) = Fr_a_h_iii(1:nr, iso) + & dgg_1(1:nr, l)* & @@ -1068,7 +1068,7 @@ CONTAINS CPASSERT(iso2 > 0 .AND. iso1 > 0) ! l = indso(1, iso1) + indso(1, iso2) - IF (l .GT. lmax_expansion) THEN + IF (l > lmax_expansion) THEN WRITE (*, *) 'calculate_jrho_atom_rad: 1 l', l WRITE (*, *) 'calculate_jrho_atom_rad: 1 lmax_expansion', lmax_expansion WRITE (*, *) '.... will stop!' @@ -1090,7 +1090,7 @@ CONTAINS !------------------------------------------------------------------ ! Dcij ! - IF (current_env%gauge .EQ. current_gauge_atom) THEN + IF (current_env%gauge == current_gauge_atom) THEN ! Hard term Fr_b_h_ii(1:nr, iso) = Fr_b_h_ii(1:nr, iso) + & gg_lm1(1:nr, l)* & @@ -1116,7 +1116,7 @@ CONTAINS !------------------------------------------------------------------ ! Dbij ! - IF (current_env%gauge .EQ. current_gauge_atom) THEN + IF (current_env%gauge == current_gauge_atom) THEN ! Hard term Fr_b_h_iii(1:nr, iso) = Fr_b_h_iii(1:nr, iso) + & gg_lm1(1:nr, l)* & @@ -1274,7 +1274,7 @@ CONTAINS ! scale = 0.0_dp idir2 = 1 - IF (idir .NE. iB) THEN + IF (idir /= iB) THEN CALL set_vecp_rev(idir, iB, idir2) scale = fac_vecp(idir, iB, idir2) END IF @@ -1361,7 +1361,7 @@ CONTAINS pra = point - ratom(:, iatom) pa = SQRT(pra(1)**2 + pra(2)**2 + pra(3)**2) DO jatom = 1, natm_gauge - IF (iatom .EQ. jatom) CYCLE + IF (iatom == jatom) CYCLE prb = point - ratom(:, jatom) pb = SQRT(prb(1)**2 + prb(2)**2 + prb(3)**2) ab = SQRT((pra(1) - prb(1))**2 + (pra(2) - prb(2))**2 + (pra(3) - prb(3))**2) @@ -1434,7 +1434,7 @@ CONTAINS jrho1_atom_set=jrho1_atom_set) do_igaim = .FALSE. - IF (current_env%gauge .EQ. current_gauge_atom) do_igaim = .TRUE. + IF (current_env%gauge == current_gauge_atom) do_igaim = .TRUE. gapw = dft_control%qs_control%gapw nkind = SIZE(qs_kind_set, 1) @@ -1467,8 +1467,8 @@ CONTAINS natm_gauge = 0 DO jatom = 1, natm_tot r(:) = pbc(particle_set(jatom)%r(:) - particle_set(iatom)%r(:), cell) - ! SQRT(SUM(r(:)**2)) .LE. 2.0_dp*hard_radius - IF (SUM(r(:)**2) .LE. (4.0_dp*hard_radius*hard_radius)) THEN + ! SQRT(SUM(r(:)**2)) <= 2.0_dp*hard_radius + IF (SUM(r(:)**2) <= (4.0_dp*hard_radius*hard_radius)) THEN natm_gauge = natm_gauge + 1 ratom(:, natm_gauge) = r(:) END IF diff --git a/src/qs_linres_current.F b/src/qs_linres_current.F index 75579615b9..ab120a12b2 100644 --- a/src/qs_linres_current.F +++ b/src/qs_linres_current.F @@ -650,7 +650,7 @@ CONTAINS ! ! Set pointers for the different gauge ! If do_igaim is False the current_env is never needed - do_igaim = current_env%gauge .EQ. current_gauge_atom + do_igaim = current_env%gauge == current_gauge_atom mat_a => mat_jp mat_b => mat_jp_rii @@ -677,7 +677,7 @@ CONTAINS ! scale2 = 0.0_dp idir2 = 1 - IF (idir .NE. iB) THEN + IF (idir /= iB) THEN CALL set_vecp_rev(idir, iB, idir2) scale2 = fac_vecp(idir, iB, idir2) END IF @@ -895,12 +895,12 @@ CONTAINS DO igrid_level = 1, gridlevel_info%ngrid_levels my_rho => rs_rho(igrid_level)%r my_current => rs_current(igrid_level)%r - IF (LBOUND(my_rho, 3) .NE. LBOUND(my_current, 3) .OR. & - LBOUND(my_rho, 2) .NE. LBOUND(my_current, 2) .OR. & - LBOUND(my_rho, 1) .NE. LBOUND(my_current, 1) .OR. & - UBOUND(my_rho, 3) .NE. UBOUND(my_current, 3) .OR. & - UBOUND(my_rho, 2) .NE. UBOUND(my_current, 2) .OR. & - UBOUND(my_rho, 1) .NE. UBOUND(my_current, 1)) THEN + IF (LBOUND(my_rho, 3) /= LBOUND(my_current, 3) .OR. & + LBOUND(my_rho, 2) /= LBOUND(my_current, 2) .OR. & + LBOUND(my_rho, 1) /= LBOUND(my_current, 1) .OR. & + UBOUND(my_rho, 3) /= UBOUND(my_current, 3) .OR. & + UBOUND(my_rho, 2) /= UBOUND(my_current, 2) .OR. & + UBOUND(my_rho, 1) /= UBOUND(my_current, 1)) THEN WRITE (*, *) 'LBOUND(my_rho,3),LBOUND(my_current,3)', LBOUND(my_rho, 3), LBOUND(my_current, 3) WRITE (*, *) 'LBOUND(my_rho,2),LBOUND(my_current,2)', LBOUND(my_rho, 2), LBOUND(my_current, 2) WRITE (*, *) 'LBOUND(my_rho,1),LBOUND(my_current,1)', LBOUND(my_rho, 1), LBOUND(my_current, 1) @@ -911,12 +911,12 @@ CONTAINS END IF my_gauge => rs_gauge(1, igrid_level)%r - IF (LBOUND(my_rho, 3) .NE. LBOUND(my_gauge, 3) .OR. & - LBOUND(my_rho, 2) .NE. LBOUND(my_gauge, 2) .OR. & - LBOUND(my_rho, 1) .NE. LBOUND(my_gauge, 1) .OR. & - UBOUND(my_rho, 3) .NE. UBOUND(my_gauge, 3) .OR. & - UBOUND(my_rho, 2) .NE. UBOUND(my_gauge, 2) .OR. & - UBOUND(my_rho, 1) .NE. UBOUND(my_gauge, 1)) THEN + IF (LBOUND(my_rho, 3) /= LBOUND(my_gauge, 3) .OR. & + LBOUND(my_rho, 2) /= LBOUND(my_gauge, 2) .OR. & + LBOUND(my_rho, 1) /= LBOUND(my_gauge, 1) .OR. & + UBOUND(my_rho, 3) /= UBOUND(my_gauge, 3) .OR. & + UBOUND(my_rho, 2) /= UBOUND(my_gauge, 2) .OR. & + UBOUND(my_rho, 1) /= UBOUND(my_gauge, 1)) THEN WRITE (*, *) 'LBOUND(my_rho,3),LBOUND(my_gauge,3)', LBOUND(my_rho, 3), LBOUND(my_gauge, 3) WRITE (*, *) 'LBOUND(my_rho,2),LBOUND(my_gauge,2)', LBOUND(my_rho, 2), LBOUND(my_gauge, 2) WRITE (*, *) 'LBOUND(my_rho,1),LBOUND(my_gauge,1)', LBOUND(my_rho, 1), LBOUND(my_gauge, 1) @@ -966,19 +966,19 @@ CONTAINS jpgf = tasks(itask)%jpgf ! apparently generalised collocation not implemented correctly yet - CPASSERT(tasks(itask)%dist_type .NE. 2) + CPASSERT(tasks(itask)%dist_type /= 2) - IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old) THEN + IF (iatom /= iatom_old .OR. jatom /= jatom_old) THEN ikind = particle_set(iatom)%atomic_kind%kind_number jkind = particle_set(jatom)%atomic_kind%kind_number - IF (iatom .NE. iatom_old) ra(:) = pbc(particle_set(iatom)%r, cell) + IF (iatom /= iatom_old) ra(:) = pbc(particle_set(iatom)%r, cell) brow = iatom bcol = jatom - IF (ikind .NE. ikind_old) THEN + IF (ikind /= ikind_old) THEN CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, & basis_type=basis_type) @@ -995,7 +995,7 @@ CONTAINS zet=zeta) END IF - IF (jkind .NE. jkind_old) THEN + IF (jkind /= jkind_old) THEN CALL get_qs_kind(qs_kind_set(jkind), & basis_set=orb_basis_set, basis_type=basis_type) @@ -1040,7 +1040,7 @@ CONTAINS END IF - IF (atom_pair_changed .OR. iset_old .NE. iset .OR. jset_old .NE. jset) THEN + IF (atom_pair_changed .OR. iset_old /= iset .OR. jset_old /= jset) THEN ncoa = npgfa(iset)*ncoset(la_max(iset)) sgfa = first_sgfa(1, iset) @@ -1134,7 +1134,7 @@ CONTAINS IF (do_igaim) THEN ! here the decontracted mat_jb_{ab} is multiplied by ! f_{ab} = g_{a} * g_{b} ! THIS GOES OUTSIDE THE LOOP ! - IF (scale2 .NE. 0.0_dp) THEN + IF (scale2 /= 0.0_dp) THEN CALL collocate_pgf_product(la_max(iset), zeta(ipgf, iset), & la_min(iset), lb_max(jset), zetb(jpgf, jset), lb_min(jset), & ra, rab, scale2, jpab_d, na1 - 1, nb1 - 1, & @@ -1355,7 +1355,7 @@ CONTAINS DO ig = start, start + length map(ig, i) = ig + offset END DO - IF (start + length .GE. ub_cube(i)) EXIT + IF (start + length >= ub_cube(i)) EXIT start = start + length + 1 END DO ELSE @@ -1448,7 +1448,7 @@ CONTAINS rs_gauge=rs_gauge, & gauge=gauge) - IF (gauge .EQ. current_gauge_atom) THEN + IF (gauge == current_gauge_atom) THEN CALL get_qs_env(qs_env=qs_env, & pw_env=pw_env) CALL pw_env_get(pw_env=pw_env, & @@ -1547,9 +1547,9 @@ CONTAINS DO ibox = 0, nbox(1) - 1 ii = 0 DO iatom = 1, natms - IF (INT(ratom(1, iatom)/dbox(1)) .EQ. ibox .AND. & - INT(ratom(2, iatom)/dbox(2)) .EQ. jbox .AND. & - INT(ratom(3, iatom)/dbox(3)) .EQ. kbox) THEN + IF (INT(ratom(1, iatom)/dbox(1)) == ibox .AND. & + INT(ratom(2, iatom)/dbox(2)) == jbox .AND. & + INT(ratom(3, iatom)/dbox(3)) == kbox) THEN box_data(:, i) = ratom(:, iatom) - offset(:) i = i + 1 ii = ii + 1 @@ -1645,21 +1645,21 @@ CONTAINS natms_local = 0 kmin = INT((point(3) + offset(3) - gauge_atom_radius)/dbox(3)) kmax = INT((point(3) + offset(3) + gauge_atom_radius)/dbox(3)) - IF (kmax - kmin + 1 .GT. nbox(3)) THEN + IF (kmax - kmin + 1 > nbox(3)) THEN kmin = 0 kmax = nbox(3) - 1 END IF DO kbox = kmin, kmax jmin = INT((point(2) + offset(2) - gauge_atom_radius)/dbox(2)) jmax = INT((point(2) + offset(2) + gauge_atom_radius)/dbox(2)) - IF (jmax - jmin + 1 .GT. nbox(2)) THEN + IF (jmax - jmin + 1 > nbox(2)) THEN jmin = 0 jmax = nbox(2) - 1 END IF DO jbox = jmin, jmax imin = INT((point(1) + offset(1) - gauge_atom_radius)/dbox(1)) imax = INT((point(1) + offset(1) + gauge_atom_radius)/dbox(1)) - IF (imax - imin + 1 .GT. nbox(1)) THEN + IF (imax - imin + 1 > nbox(1)) THEN imin = 0 imax = nbox(1) - 1 END IF @@ -1669,7 +1669,7 @@ CONTAINS DO iatom = ibeg, iend r(:) = pbc(box_data(:, iatom) - point(:), cell) + point(:) dist = (r(1) - point(1))**2 + (r(2) - point(2))**2 + (r(3) - point(3))**2 - IF (dist .LT. gauge_atom_radius**2) THEN + IF (dist < gauge_atom_radius**2) THEN natms_local = natms_local + 1 ratom(:, natms_local) = r(:) ! @@ -1687,7 +1687,7 @@ CONTAINS END DO END DO ! - IF (natms_local .GT. 0) THEN + IF (natms_local > 0) THEN ! ! DO iatom = 1, natms_local @@ -1697,7 +1697,7 @@ CONTAINS pra(3) = atms_pnt(3, iatom) pa = nrm_atms_pnt(iatom) DO jatom = 1, natms_local - IF (iatom .EQ. jatom) CYCLE + IF (iatom == jatom) CYCLE pb = nrm_atms_pnt(jatom) x = pra(1) - atms_pnt(1, jatom) y = pra(2) - atms_pnt(2, jatom) @@ -1810,9 +1810,9 @@ CONTAINS DO ibox = 0, nbox(1) - 1 ii = 0 DO iatom = 1, natms - IF (MODULO(FLOOR(ratom(1, iatom)/dbox(1)), nbox(1)) .EQ. ibox .AND. & - MODULO(FLOOR(ratom(2, iatom)/dbox(2)), nbox(2)) .EQ. jbox .AND. & - MODULO(FLOOR(ratom(3, iatom)/dbox(3)), nbox(3)) .EQ. kbox) THEN + IF (MODULO(FLOOR(ratom(1, iatom)/dbox(1)), nbox(1)) == ibox .AND. & + MODULO(FLOOR(ratom(2, iatom)/dbox(2)), nbox(2)) == jbox .AND. & + MODULO(FLOOR(ratom(3, iatom)/dbox(3)), nbox(3)) == kbox) THEN box_data(:, i) = ratom(:, iatom) i = i + 1 ii = ii + 1 @@ -1827,7 +1827,7 @@ CONTAINS DO kbox = 0, nbox(3) - 1 DO jbox = 0, nbox(2) - 1 DO ibox = 0, nbox(1) - 1 - IF (box_ptr(ibox + 1, jbox, kbox) - box_ptr(ibox, jbox, kbox) .GT. 0) THEN + IF (box_ptr(ibox + 1, jbox, kbox) - box_ptr(ibox, jbox, kbox) > 0) THEN WRITE (*, *) 'box=', ibox, jbox, kbox WRITE (*, *) 'nbr atom=', box_ptr(ibox + 1, jbox, kbox) - box_ptr(ibox, jbox, kbox) DO iatom = box_ptr(ibox, jbox, kbox), box_ptr(ibox + 1, jbox, kbox) - 1 @@ -1856,21 +1856,21 @@ CONTAINS natms_local = 0 kmin = FLOOR((box_center(3) - gauge_atom_radius)/dbox(3)) kmax = FLOOR((box_center(3) + gauge_atom_radius)/dbox(3)) - IF (kmax - kmin + 1 .GT. nbox(3)) THEN + IF (kmax - kmin + 1 > nbox(3)) THEN kmin = 0 kmax = nbox(3) - 1 END IF DO kbox = kmin, kmax jmin = FLOOR((box_center(2) - gauge_atom_radius)/dbox(2)) jmax = FLOOR((box_center(2) + gauge_atom_radius)/dbox(2)) - IF (jmax - jmin + 1 .GT. nbox(2)) THEN + IF (jmax - jmin + 1 > nbox(2)) THEN jmin = 0 jmax = nbox(2) - 1 END IF DO jbox = jmin, jmax imin = FLOOR((box_center(1) - gauge_atom_radius)/dbox(1)) imax = FLOOR((box_center(1) + gauge_atom_radius)/dbox(1)) - IF (imax - imin + 1 .GT. nbox(1)) THEN + IF (imax - imin + 1 > nbox(1)) THEN imin = 0 imax = nbox(1) - 1 END IF @@ -1879,9 +1879,9 @@ CONTAINS iend = box_ptr(MODULO(ibox, nbox(1)) + 1, MODULO(jbox, nbox(2)), MODULO(kbox, nbox(3))) - 1 DO iatom = ibeg, iend r = pbc(box_center_wrap(:) - box_data(:, iatom), cell) - IF (ABS(r(1)) .LE. (scale + 0.5_dp)*dbox(1) .AND. & - ABS(r(2)) .LE. (scale + 0.5_dp)*dbox(2) .AND. & - ABS(r(3)) .LE. (scale + 0.5_dp)*dbox(3)) THEN + IF (ABS(r(1)) <= (scale + 0.5_dp)*dbox(1) .AND. & + ABS(r(2)) <= (scale + 0.5_dp)*dbox(2) .AND. & + ABS(r(3)) <= (scale + 0.5_dp)*dbox(3)) THEN natms_local = natms_local + 1 ratom(:, natms_local) = box_data(:, iatom) END IF @@ -1893,7 +1893,7 @@ CONTAINS ! set the list box(i, j, k)%n = natms_local NULLIFY (box(i, j, k)%r) - IF (natms_local .GT. 0) THEN + IF (natms_local > 0) THEN ALLOCATE (box(i, j, k)%r(3, natms_local)) r_ptr => box(i, j, k)%r CALL dcopy(3*natms_local, ratom(1, 1), 1, r_ptr(1, 1), 1) @@ -1906,7 +1906,7 @@ CONTAINS DO k = 0, nbox(3) - 1 DO j = 0, nbox(2) - 1 DO i = 0, nbox(1) - 1 - IF (box(i, j, k)%n .GT. 0) THEN + IF (box(i, j, k)%n > 0) THEN WRITE (*, *) WRITE (*, *) 'box=', i, j, k box_center(1) = (REAL(i, dp) + 0.5_dp)*dbox(1) @@ -1919,9 +1919,9 @@ CONTAINS DO iatom = 1, box(i, j, k)%n WRITE (*, '(A,I3,3E14.6)') 'coor=', iatom, r_ptr(:, iatom) r(:) = pbc(box_center(:) - r_ptr(:, iatom), cell) - IF (ABS(r(1)) .GT. (scale + 0.5_dp)*dbox(1) .OR. & - ABS(r(2)) .GT. (scale + 0.5_dp)*dbox(2) .OR. & - ABS(r(3)) .GT. (scale + 0.5_dp)*dbox(3)) THEN + IF (ABS(r(1)) > (scale + 0.5_dp)*dbox(1) .OR. & + ABS(r(2)) > (scale + 0.5_dp)*dbox(2) .OR. & + ABS(r(3)) > (scale + 0.5_dp)*dbox(3)) THEN WRITE (*, *) 'error too many atoms' WRITE (*, *) 'dist=', ABS(r(:)) WRITE (*, *) 'large_dist=', (scale + 0.5_dp)*dbox @@ -1947,12 +1947,12 @@ CONTAINS r(:) = pbc(box_center(:) - ratom(:, iatom), cell) ifind = 0 DO jatom = 1, box(i, j, k)%n - IF (SUM(ABS(ratom(:, iatom) - r_ptr(:, jatom))) .LT. 1E-10_dp) ifind = 1 + IF (SUM(ABS(ratom(:, iatom) - r_ptr(:, jatom))) < 1E-10_dp) ifind = 1 END DO - IF (ifind .EQ. 0) THEN - ! SQRT(DOT_PRODUCT(r, r)) .LT. gauge_atom_radius - IF (DOT_PRODUCT(r, r) .LT. (gauge_atom_radius*gauge_atom_radius)) THEN + IF (ifind == 0) THEN + ! SQRT(DOT_PRODUCT(r, r)) < gauge_atom_radius + IF (DOT_PRODUCT(r, r) < (gauge_atom_radius*gauge_atom_radius)) THEN WRITE (*, *) 'error atom too close' WRITE (*, *) 'iatom', iatom WRITE (*, *) 'box_center', box_center @@ -2058,8 +2058,8 @@ CONTAINS ! ! sanity checks IF (.TRUE.) THEN - IF (REAL(ks - 1 + delta_lb(3), dp)*dr(3) .LT. REAL(kb, dp)*dbox(3) .OR. & - REAL(ke - 1 + delta_lb(3), dp)*dr(3) .GT. REAL(kb + 1, dp)*dbox(3)) THEN + IF (REAL(ks - 1 + delta_lb(3), dp)*dr(3) < REAL(kb, dp)*dbox(3) .OR. & + REAL(ke - 1 + delta_lb(3), dp)*dr(3) > REAL(kb + 1, dp)*dbox(3)) THEN WRITE (*, *) 'box_k', REAL(kb, dp)*dbox(3), REAL(kb + 1, dp)*dbox(3) WRITE (*, *) 'point_k', REAL(ks - 1 + delta_lb(3), dp)*dr(3), REAL(ke - 1 + delta_lb(3), dp)*dr(3) WRITE (*, *) 'ibox', ibox, 'jbox', jbox, 'kbox', kbox @@ -2067,16 +2067,16 @@ CONTAINS WRITE (*, *) 'ibs,ibe', ibs, ibe, ' jbs,jbe', jbs, jbe, ' kbs,kbe', kbs, kbe CPABORT("we stop_k") END IF - IF (REAL(js - 1 + delta_lb(2), dp)*dr(2) .LT. REAL(jb, dp)*dbox(2) .OR. & - REAL(je - 1 + delta_lb(2), dp)*dr(2) .GT. REAL(jb + 1, dp)*dbox(2)) THEN + IF (REAL(js - 1 + delta_lb(2), dp)*dr(2) < REAL(jb, dp)*dbox(2) .OR. & + REAL(je - 1 + delta_lb(2), dp)*dr(2) > REAL(jb + 1, dp)*dbox(2)) THEN WRITE (*, *) 'box_j', REAL(jb, dp)*dbox(2), REAL(jb + 1, dp)*dbox(2) WRITE (*, *) 'point_j', REAL(js - 1 + delta_lb(2), dp)*dr(2), REAL(je - 1 + delta_lb(2), dp)*dr(2) WRITE (*, *) 'is,ie', is, ie, ' js,je', js, je, ' ks,ke', ks, ke WRITE (*, *) 'ibs,ibe', ibs, ibe, ' jbs,jbe', jbs, jbe, ' kbs,kbe', kbs, kbe CPABORT("we stop_j") END IF - IF (REAL(is - 1 + delta_lb(1), dp)*dr(1) .LT. REAL(ib, dp)*dbox(1) .OR. & - REAL(ie - 1 + delta_lb(1), dp)*dr(1) .GT. REAL(ib + 1, dp)*dbox(1)) THEN + IF (REAL(is - 1 + delta_lb(1), dp)*dr(1) < REAL(ib, dp)*dbox(1) .OR. & + REAL(ie - 1 + delta_lb(1), dp)*dr(1) > REAL(ib + 1, dp)*dbox(1)) THEN WRITE (*, *) 'box_i', REAL(ib, dp)*dbox(1), REAL(ib + 1, dp)*dbox(1) WRITE (*, *) 'point_i', REAL(is - 1 + delta_lb(1), dp)*dr(1), REAL(ie - 1 + delta_lb(1), dp)*dr(1) WRITE (*, *) 'is,ie', is, ie, ' js,je', js, je, ' ks,ke', ks, ke @@ -2095,7 +2095,7 @@ CONTAINS r_ptr => box(ibox, jbox, kbox)%r ! ! go over the grid inside the box - IF (natms_local0 .GT. 0) THEN + IF (natms_local0 > 0) THEN ! ! here there are some atoms... DO k = ks, ke @@ -2111,7 +2111,7 @@ CONTAINS DO iatom = 1, natms_local0 r(:) = pbc(r_ptr(:, iatom) - point(:), cell) + point(:) !needed? dist = (r(1) - point(1))**2 + (r(2) - point(2))**2 + (r(3) - point(3))**2 - IF (dist .LT. gauge_atom_radius**2) THEN + IF (dist < gauge_atom_radius**2) THEN natms_local1 = natms_local1 + 1 ratom(:, natms_local1) = r(:) ! @@ -2127,7 +2127,7 @@ CONTAINS END DO ! ! - IF (natms_local1 .GT. 0) THEN + IF (natms_local1 > 0) THEN ! ! build the step DO iatom = 1, natms_local1 @@ -2137,7 +2137,7 @@ CONTAINS pra(3) = atms_pnt(3, iatom) pa = nrm_atms_pnt(iatom) DO jatom = 1, natms_local1 - IF (iatom .EQ. jatom) CYCLE + IF (iatom == jatom) CYCLE pb = nrm_atms_pnt(jatom) x = pra(1) - atms_pnt(1, jatom) y = pra(2) - atms_pnt(2, jatom) @@ -2497,26 +2497,26 @@ CONTAINS CALL set_vecp(idir, ii, iii) CALL cp_dbcsr_sm_fm_multiply(op_p_ao(idir)%matrix, psi_rxp, & p_rxp(idir), ncol=nstate_loc, alpha=1.e0_dp) - IF (iiiB .EQ. iii .OR. iiiB .EQ. ii) THEN + IF (iiiB == iii .OR. iiiB == ii) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_ao(idir)%matrix, psi_p1, & r_p1(idir), ncol=nstate_loc, alpha=1.e0_dp) END IF - IF (iiB .EQ. iii .OR. iiB .EQ. ii) THEN + IF (iiB == iii .OR. iiB == ii) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_ao(idir)%matrix, psi_p2, & r_p2(idir), ncol=nstate_loc, alpha=1.e0_dp) END IF DO idir2 = 1, 9 - IF (idir2 .EQ. ii .OR. idir2 .EQ. iii) THEN + IF (idir2 == ii .OR. idir2 == iii) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(idir2, idir)%matrix, psi_rxp, & rr_rxp(idir2, idir), ncol=nstate_loc, alpha=1.e0_dp) END IF ! - IF (idir2 .EQ. ind_m2(ii, iiiB) .OR. idir2 .EQ. ind_m2(iii, iiiB) .OR. idir2 .EQ. iiiB) THEN + IF (idir2 == ind_m2(ii, iiiB) .OR. idir2 == ind_m2(iii, iiiB) .OR. idir2 == iiiB) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(idir2, idir)%matrix, psi_p1, & rr_p1(idir2, idir), ncol=nstate_loc, alpha=1.e0_dp) END IF ! - IF (idir2 .EQ. ind_m2(ii, iiB) .OR. idir2 .EQ. ind_m2(iii, iiB) .OR. idir2 .EQ. iiB) THEN + IF (idir2 == ind_m2(ii, iiB) .OR. idir2 == ind_m2(iii, iiB) .OR. idir2 == iiB) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(idir2, idir)%matrix, psi_p2, & rr_p2(idir2, idir), ncol=nstate_loc, alpha=1.e0_dp) END IF @@ -2867,7 +2867,7 @@ CONTAINS buf, ncol=nmo, alpha=1.e0_dp) DO jdir = 1, 3 DO kdir = 1, 3 - IF (Levi_Civita(kdir, jdir, idir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, jdir, idir) == 0.0_dp) CYCLE CALL cp_fm_trace(buf, psi1_rxp(ispin, iB), contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir, jdir, idir)*2.0_dp*dk(jdir)*contrib END DO @@ -2887,26 +2887,26 @@ CONTAINS CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(jdir, idir)%matrix, mo_coeff, & buf, ncol=nmo, alpha=1.e0_dp) DO kdir = 1, 3 - IF (Levi_Civita(kdir, jdir, idir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, jdir, idir) == 0.0_dp) CYCLE CALL cp_fm_trace(buf, psi1_rxp(ispin, iB), contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir, jdir, idir)*2.0_dp*contrib END DO ! IF (.NOT. chi_pbc) THEN - IF (jdir .EQ. iiB) THEN + IF (jdir == iiB) THEN DO jjdir = 1, 3 DO kdir = 1, 3 - IF (Levi_Civita(kdir, jjdir, idir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, jjdir, idir) == 0.0_dp) CYCLE CALL cp_fm_trace(buf, psi1_p(ispin, iiiB), contrib) chi(kdir) = chi(kdir) + Levi_Civita(kdir, jjdir, idir)*2.0_dp*dk(jjdir)*contrib END DO END DO END IF ! - IF (jdir .EQ. iiiB) THEN + IF (jdir == iiiB) THEN DO jjdir = 1, 3 DO kdir = 1, 3 - IF (Levi_Civita(kdir, jjdir, idir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, jjdir, idir) == 0.0_dp) CYCLE CALL cp_fm_trace(buf, psi1_p(ispin, iiB), contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir, jjdir, idir)*2.0_dp*dk(jjdir)*contrib END DO @@ -2927,7 +2927,7 @@ CONTAINS CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(ind_m2(jdir, iiB), idir)%matrix, mo_coeff, & buf, ncol=nmo, alpha=1.e0_dp) DO kdir = 1, 3 - IF (Levi_Civita(kdir, jdir, idir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, jdir, idir) == 0.0_dp) CYCLE CALL cp_fm_trace(buf, psi1_p(ispin, iiiB), contrib) chi(kdir) = chi(kdir) + Levi_Civita(kdir, jdir, idir)*2.0_dp*contrib END DO @@ -2935,7 +2935,7 @@ CONTAINS CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(ind_m2(jdir, iiiB), idir)%matrix, mo_coeff, & buf, ncol=nmo, alpha=1.e0_dp) DO kdir = 1, 3 - IF (Levi_Civita(kdir, jdir, idir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, jdir, idir) == 0.0_dp) CYCLE CALL cp_fm_trace(buf, psi1_p(ispin, iiB), contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir, jdir, idir)*2.0_dp*contrib END DO @@ -2952,7 +2952,7 @@ CONTAINS buf, ncol=nmo, alpha=1.e0_dp) DO jdir = 1, 3 DO kdir = 1, 3 - IF (Levi_Civita(kdir, idir, jdir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, idir, jdir) == 0.0_dp) CYCLE IF (iiB == jdir) THEN CALL cp_fm_trace(buf, psi1_p(ispin, iiiB), contrib) chi(kdir) = chi(kdir) + Levi_Civita(kdir, idir, jdir)*contrib @@ -2962,7 +2962,7 @@ CONTAINS ! DO jdir = 1, 3 DO kdir = 1, 3 - IF (Levi_Civita(kdir, idir, jdir) .EQ. 0.0_dp) CYCLE + IF (Levi_Civita(kdir, idir, jdir) == 0.0_dp) CYCLE IF (iiiB == jdir) THEN CALL cp_fm_trace(buf, psi1_p(ispin, iiB), contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir, idir, jdir)*contrib diff --git a/src/qs_linres_current_utils.F b/src/qs_linres_current_utils.F index 95d503c252..eb85e8e2ef 100644 --- a/src/qs_linres_current_utils.F +++ b/src/qs_linres_current_utils.F @@ -429,7 +429,7 @@ CONTAINS mo_coeff => psi0_order(ispin) ! ! take care that no overflow can occur for uks - IF (icenter .GT. nbr_center(ispin)) THEN + IF (icenter > nbr_center(ispin)) THEN ! ! set h1_psi0 and psi1 to zero to avoid problems in linres_scf CALL cp_fm_set_all(h1_psi0(ispin), 0.0_dp) @@ -498,7 +498,7 @@ CONTAINS DO ispin = 1, nspins ! ! take care that no overflow can occur for uks - IF (icenter .GT. nbr_center(ispin)) CYCLE + IF (icenter > nbr_center(ispin)) CYCLE ! ! need to reset those guys ist_true = statetrueindex(idir, icenter, ispin) @@ -647,11 +647,11 @@ CONTAINS uniform_occupation=uniform_occupation) ! ! check that homo=nmo - IF (nmo .NE. homo) CPABORT("nmo != homo") + IF (nmo /= homo) CPABORT("nmo != homo") ! ! check that the nbr of localized states is equal to the nbr of states ! nmoloc = SIZE(linres_control%localized_wfn_control%centers_set(ispin)%array,2) -! IF (nmoloc.NE.nmo) CALL cp_abort(__LOCATION__,& +! IF (nmoloc/=nmo) CALL cp_abort(__LOCATION__,& ! "The nbr of localized functions "//& ! & "is not equal to the nbr of states.") ! @@ -767,15 +767,15 @@ CONTAINS DO istate = 1, SIZE(localized_wfn_control%centers_set(ispin)%array, 2) ! just to be sure... r(:) = pbc(localized_wfn_control%centers_set(ispin)%array(:, istate), cell) - IF (r(1) .LT. 0.0_dp) THEN + IF (r(1) < 0.0_dp) THEN localized_wfn_control%centers_set(ispin)%array(1, istate) = & r(1) + cell%hmat(1, 1) END IF - IF (r(2) .LT. 0.0_dp) THEN + IF (r(2) < 0.0_dp) THEN localized_wfn_control%centers_set(ispin)%array(2, istate) = & r(2) + cell%hmat(2, 2) END IF - IF (r(3) .LT. 0.0_dp) THEN + IF (r(3) < 0.0_dp) THEN localized_wfn_control%centers_set(ispin)%array(3, istate) = & r(3) + cell%hmat(3, 3) END IF @@ -791,10 +791,10 @@ CONTAINS r_val=current_env%selected_states_atom_radius) CALL section_vals_val_get(current_section, "SELECTED_STATES_ON_ATOM_LIST", n_rep_val=n_rep) ! - current_env%do_selected_states = n_rep .GT. 0 + 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 .EQ. ot_precond_full_all .AND. current_env%do_selected_states) & + IF (linres_control%preconditioner_type == ot_precond_full_all .AND. current_env%do_selected_states) & CPABORT("Selected states doesnt work with the preconditioner FULL_ALL") ! ! @@ -823,9 +823,9 @@ CONTAINS DO i = 1, SIZE(selected_states_on_atom_list, 1) iatom = selected_states_on_atom_list(i) r(:) = pbc(center_array(1:3, istate) - particle_set(iatom)%r(:), cell) - ! SQRT(DOT_PRODUCT(r, r)) .LE. current_env%selected_states_atom_radius - IF ((DOT_PRODUCT(r, r)) .LE. (current_env%selected_states_atom_radius & - *current_env%selected_states_atom_radius)) & + ! SQRT(DOT_PRODUCT(r, r)) <= current_env%selected_states_atom_radius + IF ((DOT_PRODUCT(r, r)) <= (current_env%selected_states_atom_radius & + *current_env%selected_states_atom_radius)) & THEN ! ! add the state to the list @@ -902,7 +902,7 @@ CONTAINS r = pbc(particle_set(iatom)%r(:), cell) rab = pbc(r, center_array(1:3, istate), cell) dist = SQRT(rab(1)**2 + rab(2)**2 + rab(3)**2) - IF (dist .LT. mdist) THEN + IF (dist < mdist) THEN buff(is) = iatom mdist = dist END IF @@ -917,7 +917,7 @@ CONTAINS is0 = .TRUE. DO is = 1, nstate istate = state_list(is, ispin) - IF (buff(is) .EQ. iatom) THEN + IF (buff(is) == iatom) THEN j = j + 1 i = i + 1 is0 = .FALSE. @@ -964,7 +964,7 @@ CONTAINS DO ibox = 1, nbr_box rab(:) = pbc(rbuff(:, ibox), center_array(1:3, istate), cell) dist = SQRT(rab(1)**2 + rab(2)**2 + rab(3)**2) - IF (dist .LT. mdist) THEN + IF (dist < mdist) THEN buff(is) = ibox mdist = dist END IF @@ -979,7 +979,7 @@ CONTAINS is0 = .TRUE. DO is = 1, nstate istate = state_list(is, ispin) - IF (buff(is) .EQ. ibox) THEN + IF (buff(is) == ibox) THEN j = j + 1 i = i + 1 is0 = .FALSE. @@ -1047,9 +1047,9 @@ CONTAINS ! ! IF (current_env%do_qmmm .AND.& - & (current_env%orb_center .EQ. current_orb_center_wannier .OR. & - current_env%orb_center .EQ. current_orb_center_atom .OR. & - current_env%orb_center .EQ. current_orb_center_box)) THEN + & (current_env%orb_center == current_orb_center_wannier .OR. & + current_env%orb_center == current_orb_center_atom .OR. & + current_env%orb_center == current_orb_center_box)) THEN IF (output_unit > 0) THEN WRITE (output_unit, *) 'WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ' WRITE (output_unit, *) 'orbital center shifted to match the ' @@ -1058,15 +1058,15 @@ CONTAINS END IF DO ispin = 1, nspins DO istate = 1, current_env%nbr_center(ispin) - IF (current_env%centers_set(ispin)%array(1, istate) .LE. 0.0_dp) THEN + IF (current_env%centers_set(ispin)%array(1, istate) <= 0.0_dp) THEN current_env%centers_set(ispin)%array(1, istate) = & current_env%centers_set(ispin)%array(1, istate) + cell%hmat(1, 1) END IF - IF (current_env%centers_set(ispin)%array(2, istate) .LE. 0.0_dp) THEN + IF (current_env%centers_set(ispin)%array(2, istate) <= 0.0_dp) THEN current_env%centers_set(ispin)%array(2, istate) = & current_env%centers_set(ispin)%array(2, istate) + cell%hmat(2, 2) END IF - IF (current_env%centers_set(ispin)%array(3, istate) .LE. 0.0_dp) THEN + IF (current_env%centers_set(ispin)%array(3, istate) <= 0.0_dp) THEN current_env%centers_set(ispin)%array(3, istate) = & current_env%centers_set(ispin)%array(3, istate) + cell%hmat(3, 3) END IF @@ -1120,7 +1120,7 @@ CONTAINS CALL set_vecp(idir, j, k) dist = SQRT(rab(j)*rab(j) + rab(k)*rab(k)) ! - IF (dist .LT. mdist) THEN + IF (dist < mdist) THEN mdist = dist istate_next = istate2 END IF @@ -1152,15 +1152,15 @@ CONTAINS REPEAT(' ', 20 - LEN_TRIM(current_env%gauge_name))//TRIM(current_env%gauge_name) WRITE (output_unit, "(T2,A,T79,L1)") "CURRENT| Use old gauge code", current_env%use_old_gauge_atom WRITE (output_unit, "(T2,A,T79,L1)") "CURRENT| Compute chi for PBC calculation", current_env%chi_pbc - IF (current_env%gauge .EQ. current_gauge_atom) THEN + IF (current_env%gauge == current_gauge_atom) THEN WRITE (output_unit, "(T2,A,T68,E12.6)") "CURRENT| Radius for building the gauge", & current_env%gauge_atom_radius END IF WRITE (output_unit, "(T2,A,T60,A)") "CURRENT| Orbital center used", & REPEAT(' ', 20 - LEN_TRIM(current_env%orb_center_name))//TRIM(current_env%orb_center_name) - IF (current_env%orb_center .EQ. current_orb_center_common) THEN + IF (current_env%orb_center == current_orb_center_common) THEN WRITE (output_unit, "(T2,A,T50,3F10.6)") "CURRENT| Common center", common_center(1:3) - ELSEIF (current_env%orb_center .EQ. 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_ownutils.F b/src/qs_linres_epr_ownutils.F index 59273e5d06..722f4c31f6 100644 --- a/src/qs_linres_epr_ownutils.F +++ b/src/qs_linres_epr_ownutils.F @@ -435,7 +435,7 @@ CONTAINS vks_ra_idir3 = Eval_Interp_Spl3_pbc(ra, & vks_pw_spline(idir3, ispin)) - IF (iat .LT. bo(1) .OR. iat .GT. bo(2)) CYCLE !quick and dirty: + IF (iat < bo(1) .OR. iat > bo(2)) CYCLE !quick and dirty: ! !here take care of the partition ! + sum_A j_loc_h_A x nabla_vks_s_A @@ -700,7 +700,7 @@ CONTAINS bind_ra_idir1 = Eval_Interp_Spl3_pbc(ra, & bind_pw_spline(idir1, iB)) - IF (iat .LT. bo(1) .OR. iat .GT. bo(2)) CYCLE !quick and dirty: + IF (iat < bo(1) .OR. iat > bo(2)) CYCLE !quick and dirty: ! !here take care of the partition rho_spin = 0.0_dp diff --git a/src/qs_linres_issc_utils.F b/src/qs_linres_issc_utils.F index e639bae9ff..fea98a08e6 100644 --- a/src/qs_linres_issc_utils.F +++ b/src/qs_linres_issc_utils.F @@ -529,7 +529,7 @@ CONTAINS ! ! FC term ! - IF (do_fc .AND. iatom .NE. jatom) THEN + IF (do_fc .AND. iatom /= jatom) THEN ! ! build the integral for the jatom CALL dbcsr_set(matrix_fc(1)%matrix, 0.0_dp) @@ -550,7 +550,7 @@ CONTAINS ! ! SD term ! - IF (do_sd .AND. iatom .NE. jatom) THEN + IF (do_sd .AND. iatom /= jatom) THEN ! ! build the integral for the jatom CALL dbcsr_set(matrix_efg(1)%matrix, 0.0_dp) @@ -577,7 +577,7 @@ CONTAINS ! ! PSO term ! - IF (do_pso .AND. iatom .NE. jatom) THEN + IF (do_pso .AND. iatom /= jatom) THEN ! ! build the integral for the jatom CALL dbcsr_set(matrix_pso(1)%matrix, 0.0_dp) @@ -599,7 +599,7 @@ CONTAINS ! DSO term ! !>>>>> for debugging we compute here the polarizability and NOT the DSO term! - IF (do_dso .AND. iatom .EQ. natom .AND. jatom .EQ. natom) THEN + 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) @@ -715,7 +715,7 @@ CONTAINS atom_kind_j => particle_set(jatom)%atomic_kind CALL get_atomic_kind(atom_kind_j, name=name_j, element_symbol=element_symbol_j) ! - IF (iatom .EQ. jatom .AND. .NOT. do_dso) CYCLE + IF (iatom == jatom .AND. .NOT. do_dso) CYCLE ! ! ! FC @@ -877,7 +877,7 @@ CONTAINS ! IF (.NOT. ASSOCIATED(issc_env%issc_on_atom_list)) THEN ALLOCATE (issc_env%issc_on_atom_list(natom), STAT=istat) - CPASSERT(istat .EQ. 0) + CPASSERT(istat == 0) DO iatom = 1, natom issc_env%issc_on_atom_list(iatom) = iatom END DO diff --git a/src/qs_linres_methods.F b/src/qs_linres_methods.F index 04d500a94d..38258861b8 100644 --- a/src/qs_linres_methods.F +++ b/src/qs_linres_methods.F @@ -365,7 +365,7 @@ CONTAINS ! ! preconditioner linres_control%flag = "" - IF (linres_control%preconditioner_type .EQ. ot_precond_none) THEN + IF (linres_control%preconditioner_type == ot_precond_none) THEN ! ! z_0 = r_0 DO ispin = 1, nspins @@ -400,12 +400,12 @@ CONTAINS ! ! check convergence linres_control%converged = .FALSE. - IF (norm_res .LT. linres_control%eps) THEN + IF (norm_res < linres_control%eps) THEN linres_control%converged = .TRUE. END IF ! t2 = m_walltime() - IF (iter .EQ. 1 .OR. MOD(iter, 1) .EQ. 0 .OR. linres_control%converged & + IF (iter == 1 .OR. MOD(iter, 1) == 0 .OR. linres_control%converged & .OR. restart .OR. should_stop) THEN IF (iounit > 0) THEN WRITE (iounit, "(T5,I5,T18,A3,T28,L1,T38,1E8.2,T48,F16.10,T68,F8.2)") & @@ -464,7 +464,7 @@ CONTAINS ! ! need to recompute the residue restart = .FALSE. - IF (MOD(iter, linres_control%restart_every) .EQ. 0) THEN + IF (MOD(iter, linres_control%restart_every) == 0) THEN ! ! r_j+1 = b - A * x_j+1 CALL apply_op(qs_env, p_env, psi0_order, psi1, Ap, chc) @@ -489,7 +489,7 @@ CONTAINS ! ! preconditioner linres_control%flag = "" - IF (linres_control%preconditioner_type .EQ. ot_precond_none) THEN + IF (linres_control%preconditioner_type == ot_precond_none) THEN ! ! z_j+1 = r_j+1 DO ispin = 1, nspins @@ -625,7 +625,7 @@ CONTAINS END DO ! skip the kernel if the DM is very small - IF (chksum .GT. 1.0E-14_dp) THEN + IF (chksum > 1.0E-14_dp) THEN CALL p_env_check_i_alloc(p_env, qs_env) @@ -1026,15 +1026,15 @@ CONTAINS CALL para_env%bcast(iostat) END IF - IF (iostat .NE. 0) EXIT + IF (iostat /= 0) EXIT CALL para_env%bcast(ivec_tmp) CALL para_env%bcast(nspins_tmp) CALL para_env%bcast(nao_tmp) ! check that the number nao, nmo and nspins are ! the same as in the current mos - IF (nspins_tmp .NE. nspins) CPABORT("nspins not consistent") - IF (nao_tmp .NE. nao) CPABORT("nao not consistent") + IF (nspins_tmp /= nspins) CPABORT("nspins not consistent") + IF (nao_tmp /= nao) CPABORT("nao not consistent") ! DO ispin = 1, nspins CALL get_mo_set(mos(ispin), mo_coeff=mo_coeff) @@ -1042,7 +1042,7 @@ CONTAINS ! IF (rst_unit > 0) READ (rst_unit) nmo_tmp CALL para_env%bcast(nmo_tmp) - IF (nmo_tmp .NE. nmo) CPABORT("nmo not consistent") + IF (nmo_tmp /= nmo) CPABORT("nmo not consistent") ! ! read the response DO i = 1, nmo, MAX(max_block, 1) @@ -1050,13 +1050,13 @@ CONTAINS DO j = 1, i_block IF (rst_unit > 0) READ (rst_unit) vecbuffer(1:nao, j) END DO - IF (iv .EQ. ivec_tmp) THEN + IF (iv == ivec_tmp) THEN CALL para_env%bcast(vecbuffer) CALL cp_fm_set_submatrix(vec(ispin), vecbuffer, 1, i, nao, i_block) END IF END DO END DO - IF (ivec .EQ. ivec_tmp) EXIT + IF (ivec == ivec_tmp) EXIT END DO IF (iostat /= 0) THEN diff --git a/src/qs_linres_nmr_shift.F b/src/qs_linres_nmr_shift.F index c293416967..bfaa758d99 100644 --- a/src/qs_linres_nmr_shift.F +++ b/src/qs_linres_nmr_shift.F @@ -368,7 +368,7 @@ CONTAINS DO jatom = 1, natom_tot rij(:) = pbc(particle_set(iatom)%r, particle_set(jatom)%r, cell) dist = SQRT(rij(1)*rij(1) + rij(2)*rij(2) + rij(3)*rij(3)) - IF (dist .LE. shift_gapw_radius) THEN + IF (dist <= shift_gapw_radius) THEN natom_local = natom_local + 1 list_j(natom_local) = jatom dist_ij(:, natom_local) = rij(:) @@ -382,7 +382,7 @@ CONTAINS r_jatom(:) = r_nics(:, jatom) rij(:) = pbc(particle_set(iatom)%r, r_jatom, cell) dist = SQRT(rij(1)*rij(1) + rij(2)*rij(2) + rij(3)*rij(3)) - IF (dist .LE. shift_gapw_radius) THEN + IF (dist <= shift_gapw_radius) THEN nnics_local = nnics_local + 1 list_nics_j(nnics_local) = jatom dist_nics_ij(:, nnics_local) = rij(:) @@ -419,7 +419,7 @@ CONTAINS ! rdiff(:) = rij(:) - r_grid(:, ira) ddiff = SQRT(rdiff(1)*rdiff(1) + rdiff(2)*rdiff(2) + rdiff(3)*rdiff(3)) - IF (ddiff .GT. 1.0E-12_dp) THEN + IF (ddiff > 1.0E-12_dp) THEN dum = scale_fac_1*j_grid(ira)/(ddiff*ddiff*ddiff) s_1 = s_1 + rdiff(idir2_1)*dum s_2 = s_2 + rdiff(idir3_1)*dum @@ -440,7 +440,7 @@ CONTAINS ! rdiff(:) = rij(:) - r_grid(:, ira) ddiff = SQRT(rdiff(1)*rdiff(1) + rdiff(2)*rdiff(2) + rdiff(3)*rdiff(3)) - IF (ddiff .GT. 1.0E-12_dp) THEN + IF (ddiff > 1.0E-12_dp) THEN dum = scale_fac_1*j_grid(ira)/(ddiff*ddiff*ddiff) s_1 = s_1 + rdiff(idir2_1)*dum s_2 = s_2 + rdiff(idir3_1)*dum diff --git a/src/qs_linres_nmr_utils.F b/src/qs_linres_nmr_utils.F index daeae3968d..e8b8176a12 100644 --- a/src/qs_linres_nmr_utils.F +++ b/src/qs_linres_nmr_utils.F @@ -255,12 +255,12 @@ CONTAINS ! check the list CPASSERT(ASSOCIATED(nmr_env%cs_atom_list)) DO ir = 1, SIZE(nmr_env%cs_atom_list, 1) - IF (nmr_env%cs_atom_list(ir) .LT. 1 .OR. nmr_env%cs_atom_list(ir) .GT. natom) THEN + IF (nmr_env%cs_atom_list(ir) < 1 .OR. nmr_env%cs_atom_list(ir) > natom) THEN CPABORT("Unknown atom(s)") END IF DO j = 1, SIZE(nmr_env%cs_atom_list, 1) - IF (j .EQ. ir) CYCLE - IF (nmr_env%cs_atom_list(ir) .EQ. nmr_env%cs_atom_list(j)) THEN + IF (j == ir) CYCLE + IF (nmr_env%cs_atom_list(ir) == nmr_env%cs_atom_list(j)) THEN CPABORT("Duplicate atoms") END IF END DO diff --git a/src/qs_linres_op.F b/src/qs_linres_op.F index 0e352b17e3..32b9a0018c 100644 --- a/src/qs_linres_op.F +++ b/src/qs_linres_op.F @@ -1274,9 +1274,9 @@ CONTAINS factor = 0.0_dp - IF ((b .EQ. a + 1 .OR. b .EQ. a - 2) .AND. (c .EQ. b + 1 .OR. c .EQ. b - 2)) THEN + IF ((b == a + 1 .OR. b == a - 2) .AND. (c == b + 1 .OR. c == b - 2)) THEN factor = 1.0_dp - ELSEIF ((b .EQ. a - 1 .OR. b .EQ. a + 2) .AND. (c .EQ. b - 1 .OR. c .EQ. 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 @@ -1393,11 +1393,11 @@ CONTAINS a => matrix%local_data DO icol_local = 1, ncol_local icol_global = matrix%matrix_struct%col_indices(icol_local) - IF (icol_global .GT. n) CYCLE + IF (icol_global > n) CYCLE rrc = rc(:, icol_global) DO irow_local = 1, nrow_local irow_global = matrix%matrix_struct%row_indices(irow_local) - IF (irow_global .GT. m) CYCLE + IF (irow_global > m) CYCLE rra = ra(:, irow_global) dist = pbc(rrc, rra, cell) a(irow_local, icol_local) = a(irow_local, icol_local)*dist(ixyz) diff --git a/src/qs_loc_states.F b/src/qs_loc_states.F index 7ce67fdd8d..e9cc494cee 100644 --- a/src/qs_loc_states.F +++ b/src/qs_loc_states.F @@ -194,7 +194,7 @@ CONTAINS ! Compute all the second moments of the Wannier states IF (section_get_lval(loc_print_section, "WANNIER_SPREADS%SECOND_MOMENTS")) THEN IF (section_get_lval(loc_print_section, "WANNIER_SPREADS%PERIODIC")) THEN - IF (dft_control%qs_control%gapw_control%lmax_sphere .LT. 6) THEN + IF (dft_control%qs_control%gapw_control%lmax_sphere < 6) THEN CPABORT("Periodic second moments require LMAXN1>=6 In QS section") END IF CALL centers_second_moments_berry(qs_env, qs_loc_env, loc_print_section, ispin) diff --git a/src/qs_localization_methods.F b/src/qs_localization_methods.F index e37659858e..bb0be11c74 100644 --- a/src/qs_localization_methods.F +++ b/src/qs_localization_methods.F @@ -186,7 +186,7 @@ CONTAINS 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 .GT. 1.0E-10_dp) THEN + IF (tnorm > 1.0E-10_dp) THEN ! other orders CALL cp_fm_to_fm(G, Gp1) DO i = 2, taylor_order @@ -198,7 +198,7 @@ CONTAINS 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 .LT. 1.0E-10_dp) EXIT + IF (tnorm*expfactor < 1.0E-10_dp) EXIT END DO END IF ! @@ -207,14 +207,14 @@ CONTAINS CALL cp_fm_to_fm(CTmp, C) ! ! printing - IF (output_unit .GT. 0) THEN + IF (output_unit > 0) THEN WRITE (output_unit, '(10X,I4,E18.10,2E10.2)') istep, f2, gnorm, ABS((f2 - f2old)/f2) END IF ! ! Are we done? sweeps = istep - !IF(gnorm.LE.grad_thresh.AND.ABS((f2-f2old)/f2).LE.f2_thresh.AND.istep.GT.1) THEN - IF (ABS((f2 - f2old)/f2) .LE. eps .AND. istep .GT. 1) THEN + !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 END IF @@ -224,20 +224,20 @@ CONTAINS ! here we should do one refine step to enforce C'*S*C=1 for any case ! ! Print the final result - IF (output_unit .GT. 0) WRITE (output_unit, '(A,E16.10)') ' sparseness function f2 = ', f2 + 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)).GT.thresh(i)) THEN + ! 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.GT.0) THEN + ! IF(output_unit>0) THEN ! WRITE(output_unit,*) 'qs_localize: ratio2=',gnorm / ( REAL(k,KIND=dp)*REAL(n,KIND=dp) ),thresh(i) ! ENDIF !ENDDO @@ -933,7 +933,7 @@ CONTAINS END IF ! reset if new_direction - IF (new_direction .AND. MOD(line_searches, 20) .EQ. 5) THEN + IF (new_direction .AND. MOD(line_searches, 20) == 5) THEN CALL cp_cfm_set_all(skc, czero) CALL cp_cfm_set_all(Gct_old, czero) norm2_old = 1.0E30_dp @@ -1078,7 +1078,7 @@ CONTAINS CALL cp_cfm_scale_and_add(cone, skc, cone, Gct_old) CALL cp_cfm_trace(skc, Gct_old, cnorm2_Gct_cross) norm2_Gct_cross = REAL(cnorm2_Gct_cross, KIND=dp) - IF (norm2_Gct_cross .LE. 0.0_dp) THEN ! back to steepest ascent + IF (norm2_Gct_cross <= 0.0_dp) THEN ! back to steepest ascent CALL cp_cfm_scale_and_add(czero, skc, cone, Gct_old) END IF ELSE @@ -1093,7 +1093,7 @@ CONTAINS ! gold line search new_direction = .FALSE. - IF (line_search_count .EQ. 1) THEN + IF (line_search_count == 1) THEN lsl = 1 lsr = 0 lsm = 1 @@ -1101,7 +1101,7 @@ CONTAINS pos(2) = ds_min/gold_sec ds = pos(2) ELSE - IF (line_search_count .EQ. 50) THEN + IF (line_search_count == 50) THEN IF (ABS(energy(line_search_count) - energy(line_search_count - 1)) < 1.0E-4_dp) THEN CPWARN("Line search failed to converge properly") ds_min = 0.1_dp @@ -1112,8 +1112,8 @@ CONTAINS CPABORT("No. of line searches exceeds 50") END IF ELSE - IF (lsr .EQ. 0) THEN - IF (energy(line_search_count - 1) .GT. energy(line_search_count)) THEN + IF (lsr == 0) THEN + IF (energy(line_search_count - 1) > energy(line_search_count)) THEN lsr = line_search_count pos(line_search_count + 1) = pos(lsm) + (pos(lsr) - pos(lsm))*gold_sec ELSE @@ -1122,27 +1122,27 @@ CONTAINS pos(line_search_count + 1) = pos(line_search_count)/gold_sec END IF ELSE - IF (pos(line_search_count) .LT. pos(lsm)) THEN - IF (energy(line_search_count) .GT. energy(lsm)) THEN + IF (pos(line_search_count) < pos(lsm)) THEN + IF (energy(line_search_count) > energy(lsm)) THEN lsr = lsm lsm = line_search_count ELSE lsl = line_search_count END IF ELSE - IF (energy(line_search_count) .GT. energy(lsm)) THEN + IF (energy(line_search_count) > energy(lsm)) THEN lsl = lsm lsm = line_search_count ELSE lsr = line_search_count END IF END IF - IF (pos(lsr) - pos(lsm) .GT. pos(lsm) - pos(lsl)) THEN + IF (pos(lsr) - pos(lsm) > pos(lsm) - pos(lsl)) THEN pos(line_search_count + 1) = pos(lsm) + gold_sec*(pos(lsr) - pos(lsm)) ELSE pos(line_search_count + 1) = pos(lsl) + gold_sec*(pos(lsm) - pos(lsl)) END IF - IF ((pos(lsr) - pos(lsl)) .LT. 1.0E-3_dp*pos(lsr)) THEN + IF ((pos(lsr) - pos(lsl)) < 1.0E-3_dp*pos(lsr)) THEN new_direction = .TRUE. END IF END IF ! lsr .eq. 0 @@ -1685,11 +1685,11 @@ CONTAINS mii(idim) = diag_z(row_indices(irow), idim) mjj(idim) = diag_z(col_indices(icol), idim) END DO - IF (row_indices(irow) .NE. col_indices(icol)) THEN + IF (row_indices(irow) /= col_indices(icol)) THEN CALL get_angle(mii, mjj, mij, weights, theta) theta = crazy_scale*theta - IF (theta .GT. limit_crazy_angle) theta = limit_crazy_angle - IF (theta .LT. -limit_crazy_angle) theta = -limit_crazy_angle + IF (theta > limit_crazy_angle) theta = limit_crazy_angle + IF (theta < -limit_crazy_angle) theta = -limit_crazy_angle IF (crazy_use_diag) THEN cmat_A%local_data(irow, icol) = -CMPLX(0.0_dp, theta, dp) ELSE @@ -1744,10 +1744,10 @@ CONTAINS "CRAZY| ", iterations, value, tolerance, maxeval, limit_crazy_angle CALL m_flush(unit_nr) END IF - IF (tolerance .LT. eps_localization .OR. iterations .GE. max_iter) EXIT + IF (tolerance < eps_localization .OR. iterations >= max_iter) EXIT END DO - IF (PRESENT(converged)) converged = (tolerance .LT. eps_localization) + IF (PRESENT(converged)) converged = (tolerance < eps_localization) CALL cp_cfm_release(cmat_A) CALL cp_cfm_release(cmat_R) @@ -1880,7 +1880,7 @@ CONTAINS CALL parallel_gemm('N', 'C', n, n, n, cone, cmat_t1, cmat_R, czero, cmat_U) cmat_U%local_data = REAL(cmat_U%local_data, KIND=dp) ! enforce numerics, U is a real matrix - IF (new_direction .AND. MOD(line_searches, 20) .EQ. 5) THEN ! reset with A .eq. 0 + IF (new_direction .AND. MOD(line_searches, 20) == 5) THEN ! reset with A .eq. 0 DO idim = 1, ndim CALL parallel_gemm('N', 'N', n, n, n, cone, c_zij(idim), cmat_U, czero, cmat_t1) CALL parallel_gemm('C', 'N', n, n, n, cone, cmat_U, cmat_t1, czero, c_zij(idim)) @@ -1940,7 +1940,7 @@ CONTAINS DO irow = 1, nrow_local ll = (0.0_dp, -1.0_dp)*evals(row_indices(irow)) lk = (0.0_dp, -1.0_dp)*evals(col_indices(icol)) - IF (ABS(ll - lk) .LT. 0.5_dp) THEN ! use a series expansion to avoid loss of precision + IF (ABS(ll - lk) < 0.5_dp) THEN ! use a series expansion to avoid loss of precision tmp = 1.0_dp cmat_B%local_data(irow, icol) = 0.0_dp DO i = 1, 16 @@ -1999,7 +1999,7 @@ CONTAINS beta_pr = MAX(beta_pr, 0.0_dp) CALL cp_fm_scale_and_add(beta_pr, matrix_G_search, -1.0_dp, matrix_G_old) CALL cp_fm_trace(matrix_G_search, matrix_G_old, normg_cross) - IF (normg_cross .GE. 0) THEN ! back to SD + IF (normg_cross >= 0) THEN ! back to SD IF (matrix_A%matrix_struct%para_env%is_source()) THEN WRITE (cp_logger_get_default_unit_nr(), *) "!" END IF @@ -2032,10 +2032,10 @@ CONTAINS b = grad(1) x1 = pos(2) a = (energy(2) - b*x1 - c)/(x1**2) - IF (a .LE. 0.0_dp) a = 1.0E-15_dp + IF (a <= 0.0_dp) a = 1.0E-15_dp npos = -b/(2.0_dp*a) val = a*npos**2 + b*npos + c - IF (val .LT. energy(1) .AND. val .LE. energy(2)) THEN + IF (val < energy(1) .AND. val <= energy(2)) THEN ! we go to a minimum, but ... ! we take a guard against too large steps pos(3) = MIN(npos, MAXVAL(pos(1:2))*4.0_dp) @@ -2051,7 +2051,7 @@ CONTAINS pos(2) = ds_min*0.8_dp CASE (2) new_direction = .FALSE. - IF (energy(2) .GT. energy(1)) THEN + IF (energy(2) > energy(1)) THEN pos(3) = ds_min*0.7_dp ELSE pos(3) = ds_min*1.4_dp @@ -2066,7 +2066,7 @@ CONTAINS fc = energy(3) nom = (xb - xa)**2*(fb - fc) - (xb - xc)**2*(fb - fa) denom = (xb - xa)*(fb - fc) - (xb - xc)*(fb - fa) - IF (ABS(denom) .LE. 1.0E-18_dp*MAX(ABS(fb - fc), ABS(fb - fa))) THEN + IF (ABS(denom) <= 1.0E-18_dp*MAX(ABS(fb - fc), ABS(fb - fa))) THEN npos = xb ELSE npos = xb - 0.5_dp*nom/denom ! position of the stationary point @@ -2074,7 +2074,7 @@ CONTAINS val = (npos - xa)*(npos - xb)*fc/((xc - xa)*(xc - xb)) + & (npos - xb)*(npos - xc)*fa/((xa - xb)*(xa - xc)) + & (npos - xc)*(npos - xa)*fb/((xb - xc)*(xb - xa)) - IF (val .LT. fa .AND. val .LE. fb .AND. val .LE. fc) THEN ! OK, we go to a minimum + IF (val < fa .AND. val <= fb .AND. val <= fc) THEN ! OK, we go to a minimum ! we take a guard against too large steps pos(4) = MAX(MAXVAL(pos(1:3))*0.01_dp, & MIN(npos, MAXVAL(pos(1:3))*4.0_dp)) @@ -2084,16 +2084,16 @@ CONTAINS END SELECT CASE (3) ! golden section hunt new_direction = .FALSE. - IF (line_search_count .EQ. 1) THEN + IF (line_search_count == 1) THEN lsl = 1 lsr = 0 lsm = 1 pos(1) = 0.0_dp pos(2) = ds_min/gold_sec ELSE - IF (line_search_count .EQ. 150) CPABORT("Too many") - IF (lsr .EQ. 0) THEN - IF (energy(line_search_count - 1) .LT. energy(line_search_count)) THEN + IF (line_search_count == 150) CPABORT("Too many") + IF (lsr == 0) THEN + IF (energy(line_search_count - 1) < energy(line_search_count)) THEN lsr = line_search_count pos(line_search_count + 1) = pos(lsm) + (pos(lsr) - pos(lsm))*gold_sec ELSE @@ -2102,27 +2102,27 @@ CONTAINS pos(line_search_count + 1) = pos(line_search_count)/gold_sec END IF ELSE - IF (pos(line_search_count) .LT. pos(lsm)) THEN - IF (energy(line_search_count) .LT. energy(lsm)) THEN + IF (pos(line_search_count) < pos(lsm)) THEN + IF (energy(line_search_count) < energy(lsm)) THEN lsr = lsm lsm = line_search_count ELSE lsl = line_search_count END IF ELSE - IF (energy(line_search_count) .LT. energy(lsm)) THEN + IF (energy(line_search_count) < energy(lsm)) THEN lsl = lsm lsm = line_search_count ELSE lsr = line_search_count END IF END IF - IF (pos(lsr) - pos(lsm) .GT. pos(lsm) - pos(lsl)) THEN + IF (pos(lsr) - pos(lsm) > pos(lsm) - pos(lsl)) THEN pos(line_search_count + 1) = pos(lsm) + gold_sec*(pos(lsr) - pos(lsm)) ELSE pos(line_search_count + 1) = pos(lsl) + gold_sec*(pos(lsm) - pos(lsl)) END IF - IF ((pos(lsr) - pos(lsl)) .LT. 1.0E-3_dp*pos(lsr)) THEN + IF ((pos(lsr) - pos(lsl)) < 1.0E-3_dp*pos(lsr)) THEN new_direction = .TRUE. END IF END IF ! lsr .eq. 0 diff --git a/src/qs_mo_io.F b/src/qs_mo_io.F index 6f1094e7a0..4c92e0f3fc 100644 --- a/src/qs_mo_io.F +++ b/src/qs_mo_io.F @@ -910,7 +910,7 @@ CONTAINS END IF DO iso = 1, nso(lshell) IF (use_this) THEN - IF (offset_read - 1 + iso .LT. 1 .OR. offset_read - 1 + iso .GT. nao_read) THEN + IF (offset_read - 1 + iso < 1 .OR. offset_read - 1 + iso > nao_read) THEN vecbuffer(1, irow) = 0.0_dp ELSE vecbuffer(1, irow) = vecbuffer_read(1, offset_read - 1 + iso) @@ -952,7 +952,7 @@ CONTAINS mos(ispin + 1)%homo = mos(ispin)%homo mos(ispin + 1)%lfomo = mos(ispin)%lfomo nelectron = mos(ispin)%nelectron - IF (my_mult .NE. 1) THEN + IF (my_mult /= 1) THEN CALL cp_abort(__LOCATION__, & "Restarting an LSD calculation from an LDA wfn only works for multiplicity=1 (singlets).") END IF diff --git a/src/qs_mo_methods.F b/src/qs_mo_methods.F index d987d32948..e3fba3aec6 100644 --- a/src/qs_mo_methods.F +++ b/src/qs_mo_methods.F @@ -96,12 +96,12 @@ CONTAINS TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp TYPE(cp_fm_type) :: overlap_vv, svmatrix - IF (ncol .EQ. 0) RETURN + IF (ncol == 0) RETURN CALL timeset(routineN, handle) CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_create(svmatrix, vmatrix%matrix_struct, "SV") CALL cp_dbcsr_sm_fm_multiply(matrix_s, vmatrix, svmatrix, ncol) @@ -145,13 +145,13 @@ CONTAINS TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp TYPE(cp_fm_type) :: overlap_vv - IF (ncol .EQ. 0) RETURN + IF (ncol == 0) RETURN CALL timeset(routineN, handle) NULLIFY (fm_struct_tmp) CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol, & para_env=vmatrix%matrix_struct%para_env, & @@ -193,13 +193,13 @@ CONTAINS TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp TYPE(cp_fm_type) :: fm_svmatrix, fm_vmatrix, overlap_vv - IF (ncol .EQ. 0) RETURN + IF (ncol == 0) RETURN CALL timeset(routineN, handle) !CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global) CALL dbcsr_get_info(vmatrix, nfullrows_total=n, nfullcols_total=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp, context=blacs_env, nrow_global=ncol, & ncol_global=ncol, para_env=para_env) @@ -257,13 +257,13 @@ CONTAINS TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp TYPE(cp_fm_type) :: overlap_vv - IF (ncol .EQ. 0) RETURN + IF (ncol == 0) RETURN CALL timeset(routineN, handle) NULLIFY (fm_struct_tmp) CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol, & para_env=vmatrix%matrix_struct%para_env, & @@ -309,13 +309,13 @@ CONTAINS TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp TYPE(cp_fm_type) :: csc, sc, work - IF (ncol .EQ. 0) RETURN + IF (ncol == 0) RETURN CALL timeset(routineN, handle) NULLIFY (fm_struct_tmp) threshold = 1.0E-7_dp CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_create(sc, vmatrix%matrix_struct, "SC") CALL cp_dbcsr_sm_fm_multiply(matrix_s, vmatrix, sc, ncol) @@ -361,14 +361,14 @@ CONTAINS TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp TYPE(cp_fm_type) :: overlap_vv - IF (ncol .EQ. 0) RETURN + IF (ncol == 0) RETURN CALL timeset(routineN, handle) NULLIFY (fm_struct_tmp) CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol, & para_env=vmatrix%matrix_struct%para_env, & @@ -443,7 +443,7 @@ CONTAINS compute_evecs = .TRUE. END IF - IF (ncol_global .GT. 0) THEN + IF (ncol_global > 0) THEN ALLOCATE (evals(ncol_global)) @@ -583,7 +583,7 @@ CONTAINS compute_evecs = .TRUE. END IF - IF (ncol_global .GT. 0) THEN + IF (ncol_global > 0) THEN ALLOCATE (evals(ncol_global)) @@ -737,7 +737,7 @@ CONTAINS DO i = 1, nrow_local DO j = 1, ncol_local alpha = overlap%local_data(i, j) - IF (row_indices(i) .EQ. col_indices(j)) alpha = alpha - 1.0_dp + IF (row_indices(i) == col_indices(j)) alpha = alpha - 1.0_dp max_alpha = MAX(max_alpha, ABS(alpha)) END DO END DO @@ -846,7 +846,7 @@ CONTAINS eigenvalues=mo_eigenvalues, homo=homo, nmo=nmo) IF (output_unit > 0) WRITE (output_unit, *) " " IF (output_unit > 0) WRITE (output_unit, *) " Eigenvalues of the occupied subspace spin ", ispin - ! IF (homo .NE. nmo) THEN + ! IF (homo /= nmo) THEN ! IF (output_unit>0) WRITE(output_unit,*)" and ",nmo-homo," added MO eigenvalues" ! END IF IF (output_unit > 0) WRITE (output_unit, *) "---------------------------------------------" diff --git a/src/qs_neighbor_list_types.F b/src/qs_neighbor_list_types.F index f6d89c58c6..01b20b59a4 100644 --- a/src/qs_neighbor_list_types.F +++ b/src/qs_neighbor_list_types.F @@ -358,7 +358,7 @@ CONTAINS TYPE(neighbor_list_set_p_type), DIMENSION(:), & POINTER :: nl - IF (SIZE(iterator_set) .NE. 1 .AND. .NOT. PRESENT(mepos)) & + IF (SIZE(iterator_set) /= 1 .AND. .NOT. PRESENT(mepos)) & CPABORT("Parallel iterator calls must include 'mepos'") IF (PRESENT(mepos)) THEN @@ -558,7 +558,7 @@ CONTAINS TYPE(neighbor_list_iterator_type), POINTER :: iterator CPASSERT(ASSOCIATED(iterator_set)) - IF ((SIZE(iterator_set) .NE. 1) .AND. (.NOT. PRESENT(mepos))) THEN + IF ((SIZE(iterator_set) /= 1) .AND. (.NOT. PRESENT(mepos))) THEN CPABORT("Parallel iterator calls must include 'mepos'") END IF IF (PRESENT(mepos)) THEN diff --git a/src/qs_neighbor_lists.F b/src/qs_neighbor_lists.F index 3d7d66e46d..8f3856381c 100644 --- a/src/qs_neighbor_lists.F +++ b/src/qs_neighbor_lists.F @@ -663,7 +663,7 @@ 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 .LE. pair_radius_lb(ikind, jkind)) & + 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 DO END DO @@ -1312,7 +1312,7 @@ CONTAINS IF (my_molecular) THEN mol_b = atom(jkind)%list_b_mol(jatom_local) IF (PRESENT(subset_of_mol)) THEN - IF (subset_of_mol(mol_b) .NE. current_subset) CYCLE + IF (subset_of_mol(mol_b) /= current_subset) CYCLE END IF END IF r = r_pbc(:, atom_b) @@ -1638,8 +1638,8 @@ CONTAINS ALLOCATE (list(na + nb)) n = na - IF (na .GT. 0) list(1:na) = lista(1:na) - IF (nb .GT. 0) THEN + IF (na > 0) list(1:na) = lista(1:na) + IF (nb > 0) THEN loopb: DO ib = 1, nb DO i = 1, na IF (listb(ib) == list(i)) CYCLE loopb diff --git a/src/qs_nl_hash_table_types.F b/src/qs_nl_hash_table_types.F index 1f9e6253ab..f3554b805c 100644 --- a/src/qs_nl_hash_table_types.F +++ b/src/qs_nl_hash_table_types.F @@ -112,7 +112,7 @@ CONTAINS CPASSERT(check_ok) ! check hash table size, if too small rehash in a larger table - IF (hash_table%obj%nelements*ENLARGE_RATIO .GE. hash_table%obj%nmax) THEN + IF (hash_table%obj%nelements*ENLARGE_RATIO >= hash_table%obj%nmax) THEN CALL nl_hash_table_rehash(hash_table=hash_table, nmax=hash_table%obj%nmax*EXPAND_FACTOR) END IF @@ -174,7 +174,7 @@ CONTAINS LOGICAL :: check_ok - CPASSERT((idx .GT. 0) .AND. (idx .LE. hash_table%obj%nmax)) + CPASSERT((idx > 0) .AND. (idx <= hash_table%obj%nmax)) check_ok = nl_hash_table_has_data(hash_table) CPASSERT(check_ok) @@ -215,13 +215,13 @@ CONTAINS ! table length should always be power of 2. Find the least ! power that is greater or equal to my_nmax two_to_power = 1 ! = 2**0 - DO WHILE (two_to_power .LT. my_nmax) + DO WHILE (two_to_power < my_nmax) two_to_power = 2*two_to_power END DO my_nmax = two_to_power IF (ASSOCIATED(hash_table%obj%table)) THEN - IF (SIZE(hash_table%obj%table) .NE. my_nmax) THEN + IF (SIZE(hash_table%obj%table) /= my_nmax) THEN DEALLOCATE (hash_table%obj%table) ALLOCATE (hash_table%obj%table(my_nmax)) END IF @@ -254,7 +254,7 @@ CONTAINS check_ok = nl_hash_table_has_data(hash_table) CPASSERT(check_ok) - check_ok = (key .LE. hash_table%obj%nmax) + check_ok = (key <= hash_table%obj%nmax) CPASSERT(check_ok) is_null = .FALSE. @@ -292,7 +292,7 @@ CONTAINS CALL nl_hash_table_release(hash_table) CALL nl_hash_table_create(hash_table=hash_table, nmax=my_nmax) DO ii = 1, SIZE(tmp_table) - IF (tmp_table(ii)%key .NE. EMPTY_KEY) THEN + IF (tmp_table(ii)%key /= EMPTY_KEY) THEN CALL nl_hash_table_add(hash_table=hash_table, & key=tmp_table(ii)%key, & val=tmp_table(ii)%val) diff --git a/src/qs_o3c_types.F b/src/qs_o3c_types.F index db0e357cde..a6f99cd0e3 100644 --- a/src/qs_o3c_types.F +++ b/src/qs_o3c_types.F @@ -178,7 +178,7 @@ CONTAINS !we only take ijk if rjk = 0 OR rik = 0 (because of symmetry) CALL get_iterator_info(ac_iterator, r=rik) rjk(:) = rik(:) - ijpair%rij(:) - IF (.NOT. (ALL(ABS(rjk) .LE. 1.0E-4_dp) .OR. ALL(ABS(rik) .LE. 1.0E-4_dp))) CYCLE + IF (.NOT. (ALL(ABS(rjk) <= 1.0E-4_dp) .OR. ALL(ABS(rik) <= 1.0E-4_dp))) CYCLE END IF nk = nk + 1 END DO @@ -195,7 +195,7 @@ CONTAINS !we only take ijk if rjk = 0 OR rik = 0 (because of symmetry) CALL get_iterator_info(ac_iterator, r=rik) rjk(:) = rik(:) - ijpair%rij(:) - IF (.NOT. (ALL(ABS(rjk) .LE. 1.0E-4_dp) .OR. ALL(ABS(rik) .LE. 1.0E-4_dp))) CYCLE + IF (.NOT. (ALL(ABS(rjk) <= 1.0E-4_dp) .OR. ALL(ABS(rik) <= 1.0E-4_dp))) CYCLE END IF nk = nk + 1 diff --git a/src/qs_oce_methods.F b/src/qs_oce_methods.F index b86cb0cc7c..4b3892166c 100644 --- a/src/qs_oce_methods.F +++ b/src/qs_oce_methods.F @@ -160,7 +160,7 @@ CONTAINS ! check if this function is hard radius = exp_radius(lb_max(jset), MAXVAL(zetb(1:npgfb(jset), jset)), eps_fit, 1.0_dp) - IF (radius .LE. hard_radius_b) sgf_hard_only = sgf_hard_only + 1 + IF (radius <= hard_radius_b) sgf_hard_only = sgf_hard_only + 1 ! Integral between proj of iatom and primitives of jatom ! Calculate the primitives overlap @@ -243,7 +243,7 @@ CONTAINS ! Check if the screened functions are all soft sgf_soft_only = .FALSE. - IF (sgf_hard_only .EQ. 0) sgf_soft_only = .TRUE. + IF (sgf_hard_only == 0) sgf_soft_only = .TRUE. DEALLOCATE (s, spa_sb, spa_tmp, ovs) @@ -796,10 +796,10 @@ CONTAINS REAL(KIND=dp) :: buf1(len1), buf2(len2) - IF (na .EQ. 0 .OR. nb .EQ. 0 .OR. nso .EQ. 0) RETURN + IF (na == 0 .OR. nb == 0 .OR. nso == 0) RETURN ! Handle special cases - IF (na .EQ. 1 .AND. nb .EQ. 1) THEN + IF (na == 1 .AND. nb == 1) THEN ! hard CALL dger(nso, nso, fac*blk(1, 1), h_a(1, 1), 1, h_b(1, 1), 1, proj_h(1, 1), nso) ! soft diff --git a/src/qs_operators_ao.F b/src/qs_operators_ao.F index ab591b18d8..689a1a6a6b 100644 --- a/src/qs_operators_ao.F +++ b/src/qs_operators_ao.F @@ -398,17 +398,17 @@ CONTAINS ! ! (a|p_x|b) = 2*a*(a+1x|b) - N_x(a)*(a-1_x|b) dumx = 2.0_dp*zeta(ipgf)*rr(ax + 1, bx, 1) - IF (ax .GT. 0) dumx = dumx - REAL(ax, dp)*rr(ax - 1, bx, 1) + IF (ax > 0) dumx = dumx - REAL(ax, dp)*rr(ax - 1, bx, 1) intab(ma, mb, 1) = f0*dumx*rr(ay, by, 2)*rr(az, bz, 3) ! ! (a|p_y|b) dumy = 2.0_dp*zeta(ipgf)*rr(ay + 1, by, 2) - IF (ay .GT. 0) dumy = dumy - REAL(ay, dp)*rr(ay - 1, by, 2) + IF (ay > 0) dumy = dumy - REAL(ay, dp)*rr(ay - 1, by, 2) intab(ma, mb, 2) = f0*rr(ax, bx, 1)*dumy*rr(az, bz, 3) ! ! (a|p_z|b) dumz = 2.0_dp*zeta(ipgf)*rr(az + 1, bz, 3) - IF (az .GT. 0) dumz = dumz - REAL(az, dp)*rr(az - 1, bz, 3) + IF (az > 0) dumz = dumz - REAL(az, dp)*rr(az - 1, bz, 3) intab(ma, mb, 3) = f0*rr(ax, bx, 1)*rr(ay, by, 2)*dumz ! END DO @@ -764,9 +764,9 @@ CONTAINS dumx = -2.0_dp*zeta(ipgf)*rr(ax + 1, bx, 1) dumy = -2.0_dp*zeta(ipgf)*rr(ay + 1, by, 2) dumz = -2.0_dp*zeta(ipgf)*rr(az + 1, bz, 3) - IF (ax .GT. 0) dumx = dumx + REAL(ax, dp)*rr(ax - 1, bx, 1) - IF (ay .GT. 0) dumy = dumy + REAL(ay, dp)*rr(ay - 1, by, 2) - IF (az .GT. 0) dumz = dumz + REAL(az, dp)*rr(az - 1, bz, 3) + IF (ax > 0) dumx = dumx + REAL(ax, dp)*rr(ax - 1, bx, 1) + IF (ay > 0) dumy = dumy + REAL(ay, dp)*rr(ay - 1, by, 2) + IF (az > 0) dumz = dumz + REAL(az, dp)*rr(az - 1, bz, 3) ! ! (a|l_z|b) intab(ma, mb, 1) = -f0*rr(ax, bx, 1)*( & @@ -1392,7 +1392,7 @@ CONTAINS CPASSERT(ASSOCIATED(op)) CPASSERT(ASSOCIATED(op_der)) !IF(.NOT.op_sm_der(1,1)%matrix%symmetry=="none") THEN - IF (.NOT. dbcsr_get_matrix_type(op_der(1, 1)%matrix) .EQ. dbcsr_type_no_symmetry) THEN + IF (.NOT. dbcsr_get_matrix_type(op_der(1, 1)%matrix) == dbcsr_type_no_symmetry) THEN CPABORT("") END IF @@ -1494,9 +1494,9 @@ CONTAINS zetb => basis_set_b%zet ldsa = SIZE(sphi_a, 1) - IF (ldsa .EQ. 0) CYCLE + IF (ldsa == 0) CYCLE ldsb = SIZE(sphi_b, 1) - IF (ldsb .EQ. 0) CYCLE + IF (ldsb == 0) CYCLE IF (inode == 1) last_jatom = 0 IF (my_minimum_image) THEN diff --git a/src/qs_ot.F b/src/qs_ot.F index 4bf2a4e14c..7404aedf91 100644 --- a/src/qs_ot.F +++ b/src/qs_ot.F @@ -196,7 +196,7 @@ CONTAINS CALL dbcsr_add(U, Gp1, alpha_scalar=1.0_dp, beta_scalar=expfactor) norm_fro = dbcsr_frobenius_norm(Gp1) !write(*,*) 'Taylor expansion i=',i,' norm(X^i)/i!=',norm_fro*expfactor - IF (norm_fro*expfactor .LT. 1.0E-10_dp) EXIT + IF (norm_fro*expfactor < 1.0E-10_dp) EXIT END DO ! ! rotate MOs @@ -295,9 +295,9 @@ CONTAINS ! ! compute the P^(-1/2) DO i = 1, k - IF (eig(i) .LE. 0.0_dp) & + IF (eig(i) <= 0.0_dp) & CPABORT("P not positive definite") - IF (eig(i) .LT. 1.0E-8_dp) THEN + IF (eig(i) < 1.0E-8_dp) THEN fun(i) = 0.0_dp ELSE fun(i) = 1.0_dp/SQRT(eig(i)) @@ -363,14 +363,14 @@ CONTAINS ! ! can we do a quick exit? quick_exit = .FALSE. - IF (norm .LT. qs_ot_env%settings%eps_irac_quick_exit) quick_exit = .TRUE. + IF (norm < qs_ot_env%settings%eps_irac_quick_exit) quick_exit = .TRUE. ! ! lets refine rescale = 1.0_dp DO irefine = 1, qs_ot_env%settings%max_irac ! ! rescaling - IF (norm .GT. 1.0_dp) THEN + IF (norm > 1.0_dp) THEN CALL dbcsr_scale(P, 1.0_dp/norm) rescale = rescale/SQRT(norm) END IF @@ -380,11 +380,11 @@ CONTAINS qs_ot_env%settings%eps_irac_filter_matrix) ! ! collect the transformation - IF (irefine .EQ. 1) THEN + IF (irefine == 1) THEN CALL dbcsr_copy(FT, FY, name='FT') ELSE CALL dbcsr_multiply('N', 'N', 1.0_dp, FT, FY, 0.0_dp, BUF1) - IF (qs_ot_env%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(buf1) CALL dbcsr_filter(buf1, qs_ot_env%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(buf1) @@ -399,13 +399,13 @@ CONTAINS ! ! P = FY^T * P * FY CALL dbcsr_multiply('N', 'N', 1.0_dp, P, FY, 0.0_dp, BUF_NOSYM) - IF (qs_ot_env%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(buf_nosym) CALL dbcsr_filter(buf_nosym, qs_ot_env%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(buf_nosym) END IF CALL dbcsr_multiply('N', 'N', 1.0_dp, FY, BUF_NOSYM, 0.0_dp, P) - IF (qs_ot_env%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(p) CALL dbcsr_filter(p, qs_ot_env%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(p) @@ -429,16 +429,16 @@ CONTAINS END IF ! ! can we do a quick exit next step? - IF (norm .LT. qs_ot_env%settings%eps_irac_quick_exit) quick_exit = .TRUE. + IF (norm < qs_ot_env%settings%eps_irac_quick_exit) quick_exit = .TRUE. ! ! are we done? - IF (norm .LT. qs_ot_env%settings%eps_irac) EXIT + IF (norm < qs_ot_env%settings%eps_irac) EXIT ! END DO ! ! C_NEW = C_NEW * FT * rescale CALL dbcsr_multiply('N', 'N', rescale, C_OLD, FT, 0.0_dp, C_NEW) - IF (qs_ot_env%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(c_new) CALL dbcsr_filter(c_new, qs_ot_env%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(c_new) @@ -447,7 +447,7 @@ CONTAINS ! update SC = SC * FY * rescale IF (update) THEN CALL dbcsr_multiply('N', 'N', rescale, SC, FT, 0.0_dp, C_TMP) - IF (qs_ot_env%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(c_tmp) CALL dbcsr_filter(c_tmp, qs_ot_env%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(c_tmp) @@ -473,7 +473,7 @@ CONTAINS CASE ("CG") SELECT CASE (qs_ot_env1%settings%line_search_method) CASE ("2PNT") - IF (qs_ot_env1%line_search_count .EQ. 2) update = .TRUE. + IF (qs_ot_env1%line_search_count == 2) update = .TRUE. CASE DEFAULT CPABORT("NYI") END SELECT @@ -497,7 +497,7 @@ CONTAINS CHARACTER(LEN=*), INTENT(INOUT) :: ortho_irac ortho_irac = qs_ot_env1%settings%ortho_irac - IF (norm_in .LT. qs_ot_env1%settings%eps_irac_switch) ortho_irac = "POLY" + IF (norm_in < qs_ot_env1%settings%eps_irac_switch) ortho_irac = "POLY" END SUBROUTINE qs_ot_ref_decide ! ************************************************************************************************** @@ -552,7 +552,7 @@ CONTAINS ! compute SC = S*C IF (ASSOCIATED(S)) THEN CALL dbcsr_multiply('N', 'N', 1.0_dp, S, C_OLD, 0.0_dp, SC) - IF (qs_ot_env1%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env1%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(sc) CALL dbcsr_filter(sc, qs_ot_env1%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(sc) @@ -563,7 +563,7 @@ CONTAINS ! ! compute P = C'*SC CALL dbcsr_multiply('T', 'N', 1.0_dp, C_OLD, SC, 0.0_dp, P) - IF (qs_ot_env1%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env1%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(p) CALL dbcsr_filter(p, qs_ot_env1%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(p) @@ -627,7 +627,7 @@ CONTAINS ! C_out = C_in * ( 15/8 * I - 10/8 * P + 3/8 * P^2) r = 3.0_dp/8.0_dp CALL dbcsr_multiply('N', 'N', r, P, P, 0.0_dp, FY) - IF (eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(fy) CALL dbcsr_filter(fy, eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(fy) @@ -639,14 +639,14 @@ CONTAINS CASE (3) ! C_out = C_in * ( 35/16 * I - 35/16 * P + 21/16 * P^2 - 5/16 P^3) CALL dbcsr_multiply('N', 'N', 1.0_dp, P, P, 0.0_dp, P2) - IF (eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(p2) CALL dbcsr_filter(p2, eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(p2) END IF r = -5.0_dp/16.0_dp CALL dbcsr_multiply('N', 'N', r, P2, P, 0.0_dp, FY) - IF (eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(fy) CALL dbcsr_filter(fy, eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(fy) @@ -661,7 +661,7 @@ CONTAINS ! C_out = C_in * ( 315/128 * I - 420/128 * P + 378/128 * P^2 - 180/128 P^3 + 35/128 P^4 ) ! = C_in * ( 315/128 * I - 420/128 * P + 378/128 * P^2 + ( - 180/128 * P + 35/128 * P^2 ) * P^2 ) CALL dbcsr_multiply('N', 'N', 1.0_dp, P, P, 0.0_dp, P2) ! P^2 - IF (eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(p2) CALL dbcsr_filter(p2, eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(p2) @@ -671,7 +671,7 @@ CONTAINS r = 35.0_dp/128.0_dp CALL dbcsr_add(T, P2, alpha_scalar=1.0_dp, beta_scalar=r) ! T=T+35/128*P^2 CALL dbcsr_multiply('N', 'N', 1.0_dp, T, P2, 0.0_dp, FY) ! Y=T*P^2 - IF (eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(fy) CALL dbcsr_filter(fy, eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(fy) @@ -720,14 +720,14 @@ CONTAINS ! C'*(H*C) CALL dbcsr_multiply('T', 'N', 1.0_dp, C, HC, 0.0_dp, CHC) - IF (qs_ot_env%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(chc) CALL dbcsr_filter(chc, qs_ot_env%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(chc) END IF ! (S*C)*(C'*H*C) CALL dbcsr_multiply('N', 'N', 1.0_dp, SC, CHC, 0.0_dp, G) - IF (qs_ot_env%settings%eps_irac_filter_matrix .GT. 0.0_dp) THEN + IF (qs_ot_env%settings%eps_irac_filter_matrix > 0.0_dp) THEN occ_in = dbcsr_get_occupation(g) CALL dbcsr_filter(g, qs_ot_env%settings%eps_irac_filter_matrix) occ_out = dbcsr_get_occupation(g) @@ -965,7 +965,7 @@ CONTAINS l1 = (0.0_dp, -1.0_dp)*e1 l2 = (0.0_dp, -1.0_dp)*e2 - IF (ABS(l1 - l2) .GT. 0.5_dp) THEN + IF (ABS(l1 - l2) > 0.5_dp) THEN cint = (EXP(l1) - EXP(l2))/(l1 - l2) ELSE x = 1.0_dp @@ -1255,7 +1255,7 @@ CONTAINS ! this de/dc*(dX/dx)*sinp i.e. zeroth order CALL dbcsr_multiply('N', 'N', rone, matrix_hc, qs_ot_env%matrix_sinp, rzero, matrix_gx) - IF (qs_ot_env%taylor_order .LE. 0) THEN + IF (qs_ot_env%taylor_order <= 0) THEN CALL timestop(handle) RETURN END IF @@ -1353,7 +1353,7 @@ CONTAINS CALL dbcsr_add_on_diag(qs_ot_env%matrix_cosp, rone) CALL dbcsr_add_on_diag(qs_ot_env%matrix_sinp, rone) - IF (qs_ot_env%taylor_order .LE. 0) THEN + IF (qs_ot_env%taylor_order <= 0) THEN CALL timestop(handle) RETURN END IF @@ -1363,7 +1363,7 @@ CONTAINS sinfactor = -1.0_dp/(2.0_dp*3.0_dp) CALL dbcsr_add(qs_ot_env%matrix_cosp, qs_ot_env%matrix_p, alpha_scalar=1.0_dp, beta_scalar=cosfactor) CALL dbcsr_add(qs_ot_env%matrix_sinp, qs_ot_env%matrix_p, alpha_scalar=1.0_dp, beta_scalar=sinfactor) - IF (qs_ot_env%taylor_order .LE. 1) THEN + IF (qs_ot_env%taylor_order <= 1) THEN CALL timestop(handle) RETURN END IF @@ -1517,10 +1517,10 @@ CONTAINS REAL(KIND=dp) :: a, b, rs, sf, x, xs, y, ybx, ybxs ! this is currently a limit of the routine, could be removed rather easily - IF (xa .LT. 0) CPABORT("x is negative") - IF (ya .LT. 0) CPABORT("y is negative") + IF (xa < 0) CPABORT("x is negative") + IF (ya < 0) CPABORT("y is negative") - IF (xa .LT. ya) THEN + IF (xa < ya) THEN x = ya y = xa ELSE @@ -1528,10 +1528,10 @@ CONTAINS y = ya END IF - IF (x .LT. 0.5_dp) THEN ! use series, keeping in mind that x,y,x+y,x-y can all be zero + IF (x < 0.5_dp) THEN ! use series, keeping in mind that x,y,x+y,x-y can all be zero qs_ot_sincf = 0.0_dp - IF (x .GT. 0.0_dp) THEN + IF (x > 0.0_dp) THEN ybx = y/x ELSE ! should be irrelevant !? ybx = 0.0_dp @@ -1551,7 +1551,7 @@ CONTAINS END DO ELSE ! no series expansion - IF (x - y .GT. 0.1_dp) THEN ! safe to use the normal form + IF (x - y > 0.1_dp) THEN ! safe to use the normal form qs_ot_sincf = (qs_ot_sinc(x) - qs_ot_sinc(y))/((x + y)*(x - y)) ELSE a = (x + y)/2.0_dp diff --git a/src/qs_ot_minimizer.F b/src/qs_ot_minimizer.F index 96e4b8740d..00ee5edc73 100644 --- a/src/qs_ot_minimizer.F +++ b/src/qs_ot_minimizer.F @@ -179,7 +179,7 @@ CONTAINS IF (.NOT. qs_ot_env(1)%energy_only) THEN ! we have not yet started with the line search - IF (qs_ot_env(1)%line_search_count .EQ. 0) THEN + IF (qs_ot_env(1)%line_search_count == 0) THEN res = .TRUE. RETURN END IF @@ -303,13 +303,13 @@ CONTAINS qs_ot_env(1)%line_search_might_be_done = .FALSE. qs_ot_env(1)%energy_only = .TRUE. - IF (count + 1 .GT. SIZE(qs_ot_env(1)%OT_pos)) THEN + IF (count + 1 > SIZE(qs_ot_env(1)%OT_pos)) THEN ! should not happen, we pass with a warning first ! you can increase the size of OT_pos and the like in qs_ot_env CPABORT("MAX ITER EXCEEDED : FATAL") END IF - IF (qs_ot_env(1)%line_search_count .EQ. 1) THEN + IF (qs_ot_env(1)%line_search_count == 1) THEN qs_ot_env(1)%line_search_left = 1 qs_ot_env(1)%line_search_right = 0 qs_ot_env(1)%line_search_mid = 1 @@ -321,8 +321,8 @@ CONTAINS ! it's essentially a book keeping game. ! keep left on the left, keep (bring) right on the right ! and mid in between these two - IF (qs_ot_env(1)%line_search_right .EQ. 0) THEN ! we do not yet have the right bracket - IF (qs_ot_env(1)%ot_energy(count - 1) .LT. qs_ot_env(1)%ot_energy(count)) THEN + IF (qs_ot_env(1)%line_search_right == 0) THEN ! we do not yet have the right bracket + IF (qs_ot_env(1)%ot_energy(count - 1) < qs_ot_env(1)%ot_energy(count)) THEN qs_ot_env(1)%line_search_right = count qs_ot_env(1)%ot_pos(count + 1) = qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid) + & (qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_right) - & @@ -334,15 +334,15 @@ CONTAINS END IF ELSE ! first determine where we are and construct the new triplet - IF (qs_ot_env(1)%ot_pos(count) .LT. qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid)) THEN - IF (qs_ot_env(1)%ot_energy(count) .LT. qs_ot_env(1)%ot_energy(qs_ot_env(1)%line_search_mid)) THEN + IF (qs_ot_env(1)%ot_pos(count) < qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid)) THEN + IF (qs_ot_env(1)%ot_energy(count) < qs_ot_env(1)%ot_energy(qs_ot_env(1)%line_search_mid)) THEN qs_ot_env(1)%line_search_right = qs_ot_env(1)%line_search_mid qs_ot_env(1)%line_search_mid = count ELSE qs_ot_env(1)%line_search_left = count END IF ELSE - IF (qs_ot_env(1)%ot_energy(count) .LT. qs_ot_env(1)%ot_energy(qs_ot_env(1)%line_search_mid)) THEN + IF (qs_ot_env(1)%ot_energy(count) < qs_ot_env(1)%ot_energy(qs_ot_env(1)%line_search_mid)) THEN qs_ot_env(1)%line_search_left = qs_ot_env(1)%line_search_mid qs_ot_env(1)%line_search_mid = count ELSE @@ -351,7 +351,7 @@ CONTAINS END IF ! now find the new point in the largest section IF ((qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_right) & - - qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid)) .GT. & + - qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid)) > & (qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid) & - qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_left))) THEN qs_ot_env(1)%ot_pos(count + 1) = & @@ -366,10 +366,10 @@ CONTAINS END IF ! check for termination IF (((qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_right) & - - qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid)) .LT. & + - qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid)) < & qs_ot_env(1)%ds_min*qs_ot_env(1)%settings%gold_target) .AND. & ((qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_mid) & - - qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_left)) .LT. & + - qs_ot_env(1)%ot_pos(qs_ot_env(1)%line_search_left)) < & qs_ot_env(1)%ds_min*qs_ot_env(1)%settings%gold_target)) THEN qs_ot_env(1)%energy_only = .FALSE. qs_ot_env(1)%line_search_might_be_done = .TRUE. @@ -413,7 +413,7 @@ CONTAINS qs_ot_env(1)%ot_pos(count) = 0.0_dp qs_ot_env(1)%ot_pos(count + 1) = qs_ot_env(1)%ds_min*0.8_dp CASE (2) - IF (qs_ot_env(1)%OT_energy(count) .GT. qs_ot_env(1)%OT_energy(count - 1)) THEN + IF (qs_ot_env(1)%OT_energy(count) > qs_ot_env(1)%OT_energy(count - 1)) THEN qs_ot_env(1)%OT_pos(count + 1) = qs_ot_env(1)%ds_min*0.5_dp ELSE qs_ot_env(1)%OT_pos(count + 1) = qs_ot_env(1)%ds_min*1.4_dp @@ -427,7 +427,7 @@ CONTAINS fc = qs_ot_env(1)%OT_energy(3) nom = (xb - xa)**2*(fb - fc) - (xb - xc)**2*(fb - fa) denom = (xb - xa)*(fb - fc) - (xb - xc)*(fb - fa) - IF (ABS(denom) .LE. 1.0E-18_dp*MAX(ABS(fb - fc), ABS(fb - fa))) THEN + IF (ABS(denom) <= 1.0E-18_dp*MAX(ABS(fb - fc), ABS(fb - fa))) THEN pos = xb ELSE pos = xb - 0.5_dp*nom/denom ! position of the stationary point @@ -435,7 +435,7 @@ CONTAINS val = (pos - xa)*(pos - xb)*fc/((xc - xa)*(xc - xb)) + & (pos - xb)*(pos - xc)*fa/((xa - xb)*(xa - xc)) + & (pos - xc)*(pos - xa)*fb/((xb - xc)*(xb - xa)) - IF (val .LT. fa .AND. val .LE. fb .AND. val .LE. fc) THEN ! OK, we go to a minimum + IF (val < fa .AND. val <= fb .AND. val <= fc) THEN ! OK, we go to a minimum ! we take a guard against too large steps qs_ot_env(1)%OT_pos(count + 1) = MAX(MAXVAL(qs_ot_env(1)%OT_pos(1:3))*0.01_dp, & MIN(pos, MAXVAL(qs_ot_env(1)%OT_pos(1:3))*4.0_dp)) @@ -489,12 +489,12 @@ CONTAINS b = qs_ot_env(1)%ot_grad(1) x1 = qs_ot_env(1)%ot_pos(2) a = (qs_ot_env(1)%ot_energy(2) - b*x1 - c)/(x1**2) - IF (a .LE. 0.0_dp) a = 1.0E-15_dp + IF (a <= 0.0_dp) a = 1.0E-15_dp pos = -b/(2.0_dp*a) val = a*pos**2 + b*pos + c qs_ot_env(1)%energy_only = .FALSE. qs_ot_env(1)%line_search_might_be_done = .TRUE. - IF (val .LT. qs_ot_env(1)%ot_energy(1) .AND. val .LE. qs_ot_env(1)%ot_energy(2)) THEN + IF (val < qs_ot_env(1)%ot_energy(1) .AND. val <= qs_ot_env(1)%ot_energy(2)) THEN ! we go to a minimum, but ... ! we take a guard against too large steps qs_ot_env(1)%OT_pos(count + 1) = MAX(MAXVAL(qs_ot_env(1)%OT_pos(1:2))*0.01_dp, & @@ -681,7 +681,7 @@ CONTAINS CALL dbcsr_dot(qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_dx, tmp) qs_ot_env(1)%gnorm = qs_ot_env(1)%gnorm + tmp END DO - IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN + IF (qs_ot_env(1)%gnorm < 0.0_dp) THEN logger => cp_get_default_logger() WRITE (cp_logger_get_default_unit_nr(logger), *) "WARNING Preconditioner not positive definite !" END IF @@ -820,7 +820,7 @@ CONTAINS CALL dbcsr_dot(qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_gx_old, tmp) qs_ot_env(1)%gnorm = qs_ot_env(1)%gnorm + tmp END DO - IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN + IF (qs_ot_env(1)%gnorm < 0.0_dp) THEN WRITE (cp_logger_get_default_unit_nr(logger), *) "WARNING Preconditioner not positive definite !" END IF DO ispin = 1, nspin @@ -921,7 +921,7 @@ CONTAINS END DO END IF - IF (test_down .GE. 0.0_dp) THEN ! reset to SD + IF (test_down >= 0.0_dp) THEN ! reset to SD beta_pr = 0.0_dp IF (do_ks) THEN DO ispin = 1, nspin @@ -972,7 +972,7 @@ CONTAINS diis_m = qs_ot_env(1)%settings%diis_m - IF (qs_ot_env(1)%diis_iter .LT. diis_m) THEN + IF (qs_ot_env(1)%diis_iter < diis_m) THEN diis_bound = qs_ot_env(1)%diis_iter + 1 ELSE diis_bound = diis_m @@ -1005,7 +1005,7 @@ CONTAINS tmp) qs_ot_env(1)%gnorm = qs_ot_env(1)%gnorm + tmp END DO - IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN + IF (qs_ot_env(1)%gnorm < 0.0_dp) THEN WRITE (cp_logger_get_default_unit_nr(logger), *) "WARNING Preconditioner not positive definite !" END IF DO ispin = 1, nspin @@ -1145,7 +1145,7 @@ CONTAINS CALL DGESV(diis_bound + 1, 1, qs_ot_env(1)%lss_diis, diis_m + 1, qs_ot_env(1)%ipivot, & qs_ot_env(1)%c_diis, diis_m + 1, info) - IF (info .NE. 0) THEN + IF (info /= 0) THEN do_ot_sd = .TRUE. WRITE (cp_logger_get_default_unit_nr(logger), *) "Singular DIIS matrix" ELSE @@ -1227,7 +1227,7 @@ CONTAINS END IF overlap = (tr_xnew_gx - tr_xold_gx) ! OK, bad luck, take a SD step along the preconditioned gradient - IF (overlap .GT. 0.0_dp) THEN + IF (overlap > 0.0_dp) THEN do_ot_sd = .TRUE. END IF END IF @@ -1301,7 +1301,7 @@ CONTAINS beta = qs_ot_env(1)%settings%broyden_beta gamma = qs_ot_env(1)%settings%broyden_gamma IF (adaptive_sigma) THEN - IF (qs_ot_env(1)%broyden_adaptive_sigma .LT. 0.0_dp) THEN + IF (qs_ot_env(1)%broyden_adaptive_sigma < 0.0_dp) THEN sigma = qs_ot_env(1)%settings%broyden_sigma ELSE sigma = qs_ot_env(1)%broyden_adaptive_sigma @@ -1319,7 +1319,7 @@ CONTAINS diis_m = qs_ot_env(1)%settings%diis_m - IF (qs_ot_env(1)%diis_iter .LT. diis_m) THEN + IF (qs_ot_env(1)%diis_iter < diis_m) THEN diis_bound = qs_ot_env(1)%diis_iter + 1 ELSE diis_bound = diis_m @@ -1353,7 +1353,7 @@ CONTAINS tmp) qs_ot_env(1)%gnorm = qs_ot_env(1)%gnorm + tmp END DO - IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN + IF (qs_ot_env(1)%gnorm < 0.0_dp) THEN WRITE (cp_logger_get_default_unit_nr(logger), *) "WARNING Preconditioner not positive definite !" END IF DO ispin = 1, nspin @@ -1450,7 +1450,7 @@ CONTAINS S(k, :) = S(k, :)/tmp S(:, k) = S(:, k)/tmp - IF (diis_bound .GT. 1) THEN + IF (diis_bound > 1) THEN tmp = 0.0_dp tmp2 = 0.0_dp i = diis_bound @@ -1484,7 +1484,7 @@ CONTAINS ! If we went uphill, do backtracking line search i = MINLOC(qs_ot_env(1)%energy_h(1:diis_bound), dim=1) - IF (i .NE. j) THEN + IF (i /= j) THEN sigma = sigma_dec*sigma qs_ot_env(1)%OT_METHOD_FULL = "OT BTRK" DO ispin = 1, nspin @@ -1510,7 +1510,7 @@ CONTAINS tmp = 1.0_dp ! We want a pos def Hessian IF (enable_flip) THEN - IF (qs_ot_env(1)%c_broy(i - 1) .GT. 0) THEN + IF (qs_ot_env(1)%c_broy(i - 1) > 0) THEN !qs_ot_env(1)%OT_METHOD_FULL="OT FLIP" tmp = -1.0_dp END IF @@ -1564,7 +1564,7 @@ CONTAINS DO ispin = 1, nspin ! if the direction of the step is not in direction of the gradient, ! change step sign - IF (tmp .GE. 0.0_dp) THEN + IF (tmp >= 0.0_dp) THEN qs_ot_env(1)%OT_METHOD_FULL = "OT TURN" IF (forget_history) THEN qs_ot_env(1)%diis_iter = 0 @@ -1669,15 +1669,15 @@ CONTAINS H(j, i) = DOT_PRODUCT(Q(:, j), MATMUL(S, v)) v(:) = v - H(j, i)*Q(:, j) END DO - IF (i .LT. k) THEN + IF (i < k) THEN tmp = DOT_PRODUCT(v, MATMUL(S, v)) - IF (tmp .LE. 0.0_dp) THEN + IF (tmp <= 0.0_dp) THEN n = i EXIT END IF tmp = SQRT(tmp) ! Lucky breakdown - IF (ABS(tmp) .LT. 1e-9_dp) THEN + IF (ABS(tmp) < 1e-9_dp) THEN n = i EXIT END IF diff --git a/src/qs_ot_types.F b/src/qs_ot_types.F index 579cedf588..0fabc7de47 100644 --- a/src/qs_ot_types.F +++ b/src/qs_ot_types.F @@ -344,13 +344,13 @@ CONTAINS qs_ot_env%use_gx_old = .TRUE. qs_ot_env%use_dx = .TRUE. CASE ("DIIS", "BROY") - IF (m_diis .LT. 1) CPABORT("m_diis less than one") + IF (m_diis < 1) CPABORT("m_diis less than one") CASE DEFAULT CPABORT("Unknown option") END SELECT - IF (qs_ot_env%settings%ot_method .EQ. "DIIS" .OR. & - qs_ot_env%settings%ot_method .EQ. "BROY") THEN + IF (qs_ot_env%settings%ot_method == "DIIS" .OR. & + qs_ot_env%settings%ot_method == "BROY") THEN ALLOCATE (qs_ot_env%ls_diis(m_diis + 1, m_diis + 1)) qs_ot_env%ls_diis = 0.0_dp ALLOCATE (qs_ot_env%lss_diis(m_diis + 1, m_diis + 1)) @@ -530,8 +530,8 @@ CONTAINS END SELECT - IF (qs_ot_env%settings%ot_method .EQ. "DIIS" .OR. & - qs_ot_env%settings%ot_method .EQ. "BROY") THEN + IF (qs_ot_env%settings%ot_method == "DIIS" .OR. & + qs_ot_env%settings%ot_method == "BROY") THEN NULLIFY (qs_ot_env%matrix_h_e) NULLIFY (qs_ot_env%matrix_h_x) CALL dbcsr_allocate_matrix_set(qs_ot_env%matrix_h_e, m_diis) @@ -569,7 +569,7 @@ CONTAINS CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_chc, template=matrix_s, m=k, n=k, & sym=dbcsr_type_no_symmetry) - IF (qs_ot_env%settings%ot_method .EQ. "DIIS") THEN + IF (qs_ot_env%settings%ot_method == "DIIS") THEN CALL dbcsr_allocate_matrix_set(qs_ot_env%rot_mat_h_e, m_diis) CALL dbcsr_allocate_matrix_set(qs_ot_env%rot_mat_h_x, m_diis) DO i = 1, m_diis @@ -613,7 +613,7 @@ CONTAINS ncoef = k ALLOCATE (qs_ot_env%ener_x(ncoef)) - IF (qs_ot_env%settings%ot_method .EQ. "DIIS") THEN + IF (qs_ot_env%settings%ot_method == "DIIS") THEN ALLOCATE (qs_ot_env%ener_h_e(m_diis, ncoef)) ALLOCATE (qs_ot_env%ener_h_x(m_diis, ncoef)) END IF @@ -678,8 +678,8 @@ CONTAINS IF (ASSOCIATED(qs_ot_env%buf1_n_k)) CALL dbcsr_release_p(qs_ot_env%buf1_n_k) IF (ASSOCIATED(qs_ot_env%buf1_n_k_dp)) CALL dbcsr_release_p(qs_ot_env%buf1_n_k_dp) - IF (qs_ot_env%settings%ot_method .EQ. "DIIS" .OR. & - qs_ot_env%settings%ot_method .EQ. "BROY") THEN + IF (qs_ot_env%settings%ot_method == "DIIS" .OR. & + qs_ot_env%settings%ot_method == "BROY") THEN CALL dbcsr_deallocate_matrix_set(qs_ot_env%matrix_h_x) CALL dbcsr_deallocate_matrix_set(qs_ot_env%matrix_h_e) DEALLOCATE (qs_ot_env%ls_diis) @@ -697,7 +697,7 @@ CONTAINS IF (ASSOCIATED(qs_ot_env%rot_mat_dedu)) CALL dbcsr_release_p(qs_ot_env%rot_mat_dedu) IF (ASSOCIATED(qs_ot_env%rot_mat_chc)) CALL dbcsr_release_p(qs_ot_env%rot_mat_chc) - IF (qs_ot_env%settings%ot_method .EQ. "DIIS") THEN + IF (qs_ot_env%settings%ot_method == "DIIS") THEN CALL dbcsr_deallocate_matrix_set(qs_ot_env%rot_mat_h_x) CALL dbcsr_deallocate_matrix_set(qs_ot_env%rot_mat_h_e) END IF @@ -713,7 +713,7 @@ CONTAINS IF (qs_ot_env%settings%do_ener) THEN DEALLOCATE (qs_ot_env%ener_x) DEALLOCATE (qs_ot_env%ener_gx) - IF (qs_ot_env%settings%ot_method .EQ. "DIIS") THEN + IF (qs_ot_env%settings%ot_method == "DIIS") THEN DEALLOCATE (qs_ot_env%ener_h_x) DEALLOCATE (qs_ot_env%ener_h_e) END IF @@ -964,7 +964,7 @@ CONTAINS WRITE (output_unit, '(A)') " Precond_solver : "//TRIM(settings%precond_solver_name) - IF (settings%OT_METHOD .EQ. "SD" .OR. settings%OT_METHOD .EQ. "CG") THEN + IF (settings%OT_METHOD == "SD" .OR. settings%OT_METHOD == "CG") THEN SELECT CASE (settings%line_search_method) CASE ("2PNT") WRITE (output_unit, '(A)') " Line search : 2PNT : 2 energies, one gradient" @@ -981,11 +981,11 @@ CONTAINS END IF WRITE (output_unit, '(A,F14.8,T49,A,F14.8)') " stepsize :", settings%ds_min, & " energy_gap :", settings%energy_gap - IF (settings%ot_algorithm .EQ. 'TOD') THEN + IF (settings%ot_algorithm == 'TOD') THEN WRITE (output_unit, '(A,E14.5,T49,A,I14)') " eps_taylor :", settings%eps_taylor, & " max_taylor :", settings%max_taylor END IF - IF (settings%ot_algorithm .EQ. 'REF') THEN + IF (settings%ot_algorithm == 'REF') THEN WRITE (output_unit, '(A,1X,A,T49,A,I14)') " ortho_irac :", settings%ortho_irac, & " irac_degree :", settings%irac_degree WRITE (output_unit, '(A,I14,T49,A,E14.5)') " max_irac :", settings%max_irac, & diff --git a/src/qs_outer_scf.F b/src/qs_outer_scf.F index 92f2d25758..9e84eac7c9 100644 --- a/src/qs_outer_scf.F +++ b/src/qs_outer_scf.F @@ -217,8 +217,8 @@ CONTAINS DO i = 1, ihistory DO j = i + 1, ihistory ! distrust often used points - IF (scf_env%outer_scf%count(i) .GT. scf_control%outer_scf%bisect_trust_count) CYCLE - IF (scf_env%outer_scf%count(j) .GT. scf_control%outer_scf%bisect_trust_count) CYCLE + IF (scf_env%outer_scf%count(i) > scf_control%outer_scf%bisect_trust_count) CYCLE + IF (scf_env%outer_scf%count(j) > scf_control%outer_scf%bisect_trust_count) CYCLE ! if they bracket a zero use them IF (scf_env%outer_scf%gradient(1, i)* & @@ -273,7 +273,7 @@ CONTAINS CALL diamat_all(b, ev) a(:, :) = b DO I = 1, nb + 1 - IF (ABS(ev(I)) .LT. 1.0E-12_dp) THEN + IF (ABS(ev(I)) < 1.0E-12_dp) THEN a(:, I) = 0.0_dp ELSE a(:, I) = a(:, I)/ev(I) @@ -318,7 +318,7 @@ 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) .LT. 3) & + 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.") diff --git a/src/qs_resp.F b/src/qs_resp.F index 48ff0012b9..cdf0b55b20 100644 --- a/src/qs_resp.F +++ b/src/qs_resp.F @@ -1415,7 +1415,7 @@ CONTAINS IF (resp_env%rheavies) THEN DO i = 1, natom CALL get_atomic_kind(atomic_kind=particle_set(i)%atomic_kind, z=z) - IF (z .NE. 1) THEN + IF (z /= 1) THEN resp_env%matrix(i, i) = resp_env%matrix(i, i) + 2.0_dp*resp_env%rheavies_strength END IF END DO diff --git a/src/qs_rho_atom_methods.F b/src/qs_rho_atom_methods.F index 949db7fda1..c0193e78df 100644 --- a/src/qs_rho_atom_methods.F +++ b/src/qs_rho_atom_methods.F @@ -188,7 +188,7 @@ CONTAINS CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) CALL get_none0_cg_list(my_CG_dxyz, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, dacg_list, dacg_n_list, damax_iso_not0_local) n1s = nsoset(lmax(iset1)) @@ -232,7 +232,7 @@ CONTAINS vgg = 0.0_dp done_vgg = .FALSE. ! reduce the number of terms in the expansion local densities - IF (lmin12 .LE. lmax_expansion) THEN + IF (lmin12 <= lmax_expansion) THEN IF (lmin12 == 0) THEN gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr) gg_lm1(1:nr, lmin12) = 0.0_dp @@ -244,7 +244,7 @@ CONTAINS END IF ! reduce the number of terms in the expansion local densities - IF (lmax12 .GT. lmax_expansion) lmax12 = lmax_expansion + IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion DO l = lmin12 + 1, lmax12 gg(1:nr, l) = grid_atom%rad(1:nr)*gg(1:nr, l - 1) @@ -632,7 +632,7 @@ CONTAINS n_cont_a = alist_ac%clist(kac)%nsgf_cnt n_cont_b = alist_bc%clist(kbc)%nsgf_cnt - IF (n_cont_a .EQ. 0 .OR. n_cont_b .EQ. 0) CYCLE + IF (n_cont_a == 0 .OR. n_cont_b == 0) CYCLE list_a => alist_ac%clist(kac)%sgf_list list_b => alist_bc%clist(kbc)%sgf_list diff --git a/src/qs_rho_methods.F b/src/qs_rho_methods.F index bed3e0e7d4..035e2d29d5 100644 --- a/src/qs_rho_methods.F +++ b/src/qs_rho_methods.F @@ -1579,8 +1579,8 @@ CONTAINS nspins = dft_control%nspins nimages = dft_control%nimages - CPASSERT(nspins .EQ. SIZE(rho_ao_kp, 1)) - CPASSERT(nimages .EQ. SIZE(rho_ao_kp, 2)) + CPASSERT(nspins == SIZE(rho_ao_kp, 1)) + CPASSERT(nimages == SIZE(rho_ao_kp, 2)) CALL dbcsr_allocate_matrix_set(rho_ao_im_kp, nspins, nimages) CALL qs_rho_set(rho, rho_ao_im_kp=rho_ao_im_kp) diff --git a/src/qs_scf.F b/src/qs_scf.F index 3b6a55e257..de0ed51989 100644 --- a/src/qs_scf.F +++ b/src/qs_scf.F @@ -238,7 +238,7 @@ CONTAINS CALL qs_scf_env_initialize(qs_env, scf_env) END IF - IF ((scf_control%density_guess .EQ. history_guess) .AND. (first_step_flag)) THEN + IF ((scf_control%density_guess == history_guess) .AND. (first_step_flag)) THEN max_scf_tmp = scf_control%max_scf scf_control%max_scf = 1 outer_scf_loop = scf_control%outer_scf%have_scf @@ -271,7 +271,7 @@ CONTAINS ! Update a counter and check if the Jacobian should be deallocated IF (ASSOCIATED(scf_env%outer_scf%inv_jacobian)) THEN 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) .GE. & + IF (scf_control%outer_scf%cdft_opt_control%ijacobian(2) >= & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) .AND. & scf_control%outer_scf%cdft_opt_control%jacobian_freq(2) > 0) & scf_env%outer_scf%deallocate_jacobian = .TRUE. @@ -279,7 +279,7 @@ CONTAINS END IF ! *** add the converged wavefunction to the wavefunction history IF ((ASSOCIATED(qs_env%wf_history)) .AND. & - ((scf_control%density_guess .NE. history_guess) .OR. & + ((scf_control%density_guess /= history_guess) .OR. & (.NOT. first_step_flag))) THEN IF (.NOT. dft_control%qs_control%cdft) THEN CALL wfi_update(qs_env%wf_history, qs_env=qs_env, dt=1.0_dp) @@ -292,7 +292,7 @@ CONTAINS CALL wfi_update(qs_env%wf_history, qs_env=qs_env, dt=1.0_dp) END IF END IF - ELSE IF ((scf_control%density_guess .EQ. history_guess) .AND. & + ELSE IF ((scf_control%density_guess == history_guess) .AND. & (first_step_flag)) THEN scf_control%max_scf = max_scf_tmp scf_control%outer_scf%have_scf = outer_scf_loop @@ -446,8 +446,8 @@ CONTAINS IF (test_for_result(results, description=description)) THEN CALL get_results(results, description=description, & values=res_val_3, n_entries=i_tmp) - CPASSERT(i_tmp .EQ. 3) - IF (ALL(res_val_3(:) .LE. 0.0)) & + CPASSERT(i_tmp == 3) + IF (ALL(res_val_3(:) <= 0.0)) & CALL cp_abort(__LOCATION__, & " Trying to access result ("//TRIM(description)// & ") which is not correctly stored.") @@ -538,7 +538,7 @@ CONTAINS IF (.NOT. just_energy) energy%tot_old = energy%total ! check for external communicator and if the intermediate energy should be sent - IF (scf_energy_message_tag .GT. 0) THEN + IF (scf_energy_message_tag > 0) THEN CALL external_comm%send(energy%total, ext_master_id, scf_energy_message_tag) END IF @@ -1140,8 +1140,8 @@ CONTAINS .AND. cdft_control%total_steps /= 1) & cdft_control%nreused = cdft_control%nreused - 1 ! SCF converged in less than precond_freq steps - IF (scf_env%outer_scf%iter_count == 1 .AND. scf_env%iter_count .LE. cdft_control%precond_freq .AND. & - cdft_control%total_steps /= 1 .AND. cdft_control%nreused .LT. cdft_control%max_reuse) THEN + 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 reuse_precond = .TRUE. cdft_control%nreused = cdft_control%nreused + 1 ELSE @@ -1152,10 +1152,10 @@ CONTAINS ! Update history purging counters IF (first_iteration .AND. cdft_control%purge_history) THEN cdft_control%istep = cdft_control%istep + 1 - IF (scf_env%outer_scf%iter_count .GT. 1) THEN + IF (scf_env%outer_scf%iter_count > 1) THEN cdft_control%nbad_conv = cdft_control%nbad_conv + 1 - IF (cdft_control%nbad_conv .GE. cdft_control%purge_freq .AND. & - cdft_control%istep .GE. cdft_control%purge_offset) THEN + IF (cdft_control%nbad_conv >= cdft_control%purge_freq .AND. & + cdft_control%istep >= cdft_control%purge_offset) THEN cdft_control%nbad_conv = 0 cdft_control%istep = 0 cdft_control%should_purge = .TRUE. @@ -1664,12 +1664,12 @@ CONTAINS IF (continue_ls .AND. .NOT. ALLOCATED(positive_sign)) THEN ALLOCATE (positive_sign(nvar)) DO ispin = 1, nvar - positive_sign(ispin) = scf_env%outer_scf%gradient(ispin, iter_count + 1) .GE. 0.0_dp + positive_sign(ispin) = scf_env%outer_scf%gradient(ispin, iter_count + 1) >= 0.0_dp END DO END IF ! Check if the L2 norm of the gradient decreased inv_jacobian => scf_env%outer_scf%inv_jacobian - IF (dnrm2(nvar, scf_env%outer_scf%gradient(:, iter_count + 1), 1) .LT. & + IF (dnrm2(nvar, scf_env%outer_scf%gradient(:, iter_count + 1), 1) < & dnrm2(nvar, scf_env%outer_scf%gradient(:, iter_count), 1)) THEN ! Optimal step size found IF (.NOT. continue_ls) THEN @@ -1679,7 +1679,7 @@ CONTAINS ! if max number of steps is not exceeded IF (found_solution) THEN ! Check if the norm also decreased w.r.t. to previously found solution - IF (dnrm2(nvar, scf_env%outer_scf%gradient(:, iter_count + 1), 1) .GT. norm_ls) THEN + IF (dnrm2(nvar, scf_env%outer_scf%gradient(:, iter_count + 1), 1) > norm_ls) THEN ! Norm increased => accept previous solution and exit continue_ls_exit = .TRUE. END IF @@ -1695,7 +1695,7 @@ CONTAINS sign_changed = .TRUE. DO ispin = 1, nvar sign_changed = sign_changed .AND. (positive_sign(ispin) .NEQV. & - scf_env%outer_scf%gradient(ispin, iter_count + 1) .GE. 0.0_dp) + scf_env%outer_scf%gradient(ispin, iter_count + 1) >= 0.0_dp) END DO IF (.NOT. ALLOCATED(mos_ls)) THEN ALLOCATE (mos_ls(nspins)) @@ -1711,7 +1711,7 @@ CONTAINS ! Exit on last iteration 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)) .LT. & + IF (SQRT(MAXVAL(scf_env%outer_scf%gradient(:, scf_env%outer_scf%iter_count + 1)**2)) < & scf_control%outer_scf%eps_scf) & continue_ls_exit = .TRUE. ! Exit if line search jumped over the optimal step length diff --git a/src/qs_scf_initialization.F b/src/qs_scf_initialization.F index 4886158c01..e8d57be39b 100644 --- a/src/qs_scf_initialization.F +++ b/src/qs_scf_initialization.F @@ -869,7 +869,7 @@ CONTAINS need_coeff_b = .TRUE. IF (SUM(ABS(scf_control%added_mos)) > 0) & CPABORT("OT with ADDED_MOS/=0 not implemented") - IF (dft_control%restricted .AND. dft_control%nspins .NE. 2) & + IF (dft_control%restricted .AND. dft_control%nspins /= 2) & CPABORT("nspin must be 2 for restricted (ROKS)") IF (do_kpoints) & CPABORT("OT not possible with kpoint calculations") diff --git a/src/qs_scf_output.F b/src/qs_scf_output.F index 43916618ad..d165d8d77c 100644 --- a/src/qs_scf_output.F +++ b/src/qs_scf_output.F @@ -743,7 +743,7 @@ CONTAINS IF (gapw .OR. gapw_xc) exc1_energy = energy%exc1 END IF - IF (psolver .EQ. pw_poisson_implicit) THEN + IF (psolver == pw_poisson_implicit) THEN implicit_ps_ehartree = pw_env%poisson_env%implicit_env%ehartree bc = pw_env%poisson_env%parameters%ps_implicit_params%boundary_condition SELECT CASE (bc) diff --git a/src/qs_scf_post_gpw.F b/src/qs_scf_post_gpw.F index c7569bbbbf..32e6824129 100644 --- a/src/qs_scf_post_gpw.F +++ b/src/qs_scf_post_gpw.F @@ -512,8 +512,8 @@ CONTAINS IF (do_kpoints) THEN CPWARN("Localization not implemented for k-point calculations!") ELSEIF (dft_control%restricted & - .AND. (section_get_ival(localize_section, "METHOD") .NE. do_loc_none) & - .AND. (section_get_ival(localize_section, "METHOD") .NE. do_loc_jacobi)) THEN + .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)) @@ -565,7 +565,7 @@ CONTAINS CPWARN("Localization and MO related output not implemented for k-point calculations!") END IF ELSE - compute_lumos = do_mo_cubes .AND. nlumo .NE. 0 + compute_lumos = do_mo_cubes .AND. nlumo /= 0 compute_lumos = compute_lumos .OR. p_loc_lumo DO ispin = 1, dft_control%nspins @@ -582,7 +582,7 @@ CONTAINS IF (nlumo > nmo - homo) THEN ! this case not yet implemented ELSE - IF (nlumo .EQ. -1) THEN + IF (nlumo == -1) THEN nlumo = nmo - homo END IF IF (output_unit > 0) WRITE (output_unit, *) " " @@ -620,7 +620,7 @@ CONTAINS homo_lumo(ispin, 2) = unoccupied_evals(ispin)%array(1) CALL get_mo_set(mo_set=mos(ispin), homo=homo) IF (check_write) THEN - IF (p_loc_lumo .AND. nlumo .NE. -1) nlumos = MIN(nlumo, nlumos) + IF (p_loc_lumo .AND. nlumo /= -1) nlumos = MIN(nlumo, nlumos) ! Prints the cube files of UNOCCUPIED ORBITALS CALL qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_env, & unoccupied_orbs(ispin), wf_g, wf_r, particles, nlumos, homo, ispin) @@ -3185,7 +3185,7 @@ CONTAINS has_implicit_ps = .FALSE. CALL get_qs_env(qs_env=qs_env, pw_env=pw_env) - IF (pw_env%poisson_env%parameters%solver .EQ. pw_poisson_implicit) has_implicit_ps = .TRUE. + IF (pw_env%poisson_env%parameters%solver == pw_poisson_implicit) has_implicit_ps = .TRUE. ! Write the dielectric constant into a cube file do_dielectric_cube = BTEST(cp_print_key_should_output(logger%iter_info, input, & @@ -3231,7 +3231,7 @@ CONTAINS has_dirichlet_bc = .FALSE. IF (has_implicit_ps) THEN boundary_condition = pw_env%poisson_env%parameters%ps_implicit_params%boundary_condition - IF (boundary_condition .EQ. MIXED_PERIODIC_BC .OR. boundary_condition .EQ. MIXED_BC) THEN + IF (boundary_condition == MIXED_PERIODIC_BC .OR. boundary_condition == MIXED_BC) THEN has_dirichlet_bc = .TRUE. END IF END IF @@ -3278,7 +3278,7 @@ CONTAINS has_dirichlet_bc = .FALSE. IF (has_implicit_ps) THEN boundary_condition = pw_env%poisson_env%parameters%ps_implicit_params%boundary_condition - IF (boundary_condition .EQ. MIXED_PERIODIC_BC .OR. boundary_condition .EQ. MIXED_BC) THEN + IF (boundary_condition == MIXED_PERIODIC_BC .OR. boundary_condition == MIXED_BC) THEN has_dirichlet_bc = .TRUE. END IF END IF @@ -3399,7 +3399,7 @@ CONTAINS CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set, sab_orb=nl, natom=natom, para_env=para_env) nkind = SIZE(qs_kind_set) - CPASSERT(SIZE(nl) .GT. 0) + CPASSERT(SIZE(nl) > 0) CALL get_neighbor_list_set_p(neighbor_list_sets=nl, symmetric=do_symmetric) CPASSERT(do_symmetric) ALLOCATE (basis_set_list_a(nkind), basis_set_list_b(nkind)) @@ -3412,7 +3412,7 @@ CONTAINS NULLIFY (nl_iterator) CALL neighbor_list_iterator_create(nl_iterator, nl) - DO WHILE (neighbor_list_iterate(nl_iterator) .EQ. 0) + DO WHILE (neighbor_list_iterate(nl_iterator) == 0) CALL get_iterator_info(nl_iterator, & ikind=ikind, jkind=jkind, & iatom=iatom, jatom=jatom) @@ -3423,7 +3423,7 @@ CONTAINS IF (.NOT. ASSOCIATED(basis_set_b)) CYCLE ! move everything to the upper triangular part - IF (iatom .LE. jatom) THEN + IF (iatom <= jatom) THEN rowind = iatom colind = jatom ELSE @@ -3450,11 +3450,11 @@ CONTAINS unit_nr = cp_print_key_unit_nr(logger, dft_section, "PRINT%ADJMAT_WRITE", & extension=".adjmat", file_form="FORMATTED", & file_status="REPLACE") - IF (unit_nr .GT. 0) THEN + IF (unit_nr > 0) THEN WRITE (unit_nr, "(1A,2X,1A,5X,1A,4X,A5,3X,A5)") "#", "iatom", "jatom", "ikind", "jkind" DO k = 1, 4*adjm_size, 4 ! print only the interacting atoms - IF (interact_adjm(k) .GT. 0 .AND. interact_adjm(k + 1) .GT. 0) THEN + IF (interact_adjm(k) > 0 .AND. interact_adjm(k + 1) > 0) THEN WRITE (unit_nr, "(I8,2X,I8,3X,I6,2X,I6)") interact_adjm(k:k + 3) END IF END DO diff --git a/src/qs_scf_wfn_mix.F b/src/qs_scf_wfn_mix.F index 0a9d8f1228..8ce86ddc85 100644 --- a/src/qs_scf_wfn_mix.F +++ b/src/qs_scf_wfn_mix.F @@ -147,7 +147,7 @@ CONTAINS CALL section_vals_val_get(update_section, "RESULT_SCALE", i_rep_section=i_rep, r_val=result_scale) mark_ind = 1 - IF (mark_number .GT. 0) result_mo_index = marked_states(mark_number, result_spin_index, mark_ind) + IF (mark_number > 0) result_mo_index = marked_states(mark_number, result_spin_index, mark_ind) ! The MO that will be added to the previous one, 'x' CALL section_vals_val_get(update_section, "ORIG_TYPE", i_rep_section=i_rep, & @@ -159,7 +159,7 @@ CONTAINS CALL section_vals_val_get(update_section, "ORIG_SCALE", i_rep_section=i_rep, r_val=orig_scale) IF (orig_type == wfn_mix_orig_virtual) mark_ind = 2 - IF (mark_number .GT. 0) orig_mo_index = marked_states(mark_number, orig_spin_index, mark_ind) + IF (mark_number > 0) orig_mo_index = marked_states(mark_number, orig_spin_index, mark_ind) CALL section_vals_val_get(wfn_mix_section, "OVERWRITE_MOS", l_val=overwrite_mos) diff --git a/src/qs_tddfpt2_assign.F b/src/qs_tddfpt2_assign.F index dd9a6ef4f2..796f3613bd 100644 --- a/src/qs_tddfpt2_assign.F +++ b/src/qs_tddfpt2_assign.F @@ -172,13 +172,13 @@ CONTAINS TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp TYPE(cp_fm_type) :: csc, sc, work - IF (ncol .EQ. 0) RETURN + IF (ncol == 0) RETURN CALL timeset(routineN, handle) threshold = 1.0E-7_dp CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_create(sc, xmatrix%matrix_struct, "SC") CALL cp_dbcsr_sm_fm_multiply(matrix_s, vmatrix, sc, ncol) @@ -246,7 +246,7 @@ CONTAINS ncol = SIZE(rdiag) CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_create(sc, vmatrix%matrix_struct, "SC") CALL cp_dbcsr_sm_fm_multiply(matrix_s, vmatrix, sc, ncol) @@ -301,7 +301,7 @@ CONTAINS ncol = SIZE(rdiag) CALL cp_fm_get_info(matrix=xmatrix, nrow_global=n, ncol_global=ncol_global) - IF (ncol .GT. ncol_global) CPABORT("Wrong ncol value") + IF (ncol > ncol_global) CPABORT("Wrong ncol value") CALL cp_fm_create(sc, xmatrix%matrix_struct, "SC") CALL cp_dbcsr_sm_fm_multiply(matrix_s, xmatrix, sc, ncol) diff --git a/src/qs_tddfpt2_bse_utils.F b/src/qs_tddfpt2_bse_utils.F index 9141111073..3797eac5db 100644 --- a/src/qs_tddfpt2_bse_utils.F +++ b/src/qs_tddfpt2_bse_utils.F @@ -343,11 +343,11 @@ CONTAINS j_occ_row = MOD(i_row_global - 1, nactive(ispin)) + 1 a_nao_col = (j_col_global - 1)/nao + 1 b_nao_col = MOD(j_col_global - 1, nao) + 1 - IF (a_nao_col .EQ. b_nao_col) THEN + IF (a_nao_col == b_nao_col) THEN WXmat2%local_data(b_nao_col, i_occ_row) = WXmat2%local_data(b_nao_col, i_occ_row) + & WXaoao%local_data(i_row_global, j_col_global)*evects(ispin, ivect)%local_data(a_nao_col, j_occ_row) END IF - IF (a_nao_col .NE. b_nao_col) THEN + IF (a_nao_col /= b_nao_col) THEN WXmat2%local_data(a_nao_col, i_occ_row) = WXmat2%local_data(a_nao_col, i_occ_row) + & WXaoao%local_data(i_row_global, j_col_global)*evects(ispin, ivect)%local_data(b_nao_col, j_occ_row) END IF diff --git a/src/qs_tddfpt2_fhxc.F b/src/qs_tddfpt2_fhxc.F index 7158b0347f..0b6228d30a 100644 --- a/src/qs_tddfpt2_fhxc.F +++ b/src/qs_tddfpt2_fhxc.F @@ -148,7 +148,7 @@ CONTAINS gapw_xc = dft_control%qs_control%gapw_xc spinflip = dft_control%tddfpt2_control%spinflip - do_noncol = spinflip .EQ. tddfpt_sf_noncol + do_noncol = spinflip == tddfpt_sf_noncol CALL cp_fm_get_info(evects(1, 1), nrow_global=nao) DO ispin = 1, nspins @@ -404,7 +404,7 @@ CONTAINS END IF ! electron-hole Coulomb interaction - IF ((.NOT. is_rks_triplets) .AND. (spinflip .EQ. no_sf_tddfpt)) THEN + IF ((.NOT. is_rks_triplets) .AND. (spinflip == no_sf_tddfpt)) THEN ! a sum J_i{alpha}a{alpha}_munu + J_i{beta}a{beta}_munu can be computed by solving ! the Poisson equation for combined density (rho_{ia,alpha} + rho_{ia,beta}) . ! The following action will destroy reciprocal-space grid in spin-unrestricted case. diff --git a/src/qs_tddfpt2_fhxc_forces.F b/src/qs_tddfpt2_fhxc_forces.F index 36db4b78f7..6bdb6618cc 100644 --- a/src/qs_tddfpt2_fhxc_forces.F +++ b/src/qs_tddfpt2_fhxc_forces.F @@ -669,7 +669,7 @@ CONTAINS END IF ! ADMM XC correction Exc[rho_admm] - IF (do_admm .AND. tddfpt_control%admm_xc_correction .AND. (tddfpt_control%spinflip .NE. tddfpt_sf_col)) THEN + IF (do_admm .AND. tddfpt_control%admm_xc_correction .AND. (tddfpt_control%spinflip /= tddfpt_sf_col)) THEN IF (admm_env%aux_exch_func == do_admm_aux_exch_func_none) THEN ! nothing to do ELSE @@ -1265,13 +1265,13 @@ CONTAINS ! XC Kernel contributions ! For spin-flip excitations this is the only contribution to the alpha response vector - IF (.NOT. (do_sf .AND. (ispin .EQ. 2))) THEN + IF (.NOT. (do_sf .AND. (ispin == 2))) THEN ! F*X CALL cp_dbcsr_sm_fm_multiply(matrix_fx(spin)%matrix, evect(spin), & cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp) END IF ! For spin-flip excitations this is the only contribution to the beta response vector - IF (.NOT. (do_sf .AND. (ispin .EQ. 1))) THEN + IF (.NOT. (do_sf .AND. (ispin == 1))) THEN ! F*Cb CALL cp_dbcsr_sm_fm_multiply(matrix_fx(spin)%matrix, mos2, vcvec, norb(ispin), alpha=1.0_dp, beta=0.0_dp) ! Ca^T*F*Cb @@ -1308,7 +1308,7 @@ CONTAINS ! Add Fock contributions to the response vector IF (do_hfx) THEN ! For spin-flip excitations this is the only contribution to the alpha response vector - IF (.NOT. (do_sf .AND. (ispin .EQ. 2))) THEN + IF (.NOT. (do_sf .AND. (ispin == 2))) THEN ! F^sym*X CALL cp_dbcsr_sm_fm_multiply(matrix_hfx(spin)%matrix, evect(spin), & cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp) @@ -1318,7 +1318,7 @@ CONTAINS END IF ! For spin-flip excitations this is the only contribution to the beta response vector - IF (.NOT. (do_sf .AND. (ispin .EQ. 1))) THEN + IF (.NOT. (do_sf .AND. (ispin == 1))) THEN ! F^sym*Cb CALL cp_dbcsr_sm_fm_multiply(matrix_hfx(spin)%matrix, mos2, vcvec, norb(ispin), alpha=1.0_dp, beta=0.0_dp) ! -F^asym*Cb diff --git a/src/qs_tddfpt2_forces.F b/src/qs_tddfpt2_forces.F index 7a904f870f..04b53dbf7b 100644 --- a/src/qs_tddfpt2_forces.F +++ b/src/qs_tddfpt2_forces.F @@ -186,7 +186,7 @@ CONTAINS nspins = dft_control%nspins tddfpt_control => dft_control%tddfpt2_control - IF (tddfpt_control%spinflip .EQ. no_sf_tddfpt) THEN + IF (tddfpt_control%spinflip == no_sf_tddfpt) THEN do_sf = .FALSE. ELSE do_sf = .TRUE. @@ -451,7 +451,7 @@ CONTAINS sab_orb=sab_orb, dft_control=dft_control, force=force) NULLIFY (tddfpt_control) tddfpt_control => dft_control%tddfpt2_control - IF (tddfpt_control%spinflip .EQ. no_sf_tddfpt) THEN + IF (tddfpt_control%spinflip == no_sf_tddfpt) THEN do_sf = .FALSE. ELSE do_sf = .TRUE. @@ -637,12 +637,12 @@ CONTAINS CALL cp_fm_get_info(mos_occ, nrow_global=nao, ncol_global=norb) ! matrix_pe = X*X^T - IF (.NOT. do_sf .OR. (do_sf .AND. (spin .EQ. 2))) THEN + IF (.NOT. do_sf .OR. (do_sf .AND. (spin == 2))) THEN CALL cp_dbcsr_plus_fm_fm_t(matrix_pe, matrix_v=evect, ncol=norb) END IF ! matrix_pe = matrix_pe - (C*X^T*S*X*C^T + (C*X^T*S*X*C^T)^T)/2 - IF (.NOT. do_sf .OR. (do_sf .AND. (spin .EQ. 1))) THEN + IF (.NOT. do_sf .OR. (do_sf .AND. (spin == 1))) THEN CALL cp_fm_get_info(evect, matrix_struct=fmstruct) NULLIFY (fmstruct2) CALL cp_fm_struct_create(fmstruct=fmstruct2, template_fmstruct=fmstruct, & @@ -679,7 +679,7 @@ CONTAINS WRITE (iounit, "(T2,A,/)") REPEAT("*", 79) END IF END IF - ELSE IF (spin .EQ. 1) THEN + ELSE IF (spin == 1) THEN IF (ABS(tmp + 1) > 1.e-08_dp) THEN logger => cp_get_default_logger() IF (logger%para_env%is_source()) THEN @@ -693,7 +693,7 @@ CONTAINS WRITE (iounit, "(T2,A,/)") REPEAT("*", 79) END IF END IF - ELSE IF (spin .EQ. 2) THEN + ELSE IF (spin == 2) THEN IF (ABS(tmp - 1) > 1.e-08_dp) THEN logger => cp_get_default_logger() IF (logger%para_env%is_source()) THEN diff --git a/src/qs_tddfpt2_operators.F b/src/qs_tddfpt2_operators.F index 8d56d00b44..49c421886d 100644 --- a/src/qs_tddfpt2_operators.F +++ b/src/qs_tddfpt2_operators.F @@ -400,7 +400,7 @@ CONTAINS CPASSERT(SIZE(rho_ia_r) == nspins) CPASSERT((.NOT. ASSOCIATED(tau_ia_r)) .OR. SIZE(tau_ia_r) == nspins) CPASSERT((.NOT. is_rks_triplets) .OR. nspins == 1) - CPASSERT((spinflip .NE. no_sf_tddfpt) .EQV. (nspins == 2)) + CPASSERT((spinflip /= no_sf_tddfpt) .EQV. (nspins == 2)) END IF IF (spinflip == tddfpt_sf_noncol) THEN diff --git a/src/qs_tddfpt2_properties.F b/src/qs_tddfpt2_properties.F index 8fa978be18..ae2f64ec0b 100644 --- a/src/qs_tddfpt2_properties.F +++ b/src/qs_tddfpt2_properties.F @@ -712,7 +712,7 @@ CONTAINS state_spin2 = 2 spin_label = ' ' spin_label2 = ' ' - ELSE IF (spinflip .NE. no_sf_tddfpt) THEN + ELSE IF (spinflip /= no_sf_tddfpt) THEN state_spin = 1 state_spin2 = 2 spin_label = '(alp)' @@ -871,7 +871,7 @@ CONTAINS ! a bug when using optimization level 3 flag state_spin = 1 state_spin2 = 1 - IF (spinflip .NE. no_sf_tddfpt) THEN + IF (spinflip /= no_sf_tddfpt) THEN state_spin = 1 state_spin2 = 2 END IF diff --git a/src/qs_tddfpt2_smearing_methods.F b/src/qs_tddfpt2_smearing_methods.F index 4cae099919..90b1f5463a 100644 --- a/src/qs_tddfpt2_smearing_methods.F +++ b/src/qs_tddfpt2_smearing_methods.F @@ -321,7 +321,7 @@ CONTAINS ALLOCATE (occup_im(nactive, nactive), interocc(nactive, nactive)) DO iocc = 1, nactive - IF (smear%method .EQ. smear_fermi_dirac) THEN + IF (smear%method == smear_fermi_dirac) THEN ! Different prefactor in comparison to Octopus ! CALL Fermi(occuptmp, nelec, dummykTS, mos(ispin)%eigenvalues, mos(ispin)%eigenvalues(iocc), & smear%electronic_temperature, mos(ispin)%maxocc) diff --git a/src/qs_tddfpt2_soc.F b/src/qs_tddfpt2_soc.F index 4f2bf674c4..1621222cfc 100644 --- a/src/qs_tddfpt2_soc.F +++ b/src/qs_tddfpt2_soc.F @@ -1028,11 +1028,11 @@ CONTAINS WRITE (log_unit, '(A)') "-----------------------------------------------------------------------------" mult = " " DO iex = 1, SIZE(soc_env%soc_evals) - IF (evects_sort(iex + 1) .GT. nsg + ntp*2 + 1) THEN + IF (evects_sort(iex + 1) > nsg + ntp*2 + 1) THEN mult = "T+1" - ELSE IF (evects_sort(iex + 1) .GT. nsg + ntp + 1) THEN + ELSE IF (evects_sort(iex + 1) > nsg + ntp + 1) THEN mult = "T0" - ELSE IF (evects_sort(iex + 1) .GT. nsg + 1) THEN + ELSE IF (evects_sort(iex + 1) > nsg + 1) THEN mult = "T-1" ELSE mult = "S " @@ -1361,9 +1361,9 @@ CONTAINS DO igrid = 1, SIZE(grid_info, 1) IF (grid_info(igrid, 1) == kind_name) THEN READ (grid_info(igrid, 2), *, iostat=stat) na - IF (stat .NE. 0) CPABORT("The 'na' value for the GRID keyword must be an integer") + IF (stat /= 0) CPABORT("The 'na' value for the GRID keyword must be an integer") READ (grid_info(igrid, 3), *, iostat=stat) nr - IF (stat .NE. 0) CPABORT("The 'nr' value for the GRID keyword must be an integer") + IF (stat /= 0) CPABORT("The 'nr' value for the GRID keyword must be an integer") EXIT END IF END DO !igrid diff --git a/src/qs_tddfpt2_soc_utils.F b/src/qs_tddfpt2_soc_utils.F index 53f63a1ed9..3df127de0e 100644 --- a/src/qs_tddfpt2_soc_utils.F +++ b/src/qs_tddfpt2_soc_utils.F @@ -538,7 +538,7 @@ CONTAINS max_wfn = 0_dp DO ii = 1, ntot wfn_sq = ABS(REAL(cpl_tmp(ii, jj)**2 - AIMAG(cpl_tmp(ii, jj)**2))) - IF (max_wfn .LE. wfn_sq) THEN + IF (max_wfn <= wfn_sq) THEN CALL test_repetition(sort, ii, rep, rep_int(ii)) IF (rep) THEN max_wfn = wfn_sq @@ -554,7 +554,7 @@ CONTAINS max_wfn = ABS(REAL(cpl_tmp(sort(i_rep), jj)**2 - AIMAG(cpl_tmp(sort(i_rep), jj)**2))) - max_dev DO ii = 1, ntot wfn_sq = ABS(REAL(cpl_tmp(ii, jj)**2 - AIMAG(cpl_tmp(ii, jj)**2))) - IF ((max_wfn - wfn_sq)/max_wfn .LE. max_dev) THEN + IF ((max_wfn - wfn_sq)/max_wfn <= max_dev) THEN CALL test_repetition(sort, ii, rep) IF (rep .AND. ii /= i_rep) THEN sort(jj) = sort(i_rep) diff --git a/src/qs_tddfpt2_utils.F b/src/qs_tddfpt2_utils.F index b7ff19b5fa..0e012d059b 100644 --- a/src/qs_tddfpt2_utils.F +++ b/src/qs_tddfpt2_utils.F @@ -1067,7 +1067,7 @@ CONTAINS spin_label1 = ' ' spin_label2 = spin_label1 ! Labels and spin component for spin-flip excitations - ELSE IF (tddfpt_control%spinflip .NE. no_sf_tddfpt) THEN + ELSE IF (tddfpt_control%spinflip /= no_sf_tddfpt) THEN spin1 = 1 spin2 = 2 spin_label1 = '(alp)' diff --git a/src/qs_vcd.F b/src/qs_vcd.F index 3f4865b8b5..705563a791 100644 --- a/src/qs_vcd.F +++ b/src/qs_vcd.F @@ -117,7 +117,7 @@ CONTAINS ! I_{alpha beta}^lambda = 1/2c \sum_j^occ ... aat_prefactor = 1.0_dp!/(c_light_au * 2._dp) - IF (nspins .EQ. 1) aat_prefactor = aat_prefactor*2.0_dp + IF (nspins == 1) aat_prefactor = aat_prefactor*2.0_dp ! The non-PP part of the AAT consists of four contributions: ! (A1): + P^0 * ε_{alpha gamma delta} * < mu | r_beta r_gamma ∂_delta | nu > * (mu == lambda) diff --git a/src/qs_vcd_ao.F b/src/qs_vcd_ao.F index da98253975..60047dd3a6 100644 --- a/src/qs_vcd_ao.F +++ b/src/qs_vcd_ao.F @@ -1258,7 +1258,7 @@ CONTAINS CPASSERT(img == 1) ! At the start of a block of tasks, get atom data (and kind data, if needed) - IF (itask .EQ. task_list%taskstart(ipair, igrid_level)) THEN + IF (itask == task_list%taskstart(ipair, igrid_level)) THEN ikind = particle_set(iatom)%atomic_kind%kind_number jkind = particle_set(jatom)%atomic_kind%kind_number @@ -1271,7 +1271,7 @@ CONTAINS bcol = iatom END IF - IF (ikind .NE. ikind_old) THEN + IF (ikind /= ikind_old) THEN CALL get_qs_kind(qs_kind_set(ikind), & basis_set=orb_basis_set, basis_type=my_basis_type) @@ -1288,7 +1288,7 @@ CONTAINS zet=zeta) END IF - IF (jkind .NE. jkind_old) THEN + IF (jkind /= jkind_old) THEN CALL get_qs_kind(qs_kind_set(jkind), & basis_set=orb_basis_set, basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set, & @@ -1322,7 +1322,7 @@ CONTAINS END IF - IF (atom_pair_changed .OR. iset_old .NE. iset .OR. jset_old .NE. jset) THEN + IF (atom_pair_changed .OR. iset_old /= iset .OR. jset_old /= jset) THEN ! We reuse the hab(:, :) array to put the new integrals in. ncoa = npgfa(iset)*ncoset(la_max(iset)) @@ -1397,7 +1397,7 @@ CONTAINS jset_new = tasks(itask + 1)%jset ipgf_new = tasks(itask + 1)%ipgf jpgf_new = tasks(itask + 1)%jpgf - IF (iset_new .NE. iset .OR. jset_new .NE. jset) THEN + IF (iset_new /= iset .OR. jset_new /= jset) THEN new_set_pair_coming = .TRUE. END IF ELSE diff --git a/src/qs_vcd_utils.F b/src/qs_vcd_utils.F index dca9728121..398aaf4d5e 100644 --- a/src/qs_vcd_utils.F +++ b/src/qs_vcd_utils.F @@ -599,14 +599,14 @@ CONTAINS ! check that the number nao, nmo and nspins are ! the same as in the current mos - IF (nspins_tmp .NE. nspins) THEN + IF (nspins_tmp /= nspins) THEN CPABORT("nspins not consistent") END IF - IF (nao_tmp .NE. nao) CPABORT("nao not consistent") + IF (nao_tmp /= nao) CPABORT("nao not consistent") ! check that it's the right file ! the same as in the current mos - IF (lambda_tmp .NE. lambda) CPABORT("lambda not consistent") - IF (beta_tmp .NE. beta) CPABORT("beta not consistent") + IF (lambda_tmp /= lambda) CPABORT("lambda not consistent") + IF (beta_tmp /= beta) CPABORT("beta not consistent") ! DO ispin = 1, nspins CALL get_mo_set(mos(ispin), mo_coeff=mo_coeff) @@ -614,7 +614,7 @@ CONTAINS ! IF (rst_unit > 0) READ (rst_unit) nmo_tmp CALL para_env%bcast(nmo_tmp) - IF (nmo_tmp .NE. nmo) CPABORT("nmo not consistent") + IF (nmo_tmp /= nmo) CPABORT("nmo not consistent") ! ! read the response DO i = 1, nmo, MAX(max_block, 1) diff --git a/src/qs_vxc.F b/src/qs_vxc.F index 164c33a973..db06ec74ab 100644 --- a/src/qs_vxc.F +++ b/src/qs_vxc.F @@ -215,7 +215,7 @@ CONTAINS CPABORT("NYI") END SELECT - IF (dft_control%sic_scaling_b .EQ. 0.0_dp) THEN + IF (dft_control%sic_scaling_b == 0.0_dp) THEN sic_scaling_b_zero = .TRUE. ELSE sic_scaling_b_zero = .FALSE. @@ -322,7 +322,7 @@ CONTAINS END IF END IF - IF (my_scaling .NE. 1.0_dp) THEN + IF (my_scaling /= 1.0_dp) THEN exc = exc*my_scaling IF (ASSOCIATED(my_vxc_rho)) THEN DO ispin = 1, SIZE(my_vxc_rho) @@ -360,7 +360,7 @@ CONTAINS END IF ! compute again the xc but now for Exc(m,o) and the opposite sign - IF (dft_control%sic_method_id .EQ. sic_mauri_spz .AND. .NOT. sic_scaling_b_zero) THEN + IF (dft_control%sic_method_id == sic_mauri_spz .AND. .NOT. sic_scaling_b_zero) THEN ALLOCATE (rho_m_rspace(2), rho_m_gspace(2)) CALL xc_pw_pool%create_pw(rho_m_gspace(1)) CALL xc_pw_pool%create_pw(rho_m_rspace(1)) @@ -410,7 +410,7 @@ CONTAINS END IF ! now we have - sum_s N_s * Exc(rho_s/N_s,0) - IF (dft_control%sic_method_id .EQ. sic_ad .AND. .NOT. sic_scaling_b_zero) THEN + IF (dft_control%sic_method_id == sic_ad .AND. .NOT. sic_scaling_b_zero) THEN ! find out how many elecs we have CALL get_ks_env(ks_env, nelectron_spin=nelec_spin) @@ -422,7 +422,7 @@ CONTAINS END DO DO ispin = 1, 2 - IF (nelec_spin(ispin) .GT. 0.0_dp) THEN + IF (nelec_spin(ispin) > 0.0_dp) THEN nelec_s_inv = 1.0_dp/nelec_spin(ispin) ELSE ! does it matter if there are no electrons with this spin (H) ? @@ -471,7 +471,7 @@ CONTAINS END IF ! compute again the xc but now for Exc(n_down,n_down) - IF (dft_control%sic_method_id .EQ. sic_mauri_us .AND. .NOT. sic_scaling_b_zero) THEN + IF (dft_control%sic_method_id == sic_mauri_us .AND. .NOT. sic_scaling_b_zero) THEN ALLOCATE (rho_r(2)) rho_r(1) = rho_struct_r(2) rho_r(2) = rho_struct_r(2) diff --git a/src/qs_vxc_atom.F b/src/qs_vxc_atom.F index e90a64be90..0d732d64b7 100644 --- a/src/qs_vxc_atom.F +++ b/src/qs_vxc_atom.F @@ -2273,7 +2273,7 @@ CONTAINS DO iset2 = 1, nset CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) n2 = nsoset(lmax(iset2)) DO ipgf1 = 1, npgf(iset1) @@ -2290,7 +2290,7 @@ CONTAINS lmax12 = lmax(iset1) + lmax(iset2) ! reduce expansion local densities - IF (lmin12 .LE. lmax_expansion) THEN + IF (lmin12 <= lmax_expansion) THEN gg = 0.0_dp IF (lmin12 == 0) THEN @@ -2300,7 +2300,7 @@ CONTAINS END IF ! limit the expansion of the local densities to a max L - IF (lmax12 .GT. lmax_expansion) lmax12 = lmax_expansion + IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion DO l = lmin12 + 1, lmax12 gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l - 1) @@ -2448,7 +2448,7 @@ CONTAINS DO iset2 = 1, nset CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) CALL get_none0_cg_list(my_CG_dxyz, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax_expansion, dcg_list, dcg_n_list, dmax_iso_not0_local) @@ -2467,7 +2467,7 @@ CONTAINS lmax12 = lmax(iset1) + lmax(iset2) !test reduce expansion local densities - IF (lmin12 .LE. lmax_expansion) THEN + IF (lmin12 <= lmax_expansion) THEN gg = 0.0_dp dgg = 0.0_dp @@ -2479,7 +2479,7 @@ CONTAINS END IF !test reduce expansion local densities - IF (lmax12 .GT. lmax_expansion) lmax12 = lmax_expansion + IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion DO l = lmin12 + 1, lmax12 gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l - 1) diff --git a/src/qs_wf_history_methods.F b/src/qs_wf_history_methods.F index ec0006683a..d66ed23683 100644 --- a/src/qs_wf_history_methods.F +++ b/src/qs_wf_history_methods.F @@ -731,14 +731,14 @@ CONTAINS END IF nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) IF (nvec >= wf_history%memory_depth) THEN - IF ((qs_env%scf_control%max_scf_hist .NE. 0) .AND. (qs_env%scf_control%eps_scf_hist .NE. 0)) THEN + IF ((qs_env%scf_control%max_scf_hist /= 0) .AND. (qs_env%scf_control%eps_scf_hist /= 0)) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%max_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%max_scf_hist /= 0) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%eps_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%eps_scf_hist /= 0) THEN qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist END IF END IF @@ -780,16 +780,16 @@ CONTAINS CPASSERT(.NOT. do_kpoints) ! figure out the actual number of vectors to use in the extrapolation: nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CPASSERT(nvec .GT. 0) + CPASSERT(nvec > 0) IF (nvec >= wf_history%memory_depth) THEN - IF ((qs_env%scf_control%max_scf_hist .NE. 0) .AND. (qs_env%scf_control%eps_scf_hist .NE. 0)) THEN + IF ((qs_env%scf_control%max_scf_hist /= 0) .AND. (qs_env%scf_control%eps_scf_hist /= 0)) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%max_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%max_scf_hist /= 0) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%eps_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%eps_scf_hist /= 0) THEN qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist END IF END IF @@ -842,17 +842,17 @@ CONTAINS CALL cite_reference(Kuhne2007) ! figure out the actual number of vectors to use in the extrapolation: nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CPASSERT(nvec .GT. 0) + CPASSERT(nvec > 0) IF (nvec >= wf_history%memory_depth) THEN - IF ((qs_env%scf_control%max_scf_hist .NE. 0) .AND. & - (qs_env%scf_control%eps_scf_hist .NE. 0)) THEN + IF ((qs_env%scf_control%max_scf_hist /= 0) .AND. & + (qs_env%scf_control%eps_scf_hist /= 0)) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%max_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%max_scf_hist /= 0) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%eps_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%eps_scf_hist /= 0) THEN qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist END IF END IF @@ -940,14 +940,14 @@ CONTAINS INTEGER, INTENT(IN) :: nvec IF (nvec >= qs_env%wf_history%memory_depth) THEN - IF ((qs_env%scf_control%max_scf_hist .NE. 0) .AND. (qs_env%scf_control%eps_scf_hist .NE. 0)) THEN + IF ((qs_env%scf_control%max_scf_hist /= 0) .AND. (qs_env%scf_control%eps_scf_hist /= 0)) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%max_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%max_scf_hist /= 0) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist qs_env%scf_control%outer_scf%have_scf = .FALSE. - ELSE IF (qs_env%scf_control%eps_scf_hist .NE. 0) THEN + ELSE IF (qs_env%scf_control%eps_scf_hist /= 0) THEN qs_env%scf_control%eps_scf = qs_env%scf_control%eps_scf_hist qs_env%scf_control%outer_scf%eps_scf = qs_env%scf_control%eps_scf_hist END IF @@ -1090,7 +1090,7 @@ CONTAINS CASE (wfi_linear_wf_method_nr, wfi_linear_p_method_nr, & wfi_linear_ps_method_nr, wfi_ps_method_nr, & wfi_aspc_nr) - IF (qs_env%wf_history%snapshot_count .GE. 2) THEN + IF (qs_env%wf_history%snapshot_count >= 2) THEN IF (debug_this_module .AND. io_unit > 0) & WRITE (io_unit, FMT="(T2,A)") "QS| Purging WFN history" CALL wfi_create(wf_history, interpolation_method_nr= & diff --git a/src/rmsd.F b/src/rmsd.F index 4970b03ecb..72b87257d9 100644 --- a/src/rmsd.F +++ b/src/rmsd.F @@ -176,7 +176,7 @@ CONTAINS CALL diamat_all(Z, lambda) ! Pick the correct eigenvectors S = 1.0_dp - IF (Z(1, 1) .LT. 0.0_dp) S = -1.0_dp + IF (Z(1, 1) < 0.0_dp) S = -1.0_dp Q(0) = S*Z(1, 1) Q(1) = S*Z(2, 1) Q(2) = S*Z(3, 1) diff --git a/src/rpa_exchange.F b/src/rpa_exchange.F index 42c01b52b2..f700451976 100644 --- a/src/rpa_exchange.F +++ b/src/rpa_exchange.F @@ -463,7 +463,7 @@ CONTAINS ! Manipulate eigenvalues to get diagonal matrix IF (exchange_work%exchange_correction == rpa_exchange_axk) THEN DO iib = 1, dimen_RI - IF (ABS(eigenval(iib)) .GE. thresh) THEN + IF (ABS(eigenval(iib)) >= thresh) THEN eigenval(iib) = & SQRT((1.0_dp/(eigenval(iib)**2))*LOG(1.0_dp + eigenval(iib)) & - 1.0_dp/(eigenval(iib)*(eigenval(iib) + 1.0_dp))) @@ -473,7 +473,7 @@ CONTAINS END DO ELSE IF (exchange_work%exchange_correction == rpa_exchange_sosex) THEN DO iib = 1, dimen_RI - IF (ABS(eigenval(iib)) .GE. thresh) THEN + IF (ABS(eigenval(iib)) >= thresh) THEN eigenval(iib) = & SQRT(-(1.0_dp/(eigenval(iib)**2))*LOG(1.0_dp + eigenval(iib)) & + 1.0_dp/eigenval(iib)) diff --git a/src/rpa_gw.F b/src/rpa_gw.F index df62ea00f9..40fb2e40af 100644 --- a/src/rpa_gw.F +++ b/src/rpa_gw.F @@ -1828,12 +1828,12 @@ CONTAINS DO j_col = 1, ncol_local i_glob = row_indices(i_row) j_glob = col_indices(j_col) - IF (i_glob .LE. nao) THEN + IF (i_glob <= nao) THEN E_i = Eigenval(i_glob, ikp, 1) ELSE E_i = Eigenval(i_glob - nao, ikp, 1) END IF - IF (j_glob .LE. nao) THEN + IF (j_glob <= nao) THEN E_j = Eigenval(j_glob, ikp, 1) ELSE E_j = Eigenval(j_glob - nao, ikp, 1) @@ -2184,7 +2184,7 @@ CONTAINS DO k = 1, SIZE(array, 3) ! check for NaN - IF (array(i, j, k) .NE. array(i, j, k)) array(i, j, k) = real_value + IF (array(i, j, k) /= array(i, j, k)) array(i, j, k) = real_value END DO END DO @@ -3419,7 +3419,7 @@ CONTAINS m_level = i_row + row_offset - 1 ! we only compute the correction for n=m - IF (m_level .NE. n_level_gw) CYCLE + IF (m_level /= n_level_gw) CYCLE IF (.NOT. do_extra_kpoints) THEN @@ -3472,7 +3472,7 @@ CONTAINS contribution = weight*(eps_inv_head(ikp) - 1.0_dp)/abs_k_square*(data_block(i_row, i_col))**2 ! we only compute the correction for n=m - IF (m_level .NE. n_level_gw) CYCLE + IF (m_level /= n_level_gw) CYCLE IF (.NOT. do_extra_kpoints) THEN diff --git a/src/rpa_gw_kpoints_util.F b/src/rpa_gw_kpoints_util.F index a4d9fe2964..b9a8db5d17 100644 --- a/src/rpa_gw_kpoints_util.F +++ b/src/rpa_gw_kpoints_util.F @@ -1121,7 +1121,7 @@ CONTAINS iatom = atom_from_RI_index(row_indices(irow)) jatom = atom_from_RI_index(col_indices(jcol)) - IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old) THEN + IF (iatom /= iatom_old .OR. jatom /= jatom_old) THEN ! symmetrize=.FALSE. necessary since we already have a symmetrized index_to_cell CALL compute_weight_re_im(weight_re, weight_im, & diff --git a/src/rpa_im_time.F b/src/rpa_im_time.F index 0d552ed43e..6a4b33bf1f 100644 --- a/src/rpa_im_time.F +++ b/src/rpa_im_time.F @@ -1284,7 +1284,7 @@ CONTAINS iatom = atom_from_ao_index(row_indices(irow)) jatom = atom_from_ao_index(col_indices(jcol)) - IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old) THEN + IF (iatom /= iatom_old .OR. jatom /= jatom_old) THEN CALL compute_weight_re_im(weight_re, weight_im, & num_cells, iatom, jatom, xkp(1:3, ik), wkp(ik), & @@ -1443,9 +1443,9 @@ CONTAINS ! check that real space super lattice is a (2n+1)x(2m+1)x(2k+1) super lattice with the unit cell ! in the middle - CPASSERT(cell_grid(1) .NE. itm(1)*2) - CPASSERT(cell_grid(2) .NE. itm(2)*2) - CPASSERT(cell_grid(3) .NE. itm(3)*2) + CPASSERT(cell_grid(1) /= itm(1)*2) + CPASSERT(cell_grid(2) /= itm(2)*2) + CPASSERT(cell_grid(3) /= itm(3)*2) IF (ASSOCIATED(cell_to_index)) DEALLOCATE (cell_to_index) IF (ASSOCIATED(index_to_cell)) DEALLOCATE (index_to_cell) @@ -1575,12 +1575,12 @@ CONTAINS y_cell_R_minus_S = y_cell_R - y_cell_S z_cell_R_minus_S = z_cell_R - z_cell_S - IF (x_cell_R_minus_S .GE. LBOUND(cell_to_index_3c, 1) .AND. & - x_cell_R_minus_S .LE. UBOUND(cell_to_index_3c, 1) .AND. & - y_cell_R_minus_S .GE. LBOUND(cell_to_index_3c, 2) .AND. & - y_cell_R_minus_S .LE. UBOUND(cell_to_index_3c, 2) .AND. & - z_cell_R_minus_S .GE. LBOUND(cell_to_index_3c, 3) .AND. & - z_cell_R_minus_S .LE. UBOUND(cell_to_index_3c, 3)) THEN + IF (x_cell_R_minus_S >= LBOUND(cell_to_index_3c, 1) .AND. & + x_cell_R_minus_S <= UBOUND(cell_to_index_3c, 1) .AND. & + y_cell_R_minus_S >= LBOUND(cell_to_index_3c, 2) .AND. & + y_cell_R_minus_S <= UBOUND(cell_to_index_3c, 2) .AND. & + z_cell_R_minus_S >= LBOUND(cell_to_index_3c, 3) .AND. & + z_cell_R_minus_S <= UBOUND(cell_to_index_3c, 3)) THEN i_cell_R_minus_S = cell_to_index_3c(x_cell_R_minus_S, y_cell_R_minus_S, z_cell_R_minus_S) @@ -1666,12 +1666,12 @@ CONTAINS y_cell_R_minus_S_minus_T = y_cell_R - y_cell_S - y_cell_T z_cell_R_minus_S_minus_T = z_cell_R - z_cell_S - z_cell_T - IF (x_cell_R_minus_S_minus_T .GE. LBOUND(cell_to_index_3c, 1) .AND. & - x_cell_R_minus_S_minus_T .LE. UBOUND(cell_to_index_3c, 1) .AND. & - y_cell_R_minus_S_minus_T .GE. LBOUND(cell_to_index_3c, 2) .AND. & - y_cell_R_minus_S_minus_T .LE. UBOUND(cell_to_index_3c, 2) .AND. & - z_cell_R_minus_S_minus_T .GE. LBOUND(cell_to_index_3c, 3) .AND. & - z_cell_R_minus_S_minus_T .LE. UBOUND(cell_to_index_3c, 3)) THEN + IF (x_cell_R_minus_S_minus_T >= LBOUND(cell_to_index_3c, 1) .AND. & + x_cell_R_minus_S_minus_T <= UBOUND(cell_to_index_3c, 1) .AND. & + y_cell_R_minus_S_minus_T >= LBOUND(cell_to_index_3c, 2) .AND. & + y_cell_R_minus_S_minus_T <= UBOUND(cell_to_index_3c, 2) .AND. & + z_cell_R_minus_S_minus_T >= LBOUND(cell_to_index_3c, 3) .AND. & + z_cell_R_minus_S_minus_T <= UBOUND(cell_to_index_3c, 3)) THEN i_cell_R_minus_S_minus_T = cell_to_index_3c(x_cell_R_minus_S_minus_T, & y_cell_R_minus_S_minus_T, & diff --git a/src/rpa_main.F b/src/rpa_main.F index 137fea15f4..ed9b8620e1 100644 --- a/src/rpa_main.F +++ b/src/rpa_main.F @@ -1190,9 +1190,9 @@ CONTAINS iter_evGW = mp2_env%ri_g0w0%iter_evGW iter_sc_GW0 = mp2_env%ri_g0w0%iter_sc_GW0 IF ((.NOT. do_im_time)) THEN - IF (iter_sc_GW0 .NE. 1 .AND. iter_evGW .NE. 1) CPABORT("Mixed scGW0/evGW not implemented.") + IF (iter_sc_GW0 /= 1 .AND. iter_evGW /= 1) CPABORT("Mixed scGW0/evGW not implemented.") ! in case of scGW0 with the N^4 algorithm, we use the evGW code but use the DFT eigenvalues for W - IF (iter_sc_GW0 .NE. 1) iter_evGW = iter_sc_GW0 + IF (iter_sc_GW0 /= 1) iter_evGW = iter_sc_GW0 END IF ELSE ext_scaling = 0.0_dp @@ -1270,7 +1270,7 @@ CONTAINS ! image charge model only implemented for cubic scaling GW CPASSERT(do_gw_im_time) CPASSERT(.NOT. do_periodic) - IF (cut_memory .NE. 1) CPABORT("For IC, use MEMORY_CUT 1 in the LOW_SCALING section.") + IF (cut_memory /= 1) CPABORT("For IC, use MEMORY_CUT 1 in the LOW_SCALING section.") END IF ALLOCATE (e_fermi(nspins)) diff --git a/src/rpa_rse.F b/src/rpa_rse.F index 88419dbc8e..2c9b45111a 100644 --- a/src/rpa_rse.F +++ b/src/rpa_rse.F @@ -243,7 +243,7 @@ CONTAINS j_global = col_indices(jjB) DO iiB = 1, nrow_local i_global = row_indices(iiB) - IF ((i_global .LE. homo(ispin)) .AND. (j_global .GT. homo(ispin))) THEN + IF ((i_global <= homo(ispin)) .AND. (j_global > homo(ispin))) THEN corr = corr + fm_X_mo(ispin)%local_data(iib, jjb)**2.0_dp/ & (eigenval(i_global, ispin) - eigenval(j_global, ispin) - diag_diff(i_global) + diag_diff(j_global)) END IF @@ -518,7 +518,7 @@ CONTAINS j_global = col_indices(jjB) DO iiB = 1, nrow_local i_global = row_indices(iiB) - IF (i_global .EQ. j_global) fm_F_mo(ispin)%local_data(iib, jjb) = & + IF (i_global == j_global) fm_F_mo(ispin)%local_data(iib, jjb) = & fm_F_mo(ispin)%local_data(iib, jjb) + eigenval(i_global, ispin) END DO END DO diff --git a/src/rpa_util.F b/src/rpa_util.F index 408377a40c..6132d07aa5 100644 --- a/src/rpa_util.F +++ b/src/rpa_util.F @@ -952,7 +952,7 @@ CONTAINS ! calculate Trace(Log(Matrix)) as Log(DET(Matrix)) via cholesky decomposition CALL cp_fm_cholesky_decompose(matrix=fm_mat_Q, n=dimen_RI, info_out=info_chol) - IF (info_chol .NE. 0) THEN + IF (info_chol /= 0) THEN CALL cp_warn(__LOCATION__, & "The Cholesky decomposition before inverting the RPA matrix / dielectric "// & "function failed. "// & diff --git a/src/rt_propagation_types.F b/src/rt_propagation_types.F index a8bb7ee1cb..4afcbdf836 100644 --- a/src/rt_propagation_types.F +++ b/src/rt_propagation_types.F @@ -537,7 +537,7 @@ CONTAINS history => rtp%history NULLIFY (history%rho_history, history%mo_history, history%s_history) - IF (aspc_order .GT. 0) THEN + IF (aspc_order > 0) THEN IF (rtp%linear_scaling) THEN nmat = SIZE(rtp%rho%new) CALL dbcsr_allocate_matrix_set(history%rho_history, nmat, aspc_order) diff --git a/src/scf_control_types.F b/src/scf_control_types.F index 9a17ad249d..5c36c9f17c 100644 --- a/src/scf_control_types.F +++ b/src/scf_control_types.F @@ -341,7 +341,7 @@ CONTAINS scf_control%use_diag = .TRUE. END IF CALL section_vals_val_get(scf_section, "OT%ALGORITHM", i_val=ialgo) - scf_control%do_outer_scf_reortho = ialgo .EQ. ot_algo_taylor_or_diag + scf_control%do_outer_scf_reortho = ialgo == ot_algo_taylor_or_diag CALL section_vals_val_get(scf_section, "SCF_GUESS", i_val=scf_control%density_guess) CALL section_vals_val_get(scf_section, "eps_eigval", r_val=scf_control%eps_eigval) CALL section_vals_val_get(scf_section, "cholesky", i_val=cholesky_flag) diff --git a/src/sirius_interface.F b/src/sirius_interface.F index 120998477f..026ceba55d 100644 --- a/src/sirius_interface.F +++ b/src/sirius_interface.F @@ -546,7 +546,7 @@ CONTAINS ! angle of magnetization might come from input Atom x y z mx my mz ! or as an angle? ! Answer : SIRIUS only accept the magnetization as mx, my, mz - IF (num_mag_dims .EQ. 3) THEN + IF (num_mag_dims == 3) THEN angle1 = 0.0_dp angle2 = 0.0_dp v1(1) = magnetization*SIN(angle1)*COS(angle2) diff --git a/src/soc_pseudopotential_utils.F b/src/soc_pseudopotential_utils.F index d774d2c572..48cc2f26b5 100644 --- a/src/soc_pseudopotential_utils.F +++ b/src/soc_pseudopotential_utils.F @@ -144,7 +144,7 @@ CONTAINS DO i_row = 1, nrow_local i_global = row_indices(i_row) IF (j_global == i_global) THEN - IF (i_global .LE. nao) THEN + IF (i_global <= nao) THEN cfm%local_data(i_row, j_col) = cfm%local_data(i_row, j_col) + & alpha(i_global)*z_one ELSE diff --git a/src/start/cp2k_runs.F b/src/start/cp2k_runs.F index d9e0c739e2..d843edc5af 100644 --- a/src/start/cp2k_runs.F +++ b/src/start/cp2k_runs.F @@ -702,7 +702,7 @@ CONTAINS WRITE (output_unit, FMT=*) "" CALL m_flush(output_unit) END IF - CPASSERT(todo .NE. do_deadlock) + CPASSERT(todo /= do_deadlock) END IF END IF @@ -792,7 +792,7 @@ CONTAINS ! change to the new working directory CALL m_chdir(TRIM(farming_env%Job(i)%cwd), ierr) - IF (ierr .NE. 0) & + IF (ierr /= 0) & CPABORT("Failed to change dir to: "//TRIM(farming_env%Job(i)%cwd)) ! generate a fresh call to cp2k_run @@ -813,10 +813,10 @@ CONTAINS CALL cp_unit_set_release(default_units) CALL section_vals_val_get(g_data, "PROJECT", & c_val=str) - IF (str .NE. "") output_file = TRIM(str)//".out" + IF (str /= "") output_file = TRIM(str)//".out" CALL section_vals_val_get(g_data, "OUTPUT_FILE_NAME", & c_val=str) - IF (str .NE. "") output_file = str + IF (str /= "") output_file = str CALL section_vals_release(g_data) CALL section_release(g_section) END IF diff --git a/src/start/libcp2k.F b/src/start/libcp2k.F index c02a8b3ba7..39d7078677 100755 --- a/src/start/libcp2k.F +++ b/src/start/libcp2k.F @@ -473,7 +473,7 @@ CONTAINS NULLIFY (f_env) CALL f_env_add_defaults(f_env_id, f_env) CALL force_env_get(f_env%force_env, in_use=in_use) - IF (in_use .EQ. use_qs_force) THEN + IF (in_use == use_qs_force) THEN f_env%force_env%qs_env%transport_env%ext_c_method_ptr = func_ptr END IF CALL f_env_rm_defaults(f_env, ierr) diff --git a/src/statistical_methods.F b/src/statistical_methods.F index a0edd7baf3..ce8d69147e 100644 --- a/src/statistical_methods.F +++ b/src/statistical_methods.F @@ -361,14 +361,14 @@ CONTAINS REAL(KIND=dp) :: a1, var nt = n - istart + 1 - IF (nt .GE. min_sample_size) THEN + IF (nt >= min_sample_size) THEN is = 0 DO j = istart, n - 1 DO k = j + 1, n a1 = xdata(j) - xdata(k) - IF (a1 .GT. 0.0_dp) THEN + IF (a1 > 0.0_dp) THEN is = is + 1 - ELSE IF (a1 .LT. 0.0_dp) THEN + ELSE IF (a1 < 0.0_dp) THEN is = is - 1 END IF END DO @@ -402,7 +402,7 @@ CONTAINS INTEGER :: i REAL(KIND=dp) :: q, s, var, x - IF (n .GE. min_sample_size) THEN + IF (n >= min_sample_size) THEN x = 0.0_dp q = 0.0_dp s = 0.0_dp diff --git a/src/submatrix_dissection.F b/src/submatrix_dissection.F index b09dce80e0..9b5bdc6522 100644 --- a/src/submatrix_dissection.F +++ b/src/submatrix_dissection.F @@ -114,14 +114,14 @@ CONTAINS first = 1 DO i = 1, nonzero_rows%elements blkid = nonzero_rows%get(i) - IF (blkid .EQ. (sm_id - 1)*this%cols_per_sm + 1) THEN + IF (blkid == (sm_id - 1)*this%cols_per_sm + 1) THEN ! We just found the nonzero row that corresponds to the first inducing column of our submatrix ! Now add up block sizes to determine the last one as well last = first - 1 DO j = i, nonzero_rows%elements blkid = nonzero_rows%get(j) last = last + this%col_blk_size(blkid) - IF (blkid .EQ. (sm_id)*this%cols_per_sm) EXIT + IF (blkid == (sm_id)*this%cols_per_sm) EXIT END DO EXIT END IF @@ -178,12 +178,12 @@ CONTAINS row_blk_size=this%row_blk_size, col_blk_size=this%col_blk_size, group=this%group, distribution=this%dist) CALL dbcsr_distribution_get(dist=this%dist, mynode=this%myrank, numnodes=this%numnodes) - IF (this%nblkcols .NE. this%nblkrows) THEN + IF (this%nblkcols /= this%nblkrows) THEN CPABORT("Number of block rows and cols need to be identical") END IF DO i = 1, this%nblkcols - IF (this%col_blk_size(i) .NE. this%row_blk_size(i)) THEN + IF (this%col_blk_size(i) /= this%row_blk_size(i)) THEN CPABORT("Block row sizes and col sizes need to be identical") END IF END DO @@ -249,8 +249,8 @@ CONTAINS this%coo_col_offsets(this%nblkcols + 1) = this%nblks + 1 j = 1 DO i = 1, this%nblkcols - DO WHILE ((j .LE. this%nblks)) - IF (this%coo_cols(j) .GE. i) EXIT + DO WHILE ((j <= this%nblks)) + IF (this%coo_cols(j) >= i) EXIT j = j + 1 END DO this%coo_col_offsets(i) = j @@ -260,8 +260,8 @@ CONTAINS this%coo_col_offsets_local(this%nblkcols + 1) = this%local_blocks + 1 j = 1 DO i = 1, this%nblkcols - DO WHILE ((j .LE. this%local_blocks)) - IF (this%coo_cols_local(j) .GE. i) EXIT + DO WHILE ((j <= this%local_blocks)) + IF (this%coo_cols_local(j) >= i) EXIT j = j + 1 END DO this%coo_col_offsets_local(i) = j @@ -302,9 +302,9 @@ CONTAINS flops_current = flops_current + 2.0D0*this%submatrix_sizes(i)*this%submatrix_sizes(i)*this%submatrix_sizes(i) flops_remaining = flops_total - flops_current flops_threshold = (this%numnodes - j - 1)*flops_per_rank - IF ((j .LT. (this%numnodes - 1)) & - .AND. ((flops_remaining .LE. flops_threshold & - .OR. (this%number_of_submatrices - i) .LT. (this%numnodes - j)))) THEN + IF ((j < (this%numnodes - 1)) & + .AND. ((flops_remaining <= flops_threshold & + .OR. (this%number_of_submatrices - i) < (this%numnodes - j)))) THEN j = j + 1 flops_total = flops_total - flops_current flops_current = 0.0D0 @@ -343,17 +343,17 @@ CONTAINS ! This block will be required to assemble the final block matrix as it is within an inducing column for submatrix i. ! Figure out who stores it and insert it into the result_blocks_* sets. CALL dbcsr_get_stored_coordinates(matrix=this%dbcsr_mat, row=this%coo_rows(k), column=j, processor=m) - IF (m .EQ. this%myrank) THEN + IF (m == this%myrank) THEN CALL result_blocks_from_rank_t(mytid)%sets(this%submatrix_owners(i))%insert(k) END IF - IF (this%submatrix_owners(i) .EQ. this%myrank) THEN + IF (this%submatrix_owners(i) == this%myrank) THEN CALL nonzero_rows_t(mytid)%sets(1)%insert(this%coo_rows(k)) CALL result_blocks_for_rank_t(mytid)%sets(m)%insert(k) END IF END DO END DO - IF (this%submatrix_owners(i) .NE. this%myrank) CYCLE + IF (this%submatrix_owners(i) /= this%myrank) CYCLE ! In the following, we determine all blocks required to build the submatrix. We interpret nonzero_rows_t(mytid)(j) as ! column and nonzero_rows_t(mytid)(k) as row. @@ -364,13 +364,13 @@ CONTAINS DO k = 1, nonzero_rows_t(mytid)%sets(1)%elements cur_row = nonzero_rows_t(mytid)%sets(1)%get(k) l = l_limit_left - DO WHILE (l .LE. l_limit_right) - IF (this%coo_rows(l) .GE. cur_row) EXIT + DO WHILE (l <= l_limit_right) + IF (this%coo_rows(l) >= cur_row) EXIT l = l + 1 END DO l_limit_left = l - IF (l .LE. l_limit_right) THEN - IF (this%coo_rows(l) .EQ. cur_row) THEN + IF (l <= l_limit_right) THEN + IF (this%coo_rows(l) == cur_row) THEN ! We found a valid block. Figure out what to do with it. CALL dbcsr_get_stored_coordinates(matrix=this%dbcsr_mat, row=this%coo_rows(l), & column=this%coo_cols(l), processor=m) @@ -418,7 +418,7 @@ CONTAINS END DO DEALLOCATE (num_blockids_send, num_blockids_recv) - IF (this%numnodes .GT. 1) THEN + IF (this%numnodes > 1) THEN DO i = 1, this%numnodes k = MODULO(this%myrank - i, this%numnodes) ! rank to receive from CALL this%group%irecv(msgout=blocks_for_rank(k)%data, source=k, request=blocks_for_rank(k)%mpi_request) @@ -439,7 +439,7 @@ CONTAINS ! Make get calls on this%result_blocks_for_rank(...) threadsafe in other routines by updating the internal sorted list DO m = 0, this%numnodes - 1 - IF ((.NOT. this%result_blocks_for_rank(m)%sorted_up_to_date) .AND. (this%result_blocks_for_rank(m)%elements .GT. 0)) THEN + IF ((.NOT. this%result_blocks_for_rank(m)%sorted_up_to_date) .AND. (this%result_blocks_for_rank(m)%elements > 0)) THEN CALL this%result_blocks_for_rank(m)%update_sorted END IF END DO @@ -498,7 +498,7 @@ CONTAINS END DO DEALLOCATE (blocks_for_rank, blocks_from_rank) - IF (this%numnodes .GT. 1) THEN + IF (this%numnodes > 1) THEN ! Communicate. We attempt to balance communication load in the network here by starting our sends with our right neighbor ! and first trying to receive from our left neighbor. DO i = 1, this%numnodes @@ -596,7 +596,7 @@ CONTAINS CPABORT("Submatrix dissection not initialized") END IF - IF (this%myrank .NE. this%submatrix_owners(sm_id)) THEN + IF (this%myrank /= this%submatrix_owners(sm_id)) THEN CPABORT("This rank is not supposed to construct this submatrix") END IF @@ -625,12 +625,12 @@ CONTAINS offset_y2 = offset_y1 + this%col_blk_size(nonzero_rows%get(i)) ! Copy block nonzero_rows(i),nonzero_rows(j) to sm(i,j) (if the block actually exists) k = k_limit_left - DO WHILE (k .LE. k_limit_right) - IF (this%coo_rows(k) .GE. nonzero_rows%get(i)) EXIT + DO WHILE (k <= k_limit_right) + IF (this%coo_rows(k) >= nonzero_rows%get(i)) EXIT k = k + 1 END DO k_limit_left = k - IF (this%coo_rows(k) .EQ. nonzero_rows%get(i)) THEN ! it does exist and k is our block id + IF (this%coo_rows(k) == nonzero_rows%get(i)) THEN ! it does exist and k is our block id sm(offset_y1 + 1:offset_y2, offset_x1 + 1:offset_x2) = RESHAPE(this%coo_dptr(k)%target, & [offset_y2 - offset_y1, offset_x2 - offset_x1]) END IF @@ -662,14 +662,14 @@ CONTAINS count = 0 DO i = 1, this%number_of_submatrices - IF (this%submatrix_owners(i) .EQ. rank) count = count + 1 + IF (this%submatrix_owners(i) == rank) count = count + 1 END DO ALLOCATE (sm_ids(count)) count = 0 DO i = 1, this%number_of_submatrices - IF (this%submatrix_owners(i) .EQ. rank) THEN + IF (this%submatrix_owners(i) == rank) THEN count = count + 1 sm_ids(count) = i END IF @@ -697,7 +697,7 @@ CONTAINS CPABORT("Submatrix dissection is not initizalized") END IF - IF (this%myrank .NE. this%submatrix_owners(sm_id)) THEN + IF (this%myrank /= this%submatrix_owners(sm_id)) THEN CPABORT("This rank is not supposed to operate on this submatrix") END IF @@ -714,13 +714,13 @@ CONTAINS sm_col_offset = 0 DO i = 1, nonzero_rows%elements - IF (nonzero_rows%get(i) .EQ. (sm_id - 1)*this%cols_per_sm + 1) THEN + IF (nonzero_rows%get(i) == (sm_id - 1)*this%cols_per_sm + 1) THEN ! We just found the nonzero row that corresponds to the first inducing column of our submatrix sm_col_offset = i EXIT END IF END DO - IF (sm_col_offset .EQ. 0) THEN + IF (sm_col_offset == 0) THEN CPABORT("Could not determine relevant result columns of submatrix") END IF @@ -728,7 +728,7 @@ CONTAINS DO j = 1, nonzero_rows%elements offset_x2 = offset_x1 + this%col_blk_size(nonzero_rows%get(j)) ! We only want to copy the blocks from the result columns - IF ((j .GE. sm_col_offset) .AND. (j .LT. sm_col_offset + this%cols_per_sm)) THEN + IF ((j >= sm_col_offset) .AND. (j < sm_col_offset + this%cols_per_sm)) THEN offset_y1 = 0 k_limit_left = this%coo_col_offsets(nonzero_rows%get(j)) k_limit_right = this%coo_col_offsets(nonzero_rows%get(j) + 1) - 1 @@ -737,19 +737,19 @@ CONTAINS ! Check if sm(i,j), i.e., (nonzero_rows(i),nonzero_rows(j)) exists in the original matrix and if so, copy it into the ! correct send buffer. k = k_limit_left - DO WHILE (k .LE. k_limit_right) - IF (this%coo_rows(k) .GE. nonzero_rows%get(i)) EXIT + DO WHILE (k <= k_limit_right) + IF (this%coo_rows(k) >= nonzero_rows%get(i)) EXIT k = k + 1 END DO k_limit_left = k - IF (this%coo_rows(k) .EQ. nonzero_rows%get(i)) THEN ! it does exist and k is our block id + IF (this%coo_rows(k) == nonzero_rows%get(i)) THEN ! it does exist and k is our block id CALL dbcsr_get_stored_coordinates(matrix=this%dbcsr_mat, row=this%coo_rows(k), column=this%coo_cols(k), & processor=m) - DO WHILE (buf_offset_idxs(m) .LE. this%result_blocks_for_rank(m)%elements) - IF (this%result_blocks_for_rank(m)%get(buf_offset_idxs(m)) .GE. k) EXIT + DO WHILE (buf_offset_idxs(m) <= this%result_blocks_for_rank(m)%elements) + IF (this%result_blocks_for_rank(m)%get(buf_offset_idxs(m)) >= k) EXIT buf_offset_idxs(m) = buf_offset_idxs(m) + 1 END DO - IF (this%result_blocks_for_rank(m)%get(buf_offset_idxs(m)) .NE. k) THEN + IF (this%result_blocks_for_rank(m)%get(buf_offset_idxs(m)) /= k) THEN CPABORT("Could not determine buffer offset for block") END IF bufsize = this%result_blocks_for_rank_buf_offsets(m)%data(buf_offset_idxs(m)) @@ -805,7 +805,7 @@ CONTAINS ! Communicate. We attempt to balance communication load in the network here by starting our sends with our right neighbor ! and first trying to receive from our left neighbor. - IF (this%numnodes .GT. 1) THEN + IF (this%numnodes > 1) THEN DO i = 1, this%numnodes k = MODULO(this%myrank - i, this%numnodes) ! rank to receive from CALL this%group%irecv(msgout=result_recvbufs(k)%data, source=k, request=result_recvbufs(k)%mpi_request) @@ -827,7 +827,7 @@ CONTAINS cur_row = this%coo_rows_local(i) cur_sm = (cur_col - 1)/this%cols_per_sm + 1 cur_buf = this%submatrix_owners(cur_sm) - IF (cur_buf .GT. last_buf) bufsize = 0 + IF (cur_buf > last_buf) bufsize = 0 row_size = this%row_blk_size(cur_row) col_size = this%col_blk_size(cur_col) bufsize_next = bufsize + row_size*col_size @@ -862,7 +862,7 @@ CONTAINS INTEGER :: i, j, pivot_a, pivot_b, tmp - IF (right - left .LT. 1) RETURN + IF (right - left < 1) RETURN i = left j = right - 1 @@ -870,13 +870,13 @@ CONTAINS pivot_b = arr_b(right) DO - DO WHILE ((arr_a(i) .LT. pivot_a) .OR. ((arr_a(i) .EQ. pivot_a) .AND. (arr_b(i) .LT. pivot_b))) + DO WHILE ((arr_a(i) < pivot_a) .OR. ((arr_a(i) == pivot_a) .AND. (arr_b(i) < pivot_b))) i = i + 1 END DO - DO WHILE ((j .GT. i) .AND. ((arr_a(j) .GT. pivot_a) .OR. ((arr_a(j) .EQ. pivot_a) .AND. (arr_b(j) .GE. pivot_b)))) + DO WHILE ((j > i) .AND. ((arr_a(j) > pivot_a) .OR. ((arr_a(j) == pivot_a) .AND. (arr_b(j) >= pivot_b)))) j = j - 1 END DO - IF (i .LT. j) THEN + IF (i < j) THEN tmp = arr_a(i) arr_a(i) = arr_a(j) arr_a(j) = tmp @@ -888,7 +888,7 @@ CONTAINS END IF END DO - IF ((arr_a(i) .GT. pivot_a) .OR. (arr_a(i) .EQ. pivot_a .AND. arr_b(i) .GT. pivot_b)) THEN + IF ((arr_a(i) > pivot_a) .OR. (arr_a(i) == pivot_a .AND. arr_b(i) > pivot_b)) THEN tmp = arr_a(i) arr_a(i) = arr_a(right) arr_a(right) = tmp @@ -897,8 +897,8 @@ CONTAINS arr_b(right) = tmp END IF - IF (i - 1 .GT. left) CALL qsort_two(arr_a, arr_b, left, i - 1) - IF (i + 1 .LT. right) CALL qsort_two(arr_a, arr_b, i + 1, right) + IF (i - 1 > left) CALL qsort_two(arr_a, arr_b, left, i - 1) + IF (i + 1 < right) CALL qsort_two(arr_a, arr_b, i + 1, right) END SUBROUTINE qsort_two diff --git a/src/submatrix_types.F b/src/submatrix_types.F index 0ade1fc6c7..dcb220e926 100644 --- a/src/submatrix_types.F +++ b/src/submatrix_types.F @@ -81,11 +81,11 @@ CONTAINS INTEGER, INTENT(IN) :: elem INTEGER, DIMENSION(:), ALLOCATABLE :: tmp - IF (this%allocated .EQ. 0) THEN + IF (this%allocated == 0) THEN this%allocated = extvec_initial_alloc ALLOCATE (this%darr(this%allocated)) ELSE - IF (this%elements .EQ. this%allocated) THEN + IF (this%elements == this%allocated) THEN ALLOCATE (tmp(this%allocated)) tmp(:) = this%darr DEALLOCATE (this%darr) @@ -161,7 +161,7 @@ CONTAINS idx = MODULO(elem, set_modulus) DO i = 1, this%data(idx)%elements - IF (this%data(idx)%darr(i) .EQ. elem) THEN + IF (this%data(idx)%darr(i) == elem) THEN found = .TRUE. EXIT END IF @@ -213,7 +213,7 @@ CONTAINS idx = 1 DO i = 0, set_modulus - 1 - IF (this%data(i)%elements .GT. 0) THEN + IF (this%data(i)%elements > 0) THEN this%sorted(idx:idx + this%data(i)%elements - 1) = this%data(i)%darr(1:this%data(i)%elements) idx = idx + this%data(i)%elements END IF diff --git a/src/subsys/molecule_types.F b/src/subsys/molecule_types.F index 61776084f3..4a10261c4d 100644 --- a/src/subsys/molecule_types.F +++ b/src/subsys/molecule_types.F @@ -531,7 +531,7 @@ CONTAINS ! will be consistent with atomic guess. A guess with broken symmetry will be easy to ! implement as well. CALL get_molecule_kind(imol_kind, nelectron=nelec) - IF (MOD(nelec, 2) .EQ. 0) THEN + IF (MOD(nelec, 2) == 0) THEN mol_to_multiplicity(imol) = 1 ELSE mol_to_multiplicity(imol) = 2 diff --git a/src/task_list_methods.F b/src/task_list_methods.F index bbf63f7a22..a9fca0a190 100644 --- a/src/task_list_methods.F +++ b/src/task_list_methods.F @@ -363,8 +363,8 @@ CONTAINS jset = task_list%tasks(i)%jset ipgf = task_list%tasks(i)%ipgf jpgf = task_list%tasks(i)%jpgf - IF (igrid_level .NE. igrid_level_old) THEN - IF (igrid_level_old .NE. -1) THEN + IF (igrid_level /= igrid_level_old) THEN + IF (igrid_level_old /= -1) THEN task_list%npairs(igrid_level_old) = ipair END IF ipair = 1 @@ -372,7 +372,7 @@ CONTAINS iatom_old = iatom jatom_old = jatom img_old = img - ELSE IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old .OR. img .NE. img_old) THEN + ELSE IF (iatom /= iatom_old .OR. jatom /= jatom_old .OR. img /= img_old) THEN ipair = ipair + 1 iatom_old = iatom jatom_old = jatom @@ -405,8 +405,8 @@ CONTAINS jset = task_list%tasks(i)%jset ipgf = task_list%tasks(i)%ipgf jpgf = task_list%tasks(i)%jpgf - IF (igrid_level .NE. igrid_level_old) THEN - IF (igrid_level_old .NE. -1) THEN + IF (igrid_level /= igrid_level_old) THEN + IF (igrid_level_old /= -1) THEN task_list%taskstop(ipair, igrid_level_old) = i - 1 END IF ipair = 1 @@ -415,7 +415,7 @@ CONTAINS iatom_old = iatom jatom_old = jatom img_old = img - ELSE IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old .OR. img .NE. img_old) THEN + ELSE IF (iatom /= iatom_old .OR. jatom /= jatom_old .OR. img /= img_old) THEN ipair = ipair + 1 task_list%taskstart(ipair, igrid_level) = i task_list%taskstop(ipair - 1, igrid_level) = i - 1 @@ -1031,7 +1031,7 @@ CONTAINS DO idest = 1, maxdest dest = list_global(1, idest, icpu) IF (dest < ncpu) THEN - IF (dest .NE. icpu) THEN + IF (dest /= icpu) THEN IF (dest > icpu) THEN Nflux = Nflux + 1 flux_limits(2, Nflux) = list_global(2, idest, icpu) @@ -1089,7 +1089,7 @@ CONTAINS DO idest = 1, maxdest dest = list_global(1, idest, icpu) IF (dest < ncpu) THEN - IF (dest .NE. icpu) THEN + IF (dest /= icpu) THEN IF (dest > icpu) THEN Nflux = Nflux + 1 IF (optimized_flux(Nflux) > 0) THEN @@ -1162,7 +1162,7 @@ CONTAINS ! ... and optimise the work per process ALLOCATE (list_global(2, maxdest, ncpu)) - IF (rank_of_root .EQ. my_pos) THEN + IF (rank_of_root == my_pos) THEN list_global(1, :, :) = list(1, :, :) list_global(2, :, :) = RESHAPE(load_all, [maxdest, ncpu]) CALL balance_global_list(list_global) @@ -1302,7 +1302,7 @@ CONTAINS ipgf = tasks(itask_start + i - 1)%ipgf jpgf = tasks(itask_start + i - 1)%jpgf - IF (ilevel .EQ. grid_level) THEN + IF (ilevel == grid_level) THEN all_dests(i) = decode_rank(tasks(itask_start + i - 1)%destination, SIZE(rs_descs)) ELSE all_dests(i) = HUGE(all_dests(i)) @@ -1311,7 +1311,7 @@ CONTAINS CALL sort(all_dests, nshort, index) ndest_pair = 1 DO i = 2, nshort - IF ((all_dests(ndest_pair) .NE. all_dests(i)) .AND. (all_dests(i) .NE. HUGE(all_dests(i)))) THEN + IF ((all_dests(ndest_pair) /= all_dests(i)) .AND. (all_dests(i) /= HUGE(all_dests(i)))) THEN ndest_pair = ndest_pair + 1 all_dests(ndest_pair) = all_dests(i) END IF @@ -1330,7 +1330,7 @@ CONTAINS jpgf = tasks(itask)%jpgf ! Only proceed with tasks which are on this grid level - IF (ilevel .NE. grid_level) CYCLE + IF (ilevel /= grid_level) CYCLE ipair = (iatom - 1)*natom8 + (jatom - 1) cost = INT(tasks(itask)%cost) @@ -1340,42 +1340,42 @@ CONTAINS nopt = 0 IF (BTEST(bit_pattern, 0)) THEN rank = rs_grid_locate_rank(rs_descs(ilevel)%rs_desc, dest, [-1, 0, 0]) - IF (ANY(all_dests(1:ndest_pair) .EQ. rank)) THEN + IF (ANY(all_dests(1:ndest_pair) == rank)) THEN nopt = nopt + 1 options(nopt) = rank END IF END IF IF (BTEST(bit_pattern, 1)) THEN rank = rs_grid_locate_rank(rs_descs(ilevel)%rs_desc, dest, [+1, 0, 0]) - IF (ANY(all_dests(1:ndest_pair) .EQ. rank)) THEN + IF (ANY(all_dests(1:ndest_pair) == rank)) THEN nopt = nopt + 1 options(nopt) = rank END IF END IF IF (BTEST(bit_pattern, 2)) THEN rank = rs_grid_locate_rank(rs_descs(ilevel)%rs_desc, dest, [0, -1, 0]) - IF (ANY(all_dests(1:ndest_pair) .EQ. rank)) THEN + IF (ANY(all_dests(1:ndest_pair) == rank)) THEN nopt = nopt + 1 options(nopt) = rank END IF END IF IF (BTEST(bit_pattern, 3)) THEN rank = rs_grid_locate_rank(rs_descs(ilevel)%rs_desc, dest, [0, +1, 0]) - IF (ANY(all_dests(1:ndest_pair) .EQ. rank)) THEN + IF (ANY(all_dests(1:ndest_pair) == rank)) THEN nopt = nopt + 1 options(nopt) = rank END IF END IF IF (BTEST(bit_pattern, 4)) THEN rank = rs_grid_locate_rank(rs_descs(ilevel)%rs_desc, dest, [0, 0, -1]) - IF (ANY(all_dests(1:ndest_pair) .EQ. rank)) THEN + IF (ANY(all_dests(1:ndest_pair) == rank)) THEN nopt = nopt + 1 options(nopt) = rank END IF END IF IF (BTEST(bit_pattern, 5)) THEN rank = rs_grid_locate_rank(rs_descs(ilevel)%rs_desc, dest, [0, 0, +1]) - IF (ANY(all_dests(1:ndest_pair) .EQ. rank)) THEN + IF (ANY(all_dests(1:ndest_pair) == rank)) THEN nopt = nopt + 1 options(nopt) = rank END IF @@ -1498,7 +1498,7 @@ CONTAINS CALL sort(sublist, ultimate_max, index) j = 1 DO i = 2, 7 - IF (sublist(i) .NE. sublist(j)) THEN + IF (sublist(i) /= sublist(j)) THEN j = j + 1 sublist(j) = sublist(i) END IF @@ -1567,7 +1567,7 @@ CONTAINS jset = tasks(i)%jset ipgf = tasks(i)%ipgf jpgf = tasks(i)%jpgf - IF (ilevel .NE. grid_level) CYCLE + IF (ilevel /= grid_level) CYCLE IF (use_reordered_ranks) THEN send_buf_i(rs_descs(ilevel)%rs_desc%virtual2real(decode_rank(tasks(i)%destination, SIZE(rs_descs))) + 1) = & send_buf_i(rs_descs(ilevel)%rs_desc%virtual2real(decode_rank(tasks(i)%destination, SIZE(rs_descs))) + 1) & @@ -1650,8 +1650,8 @@ CONTAINS no_underloaded = 0 DO i = 1, desc%group_size - IF (load_imbalance(i) .GT. 0) no_overloaded = no_overloaded + 1 - IF (load_imbalance(i) .LT. 0) no_underloaded = no_underloaded + 1 + IF (load_imbalance(i) > 0) no_overloaded = no_overloaded + 1 + IF (load_imbalance(i) < 0) no_underloaded = no_underloaded + 1 END DO ! sort the recv_buffer on number of tasks, gives us index which provides a @@ -1662,7 +1662,7 @@ CONTAINS ! but only those tasks which have not yet been assigned cost_task_rep = 0 DO i = 1, ntasks - IF (tasks(i)%dist_type .EQ. 0 & + IF (tasks(i)%dist_type == 0 & .AND. decode_rank(tasks(i)%destination, SIZE(rs_descs)) == decode_rank(tasks(i)%source, SIZE(rs_descs))) THEN cost_task_rep = cost_task_rep + tasks(i)%cost END IF @@ -1674,7 +1674,7 @@ CONTAINS DO i = 1, desc%group_size ! At the moment we can only offload replicated tasks - IF (load_imbalance(i) .GT. 0) & + IF (load_imbalance(i) > 0) & load_imbalance(i) = MIN(load_imbalance(i), recv_buf_i(i)) END DO @@ -1684,14 +1684,14 @@ CONTAINS ! task balancing will be incomplete ! only need to do anything if I've excess tasks - IF (load_imbalance(desc%my_pos + 1) .GT. 0) THEN + IF (load_imbalance(desc%my_pos + 1) > 0) THEN count = 0 ! weighted amount of tasks offloaded offset = 0 ! no of underloaded processes already filled by other more overloaded procs ! calculate offset DO i = desc%group_size, desc%group_size - no_overloaded + 1, -1 - IF (INDEX(i) .EQ. desc%my_pos + 1) THEN + IF (INDEX(i) == desc%my_pos + 1) THEN EXIT ELSE offset = offset + load_imbalance(INDEX(i)) @@ -1702,7 +1702,7 @@ CONTAINS proc_receiving = HUGE(proc_receiving) DO i = 1, no_underloaded offset = offset + load_imbalance(INDEX(i)) - IF (offset .LE. 0) THEN + IF (offset <= 0) THEN proc_receiving = i EXIT END IF @@ -1712,11 +1712,11 @@ CONTAINS ! we fill this up by adjusting the destination of tasks on the replicated grid, ! then move to next most underloaded proc DO j = 1, ntasks - IF (tasks(j)%dist_type .EQ. 0 & + IF (tasks(j)%dist_type == 0 & .AND. decode_rank(tasks(j)%destination, SIZE(rs_descs)) == decode_rank(tasks(j)%source, SIZE(rs_descs))) THEN ! just avoid sending to non existing procs due to integer truncation ! in the computation of the average - IF (proc_receiving .GT. no_underloaded) EXIT + IF (proc_receiving > no_underloaded) EXIT ! set new destination ilevel = tasks(j)%grid_level img = tasks(j)%image @@ -1729,12 +1729,12 @@ CONTAINS tasks(j)%destination = encode_rank(INDEX(proc_receiving) - 1, ilevel, SIZE(rs_descs)) offset = offset + tasks(j)%cost count = count + tasks(j)%cost - IF (count .GE. load_imbalance(desc%my_pos + 1)) EXIT - IF (offset .GT. 0) THEN + IF (count >= load_imbalance(desc%my_pos + 1)) EXIT + IF (offset > 0) THEN proc_receiving = proc_receiving + 1 ! just avoid sending to non existing procs due to integer truncation ! in the computation of the average - IF (proc_receiving .GT. no_underloaded) EXIT + IF (proc_receiving > no_underloaded) EXIT offset = load_imbalance(INDEX(proc_receiving)) END IF END IF @@ -2288,7 +2288,7 @@ CONTAINS ! do packing !$OMP DO schedule(guided) DO l = 1, desc%group_size - IF (l .EQ. me) CYCLE + IF (l == me) CYCLE send_sizes(l) = 0 DO i = 1, send_pair_count(l) arow = atom_pair_send(send_pair_disps(l) + i)%row @@ -2373,7 +2373,7 @@ CONTAINS !do unpacking !$OMP DO schedule(guided) DO l = 1, desc%group_size - IF (l .EQ. me) CYCLE + IF (l == me) CYCLE recv_sizes(l) = 0 DO i = 1, recv_pair_count(l) arow = atom_pair_recv(recv_pair_disps(l) + i)%row @@ -2735,8 +2735,8 @@ CONTAINS lbc = lb_cube + cube_center ubc = ub_cube + cube_center - IF (ALL((rs_desc%lb_global(:, dest) - rs_desc%border) .LE. lbc) .AND. & - ALL((rs_desc%ub_global(:, dest) + rs_desc%border) .GE. ubc)) THEN + IF (ALL((rs_desc%lb_global(:, dest) - rs_desc%border) <= lbc) .AND. & + ALL((rs_desc%ub_global(:, dest) + rs_desc%border) >= ubc)) THEN !standard distributed collocation/integration tasks(ntasks)%destination = encode_rank(dest, igrid_level, n_levels) tasks(ntasks)%dist_type = 1 diff --git a/src/tblite_interface.F b/src/tblite_interface.F index 0dfac880ff..e59402fe62 100644 --- a/src/tblite_interface.F +++ b/src/tblite_interface.F @@ -866,7 +866,7 @@ CONTAINS logger => cp_get_default_logger() IF (.NOT. calculate_forces) THEN IF (cp_print_key_should_output(logger%iter_info, qs_env%input, & - "DFT%PRINT%OVERLAP_CONDITION") .NE. 0) THEN + "DFT%PRINT%OVERLAP_CONDITION") /= 0) THEN iw = cp_print_key_unit_nr(logger, qs_env%input, "DFT%PRINT%OVERLAP_CONDITION", & extension=".Log") CALL section_vals_val_get(qs_env%input, "DFT%PRINT%OVERLAP_CONDITION%1-NORM", l_val=norml1) diff --git a/src/tmc/tmc_analysis.F b/src/tmc/tmc_analysis.F index 607eba6f0d..da69572d01 100644 --- a/src/tmc/tmc_analysis.F +++ b/src/tmc/tmc_analysis.F @@ -108,7 +108,7 @@ CONTAINS ! file name prefix CALL section_vals_val_get(tmc_ana_section, "PREFIX_ANA_FILES", & c_val=tmc_ana%out_file_prefix) - IF (tmc_ana%out_file_prefix .NE. "") THEN + IF (tmc_ana%out_file_prefix /= "") THEN tmc_ana%out_file_prefix = TRIM(tmc_ana%out_file_prefix)//"_" END IF @@ -117,16 +117,16 @@ CONTAINS IF (explicit_key) THEN CALL section_vals_val_get(tmc_ana_section, "DENSITY", i_vals=i_arr_tmp) - IF (SIZE(i_arr_tmp(:)) .EQ. 3) THEN - IF (ANY(i_arr_tmp(:) .LE. 0)) & + IF (SIZE(i_arr_tmp(:)) == 3) THEN + IF (ANY(i_arr_tmp(:) <= 0)) & CALL cp_abort(__LOCATION__, "The amount of intervals in each "// & "direction has to be greater than 0.") nr_bins(:) = i_arr_tmp(:) - ELSE IF (SIZE(i_arr_tmp(:)) .EQ. 1) THEN - IF (ANY(i_arr_tmp(:) .LE. 0)) & + ELSE IF (SIZE(i_arr_tmp(:)) == 1) THEN + IF (ANY(i_arr_tmp(:) <= 0)) & CPABORT("The amount of intervals has to be greater than 0.") nr_bins(:) = i_arr_tmp(1) - ELSE IF (SIZE(i_arr_tmp(:)) .EQ. 0) THEN + ELSE IF (SIZE(i_arr_tmp(:)) == 0) THEN nr_bins(:) = 1 ELSE CPABORT("unknown amount of dimensions for the binning.") @@ -389,7 +389,7 @@ CONTAINS CALL open_file(file_name=file_name_tmp, file_status="OLD", file_form="UNFORMATTED", & file_action="READ", unit_number=file_ptr) READ (file_ptr) temp - CPASSERT(ana_env%temperature .EQ. temp) + CPASSERT(ana_env%temperature == temp) ana_env%last_elem => elem CALL read_subtree_elem_unformated(elem, file_ptr) @@ -482,7 +482,7 @@ CONTAINS weight_act = elem%nr - ana_env%last_elem%nr END IF - IF (weight_act .GT. 0) THEN + IF (weight_act > 0) THEN ! calculates the 3 dimensional distributed density IF (ASSOCIATED(ana_env%density_3d)) & CALL calc_density_3d(elem=ana_env%last_elem, & @@ -500,7 +500,7 @@ CONTAINS IF (ASSOCIATED(ana_env%dip_ana)) THEN ! in symmetric case use also the dipoles ! (-x,y,z) .. .. (-x,-y,z).... (-x,-y-z) all have the same energy - IF (ana_env%dip_ana%ana_type .EQ. ana_type_sym_xyz) THEN + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) THEN ! (-x,y,z) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) dip_tmp(:) = ana_env%last_elem%dipole(:) @@ -600,23 +600,23 @@ CONTAINS ! start the timing CALL timeset(routineN, handle) IF (ASSOCIATED(ana_env%density_3d)) THEN - IF (ana_env%density_3d%conf_counter .GT. 0) & + IF (ana_env%density_3d%conf_counter > 0) & CALL print_density_3d(ana_env=ana_env) END IF IF (ASSOCIATED(ana_env%pair_correl)) THEN - IF (ana_env%pair_correl%conf_counter .GT. 0) & + IF (ana_env%pair_correl%conf_counter > 0) & CALL print_paircorrelation(ana_env=ana_env) END IF IF (ASSOCIATED(ana_env%dip_mom)) THEN - IF (ana_env%dip_mom%conf_counter .GT. 0) & + IF (ana_env%dip_mom%conf_counter > 0) & CALL print_dipole_moment(ana_env) END IF IF (ASSOCIATED(ana_env%dip_ana)) THEN - IF (ana_env%dip_ana%conf_counter .GT. 0) & + IF (ana_env%dip_ana%conf_counter > 0) & CALL print_dipole_analysis(ana_env) END IF IF (ASSOCIATED(ana_env%displace)) THEN - IF (ana_env%displace%conf_counter .GT. 0) & + IF (ana_env%displace%conf_counter > 0) & CALL print_average_displacement(ana_env) END IF @@ -657,7 +657,7 @@ CONTAINS ! open the files CALL analyse_files_open(tmc_ana=ana_env, stat=stat, dir_ind=dir_ind) ! set the existence of exact dipoles (from file) - IF (ana_env%id_dip .GT. 0) THEN + IF (ana_env%id_dip > 0) THEN tmc_params%print_dipole = .TRUE. ELSE tmc_params%print_dipole = .FALSE. @@ -670,17 +670,17 @@ CONTAINS IF (ASSOCIATED(ana_env%last_elem)) conf_nr = ana_env%last_elem%nr nr_dim = SIZE(elem%pos) - IF (stat .EQ. TMC_STATUS_OK) THEN + IF (stat == TMC_STATUS_OK) THEN conf_loop: DO CALL read_element_from_file(elem=elem, tmc_ana=ana_env, conf_nr=conf_nr, & stat=stat) - IF (stat .EQ. TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (stat == TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL deallocate_sub_tree_node(tree_elem=elem) EXIT conf_loop END IF ! if we want just a certain part of the trajectory - IF (start_id .LT. 0 .OR. conf_nr .GE. start_id) THEN - IF (end_id .LT. 0 .OR. conf_nr .LE. end_id) THEN + IF (start_id < 0 .OR. conf_nr >= start_id) THEN + IF (end_id < 0 .OR. conf_nr <= end_id) THEN ! do the analysis calculations CALL do_tmc_analysis(elem=elem, ana_env=ana_env) END IF @@ -740,7 +740,7 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(elem%pos)) - CPASSERT(weight .GT. 0) + CPASSERT(weight > 0) CPASSERT(ASSOCIATED(atoms)) CPASSERT(ASSOCIATED(ana_env)) CPASSERT(ASSOCIATED(ana_env%cell)) @@ -762,7 +762,7 @@ CONTAINS ALLOCATE (mass_bin(bin_x, bin_y, bin_z)) mass_bin(:, :, :) = 0.0_dp - ! if NPT -> box_scale.NE.1.0 use the scaled cell + ! if NPT -> box_scale/=1.0 use the scaled cell ! ATTENTION then the sub box middle points are not correct in the output ! espacially if we use multiple sub boxes CALL get_scaled_cell(cell=ana_env%cell, box_scale=elem%box_scale, & @@ -801,10 +801,10 @@ CONTAINS bin_x = INT(atom_pos(1)/interval_size(1)) + 1 bin_y = INT(atom_pos(2)/interval_size(2)) + 1 bin_z = INT(atom_pos(3)/interval_size(3)) + 1 - CPASSERT(bin_x .GT. 0 .AND. bin_y .GT. 0 .AND. bin_z .GT. 0) - CPASSERT(bin_x .LE. SIZE(ana_env%density_3d%sum_density(:, 1, 1))) - CPASSERT(bin_y .LE. SIZE(ana_env%density_3d%sum_density(1, :, 1))) - CPASSERT(bin_z .LE. SIZE(ana_env%density_3d%sum_density(1, 1, :))) + CPASSERT(bin_x > 0 .AND. bin_y > 0 .AND. bin_z > 0) + CPASSERT(bin_x <= SIZE(ana_env%density_3d%sum_density(:, 1, 1))) + CPASSERT(bin_y <= SIZE(ana_env%density_3d%sum_density(1, :, 1))) + CPASSERT(bin_z <= SIZE(ana_env%density_3d%sum_density(1, 1, :))) ! sum mass in [g] (in bins and total) mass_bin(bin_x, bin_y, bin_z) = mass_bin(bin_x, bin_y, bin_z) + & @@ -820,7 +820,7 @@ CONTAINS END DO ! check total cell density r_tmp = mass_total/vol_cell - SUM(mass_bin(:, :, :))/vol_sub_box/SIZE(mass_bin(:, :, :)) - CPASSERT(ABS(r_tmp) .LT. 1E-5) + CPASSERT(ABS(r_tmp) < 1E-5) ! calculate density (mass per volume) and sum up for average value ana_env%density_3d%sum_density(:, :, :) = ana_env%density_3d%sum_density(:, :, :) + & @@ -1011,14 +1011,14 @@ CONTAINS CPASSERT(.NOT. ASSOCIATED(ana_pair_correl%g_r)) CPASSERT(.NOT. ASSOCIATED(ana_pair_correl%pairs)) CPASSERT(ASSOCIATED(atoms)) - CPASSERT(SIZE(atoms) .GT. 1) + CPASSERT(SIZE(atoms) > 1) CPASSERT(ASSOCIATED(cell)) ! start the timing CALL timeset(routineN, handle) CALL get_cell(cell=cell, abc=cell_size) - IF (ana_pair_correl%nr_bins .LE. 0) THEN + IF (ana_pair_correl%nr_bins <= 0) THEN ana_pair_correl%nr_bins = CEILING(MAXVAL(cell_size(:))/2.0_dp/(0.03/au2a)) END IF ana_pair_correl%step_length = MAXVAL(cell_size(:))/2.0_dp/ & @@ -1034,7 +1034,7 @@ CONTAINS list_ind = search_pair_in_list(pair_list=pairs_tmp, n1=atoms(f_n)%name, & n2=atoms(s_n)%name, list_end=counter - 1) ! add to list - IF (list_ind .LT. 0) THEN + IF (list_ind < 0) THEN pairs_tmp(counter)%f_n = atoms(f_n)%name pairs_tmp(counter)%s_n = atoms(s_n)%name pairs_tmp(counter)%pair_count = 1 @@ -1082,8 +1082,8 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(elem%pos)) - CPASSERT(ALL(elem%box_scale(:) .GT. 0.0_dp)) - CPASSERT(weight .GT. 0) + CPASSERT(ALL(elem%box_scale(:) > 0.0_dp)) + CPASSERT(weight > 0) CPASSERT(ASSOCIATED(atoms)) CPASSERT(ASSOCIATED(ana_env)) CPASSERT(ASSOCIATED(ana_env%cell)) @@ -1102,11 +1102,11 @@ CONTAINS x2=elem%pos(j:j + ana_env%dim_per_elem - 1), & cell=ana_env%cell, box_scale=elem%box_scale) ind = CEILING(dist/ana_env%pair_correl%step_length) - IF (ind .LE. ana_env%pair_correl%nr_bins) THEN + IF (ind <= ana_env%pair_correl%nr_bins) THEN pair_ind = search_pair_in_list(pair_list=ana_env%pair_correl%pairs, & n1=atoms(INT(i/REAL(ana_env%dim_per_elem, KIND=dp)) + 1)%name, & n2=atoms(INT(j/REAL(ana_env%dim_per_elem, KIND=dp)) + 1)%name) - CPASSERT(pair_ind .GT. 0) + CPASSERT(pair_ind > 0) ana_env%pair_correl%g_r(pair_ind, ind) = & ana_env%pair_correl%g_r(pair_ind, ind) + weight END IF @@ -1218,7 +1218,7 @@ CONTAINS ! for every atom searcht the correct charge DO atom = 1, SIZE(atoms) charge_loop: DO charge = 1, SIZE(ana_dip_mom%charges_inp) - IF (atoms(atom)%name .EQ. ana_dip_mom%charges_inp(charge)%name) THEN + IF (atoms(atom)%name == ana_dip_mom%charges_inp(charge)%name) THEN ana_dip_mom%charges(atom) = ana_dip_mom%charges_inp(charge)%mass EXIT charge_loop END IF @@ -1327,7 +1327,7 @@ CONTAINS CPASSERT(ASSOCIATED(ana_env%dip_ana)) weight_act = weight - IF (ana_env%dip_ana%ana_type .EQ. ana_type_sym_xyz) & + IF (ana_env%dip_ana%ana_type == ana_type_sym_xyz) & weight_act = weight_act/REAL(8.0, KIND=dp) ! get the volume @@ -1337,7 +1337,7 @@ CONTAINS ! fold exact dipole moments using the classical ones IF (ASSOCIATED(ana_env%dip_mom)) THEN - IF (ALL(ana_env%dip_mom%last_dip_cl .NE. elem%dipole)) THEN + IF (ALL(ana_env%dip_mom%last_dip_cl /= elem%dipole)) THEN elem%dipole = pbc(r=elem%dipole(:) - ana_env%dip_mom%last_dip_cl, & cell=scaled_cell) + ana_env%dip_mom%last_dip_cl END IF @@ -1521,10 +1521,10 @@ 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 .EQ. ana_type_ice) & + 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" - IF (ana_env%dip_ana%ana_type .EQ. ana_type_sym_xyz) & + 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." diff --git a/src/tmc/tmc_analysis_types.F b/src/tmc/tmc_analysis_types.F index a200bd9f0d..7bbe5dbed5 100644 --- a/src/tmc/tmc_analysis_types.F +++ b/src/tmc/tmc_analysis_types.F @@ -274,7 +274,7 @@ CONTAINS CPASSERT(ASSOCIATED(pair_list)) IF (PRESENT(list_end)) THEN - CPASSERT(list_end .LE. SIZE(pair_list)) + CPASSERT(list_end <= SIZE(pair_list)) last = list_end ELSE last = SIZE(pair_list) @@ -283,10 +283,10 @@ CONTAINS ind = -1 list_search: DO list_nr = 1, last - IF ((pair_list(list_nr)%f_n .EQ. n1 .AND. & - pair_list(list_nr)%s_n .EQ. n2) .OR. & - (pair_list(list_nr)%f_n .EQ. n2 .AND. & - pair_list(list_nr)%s_n .EQ. n1)) THEN + IF ((pair_list(list_nr)%f_n == n1 .AND. & + pair_list(list_nr)%s_n == n2) .OR. & + (pair_list(list_nr)%f_n == n2 .AND. & + pair_list(list_nr)%s_n == n1)) THEN ind = list_nr EXIT list_search END IF @@ -403,7 +403,7 @@ CONTAINS INTEGER :: dim_per_elem CPASSERT(.NOT. ASSOCIATED(ana_disp)) - CPASSERT(dim_per_elem .GT. 0) + CPASSERT(dim_per_elem > 0) MARK_USED(dim_per_elem) ALLOCATE (ana_disp) diff --git a/src/tmc/tmc_calculations.F b/src/tmc/tmc_calculations.F index 5f00622af1..1f74d8d244 100644 --- a/src/tmc/tmc_calculations.F +++ b/src/tmc/tmc_calculations.F @@ -77,19 +77,19 @@ CONTAINS rnd = 0.0_dp CPASSERT(ASSOCIATED(conf)) - CPASSERT(env_id .GT. 0) + CPASSERT(env_id > 0) CPASSERT(ASSOCIATED(tmc_env)) SELECT CASE (tmc_env%params%task_type) CASE (task_type_gaussian_adaptation) !CALL gaussian_adaptation_energy(, ) CASE (task_type_MC) - IF (tmc_env%params%pressure .GE. 0.0_dp) THEN + IF (tmc_env%params%pressure >= 0.0_dp) THEN ALLOCATE (tmp_cell) CALL get_scaled_cell(cell=tmc_env%params%cell, box_scale=conf%box_scale, & scaled_cell=tmp_cell) CALL set_cell(env_id=env_id, new_cell=tmp_cell%hmat, ierr=ierr) - CPASSERT(ierr .EQ. 0) + CPASSERT(ierr == 0) DEALLOCATE (tmp_cell) END IF @@ -97,7 +97,7 @@ CONTAINS flag = .TRUE. IF (flag .EQV. .TRUE.) THEN IF (tmc_env%params%print_forces .OR. & - conf%move_type .EQ. mv_type_MD) THEN + conf%move_type == mv_type_MD) THEN e_pot = 0.0_dp conf%frc(:) = 0.0_dp CALL calc_force(env_id=env_id, pos=conf%pos, n_el_pos=SIZE(conf%pos), & @@ -241,13 +241,13 @@ CONTAINS NULLIFY (tmp_box_scale) CPASSERT(ASSOCIATED(cell)) - CPASSERT(SIZE(x1) .EQ. 3) - CPASSERT(SIZE(x2) .EQ. 3) + CPASSERT(SIZE(x1) == 3) + CPASSERT(SIZE(x2) == 3) dist_vec(:) = x2(:) - x1(:) ! distance vector between atoms ALLOCATE (tmp_box_scale(3)) IF (PRESENT(box_scale)) THEN - CPASSERT(SIZE(box_scale) .EQ. 3) + CPASSERT(SIZE(box_scale) == 3) tmp_box_scale(:) = box_scale ELSE tmp_box_scale(:) = 1.0_dp @@ -273,7 +273,7 @@ CONTAINS INTEGER :: handle, i CPASSERT(ASSOCIATED(center)) - CPASSERT(SIZE(pos) .GE. SIZE(center)) + CPASSERT(SIZE(pos) >= SIZE(center)) ! start the timing CALL timeset(routineN, handle) @@ -308,7 +308,7 @@ CONTAINS REAL(KIND=dp) :: mass_sum, mass_tmp CPASSERT(ASSOCIATED(center)) - CPASSERT(SIZE(pos) .GE. SIZE(center)) + CPASSERT(SIZE(pos) >= SIZE(center)) ! start the timing CALL timeset(routineN, handle) @@ -317,7 +317,7 @@ CONTAINS mass_sum = 0.0_dp DO i = 1, SIZE(pos), SIZE(center) IF (PRESENT(atoms)) THEN - CPASSERT(SIZE(atoms) .EQ. SIZE(pos)/SIZE(center)) + CPASSERT(SIZE(atoms) == SIZE(pos)/SIZE(center)) mass_tmp = atoms(INT(i/REAL(SIZE(center), KIND=dp)) + 1)%mass center(:) = center(:) + pos(i:i + SIZE(center) - 1)/ & (SIZE(pos)/REAL(SIZE(center), KIND=dp))*mass_tmp @@ -448,7 +448,7 @@ CONTAINS extrapolate = a**7*b + c res_err = e3 - extrapolate END IF - CPASSERT(extrapolate .NE. HUGE(extrapolate)) + CPASSERT(extrapolate /= HUGE(extrapolate)) CONTAINS ! ************************************************************************************************** !> \brief ... @@ -532,15 +532,15 @@ CONTAINS CPASSERT(ASSOCIATED(elem_old)) CPASSERT(ASSOCIATED(elem_new)) - CPASSERT(rnd_nr .GT. 0.0_dp) + CPASSERT(rnd_nr > 0.0_dp) ! start the timing CALL timeset(routineN, handle) prob = -1.0_dp - IF ((elem_new%scf_energies_count .GE. 3) .AND. & - (elem_old%scf_energies_count .GE. 3) .AND. & - tmc_params%prior_NMC_acc%counter .GE. 10) THEN + IF ((elem_new%scf_energies_count >= 3) .AND. & + (elem_old%scf_energies_count >= 3) .AND. & + tmc_params%prior_NMC_acc%counter >= 10) THEN !-- first the new element energy estimation ! using 3 point extrapolation of two different intervals -> more stable estimation ! the energies are sorted in the three_point_extrapolate routine ! @@ -549,7 +549,7 @@ CONTAINS v2=elem_new%scf_energies(MOD(elem_new%scf_energies_count - 2, 4) + 1), & v3=elem_new%scf_energies(MOD(elem_new%scf_energies_count - 1, 4) + 1), & extrapolate=E_mu_tmp, res_err=E_sigma_tmp) - IF ((elem_new%scf_energies_count .GT. 3)) THEN + IF ((elem_new%scf_energies_count > 3)) THEN CALL three_point_extrapolate(v1=elem_new%scf_energies(MOD(elem_new%scf_energies_count - 4, 4) + 1), & v2=elem_new%scf_energies(MOD(elem_new%scf_energies_count - 3, 4) + 1), & v3=elem_new%scf_energies(MOD(elem_new%scf_energies_count - 2, 4) + 1), & @@ -565,7 +565,7 @@ CONTAINS v2=elem_old%scf_energies(MOD(elem_old%scf_energies_count - 2, 4) + 1), & v3=elem_old%scf_energies(MOD(elem_old%scf_energies_count - 1, 4) + 1), & extrapolate=E_mu_tmp, res_err=E_sigma_tmp) - IF ((elem_old%scf_energies_count .GT. 3)) THEN + IF ((elem_old%scf_energies_count > 3)) THEN CALL three_point_extrapolate(v1=elem_old%scf_energies(MOD(elem_old%scf_energies_count - 4, 4) + 1), & v2=elem_old%scf_energies(MOD(elem_old%scf_energies_count - 3, 4) + 1), & v3=elem_old%scf_energies(MOD(elem_old%scf_energies_count - 2, 4) + 1), & diff --git a/src/tmc/tmc_dot_tree.F b/src/tmc/tmc_dot_tree.F index 4db41953c1..d9c90b06d1 100644 --- a/src/tmc/tmc_dot_tree.F +++ b/src/tmc/tmc_dot_tree.F @@ -61,18 +61,18 @@ CONTAINS filename = "" CPASSERT(ASSOCIATED(tmc_params)) - CPASSERT(ind .GE. 0) + CPASSERT(ind >= 0) CPASSERT(ASSOCIATED(tmc_params%Temp)) - CPASSERT(ind .LE. SIZE(tmc_params%Temp)) + CPASSERT(ind <= SIZE(tmc_params%Temp)) - IF (ind .EQ. 0) THEN + IF (ind == 0) THEN filename = TRIM(expand_file_name_char(tmc_params%dot_file_name, "global")) ELSE filename = TRIM(expand_file_name_temp(file_name=tmc_params%dot_file_name, & rvalue=tmc_params%Temp(ind))) END IF - CPASSERT(filename .NE. "") + CPASSERT(filename /= "") END FUNCTION get_dot_file_name ! ************************************************************************************************** !> \brief initializes the dot files (open and write headers) @@ -140,7 +140,7 @@ CONTAINS SUBROUTINE write_legend(file_ptr) INTEGER, INTENT(IN) :: file_ptr - CPASSERT(file_ptr .GT. 0) + CPASSERT(file_ptr > 0) WRITE (file_ptr, *) '//LEGEND' WRITE (file_ptr, *) 'subgraph clusterLegend {' @@ -191,8 +191,8 @@ CONTAINS CHARACTER(len=11) :: label INTEGER :: file_ptr - CPASSERT(filename .NE. "") - CPASSERT(node_nr .GE. 0) + CPASSERT(filename /= "") + CPASSERT(node_nr >= 0) CALL open_file(file_name=filename, file_status="OLD", & file_action="WRITE", file_position="APPEND", unit_number=file_ptr) @@ -279,7 +279,7 @@ CONTAINS TYPE(tmc_param_type), POINTER :: tmc_params CPASSERT(ASSOCIATED(new_element)) - CPASSERT(conf .GT. 0) + CPASSERT(conf > 0) CPASSERT(ASSOCIATED(tmc_params)) CALL create_dot_branch(parent_nr=new_element%parent%nr, & @@ -320,7 +320,7 @@ CONTAINS WRITE (list_of_nr, *) TRIM(ADJUSTL(list_of_nr)), " ", new_element%conf(i)%elem%nr END DO ! print out the references of each subtree element - IF (DEBUG .GT. 8) THEN + IF (DEBUG > 8) THEN WRITE (list_of_nr, *) TRIM(ADJUSTL(list_of_nr)), '\n ref' DO i = 1, SIZE(new_element%conf(:)) ref_count = 0 @@ -339,7 +339,7 @@ CONTAINS END IF IF (.NOT. ASSOCIATED(new_element%parent)) THEN - IF (new_element%nr .GT. 1) & + 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") @@ -383,7 +383,7 @@ CONTAINS CPASSERT(ASSOCIATED(tree_element)) CPASSERT(ASSOCIATED(tmc_params)) - IF (DEBUG .GT. 8) THEN + IF (DEBUG > 8) THEN list_of_nr = "" tmp_pt_list_elem => tree_element%gt_nodes_references ref_count = 0 @@ -420,7 +420,7 @@ CONTAINS CPASSERT(ASSOCIATED(gt_tree_element)) CPASSERT(ASSOCIATED(tmc_params)) - IF (DEBUG .GT. 8) WRITE (*, *) "mark global tree node color", gt_tree_element%nr, gt_tree_element%stat + IF (DEBUG > 8) WRITE (*, *) "mark global tree node color", gt_tree_element%nr, gt_tree_element%stat CALL write_color(node_nr=gt_tree_element%nr, stat=gt_tree_element%stat, & filename=get_dot_file_name(tmc_params, 0)) END SUBROUTINE create_global_tree_dot_color diff --git a/src/tmc/tmc_file_io.F b/src/tmc/tmc_file_io.F index d8f709508f..68f0ae8c7d 100644 --- a/src/tmc/tmc_file_io.F +++ b/src/tmc/tmc_file_io.F @@ -77,17 +77,17 @@ CONTAINS INTEGER :: ind - CPASSERT(file_name .NE. "") + CPASSERT(file_name /= "") ind = INDEX(file_name, ".", BACK=.TRUE.) - IF (.NOT. ind .EQ. 0) THEN + IF (.NOT. ind == 0) THEN WRITE (result_file_name, *) file_name(1:ind - 1), ".", & TRIM(ADJUSTL(extra)) ELSE WRITE (result_file_name, *) TRIM(file_name), ".", extra END IF result_file_name = TRIM(ADJUSTL(result_file_name)) - CPASSERT(result_file_name .NE. "") + CPASSERT(result_file_name /= "") END FUNCTION expand_file_name_ending ! ************************************************************************************************** @@ -104,17 +104,17 @@ CONTAINS INTEGER :: ind - CPASSERT(file_name .NE. "") + CPASSERT(file_name /= "") ind = INDEX(file_name, ".", BACK=.TRUE.) - IF (.NOT. ind .EQ. 0) THEN + IF (.NOT. ind == 0) THEN WRITE (result_file_name, *) file_name(1:ind - 1), "_", & TRIM(ADJUSTL(extra)), file_name(ind:LEN_TRIM(file_name)) ELSE WRITE (result_file_name, *) TRIM(file_name), "_", extra END IF result_file_name = TRIM(ADJUSTL(result_file_name)) - CPASSERT(result_file_name .NE. "") + CPASSERT(result_file_name /= "") END FUNCTION expand_file_name_char ! ************************************************************************************************** @@ -133,17 +133,17 @@ CONTAINS CHARACTER(LEN=18) :: rval_to_string INTEGER :: ind - CPASSERT(file_name .NE. "") + CPASSERT(file_name /= "") rval_to_string = "" WRITE (rval_to_string, "(F16.2)") rvalue ind = INDEX(file_name, ".", BACK=.TRUE.) - IF (.NOT. ind .EQ. 0) THEN + IF (.NOT. ind == 0) THEN WRITE (result_file_name, *) file_name(1:ind - 1), "_T", & TRIM(ADJUSTL(rval_to_string)), file_name(ind:LEN_TRIM(file_name)) ELSE - IF (LEN(file_name) .EQ. 0) THEN + IF (LEN(file_name) == 0) THEN WRITE (result_file_name, *) TRIM(file_name), "T", TRIM(ADJUSTL(rval_to_string)), & file_name(ind:LEN_TRIM(file_name)) ELSE @@ -151,7 +151,7 @@ CONTAINS END IF END IF result_file_name = TRIM(ADJUSTL(result_file_name)) - CPASSERT(result_file_name .NE. "") + CPASSERT(result_file_name /= "") END FUNCTION expand_file_name_temp ! ************************************************************************************************** @@ -170,17 +170,17 @@ CONTAINS CHARACTER(LEN=18) :: rval_to_string INTEGER :: ind - CPASSERT(file_name .NE. "") + CPASSERT(file_name /= "") rval_to_string = "" WRITE (rval_to_string, *) ivalue ind = INDEX(file_name, ".", BACK=.TRUE.) - IF (.NOT. ind .EQ. 0) THEN + IF (.NOT. ind == 0) THEN WRITE (result_file_name, *) file_name(1:ind - 1), "_", & TRIM(ADJUSTL(rval_to_string)), file_name(ind:LEN_TRIM(file_name)) ELSE - IF (LEN(file_name) .EQ. 0) THEN + IF (LEN(file_name) == 0) THEN WRITE (result_file_name, *) TRIM(file_name), "", TRIM(ADJUSTL(rval_to_string)), & file_name(ind:LEN_TRIM(file_name)) ELSE @@ -189,7 +189,7 @@ CONTAINS END IF END IF result_file_name = TRIM(ADJUSTL(result_file_name)) - CPASSERT(result_file_name .NE. "") + CPASSERT(result_file_name /= "") END FUNCTION expand_file_name_int !------------------------------------------------------------------------------ @@ -289,7 +289,7 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env%params)) CPASSERT(ASSOCIATED(tmc_env%m_env%gt_act)) - IF (file_name .EQ. tmc_default_restart_in_file_name) THEN + IF (file_name == tmc_default_restart_in_file_name) THEN INQUIRE (FILE=tmc_default_restart_in_file_name, EXIST=flag) CPASSERT(flag) CALL open_file(file_name=tmc_default_restart_in_file_name, file_status="OLD", & @@ -301,7 +301,7 @@ 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 .NE. SIZE(tmc_env%params%Temp)) & + 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 ") @@ -323,10 +323,10 @@ CONTAINS job_counts, & timings - IF (ANY(ABS(tmc_env%params%Temp(:) - tmp_temp(:)) .GE. 0.005)) & + 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:") - IF (ANY(mv_weight_tmp(:) .NE. tmc_env%params%move_types%mv_weight(:))) THEN + 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 @@ -380,13 +380,13 @@ CONTAINS CPASSERT(ASSOCIATED(result_count)) CPASSERT(ASSOCIATED(tmc_params)) CPASSERT(ASSOCIATED(tmc_params%Temp)) - CPASSERT(conf_updated .GE. 0) - CPASSERT(conf_updated .LE. SIZE(tmc_params%Temp)) + CPASSERT(conf_updated >= 0) + CPASSERT(conf_updated <= SIZE(tmc_params%Temp)) ! start the timing CALL timeset(routineN, handle) - IF (conf_updated .EQ. 0) THEN + IF (conf_updated == 0) THEN ! for debugging print every configuration of every temperature DO i = 1, SIZE(tmc_params%Temp) WRITE (file_name, *) "every_step_", TRIM(tmc_default_trajectory_file_name) @@ -451,7 +451,7 @@ CONTAINS ! set default file name IF (PRESENT(file_name)) THEN - CPASSERT(file_name .NE. "") + CPASSERT(file_name /= "") file_name_act = file_name ELSE CPASSERT(ASSOCIATED(tmc_params%Temp)) @@ -583,7 +583,7 @@ CONTAINS CPASSERT(ASSOCIATED(dip)) IF (PRESENT(file_ext)) THEN - CPASSERT(file_ext .NE. "") + CPASSERT(file_ext /= "") file_name_tmp = expand_file_name_ending(file_name, TRIM(file_ext)) ELSE file_name_tmp = expand_file_name_ending(file_name, "dip") @@ -638,17 +638,17 @@ CONTAINS CALL timeset(routineN, handle) ! read the coordinates - IF (tmc_ana%id_traj .GT. 0) THEN + IF (tmc_ana%id_traj > 0) THEN i_tmp = conf_nr_old CALL read_pos_from_file(elem=elem, tmc_ana=tmc_ana, stat=stat, & conf_nr=i_tmp) - IF (stat .EQ. TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (stat == TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL cp_warn(__LOCATION__, & 'end of position file reached at line '// & cp_to_string(REAL(tmc_ana%lc_traj, KIND=dp))//", last element "// & cp_to_string(tmc_ana%last_elem%nr)) ELSE - CPASSERT(i_tmp .GT. conf_nr_old) + CPASSERT(i_tmp > conf_nr_old) conf_nr = i_tmp elem%nr = i_tmp END IF @@ -658,20 +658,20 @@ CONTAINS ! TODO if necessary ! read the dipoles file - IF (tmc_ana%id_dip .GT. 0 .AND. stat .EQ. TMC_STATUS_OK) THEN + IF (tmc_ana%id_dip > 0 .AND. stat == TMC_STATUS_OK) THEN i_tmp = conf_nr_old search_conf_dip: DO CALL read_dipole_from_file(elem=elem, tmc_ana=tmc_ana, stat=stat, & conf_nr=i_tmp) - IF (stat .EQ. TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (stat == TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL cp_warn(__LOCATION__, & 'end of dipole file reached at line'// & cp_to_string(REAL(tmc_ana%lc_dip, KIND=dp))) EXIT search_conf_dip END IF ! check consitence with pos file - IF (tmc_ana%id_traj .GT. 0) THEN - IF (i_tmp .EQ. conf_nr) THEN + IF (tmc_ana%id_traj > 0) THEN + IF (i_tmp == conf_nr) THEN files_conf_missmatch = .FALSE. EXIT search_conf_dip ELSE @@ -680,7 +680,7 @@ CONTAINS files_conf_missmatch = .TRUE. END IF ! if no pos file, just take the next conf - ELSE IF (i_tmp .GT. conf_nr_old) THEN + ELSE IF (i_tmp > conf_nr_old) THEN conf_nr = i_tmp elem%nr = i_tmp EXIT search_conf_dip @@ -689,19 +689,19 @@ CONTAINS END IF ! read the cell file - IF (tmc_ana%id_cell .GT. 0 .AND. stat .EQ. TMC_STATUS_OK) THEN + IF (tmc_ana%id_cell > 0 .AND. stat == TMC_STATUS_OK) THEN search_conf_cell: DO CALL read_cell_from_file(elem=elem, tmc_ana=tmc_ana, stat=stat, & conf_nr=i_tmp) - IF (stat .EQ. TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (stat == TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL cp_warn(__LOCATION__, & 'end of cell file reached at line at line'// & cp_to_string(REAL(tmc_ana%lc_cell, KIND=dp))) EXIT search_conf_cell END IF ! check consitence with pos file - IF (tmc_ana%id_traj .GT. 0) THEN - IF (i_tmp .EQ. conf_nr) THEN + IF (tmc_ana%id_traj > 0) THEN + IF (i_tmp == conf_nr) THEN files_conf_missmatch = .FALSE. EXIT search_conf_cell ELSE @@ -710,7 +710,7 @@ CONTAINS files_conf_missmatch = .TRUE. END IF ! if no pos file, just take the next conf - ELSE IF (i_tmp .GT. conf_nr_old) THEN + ELSE IF (i_tmp > conf_nr_old) THEN conf_nr = i_tmp elem%nr = i_tmp EXIT search_conf_cell @@ -760,7 +760,7 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(elem%pos)) CPASSERT(ASSOCIATED(tmc_ana)) - CPASSERT(tmc_ana%id_traj .GT. 0) + CPASSERT(tmc_ana%id_traj > 0) ! start the timing CALL timeset(routineN, handle) @@ -769,21 +769,21 @@ CONTAINS c_tmp(:) = " " tmc_ana%lc_traj = tmc_ana%lc_traj + 1 READ (tmc_ana%id_traj, '(A)', IOSTAT=status) c_tmp(:) - IF (status .GT. 0) & + IF (status > 0) & CALL cp_abort(__LOCATION__, & "configuration header read error at line: "// & cp_to_string(tmc_ana%lc_traj)//": "//c_tmp) - IF (status .LT. 0) THEN ! end of file reached + 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, "=") .GT. 0) THEN + IF (INDEX(c_tmp, "=") > 0) THEN READ (c_tmp(INDEX(c_tmp, "=") + 1:), *, IOSTAT=status) i_tmp ! read the configuration number - IF (status .NE. 0) & + IF (status /= 0) & CALL cp_abort(__LOCATION__, & "configuration header read error (for conf nr) at line: "// & cp_to_string(tmc_ana%lc_traj)) - IF (i_tmp .GT. conf_nr) THEN + IF (i_tmp > conf_nr) THEN ! TODO we could also read the energy ... conf_nr = i_tmp IF (PRESENT(header_info)) header_info = c_tmp @@ -793,12 +793,12 @@ CONTAINS END IF END DO search_next_conf - IF (stat .EQ. TMC_STATUS_OK) THEN + IF (stat == TMC_STATUS_OK) THEN pos_loop: DO i = 1, SIZE(elem%pos), tmc_ana%dim_per_elem tmc_ana%lc_traj = tmc_ana%lc_traj + 1 READ (tmc_ana%id_traj, FMT="(A4,1X,1000F20.10)", IOSTAT=status) & c_tmp, elem%pos(i:i + tmc_ana%dim_per_elem - 1) - IF (status .NE. 0) THEN + IF (status /= 0) THEN CALL cp_abort(__LOCATION__, & "configuration pos read error at line: "// & cp_to_string(tmc_ana%lc_traj)) @@ -835,29 +835,29 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(elem%dipole)) CPASSERT(ASSOCIATED(tmc_ana)) - CPASSERT(tmc_ana%id_dip .GT. 0) + CPASSERT(tmc_ana%id_dip > 0) ! start the timing CALL timeset(routineN, handle) tmc_ana%lc_dip = tmc_ana%lc_dip + 1 READ (tmc_ana%id_dip, FMT="(A)", IOSTAT=status) c_tmp - IF (status .EQ. 0) THEN + IF (status == 0) THEN ! skip the initial line (header) - IF (INDEX(c_tmp, "#") .GT. 0) THEN + IF (INDEX(c_tmp, "#") > 0) THEN tmc_ana%lc_dip = tmc_ana%lc_dip + 1 READ (tmc_ana%id_dip, FMT="(A)", IOSTAT=status) c_tmp END IF END IF - IF (status .EQ. 0) THEN + IF (status == 0) THEN READ (c_tmp, FMT="(I8,10F20.10)", IOSTAT=status) & conf_nr, elem%dipole(:) END IF - IF (status .EQ. 0) THEN ! success + IF (status == 0) THEN ! success stat = TMC_STATUS_OK - ELSE IF (status .LT. 0) THEN ! end of file reached + ELSE IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK ELSE - IF (status .NE. 0) THEN + IF (status /= 0) THEN CPWARN("configuration dipole read error at line: "//cp_to_string(tmc_ana%lc_dip)) END IF stat = TMC_STATUS_FAILED @@ -893,32 +893,32 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(tmc_ana)) CPASSERT(ASSOCIATED(tmc_ana%cell)) - CPASSERT(tmc_ana%id_cell .GT. 0) + CPASSERT(tmc_ana%id_cell > 0) ! start the timing CALL timeset(routineN, handle) tmc_ana%lc_cell = tmc_ana%lc_cell + 1 READ (tmc_ana%id_cell, FMT="(A)", IOSTAT=status) c_tmp - IF (status .EQ. 0) THEN + IF (status == 0) THEN ! skip the initial line (header) - IF (INDEX(c_tmp, "#") .GT. 0) THEN + IF (INDEX(c_tmp, "#") > 0) THEN tmc_ana%lc_cell = tmc_ana%lc_cell + 1 READ (tmc_ana%id_cell, FMT="(A)", IOSTAT=status) c_tmp END IF END IF - IF (status .EQ. 0) THEN + IF (status == 0) THEN READ (c_tmp, FMT="(I8,9(1X,F19.10),1X,F24.10)", IOSTAT=status) conf_nr, & hmat(:, :), r_tmp END IF - IF (status .LT. 0) THEN ! end of file reached + IF (status < 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK - ELSE IF (status .GT. 0) THEN - IF (status .NE. 0) & + ELSE IF (status > 0) THEN + IF (status /= 0) & CPABORT("configuration cell read error at line: "//cp_to_string(tmc_ana%lc_cell)) stat = TMC_STATUS_FAILED ELSE - IF (elem%nr .LT. 0) elem%nr = conf_nr + IF (elem%nr < 0) elem%nr = conf_nr hmat(:, :) = hmat(:, :)/au2a ! get the box scaling CALL get_cell_scaling(cell=tmc_ana%cell, scaled_hmat=hmat, & @@ -961,10 +961,10 @@ CONTAINS IF (PRESENT(dir_ind)) THEN CPASSERT(ASSOCIATED(tmc_ana%dirs)) - CPASSERT(dir_ind .GT. 0) - CPASSERT(dir_ind .LE. SIZE(tmc_ana%dirs)) + CPASSERT(dir_ind > 0) + CPASSERT(dir_ind <= SIZE(tmc_ana%dirs)) - IF (INDEX(tmc_ana%dirs(dir_ind), "/", BACK=.TRUE.) .EQ. & + IF (INDEX(tmc_ana%dirs(dir_ind), "/", BACK=.TRUE.) == & LEN_TRIM(tmc_ana%dirs(dir_ind))) THEN dir_name = TRIM(tmc_ana%dirs(dir_ind)) ELSE @@ -979,7 +979,7 @@ CONTAINS file_name=tmc_default_trajectory_file_name, & rvalue=tmc_ana%temperature) ! position file - IF (tmc_ana%costum_pos_file_name .NE. "") THEN + IF (tmc_ana%costum_pos_file_name /= "") THEN file_name_act = TRIM(dir_name)//tmc_ana%costum_pos_file_name ELSE file_name_act = TRIM(dir_name)// & @@ -994,7 +994,7 @@ CONTAINS END IF ! cell file - IF (tmc_ana%costum_cell_file_name .NE. "") THEN + IF (tmc_ana%costum_cell_file_name /= "") THEN file_name_act = TRIM(dir_name)//tmc_ana%costum_cell_file_name ELSE file_name_act = TRIM(dir_name)// & @@ -1009,7 +1009,7 @@ CONTAINS END IF ! dipole file - IF (tmc_ana%costum_dip_file_name .NE. "") THEN + IF (tmc_ana%costum_dip_file_name /= "") THEN file_name_act = TRIM(dir_name)//tmc_ana%costum_dip_file_name ELSE file_name_act = TRIM(dir_name)// & @@ -1023,8 +1023,8 @@ CONTAINS "read dip file", TRIM(file_name_act) END IF - IF (tmc_ana%id_traj .GT. 0 .OR. tmc_ana%id_cell .GT. 0 .OR. & - tmc_ana%id_dip .GT. 0) THEN + IF (tmc_ana%id_traj > 0 .OR. tmc_ana%id_cell > 0 .OR. & + tmc_ana%id_dip > 0) THEN stat = TMC_STATUS_OK ELSE CALL cp_warn(__LOCATION__, & @@ -1054,13 +1054,13 @@ CONTAINS CALL timeset(routineN, handle) ! position file - IF (tmc_ana%id_traj .GT. 0) CALL close_file(unit_number=tmc_ana%id_traj) + IF (tmc_ana%id_traj > 0) CALL close_file(unit_number=tmc_ana%id_traj) ! cell file - IF (tmc_ana%id_cell .GT. 0) CALL close_file(unit_number=tmc_ana%id_cell) + IF (tmc_ana%id_cell > 0) CALL close_file(unit_number=tmc_ana%id_cell) ! dipole file - IF (tmc_ana%id_dip .GT. 0) CALL close_file(unit_number=tmc_ana%id_dip) + IF (tmc_ana%id_dip > 0) CALL close_file(unit_number=tmc_ana%id_dip) ! end the timing CALL timestop(handle) diff --git a/src/tmc/tmc_master.F b/src/tmc/tmc_master.F index 9980d273c2..3dda6b8630 100644 --- a/src/tmc/tmc_master.F +++ b/src/tmc/tmc_master.F @@ -131,11 +131,11 @@ CONTAINS END IF END DO working_elem_loop - CPASSERT(wg .GE. 0) - CPASSERT(stat .NE. TMC_STATUS_FAILED) - CPASSERT(work_list(wg)%elem%stat .NE. status_calc_approx_ener) + CPASSERT(wg >= 0) + CPASSERT(stat /= TMC_STATUS_FAILED) + CPASSERT(work_list(wg)%elem%stat /= status_calc_approx_ener) - IF (DEBUG .GE. 1) & + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & "TMC|master: cancel group "//cp_to_string(wg) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & @@ -284,7 +284,7 @@ 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 .NE. TMC_STAT_START_CONF_RESULT) & + IF (stat /= TMC_STAT_START_CONF_RESULT) & CALL cp_abort(__LOCATION__, & "receiving start configuration failed, received stat "// & cp_to_string(stat)) @@ -313,7 +313,7 @@ CONTAINS worker_timings=worker_timings_aver) ! init restart counter (espacially for restart case) - IF (tmc_env%m_env%restart_out_step .NE. 0) THEN + IF (tmc_env%m_env%restart_out_step /= 0) THEN restart_count = INT(tmc_env%m_env%result_count(0)/ & REAL(tmc_env%m_env%restart_out_step, KIND=dp)) + 1 END IF @@ -330,7 +330,7 @@ CONTAINS END DO ! send the atom informations to all analysis workers - IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe .GT. 1) THEN + IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe > 1) THEN DO wg = 1, tmc_env%tmc_comp_set%para_env_m_ana%num_pe - 1 stat = TMC_STAT_INIT_ANALYSIS CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & @@ -348,14 +348,14 @@ CONTAINS CALL deallocate_sub_tree_node(tree_elem=init_conf) ! regtest output - IF (tmc_env%params%print_test_output .OR. DEBUG .GT. 0) & + 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 ! calculate the approx energy of the first element (later the exact) - IF (tmc_env%m_env%gt_head%conf(1)%elem%stat .EQ. status_calc_approx_ener) THEN + 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 .GT. 0) & + IF (tmc_env%tmc_comp_set%group_cc_nr > 0) & wg = tmc_env%tmc_comp_set%group_ener_nr + 1 stat = TMC_STAT_APPROX_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & @@ -365,7 +365,7 @@ CONTAINS worker_info(wg)%busy = .TRUE. worker_info(wg)%elem => tmc_env%m_env%gt_head%conf(1)%elem init_conf => tmc_env%m_env%gt_head%conf(1)%elem - ELSE IF (tmc_env%m_env%gt_head%conf(1)%elem%stat .EQ. status_created) THEN + ELSE IF (tmc_env%m_env%gt_head%conf(1)%elem%stat == status_created) THEN init_conf => tmc_env%m_env%gt_head%conf(1)%elem ! calculation will be done automatically, ! by searching the next conf for energy calculation @@ -390,8 +390,8 @@ 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 .NE. TMC_CANCELING_RECEIPT)) THEN - IF (DEBUG .GE. 1) & + IF (worker_info(wg)%canceled .AND. (stat /= TMC_CANCELING_RECEIPT)) THEN + IF (DEBUG >= 1) & WRITE (tmc_env%m_env%io_unit, *) & "TMC|master: recv stat "//cp_to_string(stat)// & " of canceled worker group" @@ -405,7 +405,7 @@ CONTAINS "no tree elem exist when receiving stat "// & cp_to_string(stat)//"of group"//cp_to_string(wg)) - IF (DEBUG .GE. 1) & + 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)// & @@ -487,7 +487,7 @@ CONTAINS END IF !-- send energy request ! in case of one singe input file, energy is already calculated - IF (tmc_env%params%NMC_inp_file .EQ. "") THEN + IF (tmc_env%params%NMC_inp_file == "") THEN worker_info(wg)%elem%potential = worker_info(wg)%elem%e_pot_approx worker_info(wg)%elem%stat = status_calculated ! check acceptance of depending nodes @@ -508,7 +508,7 @@ CONTAINS worker_info(wg)%elem => NULL() ELSE ! if all working groups are equal, the same group calculates the energy - IF (tmc_env%tmc_comp_set%group_cc_nr .LE. 0 & + IF (tmc_env%tmc_comp_set%group_cc_nr <= 0 & .AND. (.NOT. worker_info(wg)%canceled)) THEN worker_info(wg)%elem%stat = status_calculate_energy stat = TMC_STAT_ENERGY_REQUEST @@ -564,7 +564,7 @@ CONTAINS tmc_env=tmc_env) END IF !-- write out all configurations (not only Markov Chain) e.g. for fitting - IF (tmc_env%params%all_conf_file_name .NE. "") THEN + IF (tmc_env%params%all_conf_file_name /= "") THEN CALL write_element_in_file(elem=worker_info(wg)%elem, & file_name=tmc_env%params%all_conf_file_name, & tmc_params=tmc_env%params, & @@ -578,7 +578,7 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & cancel_count=cancel_count) - IF (DEBUG .GE. 9) & + 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, & @@ -588,8 +588,8 @@ CONTAINS !-- SCF ENERGY ----------------------- CASE (TMC_STAT_SCF_STEP_ENER_RECEIVE) IF (.NOT. (ASSOCIATED(worker_info(wg)%elem, init_conf)) .AND. & - worker_info(wg)%elem%stat .NE. status_cancel_ener .AND. & - worker_info(wg)%elem%stat .NE. status_cancel_nmc) THEN + worker_info(wg)%elem%stat /= status_cancel_ener .AND. & + worker_info(wg)%elem%stat /= status_cancel_nmc) THEN ! update the acceptance probability and the canceling list CALL check_elements_for_acc_prob_update(tree_elem=worker_info(wg)%elem, & tmc_env=tmc_env) @@ -610,7 +610,7 @@ CONTAINS !-- do tree update (check new results) CALL tree_update(tmc_env=tmc_env, result_acc=flag, & something_updated=l_update_tree) - IF (DEBUG .GE. 2 .AND. l_update_tree) & + 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)// & @@ -628,15 +628,15 @@ CONTAINS ! finish building trees !TODO set correct logger para_env to use this CALL external_control(should_stop=external_stop, flag="TMC", globenv=globenv) - IF ((ANY(tmc_env%m_env%result_count(1:) .GE. tmc_env%m_env%num_MC_elem) & + IF ((ANY(tmc_env%m_env%result_count(1:) >= tmc_env%m_env%num_MC_elem) & .AND. flag) .OR. & - (m_walltime() - run_time_start .GT. & + (m_walltime() - run_time_start > & tmc_env%m_env%walltime - walltime_delay - walltime_offset) .OR. & external_stop) THEN WRITE (tmc_env%m_env%io_unit, FMT="(/,T2,A)") REPEAT("=", 79) ! calculations NOT finished, walltime exceeded IF (.NOT. ANY(tmc_env%m_env%result_count(1:) & - .GE. tmc_env%m_env%num_MC_elem)) THEN + >= tmc_env%m_env%num_MC_elem)) THEN WRITE (tmc_env%m_env%io_unit, *) "Walltime exceeded.", & m_walltime() - run_time_start, " of ", tmc_env%m_env%walltime - walltime_delay - walltime_offset, & "(incl. delay", walltime_delay, "and offset", walltime_offset, ") left" @@ -646,7 +646,7 @@ CONTAINS WRITE (tmc_env%m_env%io_unit, *) "Total energy: ", & tmc_env%m_env%result_list(1)%elem%potential END IF - IF (tmc_env%m_env%restart_out_step .NE. 0) & + 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) EXIT task_loop @@ -656,7 +656,7 @@ CONTAINS ! update the rest of the tree (canceling and deleting elements) ! ======================================================================= IF (l_update_tree) THEN - IF (DEBUG .GE. 2) & + IF (DEBUG >= 2) & WRITE (tmc_env%m_env%io_unit, *) & "TMC|master: start remove elem and cancel calculation" !-- CLEANING tree nodes beside the path through the tree from @@ -680,25 +680,25 @@ 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 .GE. 16 .AND. ALL(worker_info(:)%busy)) & + IF (DEBUG >= 16 .AND. ALL(worker_info(:)%busy)) & WRITE (tmc_env%m_env%io_unit, *) "all workers are busy" IF (.NOT. worker_info(wg)%busy) THEN - IF (DEBUG .GE. 13) & + IF (DEBUG >= 13) & WRITE (tmc_env%m_env%io_unit, *) & "TMC|master: search new task for worker ", wg ! no group separation - IF (tmc_env%tmc_comp_set%group_cc_nr .LE. 0) THEN + IF (tmc_env%tmc_comp_set%group_cc_nr <= 0) THEN ! search next element to calculate the energy CALL search_next_energy_calc(gt_head=tmc_env%m_env%gt_act, & new_gt_elem=gt_elem_tmp, stat=stat, & react_count=reactivation_ener_count) - IF (stat .EQ. TMC_STATUS_WAIT_FOR_NEW_TASK) THEN + IF (stat == TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL create_new_gt_tree_node(tmc_env=tmc_env, stat=stat, & new_elem=gt_elem_tmp, & reactivation_cc_count=reactivation_cc_count) END IF - ELSEIF (wg .GT. 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 @@ -707,7 +707,7 @@ 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 .EQ. status_created .OR. stat .EQ. status_calculate_energy) & + IF (stat == status_created .OR. stat == status_calculate_energy) & stat = TMC_STATUS_WAIT_FOR_NEW_TASK ELSE ! search next element to calculate the energy @@ -716,7 +716,7 @@ CONTAINS react_count=reactivation_ener_count) END IF - IF (DEBUG .GE. 10) & + 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) @@ -781,9 +781,9 @@ CONTAINS worker_info(wg)%start_time = m_walltime() !===================== write out info after x requested tasks========== - IF (nr_of_job(4) .GT. last_output .AND. & - (MODULO(nr_of_job(4), tmc_env%m_env%info_out_step_size) .EQ. 0) .AND. & - (stat .NE. TMC_STATUS_FAILED)) THEN + IF (nr_of_job(4) > last_output .AND. & + (MODULO(nr_of_job(4), tmc_env%m_env%info_out_step_size) == 0) .AND. & + (stat /= TMC_STATUS_FAILED)) THEN last_output = nr_of_job(4) WRITE (tmc_env%m_env%io_unit, FMT="(/,T2,A)") REPEAT("-", 79) WRITE (tmc_env%m_env%io_unit, *) & @@ -803,7 +803,7 @@ CONTAINS counters=tree_elem_counters, head_elements_nr=tree_elem_heads) WRITE (tmc_env%m_env%io_unit, *) "nodes in trees", tree_elem_counters(:) WRITE (tmc_env%m_env%io_unit, *) "tree heads ", tree_elem_heads(:) - IF (tmc_env%params%NMC_inp_file .NE. "") THEN + IF (tmc_env%params%NMC_inp_file /= "") THEN CALL count_prepared_nodes_in_trees(global_tree_ptr=tmc_env%m_env%gt_act, & counters=tree_elem_counters) WRITE (tmc_env%m_env%io_unit, FMT=*) & @@ -842,8 +842,8 @@ CONTAINS DEALLOCATE (tree_elem_counters) END IF !===================== write out restart file after x results============ - IF (tmc_env%m_env%restart_out_step .GT. 0 .AND. & - tmc_env%m_env%result_count(0) .GT. & + IF (tmc_env%m_env%restart_out_step > 0 .AND. & + tmc_env%m_env%result_count(0) > & restart_count*tmc_env%m_env%restart_out_step) THEN CALL print_restart_file(tmc_env=tmc_env, job_counts=nr_of_job, & timings=worker_timings_aver) @@ -869,14 +869,14 @@ CONTAINS " (MC elements/calculated configuration) global:", & efficiency(0), " sub tree(s): ", efficiency(1:) DEALLOCATE (efficiency) - IF (tmc_env%tmc_comp_set%group_cc_nr .GT. 0) & + 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) 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) - IF (tmc_env%params%NMC_inp_file .NE. "") THEN + IF (tmc_env%params%NMC_inp_file /= "") THEN WRITE (tmc_env%m_env%io_unit, *) & "Amount of canceled elements (E/cc):", & tmc_env%m_env%count_cancel_ener, tmc_env%m_env%count_cancel_NMC @@ -930,9 +930,9 @@ CONTAINS REAL(KIND=dp) :: time INTEGER :: walltime_delay - CPASSERT(time .GE. 0.0_dp) + CPASSERT(time >= 0.0_dp) - IF (time .GT. walltime_delay) THEN + IF (time > walltime_delay) THEN walltime_delay = INT(time) + 1 END IF END SUBROUTINE set_walltime_delay diff --git a/src/tmc/tmc_messages.F b/src/tmc/tmc_messages.F index e3c8cc56c2..7611484324 100644 --- a/src/tmc/tmc_messages.F +++ b/src/tmc/tmc_messages.F @@ -88,7 +88,7 @@ CONTAINS CPASSERT(ASSOCIATED(para_env)) master = .FALSE. - IF (para_env%mepos .EQ. MASTER_COMM_ID) & + IF (para_env%mepos == MASTER_COMM_ID) & master = .TRUE. END FUNCTION check_if_group_master @@ -135,9 +135,9 @@ CONTAINS ! init ! define send_recv flag for broadcast - IF (dest .EQ. bcast_group) THEN + IF (dest == bcast_group) THEN ! master should always send - IF (para_env%mepos .EQ. MASTER_COMM_ID) THEN + IF (para_env%mepos == MASTER_COMM_ID) THEN act_send_recv = send_msg ELSE ! worker should always receive @@ -153,8 +153,8 @@ CONTAINS ! ============================= ! creating message to send IF (act_send_recv .EQV. send_msg) THEN - IF ((DEBUG .GE. 7) .AND. (dest .NE. bcast_group) .AND. & - (dest .NE. MASTER_COMM_ID)) THEN + IF ((DEBUG >= 7) .AND. (dest /= bcast_group) .AND. & + (dest /= MASTER_COMM_ID)) THEN IF (PRESENT(elem)) THEN WRITE (*, *) "send element info to ", dest, " of type ", msg_type, "of subtree", elem%sub_tree_nr, & "elem", elem%nr @@ -199,44 +199,44 @@ CONTAINS END IF ! sending message - IF ((act_send_recv .EQV. send_msg) .AND. (dest .NE. bcast_group)) THEN + IF ((act_send_recv .EQV. send_msg) .AND. (dest /= bcast_group)) THEN CALL para_env%send(m_send%info, dest, message_tag) - IF (m_send%info(2) .GT. 0) THEN + IF (m_send%info(2) > 0) THEN CALL para_env%send(m_send%task_int, dest, message_tag) END IF - IF (m_send%info(3) .GT. 0) THEN + IF (m_send%info(3) > 0) THEN CALL para_env%send(m_send%task_real, dest, message_tag) END IF - IF (m_send%info(4) .GT. 0) THEN + IF (m_send%info(4) > 0) THEN CPABORT("") !TODO send characters CALL para_env%send(m_send%task_char, dest, message_tag) END IF - IF (DEBUG .GE. 1) & + 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 - IF (m_send%info(2) .GT. 0) DEALLOCATE (m_send%task_int) - IF (m_send%info(3) .GT. 0) DEALLOCATE (m_send%task_real) - IF (m_send%info(4) .GT. 0) DEALLOCATE (m_send%task_char) + 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) IF (PRESENT(success)) success = .TRUE. END IF ! ============================= ! broadcast ! ============================= - IF (dest .EQ. bcast_group) THEN - IF (para_env%num_pe .GT. 1) THEN + IF (dest == bcast_group) THEN + IF (para_env%num_pe > 1) THEN CALL para_env%bcast(m_send%info, MASTER_COMM_ID) - IF (m_send%info(2) .GT. 0) THEN + IF (m_send%info(2) > 0) THEN IF (.NOT. act_send_recv) ALLOCATE (m_send%task_int(m_send%info(2))) CALL para_env%bcast(m_send%task_int, MASTER_COMM_ID) END IF - IF (m_send%info(3) .GT. 0) THEN + IF (m_send%info(3) > 0) THEN IF (.NOT. act_send_recv) ALLOCATE (m_send%task_real(m_send%info(3))) CALL para_env%bcast(m_send%task_real, MASTER_COMM_ID) END IF - IF (m_send%info(4) .GT. 0) THEN + IF (m_send%info(4) > 0) THEN IF (.NOT. act_send_recv) ALLOCATE (m_send%task_char(m_send%info(3))) CPABORT("") !TODO bcast char CALL para_env%bcast(m_send%task_char, MASTER_COMM_ID) @@ -244,16 +244,16 @@ CONTAINS END IF ! sender delete arrays IF (act_send_recv) THEN - IF (m_send%info(2) .GT. 0) DEALLOCATE (m_send%task_int) - IF (m_send%info(3) .GT. 0) DEALLOCATE (m_send%task_real) - IF (m_send%info(4) .GT. 0) DEALLOCATE (m_send%task_char) + 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) END IF END IF ! ============================= ! receiving message ! ============================= - IF ((act_send_recv .EQV. recv_msg) .AND. dest .NE. bcast_group) THEN + IF ((act_send_recv .EQV. recv_msg) .AND. dest /= bcast_group) THEN flag = .FALSE. tmp_tag = TMC_STATUS_WAIT_FOR_NEW_TASK IF (PRESENT(wait_for_message)) THEN @@ -262,10 +262,10 @@ CONTAINS flag = .TRUE. ELSE participant_loop: DO i = 0, para_env%num_pe - 1 - IF (i .NE. para_env%mepos) THEN + IF (i /= para_env%mepos) THEN dest = i CALL para_env%probe(dest, tmp_tag) - IF (dest .EQ. i) THEN + IF (dest == i) THEN flag = .TRUE. EXIT participant_loop END IF @@ -278,7 +278,7 @@ CONTAINS RETURN END IF - IF (tmp_tag .EQ. TMC_STAT_SCF_STEP_ENER_RECEIVE) THEN + IF (tmp_tag == TMC_STAT_SCF_STEP_ENER_RECEIVE) THEN ! CP2K send back SCF step energies without info message message_tag = TMC_STAT_SCF_STEP_ENER_RECEIVE m_send%info(1) = TMC_STAT_SCF_STEP_ENER_RECEIVE @@ -290,22 +290,22 @@ CONTAINS ! first get message type and sizes CALL para_env%recv(m_send%info, dest, message_tag) END IF - IF (DEBUG .GE. 1) & + 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:) !-- receive message integer part - IF (m_send%info(2) .GT. 0) THEN + IF (m_send%info(2) > 0) THEN ALLOCATE (m_send%task_int(m_send%info(2))) CALL para_env%recv(m_send%task_int, dest, message_tag) END IF !-- receive message double (floatingpoint) part - IF (m_send%info(3) .GT. 0) THEN + IF (m_send%info(3) > 0) THEN ALLOCATE (m_send%task_real(m_send%info(3))) CALL para_env%recv(m_send%task_real, dest, message_tag) END IF !-- receive message character part - IF (m_send%info(4) .GT. 0) THEN + IF (m_send%info(4) > 0) THEN ALLOCATE (m_send%task_char(m_send%info(4))) CPABORT("") !TODO recv characters CALL para_env%recv(m_send%task_char, dest, message_tag) @@ -317,11 +317,11 @@ CONTAINS ! if the element is supposed to be canceled but received message is not canceling receipt do not handle element ! (because element could be already deallocated, and hence a new element would be created -> not necessary) IF (PRESENT(elem_array)) THEN - IF (elem_array(dest)%canceled .AND. m_send%info(1) .NE. TMC_CANCELING_RECEIPT) THEN + IF (elem_array(dest)%canceled .AND. m_send%info(1) /= TMC_CANCELING_RECEIPT) THEN msg_type = m_send%info(1) - IF (m_send%info(2) .GT. 0) DEALLOCATE (m_send%task_int) - IF (m_send%info(3) .GT. 0) DEALLOCATE (m_send%task_real) - IF (m_send%info(4) .GT. 0) DEALLOCATE (m_send%task_char) + 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) ! to check for further messages IF (PRESENT(success)) success = .TRUE. DEALLOCATE (m_send) @@ -369,9 +369,9 @@ CONTAINS "try to receive unknown message type "//cp_to_string(msg_type)// & "from source "//cp_to_string(dest)) END SELECT - IF (m_send%info(2) .GT. 0) DEALLOCATE (m_send%task_int) - IF (m_send%info(3) .GT. 0) DEALLOCATE (m_send%task_real) - IF (m_send%info(4) .GT. 0) DEALLOCATE (m_send%task_char) + 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) IF (PRESENT(success)) success = .TRUE. END IF @@ -440,7 +440,7 @@ CONTAINS ! END DO ! counter = counter + 1+INT(m_send%task_real(counter)) ! m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end -! CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) +! CPPostconditionNoFail(INT(m_send%task_real(msg_size_real))==message_end_flag,cp_failure_level,routineP) ! END SUBROUTINE create_atom_mass_message ! !! ************************************************************************************************** @@ -479,7 +479,7 @@ CONTAINS ! atoms(i)%mass = m_send%task_real(counter+i) ! END DO ! counter = counter + 1+INT(m_send%task_real(counter)) -! CPPostconditionNoFail(INT(m_send%task_real(counter)).EQ.message_end_flag,cp_failure_level,routineP) +! CPPostconditionNoFail(INT(m_send%task_real(counter))==message_end_flag,cp_failure_level,routineP) ! END SUBROUTINE read_atom_mass_message ! ************************************************************************************************** @@ -513,7 +513,7 @@ CONTAINS IF (tmc_params%cell%orthorhombic) m_send%task_int(counter + 2) = 1 counter = counter + 3 m_send%task_int(counter) = message_end_flag - CPASSERT(counter .EQ. SIZE(m_send%task_int)) + CPASSERT(counter == SIZE(m_send%task_int)) !float array with cell vectors msg_size_real = 1 + SIZE(tmc_params%cell%hmat) + 1 @@ -525,8 +525,8 @@ CONTAINS [SIZE(tmc_params%cell%hmat)]) counter = counter + 1 + INT(m_send%task_real(counter)) m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_worker_init_message ! ************************************************************************************************** @@ -544,33 +544,33 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_params)) CPASSERT(ASSOCIATED(m_send)) - CPASSERT(m_send%info(3) .GE. 4) + CPASSERT(m_send%info(3) >= 4) IF (.NOT. ASSOCIATED(tmc_params%cell)) ALLOCATE (tmc_params%cell) counter = 1 !int array - flag = INT(m_send%task_int(1)) .EQ. SIZE(tmc_params%cell%perd) + flag = INT(m_send%task_int(1)) == SIZE(tmc_params%cell%perd) CPASSERT(flag) counter = 1 + m_send%task_int(1) + 1 tmc_params%cell%perd = m_send%task_int(2:counter - 1) tmc_params%cell%symmetry_id = m_send%task_int(counter + 1) tmc_params%cell%orthorhombic = .FALSE. - IF (m_send%task_int(counter + 2) .EQ. 1) tmc_params%cell%orthorhombic = .TRUE. + IF (m_send%task_int(counter + 2) == 1) tmc_params%cell%orthorhombic = .TRUE. counter = counter + 3 - CPASSERT(counter .EQ. m_send%info(2)) - CPASSERT(m_send%task_int(counter) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(2)) + CPASSERT(m_send%task_int(counter) == message_end_flag) !float array with cell vectors counter = 1 - flag = INT(m_send%task_real(counter)) .EQ. SIZE(tmc_params%cell%hmat) + flag = INT(m_send%task_real(counter)) == SIZE(tmc_params%cell%hmat) CPASSERT(flag) tmc_params%cell%hmat = & RESHAPE(m_send%task_real(counter + 1:counter + & SIZE(tmc_params%cell%hmat)), [3, 3]) counter = counter + 1 + INT(m_send%task_real(counter)) - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(3)) + CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) END SUBROUTINE read_worker_init_message @@ -604,7 +604,7 @@ CONTAINS counter = 1 msg_size_int = 1 + SIZE(tmc_params%cell%perd) + 1 + 1 + 1 + 1 + SIZE(elem%mol) + 1 - IF (msg_type .EQ. TMC_STAT_INIT_ANALYSIS) THEN + IF (msg_type == TMC_STAT_INIT_ANALYSIS) THEN CPASSERT(PRESENT(result_count)) CPASSERT(ASSOCIATED(result_count)) msg_size_int = msg_size_int + 1 + SIZE(result_count(1:)) @@ -621,14 +621,14 @@ CONTAINS m_send%task_int(counter) = SIZE(elem%mol) m_send%task_int(counter + 1:counter + m_send%task_int(counter)) = elem%mol(:) counter = counter + 1 + m_send%task_int(counter) - IF (msg_type .EQ. TMC_STAT_INIT_ANALYSIS) THEN + IF (msg_type == TMC_STAT_INIT_ANALYSIS) THEN m_send%task_int(counter) = SIZE(result_count(1:)) m_send%task_int(counter + 1:counter + m_send%task_int(counter)) = & result_count(1:) counter = counter + 1 + m_send%task_int(counter) END IF m_send%task_int(counter) = message_end_flag - CPASSERT(counter .EQ. SIZE(m_send%task_int)) + CPASSERT(counter == SIZE(m_send%task_int)) counter = 0 !float array with pos, cell vectors, atom_mass @@ -649,8 +649,8 @@ CONTAINS END DO counter = counter + 1 + INT(m_send%task_real(counter)) m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_start_conf_message @@ -679,38 +679,38 @@ CONTAINS CPASSERT(.NOT. ASSOCIATED(tmc_params%atoms)) CPASSERT(ASSOCIATED(m_send)) CPASSERT(.NOT. ASSOCIATED(elem)) - CPASSERT(m_send%info(3) .GE. 4) + CPASSERT(m_send%info(3) >= 4) IF (.NOT. ASSOCIATED(tmc_params%cell)) ALLOCATE (tmc_params%cell) CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem, & nr_dim=NINT(m_send%task_real(1))) counter = 1 !int array - flag = INT(m_send%task_int(1)) .EQ. SIZE(tmc_params%cell%perd) + flag = INT(m_send%task_int(1)) == SIZE(tmc_params%cell%perd) CPASSERT(flag) counter = 1 + m_send%task_int(1) + 1 tmc_params%cell%perd = m_send%task_int(2:counter - 1) tmc_params%cell%symmetry_id = m_send%task_int(counter + 1) tmc_params%cell%orthorhombic = .FALSE. - IF (m_send%task_int(counter + 2) .EQ. 1) tmc_params%cell%orthorhombic = .TRUE. + IF (m_send%task_int(counter + 2) == 1) tmc_params%cell%orthorhombic = .TRUE. counter = counter + 3 elem%mol(:) = m_send%task_int(counter + 1:counter + m_send%task_int(counter)) counter = counter + 1 + m_send%task_int(counter) - IF (msg_type .EQ. TMC_STAT_INIT_ANALYSIS) THEN + IF (msg_type == TMC_STAT_INIT_ANALYSIS) THEN CPASSERT(PRESENT(result_count)) CPASSERT(.NOT. ASSOCIATED(result_count)) ALLOCATE (result_count(m_send%task_int(counter))) result_count(:) = m_send%task_int(counter + 1:counter + m_send%task_int(counter)) counter = counter + 1 + m_send%task_int(counter) END IF - CPASSERT(counter .EQ. m_send%info(2)) - CPASSERT(m_send%task_int(counter) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(2)) + CPASSERT(m_send%task_int(counter) == message_end_flag) counter = 0 !float array with pos, cell vectors, atom_mass counter = 2 + INT(m_send%task_real(1)) elem%pos = m_send%task_real(2:counter - 1) - flag = INT(m_send%task_real(counter)) .EQ. SIZE(tmc_params%cell%hmat) + flag = INT(m_send%task_real(counter)) == SIZE(tmc_params%cell%hmat) CPASSERT(flag) tmc_params%cell%hmat = & RESHAPE(m_send%task_real(counter + 1:counter + & @@ -724,8 +724,8 @@ CONTAINS END DO counter = counter + 1 + INT(m_send%task_real(counter)) - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(3)) + CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) END SUBROUTINE read_start_conf_message @@ -765,25 +765,25 @@ CONTAINS m_send%task_int(counter + 1:counter + m_send%task_int(counter)) = elem%nr counter = counter + 1 + m_send%task_int(counter) m_send%task_int(counter) = message_end_flag - CPASSERT(SIZE(m_send%task_int) .EQ. msg_size_int) - CPASSERT(m_send%task_int(msg_size_int) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_int) == msg_size_int) + CPASSERT(m_send%task_int(msg_size_int) == message_end_flag) !then float array with pos msg_size_real = 1 + SIZE(elem%pos) + 1 - IF (tmc_params%pressure .GE. 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) + IF (tmc_params%pressure >= 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) ALLOCATE (m_send%task_real(msg_size_real)) m_send%task_real(1) = SIZE(elem%pos) counter = 2 + INT(m_send%task_real(1)) m_send%task_real(2:counter - 1) = elem%pos - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN m_send%task_real(counter) = SIZE(elem%box_scale) m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) = elem%box_scale(:) counter = counter + 1 + INT(m_send%task_real(counter)) END IF m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_energy_request_message ! ************************************************************************************************** @@ -801,7 +801,7 @@ CONTAINS INTEGER :: counter CPASSERT(ASSOCIATED(m_send)) - CPASSERT(m_send%info(3) .GT. 0) + CPASSERT(m_send%info(3) > 0) CPASSERT(ASSOCIATED(tmc_params)) CPASSERT(.NOT. ASSOCIATED(elem)) @@ -811,26 +811,26 @@ CONTAINS tmc_params=tmc_params) END IF ! read the integer values - CPASSERT(m_send%info(2) .GT. 0) + CPASSERT(m_send%info(2) > 0) counter = 1 elem%sub_tree_nr = m_send%task_int(counter + 1) counter = counter + 1 + m_send%task_int(counter) elem%nr = m_send%task_int(counter + 1) counter = counter + 1 + m_send%task_int(counter) - CPASSERT(m_send%task_int(counter) .EQ. message_end_flag) + CPASSERT(m_send%task_int(counter) == message_end_flag) !float array with pos counter = 0 counter = 1 + NINT(m_send%task_real(1)) elem%pos = m_send%task_real(2:counter) counter = counter + 1 - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN elem%box_scale(:) = m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) END IF - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(3)) + CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) END SUBROUTINE read_energy_request_message ! ************************************************************************************************** @@ -857,7 +857,7 @@ CONTAINS !first integer array msg_size_int = 0 ! for checking the tree element mapping, send back the tree numbers - IF (DEBUG .GT. 0) THEN + IF (DEBUG > 0) THEN msg_size_int = 1 + 1 + 1 + 1 + 1 ! 1+SIZE(elem%sub_tree_nr) +1+SIZE(elem%nr) ALLOCATE (m_send%task_int(msg_size_int)) counter = 1 @@ -892,8 +892,8 @@ CONTAINS m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_energy_result_message ! ************************************************************************************************** @@ -912,22 +912,22 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(m_send)) - CPASSERT(m_send%info(3) .GT. 0) + CPASSERT(m_send%info(3) > 0) CPASSERT(ASSOCIATED(tmc_params)) ! read the integer values ! for checking the tree element mapping, check the tree numbers - IF (DEBUG .GT. 0) THEN + IF (DEBUG > 0) THEN counter = 1 - IF (elem%sub_tree_nr .NE. m_send%task_int(counter + 1) .OR. & - elem%nr .NE. m_send%task_int(counter + 3)) THEN + IF (elem%sub_tree_nr /= m_send%task_int(counter + 1) .OR. & + elem%nr /= m_send%task_int(counter + 3)) THEN WRITE (*, *) "ERROR: read_energy_result: master got energy result of subtree elem ", & m_send%task_int(counter + 1), m_send%task_int(counter + 3), & " but expect result of subtree elem", elem%sub_tree_nr, elem%nr CPABORT("read_energy_result: got energy result from unexpected tree element.") END IF ELSE - CPASSERT(m_send%info(2) .EQ. 0) + CPASSERT(m_send%info(2) == 0) END IF !then float array with energy of exact potential @@ -942,8 +942,8 @@ CONTAINS counter = counter + 1 + NINT(m_send%task_real(counter)) END IF - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(3)) + CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) END SUBROUTINE read_energy_result_message ! ************************************************************************************************** @@ -971,22 +971,22 @@ CONTAINS !then float array with energy of exact potential msg_size_real = 1 + 1 + 1 - IF (tmc_params%pressure .GE. 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) + IF (tmc_params%pressure >= 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) ALLOCATE (m_send%task_real(msg_size_real)) m_send%task_real(1) = 1 m_send%task_real(2) = elem%e_pot_approx counter = 3 ! the box size for NpT - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN m_send%task_real(counter) = SIZE(elem%box_scale) m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) = elem%box_scale(:) counter = counter + 1 + INT(m_send%task_real(counter)) END IF m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_approx_energy_result_message ! ************************************************************************************************** @@ -1005,19 +1005,19 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(m_send)) - CPASSERT(m_send%info(2) .EQ. 0 .AND. m_send%info(3) .GT. 0) + CPASSERT(m_send%info(2) == 0 .AND. m_send%info(3) > 0) CPASSERT(ASSOCIATED(tmc_params)) !then float array with energy of exact potential elem%e_pot_approx = m_send%task_real(2) counter = 3 - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN elem%box_scale(:) = m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) END IF - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(3)) + CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) END SUBROUTINE read_approx_energy_result !============================================================================ @@ -1075,15 +1075,15 @@ 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 .EQ. TMC_STAT_MD_REQUEST .OR. msg_type .EQ. TMC_STAT_MD_BROADCAST) & + 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 .GE. 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(elem%box_scale(:)) ! box size for NpT + 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)) m_send%task_real(1) = SIZE(elem%pos) counter = 2 + INT(m_send%task_real(1)) m_send%task_real(2:counter - 1) = elem%pos - IF (msg_type .EQ. TMC_STAT_MD_REQUEST .OR. msg_type .EQ. TMC_STAT_MD_BROADCAST) THEN + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) THEN m_send%task_real(counter) = SIZE(elem%vel) m_send%task_real(counter + 1:counter + NINT(m_send%task_real(counter))) = elem%vel counter = counter + 1 + NINT(m_send%task_real(counter)) @@ -1097,17 +1097,17 @@ CONTAINS m_send%task_real(counter + 1:counter + SIZE(elem%subbox_center)) = elem%subbox_center(:) counter = counter + 1 + NINT(m_send%task_real(counter)) ! the box size for NpT - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN m_send%task_real(counter) = SIZE(elem%box_scale) m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) = elem%box_scale(:) counter = counter + 1 + INT(m_send%task_real(counter)) END IF m_send%task_real(counter) = message_end_flag !message end - CPASSERT(SIZE(m_send%task_int) .EQ. msg_size_int) - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(m_send%task_int(msg_size_int) .EQ. message_end_flag) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_int) == msg_size_int) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(m_send%task_int(msg_size_int) == message_end_flag) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_NMC_request_massage ! ************************************************************************************************** @@ -1129,7 +1129,7 @@ CONTAINS CPASSERT(.NOT. ASSOCIATED(elem)) CPASSERT(ASSOCIATED(m_send)) - CPASSERT(m_send%info(2) .GT. 5 .AND. m_send%info(3) .GT. 8) + CPASSERT(m_send%info(2) > 5 .AND. m_send%info(3) > 8) CPASSERT(ASSOCIATED(tmc_params)) counter = 0 @@ -1154,14 +1154,14 @@ CONTAINS counter = counter + 2 elem%temp_created = m_send%task_int(counter + 1) counter = counter + 2 - CPASSERT(counter .EQ. m_send%info(2)) + CPASSERT(counter == m_send%info(2)) counter = 0 !then float array with pos, (vel), subbox_center and temp num_dim = NINT(m_send%task_real(1)) counter = 2 + INT(m_send%task_real(1)) elem%pos = m_send%task_real(2:counter - 1) - IF (msg_type .EQ. TMC_STAT_MD_REQUEST .OR. msg_type .EQ. TMC_STAT_MD_BROADCAST) THEN + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_BROADCAST) THEN elem%vel = m_send%task_real(counter + 1:counter + NINT(m_send%task_real(counter))) counter = counter + NINT(m_send%task_real(counter)) + 1 END IF @@ -1172,16 +1172,16 @@ CONTAINS elem%subbox_center(:) = m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) counter = counter + 1 + NINT(m_send%task_real(counter)) - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN elem%box_scale(:) = m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) ELSE elem%box_scale(:) = 1.0_dp END IF - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(m_send%task_int(m_send%info(2)) .EQ. message_end_flag) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + 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) END SUBROUTINE read_NMC_request_massage !============================================================================ @@ -1213,14 +1213,14 @@ CONTAINS msg_size_int = 1 + SIZE(elem%mol) & + 1 + SIZE(tmc_params%nmc_move_types%mv_count) & + 1 + SIZE(tmc_params%nmc_move_types%acc_count) + 1 - IF (DEBUG .GT. 0) msg_size_int = msg_size_int + 1 + 1 + 1 + 1 - IF (.NOT. ANY(tmc_params%sub_box_size .LE. 0.1_dp)) & + IF (DEBUG > 0) msg_size_int = msg_size_int + 1 + 1 + 1 + 1 + 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) ALLOCATE (m_send%task_int(msg_size_int)) counter = 1 - IF (DEBUG .GT. 0) THEN + IF (DEBUG > 0) THEN ! send the element number back m_send%task_int(counter) = 1 m_send%task_int(counter + 1) = elem%sub_tree_nr @@ -1246,7 +1246,7 @@ CONTAINS [SIZE(tmc_params%nmc_move_types%acc_count)]) counter = counter + 1 + m_send%task_int(counter) ! amount of rejected subbox moves - IF (.NOT. ANY(tmc_params%sub_box_size .LE. 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN m_send%task_int(counter) = SIZE(tmc_params%nmc_move_types%subbox_count) m_send%task_int(counter + 1:counter + m_send%task_int(counter)) = & RESHAPE(tmc_params%nmc_move_types%subbox_count(:, :), & @@ -1269,8 +1269,8 @@ CONTAINS + 1 + 1 & ! e_pot_approx + 1 ! check bit - IF (msg_type .EQ. TMC_STAT_MD_REQUEST .OR. msg_type .EQ. TMC_STAT_MD_RESULT .OR. & - msg_type .EQ. TMC_STAT_MD_BROADCAST) & + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_RESULT .OR. & + msg_type == TMC_STAT_MD_BROADCAST) & msg_size_real = msg_size_real + 1 + SIZE(elem%vel) + 1 + 1 + 1 + 1 ! for MD also: vel, e_kin_befor_md, ekin ALLOCATE (m_send%task_real(msg_size_real)) @@ -1293,8 +1293,8 @@ CONTAINS m_send%task_real(counter + 1) = elem%e_pot_approx counter = counter + 2 ! for MD also: vel, e_kin_befor_md, ekin - IF (msg_type .EQ. TMC_STAT_MD_REQUEST .OR. msg_type .EQ. TMC_STAT_MD_RESULT .OR. & - msg_type .EQ. TMC_STAT_MD_BROADCAST) THEN + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_RESULT .OR. & + msg_type == TMC_STAT_MD_BROADCAST) THEN m_send%task_real(counter) = SIZE(elem%vel) m_send%task_real(counter + 1:counter + NINT(m_send%task_real(counter))) = elem%vel counter = counter + 1 + INT(m_send%task_real(counter)) @@ -1307,10 +1307,10 @@ CONTAINS END IF m_send%task_real(counter) = message_end_flag ! message end - CPASSERT(SIZE(m_send%task_int) .EQ. msg_size_int) - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(m_send%task_int(msg_size_int) .EQ. message_end_flag) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_int) == msg_size_int) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(m_send%task_int(msg_size_int) == message_end_flag) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_NMC_result_massage ! ************************************************************************************************** @@ -1335,13 +1335,13 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) CPASSERT(ASSOCIATED(m_send)) - CPASSERT(m_send%info(2) .GT. 0 .AND. m_send%info(3) .GT. 0) + CPASSERT(m_send%info(2) > 0 .AND. m_send%info(3) > 0) CPASSERT(ASSOCIATED(tmc_params)) !first integer array with element status, random number seed, and move type counter = 1 - IF (DEBUG .GT. 0) THEN - IF ((m_send%task_int(counter + 1) .NE. elem%sub_tree_nr) .AND. (m_send%task_int(counter + 3) .NE. elem%nr)) THEN + IF (DEBUG > 0) THEN + IF ((m_send%task_int(counter + 1) /= elem%sub_tree_nr) .AND. (m_send%task_int(counter + 3) /= elem%nr)) THEN CPABORT("read_NMC_result_massage: got result of wrong element") END IF counter = counter + 2 + 2 @@ -1364,7 +1364,7 @@ CONTAINS SIZE(tmc_params%nmc_move_types%acc_count(1, :))]) counter = counter + 1 + m_send%task_int(counter) ! amount of rejected subbox moves - IF (.NOT. ANY(tmc_params%sub_box_size .LE. 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN ALLOCATE (subbox_counter(SIZE(tmc_params%nmc_move_types%subbox_count(:, 1)), & SIZE(tmc_params%nmc_move_types%subbox_count(1, :)))) subbox_counter(:, :) = RESHAPE(m_send%task_int(counter + 1:counter + m_send%task_int(counter)), & @@ -1378,7 +1378,7 @@ CONTAINS SIZE(tmc_params%nmc_move_types%subbox_acc_count(1, :))]) counter = counter + 1 + m_send%task_int(counter) END IF - CPASSERT(counter .EQ. m_send%info(2)) + CPASSERT(counter == m_send%info(2)) counter = 0 !then float array with pos, (vel, e_kin_befor_md, ekin), (forces), rng_seed, potential, e_pot_approx @@ -1396,11 +1396,11 @@ CONTAINS elem%e_pot_approx = m_send%task_real(counter + 1) counter = counter + 2 ! for MD also: vel, e_kin_befor_md, ekin - IF (msg_type .EQ. TMC_STAT_MD_REQUEST .OR. msg_type .EQ. TMC_STAT_MD_RESULT .OR. & - msg_type .EQ. TMC_STAT_MD_BROADCAST) THEN + IF (msg_type == TMC_STAT_MD_REQUEST .OR. msg_type == TMC_STAT_MD_RESULT .OR. & + 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 .EQ. task_type_gaussian_adaptation)) & + IF (.NOT. (tmc_params%task_type == task_type_gaussian_adaptation)) & elem%ekin_before_md = m_send%task_real(counter + 1) counter = counter + 2 elem%ekin = m_send%task_real(counter + 1) @@ -1409,17 +1409,17 @@ CONTAINS CALL add_mv_prob(move_types=tmc_params%nmc_move_types, prob_opt=tmc_params%esimate_acc_prob, & mv_counter=mv_counter, acc_counter=acc_counter) - IF (.NOT. ANY(tmc_params%sub_box_size .LE. 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) THEN CALL add_mv_prob(move_types=tmc_params%nmc_move_types, prob_opt=tmc_params%esimate_acc_prob, & subbox_counter=subbox_counter, subbox_acc_counter=subbox_acc_counter) END IF DEALLOCATE (mv_counter, acc_counter) - IF (.NOT. ANY(tmc_params%sub_box_size .LE. 0.1_dp)) & + IF (.NOT. ANY(tmc_params%sub_box_size <= 0.1_dp)) & DEALLOCATE (subbox_counter, subbox_acc_counter) - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(m_send%task_int(m_send%info(2)) .EQ. message_end_flag) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + 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) END SUBROUTINE read_NMC_result_massage !============================================================================ @@ -1460,25 +1460,25 @@ CONTAINS m_send%task_int(counter + 1:counter + m_send%task_int(counter)) = list_elem%nr counter = counter + 1 + m_send%task_int(counter) m_send%task_int(counter) = message_end_flag - CPASSERT(SIZE(m_send%task_int) .EQ. msg_size_int) - CPASSERT(m_send%task_int(msg_size_int) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_int) == msg_size_int) + CPASSERT(m_send%task_int(msg_size_int) == message_end_flag) !then float array with pos msg_size_real = 1 + SIZE(list_elem%elem%pos) + 1 - IF (tmc_params%pressure .GE. 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(list_elem%elem%box_scale(:)) + IF (tmc_params%pressure >= 0.0_dp) msg_size_real = msg_size_real + 1 + SIZE(list_elem%elem%box_scale(:)) ALLOCATE (m_send%task_real(msg_size_real)) m_send%task_real(1) = SIZE(list_elem%elem%pos) counter = 2 + INT(m_send%task_real(1)) m_send%task_real(2:counter - 1) = list_elem%elem%pos - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN m_send%task_real(counter) = SIZE(list_elem%elem%box_scale) m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) = list_elem%elem%box_scale(:) counter = counter + 1 + INT(m_send%task_real(counter)) END IF m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPASSERT(SIZE(m_send%task_real) .EQ. msg_size_real) - CPASSERT(INT(m_send%task_real(msg_size_real)) .EQ. message_end_flag) + CPASSERT(SIZE(m_send%task_real) == msg_size_real) + CPASSERT(INT(m_send%task_real(msg_size_real)) == message_end_flag) END SUBROUTINE create_analysis_request_message ! ************************************************************************************************** @@ -1496,7 +1496,7 @@ CONTAINS INTEGER :: counter CPASSERT(ASSOCIATED(m_send)) - CPASSERT(m_send%info(3) .GT. 0) + CPASSERT(m_send%info(3) > 0) CPASSERT(ASSOCIATED(tmc_params)) CPASSERT(.NOT. ASSOCIATED(elem)) @@ -1506,26 +1506,26 @@ CONTAINS tmc_params=tmc_params) END IF ! read the integer values - CPASSERT(m_send%info(2) .GT. 0) + CPASSERT(m_send%info(2) > 0) counter = 1 elem%sub_tree_nr = m_send%task_int(counter + 1) counter = counter + 1 + m_send%task_int(counter) elem%nr = m_send%task_int(counter + 1) counter = counter + 1 + m_send%task_int(counter) - CPASSERT(m_send%task_int(counter) .EQ. message_end_flag) + CPASSERT(m_send%task_int(counter) == message_end_flag) !float array with pos counter = 0 counter = 1 + NINT(m_send%task_real(1)) elem%pos = m_send%task_real(2:counter) counter = counter + 1 - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN elem%box_scale(:) = m_send%task_real(counter + 1:counter + INT(m_send%task_real(counter))) counter = counter + 1 + INT(m_send%task_real(counter)) END IF - CPASSERT(counter .EQ. m_send%info(3)) - CPASSERT(INT(m_send%task_real(m_send%info(3))) .EQ. message_end_flag) + CPASSERT(counter == m_send%info(3)) + CPASSERT(INT(m_send%task_real(m_send%info(3))) == message_end_flag) END SUBROUTINE read_analysis_request_message !============================================================================ @@ -1568,11 +1568,11 @@ CONTAINS INTEGER :: i CPASSERT(ASSOCIATED(para_env)) - CPASSERT(source .GE. 0) - CPASSERT(source .LT. para_env%num_pe) + CPASSERT(source >= 0) + CPASSERT(source < para_env%num_pe) ALLOCATE (msg(SIZE(atoms))) - IF (para_env%mepos .EQ. source) THEN + IF (para_env%mepos == source) THEN DO i = 1, SIZE(atoms) msg(i) = atoms(i)%name END DO @@ -1641,7 +1641,7 @@ CONTAINS END IF ! receive stop message receipt - IF (para_env%mepos .EQ. MASTER_COMM_ID) THEN + IF (para_env%mepos == MASTER_COMM_ID) THEN wait_for_receipts: DO ! check incomming messages stat = TMC_STATUS_WAIT_FOR_NEW_TASK diff --git a/src/tmc/tmc_move_handle.F b/src/tmc/tmc_move_handle.F index c0ffd117ab..a4b6197357 100644 --- a/src/tmc/tmc_move_handle.F +++ b/src/tmc/tmc_move_handle.F @@ -114,19 +114,19 @@ 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 .EQ. "") & + IF (tmc_params%NMC_inp_file == "") & CPABORT("Please specify a valid approximate potential.") CALL section_vals_val_get(nmc_section, "NR_NMC_STEPS", & i_val=nmc_steps) - IF (nmc_steps .LE. 0) & + IF (nmc_steps <= 0) & CPABORT("Please specify a valid amount of NMC steps (NR_NMC_STEPS {INTEGER}).") 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 .LE. 0.0_dp) & + 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") @@ -146,11 +146,11 @@ CONTAINS ! get the total weight/amount of move probabilities mv_prob_sum = mv_prob_sum + nmc_prob - IF (n_items + n_NMC_items .GT. 0) THEN + IF (n_items + n_NMC_items > 0) THEN ! 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 .LE. 0.0) & + IF (mv_prob_sum <= 0.0) & CALL cp_abort(__LOCATION__, & "The probabilities to perform the moves are "// & "in total less equal 0") @@ -158,9 +158,9 @@ CONTAINS ! get the sizes, probs, etc. for each move type and convert units DO i_tmp = 1, n_items + n_NMC_items ! select the correct section - IF (i_tmp .GT. n_items) THEN + IF (i_tmp > n_items) THEN i_rep = i_tmp - n_items - IF (i_rep .EQ. 1) THEN + IF (i_rep == 1) THEN ! set the NMC stuff (approx potential) tmc_params%move_types%mv_weight(mv_type_NMC_moves) = & nmc_prob/REAL(mv_prob_sum, KIND=dp) @@ -188,13 +188,13 @@ 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 .LT. 0.0_dp) & + 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) 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 .LT. 0.0_dp) & + 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) @@ -244,7 +244,7 @@ CONTAINS ind = mv_type_swap_conf ! the move size is not necessary delta_x = 0.0_dp - IF (tmc_params%nr_temp .LE. 1) THEN + IF (tmc_params%nr_temp <= 1) THEN ! no configurational swapping if only one temperature mv_prob = 0.0_dp CALL cp_warn(__LOCATION__, & @@ -255,7 +255,7 @@ CONTAINS CASE ("VOL_MOVE") ind = mv_type_volume_move ! check the selected pressure - IF (tmc_params%pressure .GE. 0.0_dp) THEN + IF (tmc_params%pressure >= 0.0_dp) THEN delta_x = delta_x/au2a tmc_params%print_cell = .TRUE. ! print the cell sizes by default ELSE @@ -272,13 +272,13 @@ CONTAINS ! select the types of atoms swapped CALL section_vals_val_get(move_type_section, "ATOMS", i_rep_section=i_rep, & n_rep_val=n_rep_val) - IF (n_rep_val .GT. 0) THEN + IF (n_rep_val > 0) THEN ALLOCATE (move_types%atom_lists(n_rep_val)) DO i = 1, n_rep_val 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) .LE. 1) & + IF (SIZE(move_types%atom_lists(i)%atoms) <= 1) & CPABORT("ATOM_SWAP requires minimum two atom kinds selected. ") END DO END IF @@ -290,12 +290,12 @@ CONTAINS CPABORT("A unknown move type is selected: "//inp_kind_name) END SELECT ! check for valid move sizes - IF (delta_x .LT. 0.0_dp) & + 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) ! check if not already set - IF (move_types%mv_weight(ind) .GT. 0.0) THEN + IF (move_types%mv_weight(ind) > 0.0) THEN CPABORT("TMC: Each move type can be set only once. ") END IF @@ -311,7 +311,7 @@ CONTAINS END IF mv_prob_sum = SUM(tmc_params%move_types%mv_weight(:)) flag = .TRUE. - CPASSERT(ABS(mv_prob_sum - 1.0_dp) .LT. 0.01_dp) + CPASSERT(ABS(mv_prob_sum - 1.0_dp) < 0.01_dp) IF (ASSOCIATED(tmc_params%nmc_move_types)) THEN mv_prob_sum = SUM(tmc_params%nmc_move_types%mv_weight(:)) CPASSERT(ABS(mv_prob_sum - 1.0_dp) < 10*EPSILON(1.0_dp)) @@ -337,11 +337,11 @@ CONTAINS CPASSERT(ASSOCIATED(move_types)) ! molecule moves need molecule info - IF (move_types%mv_weight(mv_type_mol_trans) .GT. 0.0_dp .OR. & - move_types%mv_weight(mv_type_mol_rot) .GT. 0.0_dp) THEN + IF (move_types%mv_weight(mv_type_mol_trans) > 0.0_dp .OR. & + 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)) .EQ. SIZE(mol_array)) & + 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 "// & @@ -349,7 +349,7 @@ CONTAINS END IF ! for the atom swap move - IF (move_types%mv_weight(mv_type_atom_swap) .GT. 0.0_dp) THEN + IF (move_types%mv_weight(mv_type_atom_swap) > 0.0_dp) THEN ! check if the selected atom swaps are possible IF (ASSOCIATED(move_types%atom_lists)) THEN DO list_i = 1, SIZE(move_types%atom_lists(:)) @@ -357,7 +357,7 @@ CONTAINS ! check if atoms exists found = .FALSE. ref_loop: DO ref_k = 1, SIZE(tmc_params%atoms(:)) - IF (move_types%atom_lists(list_i)%atoms(atom_j) .EQ. & + IF (move_types%atom_lists(list_i)%atoms(atom_j) == & tmc_params%atoms(ref_k)%name) THEN found = .TRUE. EXIT ref_loop @@ -369,7 +369,7 @@ CONTAINS TRIM(move_types%atom_lists(list_i)%atoms(atom_j))// & ") is not contained in the system. ") ! check if not be swapped with the same atom type - IF (ANY(move_types%atom_lists(list_i)%atoms(atom_j) .EQ. & + IF (ANY(move_types%atom_lists(list_i)%atoms(atom_j) == & move_types%atom_lists(list_i)%atoms(atom_j + 1:))) THEN CALL cp_abort(__LOCATION__, & "ATOM_SWAP can not swap two atoms of same kind ("// & @@ -381,9 +381,9 @@ CONTAINS ELSE ! check if there exisit different atoms found = .FALSE. - IF (SIZE(tmc_params%atoms(:)) .GT. 1) THEN + IF (SIZE(tmc_params%atoms(:)) > 1) THEN ref_lop: DO ref_k = 2, SIZE(tmc_params%atoms(:)) - IF (tmc_params%atoms(1)%name .NE. tmc_params%atoms(ref_k)%name) THEN + IF (tmc_params%atoms(1)%name /= tmc_params%atoms(ref_k)%name) THEN found = .TRUE. EXIT ref_lop END IF @@ -443,14 +443,14 @@ CONTAINS column_size = 10 subbox_out = .FALSE. type_title = .FALSE. - CPASSERT(file_io .GT. 0) + CPASSERT(file_io > 0) CPASSERT(ASSOCIATED(tmc_params%move_types)) FLUSH (file_io) IF (.NOT. init .AND. & - tmc_params%move_types%mv_weight(mv_type_NMC_moves) .GT. 0 .AND. & - ANY(tmc_params%sub_box_size .GT. 0.0_dp)) subbox_out = .TRUE. + tmc_params%move_types%mv_weight(mv_type_NMC_moves) > 0 .AND. & + ANY(tmc_params%sub_box_size > 0.0_dp)) subbox_out = .TRUE. ! set the format for each typ to add one column WRITE (FMT_c, '("(A,1X,A", I0, ")")') column_size @@ -466,11 +466,11 @@ CONTAINS temp_loop: DO temper = 1, tmc_params%nr_temp c_tit = ""; c_a = ""; c_b = ""; c_c = "" - IF (init .AND. temper .GT. 1) EXIT temp_loop + IF (init .AND. temper > 1) EXIT temp_loop WRITE (c_t, "(F10.2)") tmc_params%Temp(temper) typ_loop: DO move = 0, SIZE(tmc_params%move_types%mv_weight) + nr_nmc_moves ! the NMC moves - IF (move .LE. SIZE(tmc_params%move_types%mv_weight)) THEN + IF (move <= SIZE(tmc_params%move_types%mv_weight)) THEN typ = move move_types => tmc_params%move_types ELSE @@ -478,7 +478,7 @@ CONTAINS move_types => tmc_params%nmc_move_types END IF ! total average - IF (typ .EQ. 0) THEN + IF (typ == 0) THEN ! line start IF (type_title) WRITE (c_tit, TRIM(FMT_c)) " type temperature |" IF (init) WRITE (c_b, TRIM(FMT_c)) " I I |" @@ -526,15 +526,15 @@ CONTAINS END IF ELSE ! certain move types - IF (move_types%mv_weight(typ) .GT. 0.0_dp) THEN + IF (move_types%mv_weight(typ) > 0.0_dp) THEN ! INIT: the weights in the initialisation output IF (init) THEN c_tmp = TRIM(c_b) WRITE (c_b, TRIM(FMT_r)) TRIM(c_tmp), move_types%mv_weight(typ) END IF ! acc probabilities - IF (typ .EQ. mv_type_swap_conf .AND. & - temper .EQ. tmc_params%nr_temp) THEN + IF (typ == mv_type_swap_conf .AND. & + temper == tmc_params%nr_temp) THEN IF (.NOT. init) THEN c_tmp = TRIM(c_a) WRITE (c_a, TRIM(FMT_c)) TRIM(c_tmp), "---" @@ -555,7 +555,7 @@ CONTAINS END IF ! sub box IF (subbox_out) THEN - IF (move .GT. SIZE(tmc_params%move_types%mv_weight)) THEN + IF (move > SIZE(tmc_params%move_types%mv_weight)) THEN c_tmp = TRIM(c_d) WRITE (c_d, TRIM(FMT_r)) TRIM(c_tmp), & move_types%subbox_acc_count(typ, temper)/ & @@ -679,7 +679,7 @@ CONTAINS END IF END DO typ_loop IF (init) WRITE (UNIT=file_io, FMT="(/,T2,A)") REPEAT("-", 79) - IF (type_title .AND. temper .LE. 1) WRITE (file_io, *) TRIM(c_tit) + IF (type_title .AND. temper <= 1) WRITE (file_io, *) TRIM(c_tit) IF (.NOT. init) WRITE (file_io, *) TRIM(c_a) WRITE (file_io, *) TRIM(c_b) WRITE (file_io, *) TRIM(c_c) @@ -780,21 +780,21 @@ CONTAINS !-- INcrease or DEcrease accaptance rate ! MOVE types - IF (change_type .GT. 0) THEN + IF (change_type > 0) THEN move_types%acc_count(mv_type, conf_moved) = move_types%acc_count(mv_type, conf_moved) + 1 END IF ! RESULTs - IF (change_res .GT. 0) THEN + IF (change_res > 0) THEN move_types%acc_count(0, conf_moved) = move_types%acc_count(0, conf_moved) + 1 END IF - IF (conf_moved .GT. 0) move_types%mv_count(0, conf_moved) = move_types%mv_count(0, conf_moved) + ABS(change_res) - IF (mv_type .GE. 0 .AND. conf_moved .GT. 0) & + 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) & move_types%mv_count(mv_type, conf_moved) = move_types%mv_count(mv_type, conf_moved) + ABS(change_type) IF (prob_opt) THEN - WHERE (move_types%mv_count .GT. 0) & + WHERE (move_types%mv_count > 0) & move_types%acc_prob(:, :) = move_types%acc_count(:, :)/REAL(move_types%mv_count(:, :), KIND=dp) END IF ! end the timing @@ -826,7 +826,7 @@ CONTAINS move_types%mv_count(:, :) = move_types%mv_count(:, :) + mv_counter(:, :) move_types%acc_count(:, :) = move_types%acc_count(:, :) + acc_counter(:, :) IF (prob_opt) THEN - WHERE (move_types%mv_count .GT. 0) & + WHERE (move_types%mv_count > 0) & move_types%acc_prob(:, :) = move_types%acc_count(:, :)/REAL(move_types%mv_count(:, :), KIND=dp) END IF END IF @@ -876,7 +876,7 @@ CONTAINS REAL(KIND=dp) :: rnd_mv, total_moves CPASSERT(ASSOCIATED(move_types)) - CPASSERT(rnd .GE. 0.0_dp .AND. rnd .LT. 1.0_dp) + CPASSERT(rnd >= 0.0_dp .AND. rnd < 1.0_dp) CALL timeset(routineN, handle) @@ -884,7 +884,7 @@ CONTAINS rnd_mv = total_moves*rnd mv_type = 0 search_loop: DO i = 2, SIZE(move_types%mv_weight(:)) - IF (SUM(move_types%mv_weight(2:i)) .GE. rnd_mv) THEN + IF (SUM(move_types%mv_weight(2:i)) >= rnd_mv) THEN mv_type = i EXIT search_loop END IF diff --git a/src/tmc/tmc_moves.F b/src/tmc/tmc_moves.F index a47b334ae4..de3ab8dffd 100644 --- a/src/tmc/tmc_moves.F +++ b/src/tmc/tmc_moves.F @@ -92,7 +92,7 @@ CONTAINS cg=elem%rng_seed(:, :, 2), ig=elem%rng_seed(:, :, 3)) IF (new_subbox) THEN - IF (ALL(tmc_params%sub_box_size .GT. 0.0_dp)) THEN + IF (ALL(tmc_params%sub_box_size > 0.0_dp)) THEN CALL elements_in_new_subbox(tmc_params=tmc_params, & rng_stream=rng_stream, elem=elem, & nr_of_sub_box_elements=nr_sub_box_elem) @@ -102,8 +102,8 @@ CONTAINS END IF ! at least one atom should be in the sub box - CPASSERT(ANY(elem%elem_stat(:) .EQ. status_ok)) - IF (tmc_params%nr_elem_mv .EQ. 0) THEN + CPASSERT(ANY(elem%elem_stat(:) == status_ok)) + IF (tmc_params%nr_elem_mv == 0) THEN ! move all elements (could be all atoms or all molecules) act_nr_elem_mv = 0 ELSE @@ -124,13 +124,13 @@ 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 .EQ. 0) & + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = SIZE(elem%pos)/tmc_params%dim_per_elem ALLOCATE (elem_center(tmc_params%dim_per_elem)) i = 1 move_elements_loop: DO ! select atom - IF (tmc_params%nr_elem_mv .EQ. 0) THEN + IF (tmc_params%nr_elem_mv == 0) THEN ind = (i - 1)*(tmc_params%dim_per_elem) + 1 ELSE rnd = rng_stream%next() @@ -138,7 +138,7 @@ CONTAINS INT(rnd*(SIZE(elem%pos)/tmc_params%dim_per_elem)) + 1 END IF ! apply move - IF (elem%elem_stat(ind) .EQ. status_ok) THEN + IF (elem%elem_stat(ind) == status_ok) THEN ! displace atom DO d = 0, tmc_params%dim_per_elem - 1 rnd = rng_stream%next() @@ -156,10 +156,10 @@ CONTAINS END IF ELSE ! element was not in sub box, search new one instead - IF (tmc_params%nr_elem_mv .GT. 0) i = i - 1 + IF (tmc_params%nr_elem_mv > 0) i = i - 1 END IF i = i + 1 - IF (i .GT. act_nr_elem_mv) EXIT move_elements_loop + IF (i > act_nr_elem_mv) EXIT move_elements_loop END DO move_elements_loop DEALLOCATE (elem_center) @@ -167,7 +167,7 @@ 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 .EQ. 0) & + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = nr_molec ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) @@ -185,12 +185,12 @@ CONTAINS mol_in_sb(m) = status_ok END DO ! displace the selected amount of molecules - IF (ANY(mol_in_sb(:) .EQ. status_ok)) THEN + IF (ANY(mol_in_sb(:) == status_ok)) THEN ALLOCATE (direction(tmc_params%dim_per_elem)) counter = 1 move_molecule_loop: DO ! select molecule - IF (tmc_params%nr_elem_mv .EQ. 0) THEN + IF (tmc_params%nr_elem_mv == 0) THEN m = counter ELSE rnd = rng_stream%next() @@ -199,11 +199,11 @@ CONTAINS CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, mol=m, & start_ind=ind, end_ind=ind_e) ! when "molecule" is single atom, search a new one - IF (ind .EQ. ind_e) CYCLE move_molecule_loop + IF (ind == ind_e) CYCLE move_molecule_loop ! calculate displacement ! move only molecules, with geom. center in subbox - IF (mol_in_sb(m) .EQ. status_ok) THEN + IF (mol_in_sb(m) == status_ok) THEN ! calculate displacement DO d = 1, tmc_params%dim_per_elem rnd = rng_stream%next() @@ -229,10 +229,10 @@ CONTAINS END IF ELSE ! element was not in sub box, search new one instead - IF (tmc_params%nr_elem_mv .GT. 0) counter = counter - 1 + IF (tmc_params%nr_elem_mv > 0) counter = counter - 1 END IF counter = counter + 1 - IF (counter .GT. act_nr_elem_mv) EXIT move_molecule_loop + IF (counter > act_nr_elem_mv) EXIT move_molecule_loop END DO move_molecule_loop DEALLOCATE (direction) END IF @@ -242,7 +242,7 @@ CONTAINS !-- molecule rotation CASE (mv_type_mol_rot) nr_molec = MAXVAL(elem%mol(:)) - IF (act_nr_elem_mv .EQ. 0) & + IF (act_nr_elem_mv == 0) & act_nr_elem_mv = nr_molec ALLOCATE (mol_in_sb(nr_molec)) ALLOCATE (elem_center(tmc_params%dim_per_elem)) @@ -260,11 +260,11 @@ CONTAINS mol_in_sb(m) = status_ok END DO ! rotate the selected amount of molecules - IF (ANY(mol_in_sb(:) .EQ. status_ok)) THEN + IF (ANY(mol_in_sb(:) == status_ok)) THEN counter = 1 rot_molecule_loop: DO ! select molecule - IF (tmc_params%nr_elem_mv .EQ. 0) THEN + IF (tmc_params%nr_elem_mv == 0) THEN m = counter ELSE rnd = rng_stream%next() @@ -273,10 +273,10 @@ CONTAINS CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, mol=m, & start_ind=ind, end_ind=ind_e) ! when "molecule" is single atom, search a new one - IF (ind .EQ. ind_e) CYCLE rot_molecule_loop + IF (ind == ind_e) CYCLE rot_molecule_loop ! apply move - IF (mol_in_sb(m) .EQ. status_ok) THEN + IF (mol_in_sb(m) == status_ok) THEN CALL do_mol_rot(pos=elem%pos, ind_start=ind, ind_end=ind_e, & max_angle=move_types%mv_size( & mv_type_mol_rot, mv_conf), & @@ -296,10 +296,10 @@ CONTAINS END DO ELSE ! element was not in sub box, search new one instead - IF (tmc_params%nr_elem_mv .GT. 0) counter = counter - 1 + IF (tmc_params%nr_elem_mv > 0) counter = counter - 1 END IF counter = counter + 1 - IF (counter .GT. act_nr_elem_mv) EXIT rot_molecule_loop + IF (counter > act_nr_elem_mv) EXIT rot_molecule_loop END DO rot_molecule_loop END IF DEALLOCATE (elem_center) @@ -311,7 +311,7 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_params%atoms)) change_all_velocities_loop: DO i = 1, SIZE(elem%pos) !-- attention, move type size is in atomic units of velocity - IF (elem%elem_stat(i) .NE. status_frozen) THEN + IF (elem%elem_stat(i) /= status_frozen) THEN CALL vel_change(vel=elem%vel(i), & atom_kind=tmc_params%atoms(INT(i/REAL(tmc_params%dim_per_elem, KIND=dp)) + 1), & phi=move_types%mv_size(mv_type_MD, 1), & ! TODO parallel tempering move sizes for vel_change @@ -374,25 +374,25 @@ CONTAINS end_ind = -1 CPASSERT(ASSOCIATED(mol_arr)) - CPASSERT(mol .LE. MAXVAL(mol_arr(:))) + CPASSERT(mol <= MAXVAL(mol_arr(:))) ! get start index loop_start: DO i = 1, SIZE(mol_arr) - IF (mol_arr(i) .EQ. mol) THEN + IF (mol_arr(i) == mol) THEN start_ind = i EXIT loop_start END IF END DO loop_start ! get end index loop_end: DO i = SIZE(mol_arr), i, -1 - IF (mol_arr(i) .EQ. mol) THEN + IF (mol_arr(i) == mol) THEN end_ind = i EXIT loop_end END IF END DO loop_end ! check if all atoms inbetween attend to molecule - CPASSERT(ALL(mol_arr(start_ind:end_ind) .EQ. mol)) - CPASSERT(start_ind .GT. 0) - CPASSERT(end_ind .GT. 0) + CPASSERT(ALL(mol_arr(start_ind:end_ind) == mol)) + CPASSERT(start_ind > 0) + CPASSERT(end_ind > 0) ! convert to indeces mapped for the position array (multiple dim per atom) start_ind = (start_ind - 1)*tmc_params%dim_per_elem + 1 end_ind = (end_ind - 1)*tmc_params%dim_per_elem + 1 @@ -424,10 +424,10 @@ CONTAINS CPASSERT(ASSOCIATED(subbox_center)) CPASSERT(ASSOCIATED(box_scale)) ! if pressure is defined, no scale should be 0 - flag = .NOT. ((tmc_params%pressure .GT. 0.0_dp) .AND. (ANY(box_scale .EQ. 0.0_dp))) + flag = .NOT. ((tmc_params%pressure > 0.0_dp) .AND. (ANY(box_scale == 0.0_dp))) CPASSERT(flag) - CPASSERT(SIZE(pos) .EQ. 3) - CPASSERT(SIZE(pos) .EQ. SIZE(subbox_center)) + CPASSERT(SIZE(pos) == 3) + CPASSERT(SIZE(pos) == SIZE(subbox_center)) ! start the timing CALL timeset(routineN, handle) @@ -436,13 +436,13 @@ CONTAINS inside = .TRUE. ! return if no subbox is defined - IF (.NOT. ANY(tmc_params%sub_box_size(:) .LE. 0.1_dp)) THEN + IF (.NOT. ANY(tmc_params%sub_box_size(:) <= 0.1_dp)) THEN pos_tmp(:) = pos(:) - subbox_center(:) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=box_scale, & vec=pos_tmp) ! check - IF (ANY(pos_tmp(:) .GE. tmc_params%sub_box_size(:)/2.0) .OR. & - ANY(pos_tmp(:) .LE. -tmc_params%sub_box_size(:)/2.0)) THEN + IF (ANY(pos_tmp(:) >= tmc_params%sub_box_size(:)/2.0) .OR. & + ANY(pos_tmp(:) <= -tmc_params%sub_box_size(:)/2.0)) THEN inside = .FALSE. END IF END IF @@ -483,7 +483,7 @@ CONTAINS ! start the timing CALL timeset(routineN, handle) - IF (ANY(tmc_params%sub_box_size(:) .LE. 0.1_dp)) THEN + IF (ANY(tmc_params%sub_box_size(:) <= 0.1_dp)) THEN !CPWARN("try to count elements in sub box without sub box.") elem%elem_stat = status_ok nr_of_sub_box_elements = SIZE(elem%elem_stat) @@ -552,9 +552,9 @@ CONTAINS NULLIFY (elem_center) CPASSERT(ASSOCIATED(pos)) - CPASSERT(dim_per_elem .EQ. 3) - CPASSERT(ind_start .GT. 0 .AND. ind_start .LT. SIZE(pos)) - CPASSERT(ind_end .GT. 0 .AND. ind_end .LT. SIZE(pos)) + CPASSERT(dim_per_elem == 3) + CPASSERT(ind_start > 0 .AND. ind_start < SIZE(pos)) + CPASSERT(ind_end > 0 .AND. ind_end < SIZE(pos)) CPASSERT(ASSOCIATED(move_types)) MARK_USED(move_types) @@ -628,7 +628,7 @@ CONTAINS ! without still the balance condition should be fulfilled rnd3 = rng_stream%next() - IF (rnd3 .GE. 0.5 .AND. rnd_sign_change) THEN + IF (rnd3 >= 0.5 .AND. rnd_sign_change) THEN d = -1 ELSE d = 1 @@ -680,7 +680,7 @@ CONTAINS mol_arr(:) = -1 donor_acceptor = not_selected ! select randomly if neighboring molecule is donor / acceptor - IF (rng_stream%next() .LT. 0.5_dp) THEN + IF (rng_stream%next() < 0.5_dp) THEN donor_acceptor = proton_acceptor ELSE donor_acceptor = proton_donor @@ -703,7 +703,7 @@ 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(:) .EQ. mol)) & + IF (ANY(mol_arr(:) == mol)) & EXIT chain_completition_loop mol_arr(counter) = mol END DO chain_completition_loop @@ -711,14 +711,14 @@ CONTAINS ! just take the loop of molecules out of the chain DO k = 1, counter - IF (mol_arr(k) .EQ. mol) & + IF (mol_arr(k) == mol) & EXIT END DO mol_arr(1:counter - k + 1) = mol_arr(k:counter) counter = counter - k + 1 ! check if loop is minimum size of 6 molecules - IF (counter .LT. 6) THEN + IF (counter < 6) THEN CALL cp_warn(__LOCATION__, & "short proton loop with"//cp_to_string(counter)// & "molecules.") @@ -790,21 +790,21 @@ CONTAINS ! calculate distances to all molecules list_distances: DO mol_tmp = 1, nr_mol - IF (mol_tmp .EQ. mol) CYCLE list_distances + IF (mol_tmp == mol) CYCLE list_distances ! index of the molecule (the O atom) ! assume the first atom of the molecule the first atom CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, & mol=mol_tmp, start_ind=ind_n, end_ind=ind_e) ! check if selected molecule is water respectively consists of 3 atoms - IF (MOD(ind_e - ind_n, 3) .GT. 0) THEN + IF (MOD(ind_e - ind_n, 3) > 0) THEN CALL cp_warn(__LOCATION__, & "selected a molecule with more than 3 atoms, "// & "the proton reordering does not support, skip molecule") CYCLE list_distances END IF - IF (donor_acceptor .EQ. proton_acceptor) THEN + IF (donor_acceptor == proton_acceptor) THEN IF (check_donor_acceptor(elem=elem, i_orig=ind, i_neighbor=ind_n, & - tmc_params=tmc_params) .EQ. proton_acceptor) THEN + tmc_params=tmc_params) == proton_acceptor) THEN !distance of fist proton to certain O distH1(mol_tmp) = nearest_distance( & x1=elem%pos(ind + tmc_params%dim_per_elem: & @@ -820,9 +820,9 @@ CONTAINS END IF END IF !check for neighboring proton donors - IF (donor_acceptor .EQ. proton_donor) THEN + IF (donor_acceptor == proton_donor) THEN IF (check_donor_acceptor(elem=elem, i_orig=ind, i_neighbor=ind_n, & - tmc_params=tmc_params) .EQ. proton_donor) THEN + tmc_params=tmc_params) == proton_donor) THEN !distance of selected O to all first protons of other melecules distO(mol_tmp) = nearest_distance( & x1=elem%pos(ind:ind + tmc_params%dim_per_elem - 1), & @@ -834,7 +834,7 @@ CONTAINS x2=elem%pos(ind_n + 2*tmc_params%dim_per_elem: & ind_n + 3*tmc_params%dim_per_elem - 1), & cell=tmc_params%cell, box_scale=elem%box_scale) - IF (dist_tmp .LT. distO(mol_tmp)) distO(mol_tmp) = dist_tmp + IF (dist_tmp < distO(mol_tmp)) distO(mol_tmp) = dist_tmp END IF END IF END DO list_distances @@ -842,14 +842,14 @@ CONTAINS mol_tmp = 1 ! select the nearest neighbors !check for neighboring proton acceptors - IF (donor_acceptor .EQ. proton_acceptor) THEN + IF (donor_acceptor == proton_acceptor) THEN neighbor_mol(mol_tmp) = MINLOC(distH1(:), 1) neighbor_mol(mol_tmp + 1) = MINLOC(distH2(:), 1) ! if both smallest distances points to the shortest molecule search also the second next shortest distance - IF (neighbor_mol(mol_tmp) .EQ. neighbor_mol(mol_tmp + 1)) THEN + IF (neighbor_mol(mol_tmp) == neighbor_mol(mol_tmp + 1)) THEN distH1(neighbor_mol(mol_tmp)) = HUGE(distH1(1)) distH2(neighbor_mol(mol_tmp + 1)) = HUGE(distH2(1)) - IF (MINVAL(distH1(:), 1) .LT. MINVAL(distH2(:), 1)) THEN + IF (MINVAL(distH1(:), 1) < MINVAL(distH2(:), 1)) THEN neighbor_mol(mol_tmp) = MINLOC(distH1(:), 1) ELSE neighbor_mol(mol_tmp + 1) = MINLOC(distH2(:), 1) @@ -859,7 +859,7 @@ CONTAINS END IF !check for neighboring proton donors - IF (donor_acceptor .EQ. proton_donor) THEN + IF (donor_acceptor == proton_donor) THEN neighbor_mol(mol_tmp) = MINLOC(distO(:), 1) distO(neighbor_mol(mol_tmp)) = HUGE(distO(1)) neighbor_mol(mol_tmp + 1) = MINLOC(distO(:), 1) @@ -899,8 +899,8 @@ CONTAINS REAL(KIND=dp), DIMENSION(4) :: distances CPASSERT(ASSOCIATED(elem)) - CPASSERT(i_orig .GE. 1 .AND. i_orig .LE. SIZE(elem%pos)) - CPASSERT(i_neighbor .GE. 1 .AND. i_neighbor .LE. SIZE(elem%pos)) + CPASSERT(i_orig >= 1 .AND. i_orig <= SIZE(elem%pos)) + CPASSERT(i_neighbor >= 1 .AND. i_neighbor <= SIZE(elem%pos)) CPASSERT(ASSOCIATED(tmc_params)) ! 1. proton of orig with neighbor O @@ -928,7 +928,7 @@ CONTAINS i_neighbor + 3*tmc_params%dim_per_elem - 1), & cell=tmc_params%cell, box_scale=elem%box_scale) - IF (MINLOC(distances(:), 1) .LE. 2) THEN + IF (MINLOC(distances(:), 1) <= 2) THEN donor_acceptor = proton_acceptor ELSE donor_acceptor = proton_donor @@ -1000,7 +1000,7 @@ CONTAINS x2=elem%pos(ind_arr(i) + tmc_params%dim_per_elem: & ind_arr(i) + 2*tmc_params%dim_per_elem - 1), & cell=tmc_params%cell, box_scale=elem%box_scale) & - .LT. & + < & nearest_distance( & x1=elem%pos(ind_arr(i + donor_acceptor): & ind_arr(i + donor_acceptor) + tmc_params%dim_per_elem - 1), & @@ -1048,11 +1048,11 @@ CONTAINS dist_near = HUGE(dist_near) search_O_loop: DO ind = 1, SIZE(elem%pos), & tmc_params%dim_per_elem*3 - IF (ind .EQ. ind_arr(i)) CYCLE search_O_loop + IF (ind == ind_arr(i)) CYCLE search_O_loop tmp = nearest_distance(x1=vec_2H_f, & x2=elem%pos(ind:ind + tmc_params%dim_per_elem - 1), & cell=tmc_params%cell, box_scale=elem%box_scale) - IF (dist_near .GT. tmp) THEN + IF (dist_near > tmp) THEN dist_near = tmp vec_4O = elem%pos(ind:ind + tmc_params%dim_per_elem - 1) END IF @@ -1067,7 +1067,7 @@ CONTAINS ind_arr(i) + (H_offset + 1)*tmc_params%dim_per_elem - 1) & = vec_2O + vec_rotated vec_rotated = rotate_vector(vec_2H_f - vec_2O, dihe_angle, rot_axis) - IF (H_offset .EQ. 1) THEN + IF (H_offset == 1) THEN H_offset = 2 ELSE H_offset = 1 @@ -1119,8 +1119,8 @@ CONTAINS CPASSERT(ASSOCIATED(conf)) CPASSERT(ASSOCIATED(move_types)) CPASSERT(ASSOCIATED(tmc_params)) - CPASSERT(T_ind .GT. 0 .AND. T_ind .LE. tmc_params%nr_temp) - CPASSERT(tmc_params%dim_per_elem .EQ. 3) + CPASSERT(T_ind > 0 .AND. T_ind <= tmc_params%nr_temp) + CPASSERT(tmc_params%dim_per_elem == 3) CPASSERT(tmc_params%cell%orthorhombic) ! start the timing @@ -1251,13 +1251,13 @@ CONTAINS a_2 = INT(SIZE(conf%pos)/REAL(tmc_params%dim_per_elem, KIND=dp)* & rng_stream%next()) + 1 ! check if they have different kinds - IF (tmc_params%atoms(a_1)%name .NE. tmc_params%atoms(a_2)%name) THEN + IF (tmc_params%atoms(a_1)%name /= tmc_params%atoms(a_2)%name) THEN ! if present, check if atoms have different type related to the specified table IF (ASSOCIATED(move_types%atom_lists)) THEN DO ind_1 = 1, SIZE(move_types%atom_lists) - IF (ANY(move_types%atom_lists(ind_1)%atoms(:) .EQ. & + IF (ANY(move_types%atom_lists(ind_1)%atoms(:) == & tmc_params%atoms(a_1)%name) .AND. & - ANY(move_types%atom_lists(ind_1)%atoms(:) .EQ. & + ANY(move_types%atom_lists(ind_1)%atoms(:) == & tmc_params%atoms(a_2)%name)) THEN found = .TRUE. EXIT atom_search_loop diff --git a/src/tmc/tmc_setup.F b/src/tmc/tmc_setup.F index 4a74bce6c2..019e3a5b6b 100644 --- a/src/tmc/tmc_setup.F +++ b/src/tmc/tmc_setup.F @@ -128,7 +128,7 @@ CONTAINS END IF ! ugly, we need to know the output unit on source, everywhere, in particular ! the tmc master - IF (output_unit .NE. default_output_unit .AND. output_unit .GT. 0) THEN + IF (output_unit /= default_output_unit .AND. output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(/,T2,A)") REPEAT("-", 79) WRITE (UNIT=output_unit, FMT="(/,T2,A)") "The TMC output files are:" WRITE (UNIT=output_unit, FMT="(/,T2,A)") & @@ -151,9 +151,9 @@ CONTAINS IF (success) THEN ! initialize master and worker environment - IF (tmc_env%tmc_comp_set%group_nr .EQ. 0) THEN + IF (tmc_env%tmc_comp_set%group_nr == 0) THEN CALL tmc_master_env_create(tmc_env) ! create master env - ELSE IF (tmc_env%tmc_comp_set%group_nr .NE. 0) THEN + ELSE IF (tmc_env%tmc_comp_set%group_nr /= 0) THEN CALL tmc_worker_env_create(tmc_env) ! create worker env END IF @@ -162,8 +162,8 @@ CONTAINS ! init random number generator: use determistic random numbers init_rng = .TRUE. - IF (tmc_env%tmc_comp_set%group_nr .EQ. 0) THEN - IF (tmc_env%m_env%rnd_init .GT. 0) THEN + IF (tmc_env%tmc_comp_set%group_nr == 0) THEN + IF (tmc_env%m_env%rnd_init > 0) THEN init_rng = .FALSE. ALLOCATE (init_rng_seed(3, 2)) init_rng_seed(:, :) = & @@ -189,7 +189,7 @@ CONTAINS ! start running master and worker routines ! the master - IF (tmc_env%tmc_comp_set%group_nr .EQ. 0) THEN + IF (tmc_env%tmc_comp_set%group_nr == 0) THEN !TODO get the correct usage of creating and handling the logger... CALL cp_logger_create(logger_sub, para_env=tmc_env%tmc_comp_set%para_env_m_only, & default_global_unit_nr=default_output_unit, close_global_unit_on_dealloc=.FALSE.) @@ -213,7 +213,7 @@ CONTAINS tmc_params=tmc_env%params) CALL do_tmc_master(tmc_env=tmc_env, globenv=globenv) ! start the master routine - IF (bcast_output_unit .NE. tmc_env%m_env%io_unit) THEN + IF (bcast_output_unit /= tmc_env%m_env%io_unit) THEN CALL close_file(unit_number=tmc_env%m_env%io_unit) END IF @@ -221,7 +221,7 @@ CONTAINS CALL cp_logger_release(logger_sub) ! the worker groups - ELSE IF (tmc_env%tmc_comp_set%group_nr .GT. 0) THEN + ELSE IF (tmc_env%tmc_comp_set%group_nr > 0) THEN NULLIFY (logger_sub) ! create separate logger and error handler for each worker CALL cp_logger_create(logger_sub, para_env=tmc_env%tmc_comp_set%para_env_sub_group, & @@ -231,7 +231,7 @@ CONTAINS tmc_env%w_env%io_unit = default_output_unit ! energy worker - IF (tmc_env%tmc_comp_set%group_nr .LE. tmc_env%tmc_comp_set%group_ener_nr) THEN + IF (tmc_env%tmc_comp_set%group_nr <= tmc_env%tmc_comp_set%group_ener_nr) THEN CALL create_force_env(new_env_id=tmc_env%w_env%env_id_ener, & input_declaration=input_declaration, & input_path=tmc_env%params%energy_inp_file, & @@ -239,13 +239,13 @@ 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 .NE. 0) & + IF (ierr /= 0) & CPABORT("creating force env result in error "//cp_to_string(ierr)) END IF ! worker for configurational change - IF (tmc_env%params%NMC_inp_file .NE. "" .AND. & - (tmc_env%tmc_comp_set%group_cc_nr .EQ. 0 .OR. & - tmc_env%tmc_comp_set%group_nr .GT. tmc_env%tmc_comp_set%group_ener_nr)) THEN + IF (tmc_env%params%NMC_inp_file /= "" .AND. & + (tmc_env%tmc_comp_set%group_cc_nr == 0 .OR. & + tmc_env%tmc_comp_set%group_nr > tmc_env%tmc_comp_set%group_ener_nr)) THEN CALL create_force_env(new_env_id=tmc_env%w_env%env_id_approx, & input_declaration=input_declaration, & input_path=tmc_env%params%NMC_inp_file, & @@ -253,14 +253,14 @@ 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 .NE. 0) & + IF (ierr /= 0) & CPABORT("creating approx force env result in error "//cp_to_string(ierr)) END IF CALL do_tmc_worker(tmc_env=tmc_env) ! start the worker routine - IF (tmc_env%w_env%env_id_ener .GT. 0) & + IF (tmc_env%w_env%env_id_ener > 0) & CALL destroy_force_env(tmc_env%w_env%env_id_ener, ierr) - IF (tmc_env%w_env%env_id_approx .GT. 0) & + IF (tmc_env%w_env%env_id_approx > 0) & CALL destroy_force_env(tmc_env%w_env%env_id_approx, ierr) CALL cp_rm_default_logger() @@ -301,7 +301,7 @@ CONTAINS CALL tmc_ana_env_release(tmc_ana_env_list(i)%temp) END DO DEALLOCATE (tmc_ana_env_list) - IF (bcast_output_unit .NE. output_unit) THEN + IF (bcast_output_unit /= output_unit) THEN CALL close_file(unit_number=tmc_env%m_env%io_unit) END IF CALL cp_rm_default_logger() @@ -316,9 +316,9 @@ CONTAINS CALL finalize_mv_types(tmc_env%params) ! finalize master and worker environment - IF (tmc_env%tmc_comp_set%group_nr .EQ. 0) THEN + IF (tmc_env%tmc_comp_set%group_nr == 0) THEN CALL tmc_master_env_release(tmc_env) ! release master env - ELSE IF (tmc_env%tmc_comp_set%group_nr .NE. 0) THEN + ELSE IF (tmc_env%tmc_comp_set%group_nr /= 0) THEN CALL tmc_worker_env_release(tmc_env) ! release worker env END IF ! unused worker groups have nothing to do @@ -368,15 +368,15 @@ CONTAINS ! -- spiltting communicator ALLOCATE (tmc_env%tmc_comp_set%para_env_m_ana) CALL tmc_env%tmc_comp_set%para_env_m_ana%from_split(para_env, para_env%mepos, 0) - IF (para_env%num_pe .NE. 1) THEN + IF (para_env%num_pe /= 1) THEN CPWARN("just one out of "//cp_to_string(para_env%num_pe)//"cores is used ") END IF ! distribute work to availuble cores - IF (para_env%mepos .EQ. 0) THEN + IF (para_env%mepos == 0) THEN !TODO get the correct usage of creating and handling the logger... logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) - CPASSERT(output_unit .GT. 0) + CPASSERT(output_unit > 0) ! write the header CALL tmc_ana_header(output_unit) @@ -387,7 +387,7 @@ CONTAINS nr_dim = SIZE(elem%pos) ! we need a new tree element with all neccessay arrays, (e.g. dipoles could not be allocated already) CALL deallocate_sub_tree_node(tree_elem=elem) - CPASSERT(SIZE(ana_list) .GT. 0) + CPASSERT(SIZE(ana_list) > 0) ! print initial test output (for single core tests, where no data is produced) IF (tmc_env%params%print_test_output) THEN @@ -400,7 +400,7 @@ CONTAINS ana_list(temp)%temp%io_unit = output_unit 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 .NE. & + IF (ana_list(temp)%temp%costum_dip_file_name /= & tmc_default_unspecified_name) & tmc_env%params%print_dipole = .TRUE. @@ -423,7 +423,7 @@ CONTAINS tmc_params=tmc_env%params) ! remove the last saved element to start with a new file ! there is no weight for this element - IF (dir_ind .LT. SIZE(ana_list(temp)%temp%dirs) .AND. & + IF (dir_ind < SIZE(ana_list(temp)%temp%dirs) .AND. & ASSOCIATED(ana_list(temp)%temp%last_elem)) & CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) IF (ASSOCIATED(ana_list(temp)%temp%last_elem)) & @@ -499,9 +499,9 @@ CONTAINS CALL section_vals_val_get(tmc_section, "NR_TEMPERATURE", i_val=nr_temp) CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF ((nr_temp .GT. 1) .AND. (SIZE(inp_Temp) .NE. 2)) & + IF ((nr_temp > 1) .AND. (SIZE(inp_Temp) /= 2)) & CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") - IF (nr_temp .EQ. 1) THEN + IF (nr_temp == 1) THEN nr_temp = SIZE(inp_Temp) ALLOCATE (Temps(nr_temp)) Temps(:) = inp_Temp(:) @@ -513,7 +513,7 @@ 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 .LT. 0.0_dp)) & + 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 @@ -596,9 +596,9 @@ 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 .GT. 0) & + IF (tmc_env%tmc_comp_set%ana_on_the_fly > 0) & tmc_env%tmc_comp_set%ana_on_the_fly = itmp - IF (tmc_env%tmc_comp_set%ana_on_the_fly .GT. 1) & + 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 "// & @@ -610,12 +610,12 @@ CONTAINS ! stuff everyone needs to know CALL section_vals_val_get(tmc_section, "NMC_MOVES%NMC_FILE_NAME", c_val=tmc_env%params%NMC_inp_file) - IF (tmc_env%params%NMC_inp_file .EQ. tmc_default_unspecified_name) THEN + IF (tmc_env%params%NMC_inp_file == tmc_default_unspecified_name) THEN ! file name keyword without file name CPABORT("no or a valid NMC input file has to be specified ") - ELSE IF (tmc_env%params%NMC_inp_file .EQ. "") THEN + ELSE IF (tmc_env%params%NMC_inp_file == "") THEN ! no keyword - IF (tmc_env%tmc_comp_set%group_cc_size .GT. 0) & + 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.") @@ -623,14 +623,14 @@ CONTAINS ELSE ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%NMC_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp .NE. 0) & + IF (.NOT. flag .OR. itmp /= 0) & CPABORT("a valid NMC input file has to be specified") END IF CALL section_vals_val_get(tmc_section, "TEMPERATURE", r_vals=inp_Temp) - IF (tmc_env%params%nr_temp .GT. 1 .AND. SIZE(inp_Temp) .NE. 2) & + IF (tmc_env%params%nr_temp > 1 .AND. SIZE(inp_Temp) /= 2) & CPABORT("specify each temperature, skip keyword NR_TEMPERATURE") - IF (tmc_env%params%nr_temp .EQ. 1) THEN + 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)) tmc_env%params%Temp(:) = inp_Temp(:) @@ -642,7 +642,7 @@ 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 .LT. 0.0_dp)) & + 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 @@ -700,18 +700,18 @@ CONTAINS CALL section_vals_val_get(tmc_section, "RND_DETERMINISTIC", i_val=tmc_env%m_env%rnd_init) ! restarting CALL section_vals_val_get(tmc_section, "RESTART_IN", c_val=tmc_env%m_env%restart_in_file_name) - IF (tmc_env%m_env%restart_in_file_name .EQ. tmc_default_unspecified_name) THEN + IF (tmc_env%m_env%restart_in_file_name == tmc_default_unspecified_name) THEN tmc_env%m_env%restart_in_file_name = tmc_default_restart_in_file_name INQUIRE (FILE=tmc_env%m_env%restart_in_file_name, EXIST=flag) IF (.NOT. flag) tmc_env%m_env%restart_in_file_name = "" END IF CALL section_vals_val_get(tmc_section, "RESTART_OUT", i_val=tmc_env%m_env%restart_out_step) ! restart just at the end (lone keyword) - IF (tmc_env%m_env%restart_out_step .EQ. -9) THEN + IF (tmc_env%m_env%restart_out_step == -9) THEN 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 .LT. 0) & + 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 #). "// & @@ -722,10 +722,10 @@ CONTAINS 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) CALL section_vals_val_get(tmc_section, "ALL_CONF_FILE_NAME", c_val=tmc_env%params%all_conf_file_name) - IF (tmc_env%params%dot_file_name .NE. "") tmc_env%params%DRAW_TREE = .TRUE. + IF (tmc_env%params%dot_file_name /= "") tmc_env%params%DRAW_TREE = .TRUE. ! everything for the worker group - ELSE IF (tmc_env%tmc_comp_set%group_nr .NE. 0) THEN + ELSE IF (tmc_env%tmc_comp_set%group_nr /= 0) THEN CPASSERT(ASSOCIATED(tmc_env%w_env)) END IF @@ -734,11 +734,11 @@ 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 .EQ. "") & + IF (tmc_env%params%energy_inp_file == "") & CPABORT("a valid exact energy input file has to be specified ") ! check file existence INQUIRE (FILE=TRIM(tmc_env%params%energy_inp_file), EXIST=flag, IOSTAT=itmp) - IF (.NOT. flag .OR. itmp .NE. 0) & + 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.") @@ -750,15 +750,15 @@ CONTAINS CALL section_vals_val_get(tmc_section, "MOVE_CENTER_OF_MASS", l_val=tmc_env%params%mv_cen_of_mass) CALL section_vals_val_get(tmc_section, "SUB_BOX", r_vals=r_arr_tmp) - IF (SIZE(r_arr_tmp) .GT. 1) THEN - IF (SIZE(r_arr_tmp) .NE. tmc_env%params%dim_per_elem) & + IF (SIZE(r_arr_tmp) > 1) 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.") - IF (ANY(r_arr_tmp .LE. 0.0_dp)) & + IF (ANY(r_arr_tmp <= 0.0_dp)) & CPABORT("The entered sub box lengths should be greater than 0.") DO itmp = 1, SIZE(tmc_env%params%sub_box_size) tmc_env%params%sub_box_size(itmp) = r_arr_tmp(itmp)/au2a END DO - ELSE IF (r_arr_tmp(1) .GT. 0.0_dp) THEN + ELSE IF (r_arr_tmp(1) > 0.0_dp) THEN r_tmp = r_arr_tmp(1)/au2a tmc_env%params%sub_box_size(:) = r_tmp END IF @@ -826,18 +826,18 @@ CONTAINS flag = .FALSE. success = .TRUE. - IF (para_env%num_pe .LE. 1) THEN + IF (para_env%num_pe <= 1) THEN CPWARN("TMC need at least 2 cores (one for master, one for worker)") success = .FALSE. ELSE ! check if there are enougth cores available - IF (tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr .GT. (para_env%num_pe - 1)) THEN + IF (tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr > (para_env%num_pe - 1)) THEN CPWARN("The selected energy group size is too huge. ") END IF IF (flag) THEN tmc_comp_set%group_ener_nr = INT((para_env%num_pe - 1)/ & REAL(tmc_comp_set%group_ener_size, KIND=dp)) - IF (tmc_comp_set%group_ener_nr .LT. 1) THEN + IF (tmc_comp_set%group_ener_nr < 1) THEN CPWARN("The selected energy group size is too huge. ") END IF IF (flag) success = .FALSE. @@ -845,12 +845,12 @@ CONTAINS ! set the amount of configurational change worker groups tmc_comp_set%group_cc_nr = 0 - IF (tmc_comp_set%group_cc_size .GT. 0) THEN + IF (tmc_comp_set%group_cc_size > 0) THEN tmc_comp_set%group_cc_nr = INT((para_env%num_pe - 1 - tmc_comp_set%ana_on_the_fly & - 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 .LT. 1) & + IF (tmc_comp_set%group_cc_nr < 1) & CALL cp_warn(__LOCATION__, & "There are not enougth cores left for creating groups for configurational change.") IF (flag) success = .FALSE. @@ -859,7 +859,7 @@ CONTAINS total_used = tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr + & tmc_comp_set%group_cc_size*tmc_comp_set%group_cc_nr + & tmc_comp_set%ana_on_the_fly - IF (para_env%num_pe - 1 .GT. total_used) THEN + IF (para_env%num_pe - 1 > total_used) THEN CPWARN(" mpi ranks are unused, but can be used for analysis.") END IF @@ -875,13 +875,13 @@ CONTAINS master_ana_rank = 0 ELSE ! energy calculation groups - IF (para_env%mepos .LT. tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr) THEN + IF (para_env%mepos < tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr) THEN tmc_comp_set%group_nr = INT(para_env%mepos/tmc_comp_set%group_ener_size) + 1 ! assign to groups ! master of worker group - IF (MODULO(para_env%mepos, tmc_comp_set%group_ener_size) .EQ. 0) THEN ! tmc_comp_set%group_nr masters + IF (MODULO(para_env%mepos, tmc_comp_set%group_ener_size) == 0) THEN ! tmc_comp_set%group_nr masters master_worker_group = para_env%num_pe + 3 ! belong to master_worker_comm master_worker_rank = tmc_comp_set%group_nr ! rank in m_w_comm - IF (master_worker_rank .EQ. 1) THEN + IF (master_worker_rank == 1) THEN master_first_e_worker_g = para_env%num_pe + 3 ! belong to master_first_energy_worker_comm master_first_e_worker_r = 1 END IF @@ -891,13 +891,13 @@ CONTAINS (tmc_comp_set%group_nr - 1)*tmc_comp_set%group_ener_size ! rank in worker group ! configurational change groups - ELSE IF (para_env%mepos .LT. (tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr + & - tmc_comp_set%group_cc_size*tmc_comp_set%group_cc_nr)) THEN + ELSE IF (para_env%mepos < (tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr + & + tmc_comp_set%group_cc_size*tmc_comp_set%group_cc_nr)) THEN cc_group_rank = para_env%mepos - tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr ! temporary tmc_comp_set%group_nr = tmc_comp_set%group_ener_nr + 1 + INT(cc_group_rank/tmc_comp_set%group_cc_size) cc_group = tmc_comp_set%group_nr ! master of worker group - IF (MODULO(cc_group_rank, tmc_comp_set%group_cc_size) .EQ. 0) THEN ! tmc_comp_set%group_nr masters + IF (MODULO(cc_group_rank, tmc_comp_set%group_cc_size) == 0) THEN ! tmc_comp_set%group_nr masters master_worker_group = para_env%num_pe + 3 ! belong to master_worker_comm master_worker_rank = tmc_comp_set%group_nr ! rank in m_w_comm END IF @@ -906,10 +906,10 @@ CONTAINS ELSE ! not used cores ! up to now we use just one core for doing the analysis - IF (para_env%mepos .EQ. para_env%num_pe - 2) THEN + IF (para_env%mepos == para_env%num_pe - 2) THEN tmc_comp_set%group_nr = para_env%mepos - (para_env%num_pe - 1) ! negative - CPASSERT(tmc_comp_set%group_nr .LT. 0) - IF (para_env%mepos .GE. para_env%num_pe - 1 - ana_on_the_fly) THEN + CPASSERT(tmc_comp_set%group_nr < 0) + IF (para_env%mepos >= para_env%num_pe - 1 - ana_on_the_fly) THEN master_ana_group = para_env%num_pe + 4 master_ana_rank = -tmc_comp_set%group_nr END IF @@ -1013,7 +1013,7 @@ CONTAINS 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) - IF (SIZE(tmc_env%params%Temp(:)) .LE. 7) THEN + IF (SIZE(tmc_env%params%Temp(:)) <= 7) THEN WRITE (fmt_tmp, *) '(T2,A,"| ",A,T25,A56)' c_tmp = "" WRITE (c_tmp, FMT="(1000F8.2)") tmc_env%params%Temp(:) @@ -1026,16 +1026,16 @@ 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 .NE. "") & + 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) - IF (ANY(tmc_env%params%sub_box_size .GT. 0.0_dp)) THEN + 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 .GT. 0.0_dp) & + 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) WRITE (file_nr, FMT=fmt_my) plabel, "Numbers of atoms/molecules moved " diff --git a/src/tmc/tmc_tree_acceptance.F b/src/tmc/tmc_tree_acceptance.F index ed6e2f757e..78fdb7b83d 100644 --- a/src/tmc/tmc_tree_acceptance.F +++ b/src/tmc/tmc_tree_acceptance.F @@ -95,15 +95,15 @@ CONTAINS CPASSERT(ASSOCIATED(tree_element)) CPASSERT(ASSOCIATED(parent_element)) CPASSERT(ASSOCIATED(tmc_params)) - CPASSERT(temperature .GT. 0.0_dp) - CPASSERT(rnd_nr .GE. 0.0_dp .AND. rnd_nr .LE. 1.0_dp) + CPASSERT(temperature > 0.0_dp) + CPASSERT(rnd_nr >= 0.0_dp .AND. rnd_nr <= 1.0_dp) kB = boltzmann/joule ! start the timing CALL timeset(routineN, handle) - IF (tmc_params%task_type .EQ. task_type_gaussian_adaptation) THEN + IF (tmc_params%task_type == task_type_gaussian_adaptation) THEN CPABORT("") !TODO CALL acc_check_gauss_adapt(f=tree_element%potential, ct=tree_element%ekin_before_md, acc=accept) !DO NOT DO RETURN @@ -112,9 +112,9 @@ CONTAINS !-- using 2 different potentials, the energy difference between these potentials ! and the two configurations have to be regarded. ! The ensamble should be in equilibrium state of the approximate potential - IF (diff_pot_check .AND. (tmc_params%NMC_inp_file .NE. "")) THEN - IF ((tree_element%potential .EQ. HUGE(tree_element%potential)) .OR. & - tree_element%e_pot_approx .EQ. HUGE(tree_element%e_pot_approx)) THEN + IF (diff_pot_check .AND. (tmc_params%NMC_inp_file /= "")) THEN + IF ((tree_element%potential == HUGE(tree_element%potential)) .OR. & + tree_element%e_pot_approx == HUGE(tree_element%e_pot_approx)) THEN elem_ener = HUGE(elem_ener) ELSE !for different potentials we have to regard the differences in energy @@ -128,11 +128,11 @@ CONTAINS *parent_element%e_pot_approx !-- always accepted if new energy is smaller than old energy - IF (elem_ener .LE. parent_ener) THEN + IF (elem_ener <= parent_ener) THEN accept = .TRUE. ELSE !-- gaussian distributed acceptance if new energy is greater than old energy - IF (rnd_nr .LT. & + IF (rnd_nr < & EXP(-(elem_ener - parent_ener))) THEN accept = .TRUE. ELSE @@ -141,7 +141,7 @@ CONTAINS END IF ELSE !-- standard MC check, but also using the kinetic energy for Hybrid Monte Carlo - IF (tree_element%move_type .EQ. mv_type_MD) THEN + IF (tree_element%move_type == mv_type_MD) THEN ekin_last_acc = tree_element%ekin_before_md ! using the kinetic energy before velocity change ELSE @@ -161,11 +161,11 @@ CONTAINS END IF !-- always accepted if new energy is smaller than old energy - IF (elem_ener .LE. parent_ener) THEN + IF (elem_ener <= parent_ener) THEN accept = .TRUE. ELSE !-- gaussian distributed acceptance if new energy is greater than old energy - IF (rnd_nr .LT. & + IF (rnd_nr < & EXP(-1.0_dp/(kB*temperature)*(elem_ener - parent_ener))) THEN accept = .TRUE. ELSE @@ -217,7 +217,7 @@ CONTAINS kB = boltzmann/joule CPASSERT(ASSOCIATED(tree_elem)) - CPASSERT(tree_elem%rnd_nr .GE. 0.0_dp) + CPASSERT(tree_elem%rnd_nr >= 0.0_dp) CPASSERT(ASSOCIATED(conf1)) CPASSERT(ASSOCIATED(conf2)) CPASSERT(ASSOCIATED(tmc_params)) @@ -225,7 +225,7 @@ CONTAINS ! start the timing CALL timeset(routineN, handle) - IF (tmc_params%pressure .GT. 0.0_dp) THEN + IF (tmc_params%pressure > 0.0_dp) THEN ! pt-NVT elem1_ener = conf1%potential & + conf1%ekin @@ -233,9 +233,9 @@ CONTAINS + conf2%ekin ! the swap is done with prob: exp((\beta_i-\beta_j)(U_i-U_j)), ! BUT because they are already swaped we exchange the energies. - IF (tree_elem%rnd_nr .LT. EXP((1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf)) - & - 1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf + 1))) & - *(elem2_ener - elem1_ener))) THEN + IF (tree_elem%rnd_nr < EXP((1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf)) - & + 1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf + 1))) & + *(elem2_ener - elem1_ener))) THEN accept = .TRUE. ELSE accept = .FALSE. @@ -253,7 +253,7 @@ CONTAINS (1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf))*tmc_params%pressure & - 1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf + 1))*tmc_params%pressure)* & (vol2 - vol1) - IF (tree_elem%rnd_nr .LT. EXP(delta)) THEN + IF (tree_elem%rnd_nr < EXP(delta)) THEN accept = .TRUE. ELSE accept = .FALSE. @@ -292,10 +292,10 @@ CONTAINS CPASSERT(ASSOCIATED(parent_elem)) CPASSERT(ASSOCIATED(new_elem)) - CPASSERT(temperature .GT. 0.0_dp) - CPASSERT(rnd_nr .GT. 0.0_dp) + CPASSERT(temperature > 0.0_dp) + CPASSERT(rnd_nr > 0.0_dp) CPASSERT(ASSOCIATED(tmc_params)) - CPASSERT(tmc_params%pressure .GE. 0.0_dp) + CPASSERT(tmc_params%pressure >= 0.0_dp) ! start the timing CALL timeset(routineN, handle) @@ -329,10 +329,10 @@ CONTAINS END IF END IF ! acc(o->n) = min(1, exp(-beta*delta_H)) - IF (d_enthalpy .LE. 0.0_dp) THEN + IF (d_enthalpy <= 0.0_dp) THEN accept = .TRUE. ELSE - IF (rnd_nr .LT. EXP(-1.0_dp/(kB*temperature)*d_enthalpy)) THEN + IF (rnd_nr < EXP(-1.0_dp/(kB*temperature)*d_enthalpy)) THEN accept = .TRUE. ELSE accept = .FALSE. @@ -366,7 +366,7 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env)) CPASSERT(ASSOCIATED(tree_elem)) - CPASSERT(tree_elem%stat .EQ. status_calculated) + CPASSERT(tree_elem%stat == status_calculated) CPASSERT(ASSOCIATED(tree_elem%parent)) ! start the timing @@ -403,7 +403,7 @@ CONTAINS parent_elem => tree_elem IF (ASSOCIATED(tree_elem%acc)) THEN act_elem => tree_elem%acc - IF (act_elem%stat .EQ. status_calculated) THEN + IF (act_elem%stat == status_calculated) THEN CALL check_and_change_status_of_subtree_elem(act_elem=act_elem, & parent_elem=parent_elem, tmc_env=tmc_env) END IF @@ -412,7 +412,7 @@ CONTAINS nacc_loop: DO IF (.NOT. ASSOCIATED(act_elem%nacc)) EXIT nacc_loop act_elem => act_elem%nacc - IF (act_elem%stat .EQ. status_calculated) THEN + IF (act_elem%stat == status_calculated) THEN CALL check_and_change_status_of_subtree_elem(act_elem=act_elem, & parent_elem=parent_elem, tmc_env=tmc_env) END IF @@ -450,7 +450,7 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env%params)) CPASSERT(ASSOCIATED(act_elem)) CPASSERT(ASSOCIATED(parent_elem)) - CPASSERT(act_elem%stat .EQ. status_calculated) + CPASSERT(act_elem%stat == status_calculated) MARK_USED(parent_elem) flag = .FALSE. @@ -459,8 +459,8 @@ CONTAINS ! check for all global tree elements referring to this subtree element ! same subtree element can be accepted at a certain temperature and rejected at another one DO WHILE (ASSOCIATED(tmp_gt_list_ptr)) - CPASSERT(tmp_gt_list_ptr%gt_elem%stat .NE. status_accepted_result) - CPASSERT(tmp_gt_list_ptr%gt_elem%stat .NE. status_rejected_result) + CPASSERT(tmp_gt_list_ptr%gt_elem%stat /= status_accepted_result) + CPASSERT(tmp_gt_list_ptr%gt_elem%stat /= status_rejected_result) CALL check_elements(gt_act_elem=tmp_gt_list_ptr%gt_elem, tmc_env=tmc_env, & check_done=flag, result_acc=result_acc) @@ -625,9 +625,9 @@ CONTAINS SELECT CASE (gt_act_elem%stat) CASE (status_accepted, status_rejected) check_done = .TRUE. - IF (gt_act_elem%stat .EQ. status_accepted) THEN + IF (gt_act_elem%stat == status_accepted) THEN result_acc = .TRUE. - ELSE IF (gt_act_elem%stat .EQ. status_rejected) THEN + ELSE IF (gt_act_elem%stat == status_rejected) THEN result_acc = .FALSE. ELSE CALL cp_abort(__LOCATION__, & @@ -657,13 +657,13 @@ CONTAINS conf2=tmp_element, tmc_params=tmc_env%params, & accept=result_acc) ! volume move check - ELSE IF (act_element%move_type .EQ. mv_type_volume_move) THEN + ELSE IF (act_element%move_type == mv_type_volume_move) THEN CALL volume_acceptance_check(parent_elem=tmp_element, new_elem=act_element, & temperature=tmc_env%params%Temp(gt_act_elem%mv_conf), & rnd_nr=gt_act_elem%rnd_nr, & tmc_params=tmc_env%params, accept=result_acc) ELSE - IF (tmc_env%m_env%temp_decrease .NE. 1.0_dp) THEN + IF (tmc_env%m_env%temp_decrease /= 1.0_dp) THEN CALL acceptance_check(tree_element=act_element, parent_element=tmp_element, & tmc_params=tmc_env%params, temperature=gt_act_elem%Temp, & diff_pot_check=.TRUE., accept=result_acc, & @@ -685,7 +685,7 @@ 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 .NE. gt_act_elem%stat) & + 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 CASE (status_calculated) CASE DEFAULT @@ -763,8 +763,8 @@ CONTAINS ! flag for doing tree cleaning with canceling and deallocation something_updated = .TRUE. - !IF((.NOT.gt_act_elem%swaped) .AND. act_element%temp_created.NE.0 .AND. & - ! act_element%temp_created.NE.gt_act_elem%mv_conf)& + !IF((.NOT.gt_act_elem%swaped) .AND. act_element%temp_created/=0 .AND. & + ! act_element%temp_created/=gt_act_elem%mv_conf)& ! count_wrong_temp_move(gt_act_elem%mv_conf) = & ! count_wrong_temp_move(gt_act_elem%mv_conf)+1 @@ -772,11 +772,11 @@ CONTAINS !-- sort element in lists !-- case NOT ACCEPTED IF (.NOT. result_acc) THEN !result NOT accepted - IF (gt_act_elem%prob_acc .GT. 0.0_dp) THEN - IF (gt_act_elem%prob_acc .GE. 0.5_dp) THEN + IF (gt_act_elem%prob_acc > 0.0_dp) THEN + IF (gt_act_elem%prob_acc >= 0.5_dp) THEN ! wrong estimate (estimated accepted) tmc_env%m_env%estim_corr_wrong(4) = tmc_env%m_env%estim_corr_wrong(4) + 1 - IF (DEBUG .GT. 0) WRITE (tmc_env%m_env%io_unit, *) & + IF (DEBUG > 0) WRITE (tmc_env%m_env%io_unit, *) & "Wrong guess for NACC (elem/estim acc prob)", gt_act_elem%nr, gt_act_elem%prob_acc ELSE tmc_env%m_env%estim_corr_wrong(3) = tmc_env%m_env%estim_corr_wrong(3) + 1 @@ -788,11 +788,11 @@ CONTAINS !-- case ACCEPTED ELSE - IF (gt_act_elem%prob_acc .GT. 0.0_dp) THEN - IF (gt_act_elem%prob_acc .LE. 0.5_dp) THEN + IF (gt_act_elem%prob_acc > 0.0_dp) THEN + IF (gt_act_elem%prob_acc <= 0.5_dp) THEN ! wrong estimate (estimated NOT accepted) tmc_env%m_env%estim_corr_wrong(2) = tmc_env%m_env%estim_corr_wrong(2) + 1 - IF (DEBUG .GT. 0) WRITE (tmc_env%m_env%io_unit, *) & + IF (DEBUG > 0) WRITE (tmc_env%m_env%io_unit, *) & "wrong guess for ACC (elem/estim acc prob)", gt_act_elem%nr, gt_act_elem%prob_acc ELSE tmc_env%m_env%estim_corr_wrong(1) = tmc_env%m_env%estim_corr_wrong(1) + 1 @@ -842,7 +842,7 @@ CONTAINS tmc_params=tmc_env%params) ! save for analysis - IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe .GT. 1 .AND. result_acc) THEN + IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe > 1 .AND. result_acc) THEN CALL add_to_list(elem=tmc_env%m_env%result_list(gt_act_elem%mv_conf)%elem, & list=tmc_env%m_env%analysis_list, & temp_ind=gt_act_elem%mv_conf, & @@ -877,9 +877,9 @@ CONTAINS CPASSERT(ASSOCIATED(elem)) ready = .FALSE. - IF ((elem%scf_energies_count .GE. 4) & - .AND. (elem%stat .NE. status_deleted) .AND. (elem%stat .NE. status_deleted_result) & - .AND. (elem%stat .NE. status_canceled_ener)) & + IF ((elem%scf_energies_count >= 4) & + .AND. (elem%stat /= status_deleted) .AND. (elem%stat /= status_deleted_result) & + .AND. (elem%stat /= status_canceled_ener)) & ready = .TRUE. END FUNCTION ready_for_update_acc_prob @@ -1029,7 +1029,7 @@ CONTAINS END IF END IF !successful probability update - IF (tmp_prob .GE. 0.0_dp) THEN + 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) & diff --git a/src/tmc/tmc_tree_build.F b/src/tmc/tmc_tree_build.F index 18bcff3ab8..a88cc83910 100644 --- a/src/tmc/tmc_tree_build.F +++ b/src/tmc/tmc_tree_build.F @@ -184,8 +184,8 @@ CONTAINS ALLOCATE (next_el%elem_stat(nr_dim)) next_el%elem_stat = status_ok ALLOCATE (next_el%subbox_center(tmc_params%dim_per_elem)) - IF (tmc_params%print_forces .OR. tmc_params%task_type .EQ. task_type_gaussian_adaptation) THEN - IF (tmc_params%task_type .EQ. task_type_gaussian_adaptation) THEN + IF (tmc_params%print_forces .OR. tmc_params%task_type == task_type_gaussian_adaptation) THEN + IF (tmc_params%task_type == task_type_gaussian_adaptation) THEN ALLOCATE (next_el%frc(nr_dim*nr_dim)) ELSE ALLOCATE (next_el%frc(nr_dim)) @@ -314,7 +314,7 @@ CONTAINS global_tree%conf(i)%elem%temp_created = i global_tree%conf(i)%elem%stat = status_calculate_energy !it is default already: global_tree%conf(i)%elem%box_scale(:) = 1.0_dp - IF (tmc_env%params%task_type .EQ. task_type_gaussian_adaptation) THEN + IF (tmc_env%params%task_type == task_type_gaussian_adaptation) THEN global_tree%conf(i)%elem%vel(:) = start_elem%vel(:) global_tree%conf(i)%elem%frc(:) = start_elem%frc(:) global_tree%conf(i)%elem%potential = start_elem%potential @@ -330,8 +330,8 @@ CONTAINS !-- gaussian distributed velocities !-- calculating the kinetic energy of the initial configuration velocity - IF (tmc_env%params%task_type .EQ. task_type_MC) THEN - IF (tmc_env%params%move_types%mv_weight(mv_type_MD) .GT. 0.0_dp) THEN + IF (tmc_env%params%task_type == task_type_MC) THEN + IF (tmc_env%params%move_types%mv_weight(mv_type_MD) > 0.0_dp) THEN CALL init_vel(vel=global_tree%conf(i)%elem%vel, atoms=tmc_env%params%atoms, & temerature=tmc_env%params%Temp(i), & rng_stream=tmc_env%rng_stream, & @@ -364,13 +364,13 @@ CONTAINS ! simulated annealing start temperature global_tree%Temp = tmc_env%params%Temp(1) - IF (tmc_env%params%nr_temp .NE. 1 .AND. tmc_env%m_env%temp_decrease .NE. 1.0_dp) & + 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.") !-- IF program is restarted, read restart file - IF (tmc_env%m_env%restart_in_file_name .NE. "") THEN + IF (tmc_env%m_env%restart_in_file_name /= "") THEN CALL read_restart_file(tmc_env=tmc_env, job_counts=job_counts, & timings=worker_timings, & file_name=tmc_env%m_env%restart_in_file_name) @@ -387,10 +387,10 @@ CONTAINS !TODO enable calculation of the approx energy for case of fitting potential ! and changing the potential in between ! BUT check, there is no double counting (of the last/restarted elem) in the trajectory - !IF(tmc_env%params%NMC_inp_file.NE."") & + !IF(tmc_env%params%NMC_inp_file/="") & ! global_tree%conf(1)%elem%stat = status_calc_approx_ener global_tree%stat = status_accepted_result - ELSE IF (tmc_env%params%NMC_inp_file .NE. "") THEN + ELSE IF (tmc_env%params%NMC_inp_file /= "") THEN global_tree%conf(1)%elem%stat = status_calc_approx_ener ELSE global_tree%conf(1)%elem%stat = status_created @@ -442,11 +442,11 @@ CONTAINS gt_tree_ptr%conf(i)%elem%stat = status_accepted_result IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) & gt_tree_ptr%conf(i)%elem%dipole = gt_tree_ptr%conf(1)%elem%dipole - IF (tmc_env%m_env%restart_in_file_name .EQ. "") & + IF (tmc_env%m_env%restart_in_file_name == "") & gt_tree_ptr%conf(i)%elem%potential = gt_tree_ptr%conf(1)%elem%potential END DO - IF (tmc_env%m_env%restart_in_file_name .EQ. "") THEN + IF (tmc_env%m_env%restart_in_file_name == "") THEN tmc_env%m_env%result_count(:) = tmc_env%m_env%result_count(:) + 1 tmc_env%m_env%result_list(:) = gt_tree_ptr%conf(:) !-- write initial elements in result files @@ -456,7 +456,7 @@ CONTAINS conf_updated=i, accepted=.TRUE., & tmc_params=tmc_env%params) ! save for analysis - IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe .GT. 1) THEN + IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe > 1) THEN CALL add_to_list(elem=tmc_env%m_env%result_list(i)%elem, & list=tmc_env%m_env%analysis_list, & nr=tmc_env%m_env%result_count(i), & @@ -517,7 +517,7 @@ CONTAINS CALL most_prob_end(global_tree_elem=tmp_elem, prob=prob, n_acc=n_acc) keep_on = .TRUE. - IF (ASSOCIATED(tmp_elem) .AND. (EXP(prob) .LT. 1.0E-10)) THEN + IF (ASSOCIATED(tmp_elem) .AND. (EXP(prob) < 1.0E-10)) THEN new_elem => NULL() stat = TMC_STATUS_FAILED keep_on = .FALSE. @@ -570,13 +570,13 @@ 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 .NE. status_canceled_nmc) & + 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)) new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_NMC_steps - !IF(DEBUG.GE.1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", & + !IF(DEBUG>=1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", & ! new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, "elem", new_elem%conf(new_elem%mv_conf)%elem%nr, & ! " of existing gt elem ",new_elem%nr,", again calculate NMC steps" CASE (mv_type_atom_trans, mv_type_mol_trans, mv_type_mol_rot, & @@ -668,7 +668,7 @@ CONTAINS ! swap moves are not part of the subtree structure, ! because existing elements from DIFFERENT subtrees are swaped ! -- do swap ?! - IF (tmc_env%params%move_types%mv_weight(mv_type_swap_conf) .GE. rnd) THEN + IF (tmc_env%params%move_types%mv_weight(mv_type_swap_conf) >= rnd) THEN ! set the index for the swaping element ! and the conf to move in next move new_elem%mv_next_conf = new_elem%mv_conf @@ -746,10 +746,10 @@ CONTAINS END IF ! keep on (checking and creating) IF (keep_on) THEN ! status changes - IF (new_elem%stat .EQ. status_accepted_result .OR. & - new_elem%stat .EQ. status_accepted .OR. & - new_elem%stat .EQ. status_rejected .OR. & - new_elem%stat .EQ. status_rejected_result) & + 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) & CPABORT("selected existing RESULT gt node") !-- set status of global tree element for decision in master routine SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%stat) @@ -763,7 +763,7 @@ CONTAINS tmc_params=tmc_env%params) CASE (status_calc_approx_ener) new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (stat .NE. status_calculated) THEN + IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & @@ -773,7 +773,7 @@ CONTAINS status_calculate_NMC_steps, status_created) ! if not already in progress, set status for new task message new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat - IF (stat .NE. status_calculated) THEN + IF (stat /= status_calculated) THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF (tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, & @@ -810,8 +810,8 @@ CONTAINS ! set stat TMC_STATUS_WAIT_FOR_NEW_TASK if no new calculation necessary ! (energy calculation nodes searched by different routine) - IF (stat .EQ. TMC_STATUS_FAILED) stat = TMC_STATUS_WAIT_FOR_NEW_TASK - IF (stat .EQ. status_calculated) stat = TMC_STATUS_WAIT_FOR_NEW_TASK + IF (stat == TMC_STATUS_FAILED) stat = TMC_STATUS_WAIT_FOR_NEW_TASK + IF (stat == status_calculated) stat = TMC_STATUS_WAIT_FOR_NEW_TASK END IF ! end the timing CALL timestop(handle) @@ -876,7 +876,7 @@ CONTAINS new_elem%next_elem_nr => parent_elem%next_elem_nr new_elem%sub_tree_nr = parent_elem%sub_tree_nr new_elem%box_scale = parent_elem%box_scale - IF (tmc_env%params%task_type .EQ. task_type_gaussian_adaptation) THEN + IF (tmc_env%params%task_type == task_type_gaussian_adaptation) THEN new_elem%frc(:) = parent_elem%frc(:) new_elem%potential = parent_elem%potential new_elem%ekin_before_md = parent_elem%ekin_before_md @@ -893,7 +893,7 @@ CONTAINS ! set the temperature for the NMC moves rnd = tmc_env%rng_stream%next() - IF (tmc_env%params%NMC_inp_file .NE. "") THEN + IF (tmc_env%params%NMC_inp_file /= "") THEN new_elem%temp_created = INT(tmc_env%params%nr_temp*rnd) + 1 ELSE new_elem%temp_created = act_gt_el%mv_conf @@ -939,7 +939,7 @@ CONTAINS mv_type_volume_move) new_subbox = .TRUE. ! volume move on whole cell - IF (new_elem%move_type .EQ. mv_type_volume_move) THEN + IF (new_elem%move_type == mv_type_volume_move) THEN new_subbox = .FALSE. END IF CALL change_pos(tmc_params=tmc_env%params, & @@ -953,7 +953,7 @@ CONTAINS new_elem%stat = status_calculated ELSE new_elem%stat = status_created - IF (tmc_env%params%NMC_inp_file .NE. "") & + IF (tmc_env%params%NMC_inp_file /= "") & new_elem%stat = status_calc_approx_ener END IF CASE (mv_type_gausian_adapt) @@ -999,7 +999,7 @@ CONTAINS CALL remove_gt_references(gt_ptr=gt_ptr, tmc_env=tmc_env) ! set status and draw in tree - IF ((gt_ptr%stat .EQ. status_accepted_result) .OR. (gt_ptr%stat .EQ. status_rejected_result)) THEN + IF ((gt_ptr%stat == status_accepted_result) .OR. (gt_ptr%stat == status_rejected_result)) THEN gt_ptr%stat = status_deleted_result ELSE gt_ptr%stat = status_deleted @@ -1089,8 +1089,8 @@ CONTAINS IF (ready) THEN ! set status and draw in tree - IF ((ptr%stat .EQ. status_accepted_result) .OR. & - (ptr%stat .EQ. status_rejected_result)) THEN + IF ((ptr%stat == status_accepted_result) .OR. & + (ptr%stat == status_rejected_result)) THEN ptr%stat = status_deleted_result ELSE ptr%stat = status_deleted @@ -1246,7 +1246,7 @@ CONTAINS nacc_removed = .TRUE. END IF - !IF (DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"try to dealloc: node", begin_ptr%nr," sides are removed: ", & + !IF (DEBUG>=20) WRITE(tmc_out_file_nr,*)"try to dealloc: node", begin_ptr%nr," sides are removed: ", & ! acc_removed, nacc_removed !-- deallocate node if NO child node exist @@ -1292,7 +1292,7 @@ CONTAINS END IF END DO IF (removed) THEN - !IF (DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"deallocation of node ", begin_ptr%nr, "with status ", begin_ptr%stat + !IF (DEBUG>=20) WRITE(tmc_out_file_nr,*)"deallocation of node ", begin_ptr%nr, "with status ", begin_ptr%stat ! if all groups are finished with this element, we can deallocate CALL remove_st_elem(ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env) IF (.NOT. ASSOCIATED(tmp_ptr)) THEN @@ -1340,7 +1340,7 @@ CONTAINS !-- new tree head has no parent IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN !-- deallocate node - !IF(DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"dealloc gt result tree element: ",actual_ptr%nr + !IF(DEBUG>=20) WRITE(tmc_out_file_nr,*)"dealloc gt result tree element: ",actual_ptr%nr tmp_ptr => actual_ptr CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env) actual_ptr => tmp_ptr @@ -1452,7 +1452,7 @@ CONTAINS change_trajec = .TRUE. 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.GE.20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr + !IF (DEBUG>=20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr END IF !-- deallocate the subtrees @@ -1461,10 +1461,10 @@ 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 .EQ. tree) & + IF (last_acc_st_elem%sub_tree_nr == tree) & EXIT conf_loop END DO conf_loop - CPASSERT(last_acc_st_elem%sub_tree_nr .EQ. tree) + 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, & end_ptr=last_acc_st_elem, working_elem_list=working_elem_list, & removed=flag, tmc_env=tmc_env) @@ -1475,11 +1475,11 @@ CONTAINS IF (tmc_env%params%USE_REDUCED_TREE .AND. change_trajec) THEN DO tree = 1, tmc_env%params%nr_temp tmp_ptr => tmc_env%m_env%st_clean_ends(tree)%elem - CPASSERT(tmp_ptr%sub_tree_nr .EQ. tree) + CPASSERT(tmp_ptr%sub_tree_nr == tree) CALL remove_result_s_tree(end_of_clean_tree=tmc_env%m_env%st_clean_ends(tree)%elem, & actual_ptr=tmp_ptr, tmc_env=tmc_env) tmc_env%m_env%st_heads(tree)%elem => tmc_env%m_env%st_clean_ends(tree)%elem - !IF(DEBUG.GE.20) & + !IF(DEBUG>=20) & ! WRITE(tmc_out_file_nr,*)"new head of tree ",tree," is ",& ! tmc_env%m_env%st_heads(tree)%elem%nr END DO diff --git a/src/tmc/tmc_tree_search.F b/src/tmc/tmc_tree_search.F index c45f2b436a..a03749d2d6 100644 --- a/src/tmc/tmc_tree_search.F +++ b/src/tmc/tmc_tree_search.F @@ -203,7 +203,7 @@ CONTAINS ! test which direction is more likely ! and set result pointer and probability, ! remembering the direction - IF (prob_n_acc .GE. prob_n_nacc) THEN + IF (prob_n_acc >= prob_n_nacc) THEN prob = prob_n_acc global_tree_elem => ptr_acc n_acc = tmp_acc @@ -250,18 +250,18 @@ CONTAINS stat = status_created ! set status for master ! (if TMC_STATUS_WAIT_FOR_NEW_TASK, no calculation necessary) - IF (.NOT. ASSOCIATED(new_gt_elem) .OR. (EXP(prob) .LT. 1.0E-10)) THEN + IF (.NOT. ASSOCIATED(new_gt_elem) .OR. (EXP(prob) < 1.0E-10)) THEN stat = TMC_STATUS_WAIT_FOR_NEW_TASK ELSE ! reactivate canceled elements - IF (new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat .EQ. & + IF (new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat == & status_canceled_ener) THEN CALL add_to_references(gt_elem=new_gt_elem) react_count = react_count + 1 new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat = status_created END IF ! if elem status is not status_created - IF (new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat .NE. status_created) THEN + IF (new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat /= status_created) THEN stat = TMC_STATUS_WAIT_FOR_NEW_TASK END IF END IF @@ -523,9 +523,9 @@ CONTAINS ready = .TRUE. ! if prob present select the related branch IF (PRESENT(prob)) THEN - IF (prob .LT. 1.0E-10 .AND. ASSOCIATED(pt_elem_in%acc)) THEN + IF (prob < 1.0E-10 .AND. ASSOCIATED(pt_elem_in%acc)) THEN pt_elem => pt_elem_in%acc - ELSE IF (prob .GT. (1.0_dp - 1.0E-10) .AND. ASSOCIATED(pt_elem_in%nacc)) THEN + ELSE IF (prob > (1.0_dp - 1.0E-10) .AND. ASSOCIATED(pt_elem_in%nacc)) THEN pt_elem => pt_elem_in%nacc ELSE ready = .FALSE. @@ -588,7 +588,7 @@ CONTAINS CPASSERT(ASSOCIATED(global_tree_ptr)) CPASSERT(ASSOCIATED(counters)) - CPASSERT(SIZE(counters(1:)) .EQ. SIZE(global_tree_ptr%conf(:))) + CPASSERT(SIZE(counters(1:)) == SIZE(global_tree_ptr%conf(:))) ! start the timing CALL timeset(routineN, handle) @@ -634,7 +634,7 @@ CONTAINS END IF CASE (status_created, status_calculate_MD, status_calculate_NMC_steps, & status_calc_approx_ener, status_calculated, status_calculate_energy) - IF (tree_ptr%stat .EQ. status_created) counter = counter + 1 + IF (tree_ptr%stat == status_created) counter = counter + 1 IF (ASSOCIATED(tree_ptr%acc)) THEN tmp_ptr => tree_ptr%acc CALL count_prepared_nodes_in_subtree(tmp_ptr, counter) @@ -680,7 +680,7 @@ CONTAINS CPASSERT(ASSOCIATED(global_tree_ptr)) CPASSERT(ASSOCIATED(end_of_clean_trees)) CPASSERT(ASSOCIATED(counters)) - CPASSERT(SIZE(counters(1:)) .EQ. SIZE(global_tree_ptr%conf(:))) + CPASSERT(SIZE(counters(1:)) == SIZE(global_tree_ptr%conf(:))) ! start the timing CALL timeset(routineN, handle) diff --git a/src/tmc/tmc_tree_types.F b/src/tmc/tmc_tree_types.F index 6ecf432a25..d310cdb089 100644 --- a/src/tmc/tmc_tree_types.F +++ b/src/tmc/tmc_tree_types.F @@ -245,7 +245,7 @@ CONTAINS INTEGER :: io_unit CPASSERT(ASSOCIATED(elem)) - CPASSERT(io_unit .GT. 0) + CPASSERT(io_unit > 0) WRITE (io_unit) elem%nr, & elem%sub_tree_nr, & elem%stat, & @@ -275,7 +275,7 @@ CONTAINS INTEGER :: io_unit CPASSERT(ASSOCIATED(elem)) - CPASSERT(io_unit .GT. 0) + CPASSERT(io_unit > 0) READ (io_unit) elem%nr, & elem%sub_tree_nr, & @@ -326,7 +326,7 @@ CONTAINS IF (l_tmp) THEN READ (io_unit) i_tmp IF (ASSOCIATED(array)) THEN - CPASSERT(SIZE(array) .EQ. i_tmp) + CPASSERT(SIZE(array) == i_tmp) ELSE ALLOCATE (array(i_tmp)) END IF diff --git a/src/tmc/tmc_types.F b/src/tmc/tmc_types.F index 5420647a6a..08c8627f52 100644 --- a/src/tmc/tmc_types.F +++ b/src/tmc/tmc_types.F @@ -257,7 +257,7 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env)) CPASSERT(ASSOCIATED(tmc_env%params)) - CPASSERT(tmc_env%params%nr_temp .GT. 0) + CPASSERT(tmc_env%params%nr_temp > 0) CPASSERT(.NOT. ASSOCIATED(tmc_env%m_env)) @@ -395,7 +395,7 @@ CONTAINS INTEGER, INTENT(IN) :: nr_atoms CPASSERT(.NOT. ASSOCIATED(atoms)) - CPASSERT(nr_atoms .GT. 0) + CPASSERT(nr_atoms > 0) ALLOCATE (atoms(nr_atoms)) diff --git a/src/tmc/tmc_worker.F b/src/tmc/tmc_worker.F index d1934c4127..aa6bb3557e 100644 --- a/src/tmc/tmc_worker.F +++ b/src/tmc/tmc_worker.F @@ -136,9 +136,9 @@ CONTAINS CALL timeset(routineN, handle) ! initialize - IF (tmc_env%tmc_comp_set%group_nr .GT. 0) THEN + IF (tmc_env%tmc_comp_set%group_nr > 0) THEN CPASSERT(ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) - IF (tmc_env%w_env%env_id_ener .GT. 0) THEN + IF (tmc_env%w_env%env_id_ener > 0) THEN itmp = tmc_env%w_env%env_id_ener ELSE itmp = tmc_env%w_env%env_id_approx @@ -159,8 +159,8 @@ CONTAINS ! get messages from master and handle them IF (master) THEN ! NOT the analysis group - IF (tmc_env%tmc_comp_set%group_nr .GT. 0) THEN - IF (tmc_env%w_env%env_id_ener .GT. 0) THEN + IF (tmc_env%tmc_comp_set%group_nr > 0) THEN + IF (tmc_env%w_env%env_id_ener > 0) THEN itmp = tmc_env%w_env%env_id_ener ELSE itmp = tmc_env%w_env%env_id_approx @@ -187,7 +187,7 @@ CONTAINS result_count=ana_restart_conf, & tmc_params=tmc_env%params, elem=conf) - IF (DEBUG .GE. 1 .AND. work_stat .NE. TMC_STATUS_WAIT_FOR_NEW_TASK) & + 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 calc_stat = TMC_STATUS_CALCULATING @@ -208,13 +208,13 @@ CONTAINS para_env=para_env_m_w, & tmc_params=tmc_env%params) CASE (TMC_STATUS_FAILED) - IF (DEBUG .GE. 1) & + IF (DEBUG >= 1) & WRITE (tmc_env%w_env%io_unit, *) "master worker of group", & 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) - IF (tmc_env%w_env%env_id_ener .GT. 0) THEN + IF (tmc_env%w_env%env_id_ener > 0) THEN itmp = tmc_env%w_env%env_id_ener ELSE itmp = tmc_env%w_env%env_id_approx @@ -236,7 +236,7 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_m_first_w) !-- calculate the approximate energy CASE (TMC_STAT_APPROX_ENERGY_REQUEST) - CPASSERT(tmc_env%w_env%env_id_approx .GT. 0) + CPASSERT(tmc_env%w_env%env_id_approx > 0) itmp = bcast_group !-- DISTRIBUTING WORK (group master) to all other group members CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & @@ -262,12 +262,12 @@ CONTAINS para_env=tmc_env%tmc_comp_set%para_env_sub_group, & tmc_params=tmc_env%params, elem=conf) !-- collective calculation for MD/NMC steps - IF (work_stat .EQ. TMC_STAT_NMC_REQUEST) THEN + IF (work_stat == TMC_STAT_NMC_REQUEST) THEN !-- calculate MD steps, in case of 2 different potentials do nested Monte Carlo CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSEIF (work_stat .EQ. 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.") @@ -307,7 +307,7 @@ CONTAINS para_env=para_env_m_w, & tmc_params=tmc_env%params, elem=conf) CASE (TMC_STAT_ENERGY_REQUEST) - CPASSERT(tmc_env%w_env%env_id_ener .GT. 0) + CPASSERT(tmc_env%w_env%env_id_ener > 0) !-- DISTRIBUTING WORK (group master) to all other group members itmp = bcast_group CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & @@ -358,7 +358,7 @@ CONTAINS END SELECT !-- send information back to master - IF (DEBUG .GE. 1) & + 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 @@ -369,7 +369,7 @@ CONTAINS tmc_params=tmc_env%params, elem=conf) CASE (TMC_STAT_INIT_ANALYSIS) CPASSERT(ASSOCIATED(ana_restart_conf)) - CPASSERT(SIZE(ana_restart_conf) .EQ. tmc_env%params%nr_temp) + CPASSERT(SIZE(ana_restart_conf) == tmc_env%params%nr_temp) CPASSERT(PRESENT(ana_list)) CPASSERT(ASSOCIATED(ana_list)) itmp = MASTER_COMM_ID @@ -394,7 +394,7 @@ CONTAINS !check if we have the read the file flag = .FALSE. IF ((.NOT. ASSOCIATED(ana_list(itmp)%temp%last_elem)) .AND. & - ana_restart_conf(itmp) .GT. 0) THEN + ana_restart_conf(itmp) > 0) THEN flag = .TRUE. i1 = 0 i2 = ana_restart_conf(itmp) @@ -403,7 +403,7 @@ CONTAINS "elem "//cp_to_string(ana_restart_conf(itmp))// & ". Read trajectory file.") ELSE IF (ASSOCIATED(ana_list(itmp)%temp%last_elem)) THEN - IF (.NOT. (ana_list(itmp)%temp%last_elem%nr .EQ. ana_restart_conf(itmp))) THEN + IF (.NOT. (ana_list(itmp)%temp%last_elem%nr == ana_restart_conf(itmp))) THEN flag = .TRUE. i1 = ana_list(itmp)%temp%last_elem%nr i2 = ana_restart_conf(itmp) @@ -438,7 +438,7 @@ CONTAINS cp_to_string(work_stat)) END SELECT - IF (DEBUG .GE. 1 .AND. work_stat .NE. TMC_STATUS_WAIT_FOR_NEW_TASK) & + 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 @@ -465,11 +465,11 @@ CONTAINS EXIT worker_work_time ! all group members have to calculate the (MD potential) energy together CASE (TMC_STAT_START_CONF_RESULT) - CPASSERT(tmc_env%w_env%env_id_approx .GT. 0) + CPASSERT(tmc_env%w_env%env_id_approx > 0) !-- collective calculation of the potential energy of MD potential SELECT CASE (tmc_env%params%task_type) CASE (task_type_MC, task_type_ideal_gas) - IF (tmc_env%params%NMC_inp_file .NE. "") THEN + IF (tmc_env%params%NMC_inp_file /= "") THEN conf%box_scale(:) = 1.0_dp CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & @@ -484,12 +484,12 @@ CONTAINS !-- HMC - calculating MD steps CASE (TMC_STAT_NMC_REQUEST, TMC_STAT_MD_REQUEST) !-- collective calculation for MD/NMC steps - IF (work_stat .EQ. TMC_STAT_NMC_REQUEST) THEN + IF (work_stat == TMC_STAT_NMC_REQUEST) THEN !-- calculate MD steps, in case of 2 different potentials do nested Monte Carlo CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & tmc_env=tmc_env, calc_status=calc_stat) - ELSEIF (work_stat .EQ. 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.") @@ -499,14 +499,14 @@ CONTAINS !-- energy calculations CASE (TMC_STAT_APPROX_ENERGY_REQUEST) !--- do calculate energy - CPASSERT(tmc_env%w_env%env_id_approx .GT. 0) + CPASSERT(tmc_env%w_env%env_id_approx > 0) CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & exact_approx_pot=.FALSE., & tmc_env=tmc_env) CASE (TMC_STAT_ENERGY_REQUEST) !--- do calculate energy - CPASSERT(tmc_env%w_env%env_id_ener .GT. 0) + CPASSERT(tmc_env%w_env%env_id_ener > 0) CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_ener, & exact_approx_pot=.TRUE., & @@ -534,11 +534,11 @@ CONTAINS ! sending back receipt for stopping IF (master) THEN ! NOT the analysis group - IF (tmc_env%tmc_comp_set%group_nr .GT. 0) THEN + IF (tmc_env%tmc_comp_set%group_nr > 0) THEN ! remove 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%w_env%env_id_ener .GT. 0) THEN + IF (tmc_env%w_env%env_id_ener > 0) THEN itmp = tmc_env%w_env%env_id_ener ELSE itmp = tmc_env%w_env%env_id_approx @@ -563,7 +563,7 @@ CONTAINS tmc_params=tmc_env%params) END IF - IF (DEBUG .GE. 5) & + 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!" @@ -614,9 +614,9 @@ CONTAINS CPASSERT(ASSOCIATED(tmc_env%tmc_comp_set)) CPASSERT(ALLOCATED(tmc_env%rng_stream)) CPASSERT(ASSOCIATED(conf)) - CPASSERT(conf%temp_created .GT. 0) - CPASSERT(conf%temp_created .LE. tmc_env%params%nr_temp) - CPASSERT(env_id .GT. 0) + CPASSERT(conf%temp_created > 0) + CPASSERT(conf%temp_created <= tmc_env%params%nr_temp) + CPASSERT(env_id > 0) MARK_USED(env_id) ! start the timing @@ -680,7 +680,7 @@ CONTAINS move_rejected=change_rejected) ! for Hybrid MC the change_pos is only velocity change, ! the actual MD step hast to be done in this module for communication reason - IF (conf%move_type .EQ. mv_type_MD) THEN + IF (conf%move_type == mv_type_MD) THEN !TODO implement the MD part !CALL calc_MD_step(...) !CALL calc_calc_e_kin(...) @@ -782,7 +782,7 @@ CONTAINS ! get positions CALL get_natom(env_id=env_id, n_atom=nr_atoms, ierr=ierr) - CPASSERT(ierr .EQ. 0) + CPASSERT(ierr == 0) ndim = 3*nr_atoms CALL allocate_new_sub_tree_node(tmc_params=tmc_params, & next_el=init_conf, nr_dim=ndim) @@ -825,7 +825,7 @@ CONTAINS NULLIFY (f_env, subsys, particles) nr_atoms = 0 - CPASSERT(env_id .GT. 0) + CPASSERT(env_id > 0) CPASSERT(.NOT. ASSOCIATED(atoms)) CPASSERT(.NOT. ASSOCIATED(cell)) @@ -839,12 +839,12 @@ CONTAINS CALL allocate_tmc_atom_type(atoms, nr_atoms) CALL cp_subsys_get(subsys, particles=particles) nunits_tot = SIZE(particles%els(:)) - IF (nunits_tot .GT. 0) THEN + IF (nunits_tot > 0) THEN DO iparticle = 1, nunits_tot atoms(iparticle)%name = particles%els(iparticle)%atomic_kind%name atoms(iparticle)%mass = particles%els(iparticle)%atomic_kind%mass END DO - CPASSERT(iparticle - 1 .EQ. nr_atoms) + CPASSERT(iparticle - 1 == nr_atoms) END IF END SUBROUTINE get_atom_kinds_and_cell @@ -866,7 +866,7 @@ CONTAINS TYPE(f_env_type), POINTER :: f_env NULLIFY (results, subsys) - CPASSERT(env_id .GT. 0) + CPASSERT(env_id > 0) CALL f_env_get_from_id(env_id, f_env) @@ -904,7 +904,7 @@ CONTAINS TYPE(f_env_type), POINTER :: f_env NULLIFY (subsys, results) - CPASSERT(env_id .GT. 0) + CPASSERT(env_id > 0) CALL f_env_get_from_id(env_id, f_env) diff --git a/src/topology_amber.F b/src/topology_amber.F index 03d0a0334f..a43d32ea77 100644 --- a/src/topology_amber.F +++ b/src/topology_amber.F @@ -1623,7 +1623,7 @@ CONTAINS label_d(iphi) = work_label(4, 1) k(iphi) = pk(icp(iwork(1))) m(iphi) = NINT(pn(icp(iwork(1)))) - IF (m(iphi) - pn(icp(iwork(1))) .GT. EPSILON(1.0_dp)) THEN + IF (m(iphi) - pn(icp(iwork(1))) > EPSILON(1.0_dp)) THEN ! non integer torsions not supported CPABORT("") END IF @@ -1657,7 +1657,7 @@ CONTAINS label_d(iphi) = work_label(4, i) k(iphi) = pk(icp(iwork(i))) m(iphi) = NINT(pn(icp(iwork(i)))) - IF (m(iphi) - pn(icp(iwork(i))) .GT. EPSILON(1.0_dp)) THEN + IF (m(iphi) - pn(icp(iwork(i))) > EPSILON(1.0_dp)) THEN ! non integer torsions not supported CPABORT("") END IF diff --git a/src/topology_constraint_util.F b/src/topology_constraint_util.F index ae03a5a028..50fc5e7b0f 100644 --- a/src/topology_constraint_util.F +++ b/src/topology_constraint_util.F @@ -617,7 +617,7 @@ CONTAINS CALL get_molecule_kind(molecule_kind=molecule_kind, & nmolecule=nmolecule, molecule_list=molecule_list, name=molname) is_qm = qmmm_ff_precond_only_qm(id1=molname) - WHERE (molname .EQ. cons_info%fixed_molnames) + WHERE (molname == cons_info%fixed_molnames) missed_molname = .FALSE. END WHERE ! Try to figure out how many atoms of the list belong to this molecule_kind @@ -628,7 +628,7 @@ CONTAINS fix_atom_molname = .FALSE. IF (ASSOCIATED(cons_info%fixed_molnames)) THEN DO k = 1, SIZE(cons_info%fixed_molnames) - IF (cons_info%fixed_molnames(k) .EQ. molname) THEN + IF (cons_info%fixed_molnames(k) == molname) THEN fix_atom_molname = .TRUE. IF (is_qm .AND. cons_info%fixed_exclude_qm(k)) fix_atom_molname = .FALSE. IF ((.NOT. is_qm) .AND. cons_info%fixed_exclude_mm(k)) fix_atom_molname = .FALSE. @@ -666,7 +666,7 @@ CONTAINS fix_atom_molname = .FALSE. IF (ASSOCIATED(cons_info%fixed_molnames)) THEN DO k1loc = 1, SIZE(cons_info%fixed_molnames) - IF (cons_info%fixed_molnames(k1loc) .EQ. molname) THEN + IF (cons_info%fixed_molnames(k1loc) == molname) THEN fix_atom_molname = .TRUE. itype = cons_info%fixed_mol_type(k1loc) EXIT diff --git a/src/topology_coordinate_util.F b/src/topology_coordinate_util.F index 97066ae874..ef50c79df7 100644 --- a/src/topology_coordinate_util.F +++ b/src/topology_coordinate_util.F @@ -161,7 +161,7 @@ CONTAINS first_atom=first, last_atom=last) IF (iw > 0) WRITE (iw, *) "boundaries of molecules (first, last) ::", first, last DO j = 1, natom - IF (.NOT. ANY(id_work(1:counter) .EQ. atom_list(j)%id_name)) THEN + IF (.NOT. ANY(id_work(1:counter) == atom_list(j)%id_name)) THEN counter = counter + 1 id_work(counter) = atom_list(j)%id_name mass(counter) = atom_info%atm_mass(first + j - 1) @@ -290,7 +290,7 @@ CONTAINS IF (iw > 0) THEN WRITE (iw, '(A,I6,A)') " Atomic kind ", i, " contains particles" DO J = 1, SIZE(iatomlist) - IF (MOD(J, 5) .EQ. 0) THEN ! split long lines + IF (MOD(J, 5) == 0) THEN ! split long lines WRITE (iw, '(I12)') iatomlist(J) ELSE WRITE (iw, '(I12)', ADVANCE="NO") iatomlist(J) diff --git a/src/topology_gromos.F b/src/topology_gromos.F index 0b47699bf2..2c63ad5efc 100644 --- a/src/topology_gromos.F +++ b/src/topology_gromos.F @@ -222,19 +222,19 @@ CONTAINS begin = 1 IF (ntype /= 0) THEN DO - IF (begin .EQ. 1) THEN + IF (begin == 1) THEN READ (parser%input_line, iostat=stat, FMT=*) itemp, itemp, ctemp, itemp, ftemp, ftemp, & itemp, itemp, (ii(i), i=begin, ntype) - ELSE IF (begin .GT. 1) THEN + ELSE IF (begin > 1) THEN CALL parser_get_next_line(parser, 1) READ (parser%input_line, iostat=stat, FMT=*) (ii(i), i=begin, ntype) END IF DO i = ntype, 1, -1 - IF (ii(i) .LT. 0) THEN + IF (ii(i) < 0) THEN begin = i END IF END DO - IF (stat .EQ. 0) EXIT + IF (stat == 0) EXIT END DO END IF ! 1-4 list @@ -254,18 +254,18 @@ CONTAINS begin = 1 IF (ntype /= 0) THEN DO - IF (begin .EQ. 1) THEN + IF (begin == 1) THEN READ (parser%input_line, iostat=stat, FMT=*) itemp, (ii(i), i=begin, ntype) - ELSE IF (begin .GT. 1) THEN + ELSE IF (begin > 1) THEN CALL parser_get_next_line(parser, 1) READ (parser%input_line, iostat=stat, FMT=*) (ii(i), i=begin, ntype) END IF DO i = ntype, 1, -1 - IF (ii(i) .LT. 0) THEN + IF (ii(i) < 0) THEN begin = i END IF END DO - IF (stat .EQ. 0) EXIT + IF (stat == 0) EXIT END DO DO i = 1, ntype conn_info%onfo_b(offset + i) = ii(i) diff --git a/src/topology_psf.F b/src/topology_psf.F index 992400171d..99bc048366 100644 --- a/src/topology_psf.F +++ b/src/topology_psf.F @@ -776,7 +776,7 @@ CONTAINS END IF ! fixup for topology output DO j = 1, topology%natoms - IF (charges(j) .EQ. -HUGE(0.0_dp)) charges(j) = -99.0_dp + IF (charges(j) == -HUGE(0.0_dp)) charges(j) = -99.0_dp END DO record = cp_print_key_generate_filename(logger, print_key, & extension=".psf", my_local=.FALSE.) diff --git a/src/topology_util.F b/src/topology_util.F index ceaae74b1f..3bf897f06e 100644 --- a/src/topology_util.F +++ b/src/topology_util.F @@ -180,7 +180,7 @@ CONTAINS iindex = 0 imol = 0 DO i = 1, natom - IF (old_mol .NE. atom_info%map_mol_num(I)) THEN + IF (old_mol /= atom_info%map_mol_num(I)) THEN old_mol = atom_info%map_mol_num(I) iindex = 0 IF (imol > 0) THEN @@ -225,7 +225,7 @@ CONTAINS "New ones will be provided on the basis of the connectivity!" END IF DO j = 1, max_mol_num - IF (mol_hash(j) .NE. old_hash) THEN + IF (mol_hash(j) /= old_hash) THEN unique_mol = unique_mol + 1 old_hash = mol_hash(j) CALL setup_graph_set(reference_set, unique_mol, map_mol_hash(j), & diff --git a/src/transport.F b/src/transport.F index 585f90e9a0..dc24d12c9a 100644 --- a/src/transport.F +++ b/src/transport.F @@ -256,7 +256,7 @@ CONTAINS CALL section_vals_val_get(contact_section, "INJECTION_SIGN", i_rep_section=i, i_val=contact_injsign) CALL section_vals_val_get(contact_section, "INJECTING_CONTACT", i_rep_section=i, l_val=injecting_contact) - IF (contact_natoms .LE. 0) CPABORT("Number of atoms in contact region needs to be defined.") + IF (contact_natoms <= 0) CPABORT("Number of atoms in contact region needs to be defined.") transport_env%contacts_data((i - 1)*stride_contacts + 1) = contact_bandwidth transport_env%contacts_data((i - 1)*stride_contacts + 2) = contact_start - 1 ! C indexing @@ -461,25 +461,25 @@ CONTAINS nzerow_local => csr_mat%nzerow_local nzvals_local => csr_mat%nzval_local%r_dp ! support real double percision for now - IF (SIZE(rowptr_local) .EQ. 0) THEN + IF (SIZE(rowptr_local) == 0) THEN csr_interop_mat%rowptr_local = C_NULL_PTR ELSE csr_interop_mat%rowptr_local = C_LOC(rowptr_local(1)) END IF - IF (SIZE(colind_local) .EQ. 0) THEN + IF (SIZE(colind_local) == 0) THEN csr_interop_mat%colind_local = C_NULL_PTR ELSE csr_interop_mat%colind_local = C_LOC(colind_local(1)) END IF - IF (SIZE(nzerow_local) .EQ. 0) THEN + IF (SIZE(nzerow_local) == 0) THEN csr_interop_mat%nzerow_local = C_NULL_PTR ELSE csr_interop_mat%nzerow_local = C_LOC(nzerow_local(1)) END IF - IF (SIZE(nzvals_local) .EQ. 0) THEN + IF (SIZE(nzvals_local) == 0) THEN csr_interop_mat%nzvals_local = C_NULL_PTR ELSE csr_interop_mat%nzvals_local = C_LOC(nzvals_local(1)) @@ -490,7 +490,7 @@ CONTAINS CALL mp_group%allgather(csr_mat%nrows_local, nrows_local_all) CALL cumsum_i(nrows_local_all, first_row_all) - IF (mepos .EQ. 0) THEN + IF (mepos == 0) THEN csr_interop_mat%first_row = 0 ELSE csr_interop_mat%first_row = first_row_all(mepos - 1) @@ -617,7 +617,7 @@ CONTAINS END DO END DO - IF (natom .EQ. 0) THEN + IF (natom == 0) THEN transport_env%params%nsgf = C_NULL_PTR transport_env%params%zeff = C_NULL_PTR ELSE diff --git a/src/voronoi_interface.F b/src/voronoi_interface.F index d0fea25f01..6d12cb04f1 100644 --- a/src/voronoi_interface.F +++ b/src/voronoi_interface.F @@ -548,7 +548,7 @@ CONTAINS DO I2 = L2, U2 ! cycling through the CPUs, check if the current ray (I1,I2) is local to that CPU - IF (rspace_pw%pw_grid%para%mode .NE. PW_MODE_LOCAL) THEN + IF (rspace_pw%pw_grid%para%mode /= PW_MODE_LOCAL) THEN DO ip = 0, num_pe - 1 IF (rspace_pw%pw_grid%para%bo(1, 1, ip, 1) <= I1 - L1 + 1 & .AND. rspace_pw%pw_grid%para%bo(2, 1, ip, 1) >= I1 - L1 + 1 .AND. & diff --git a/src/wannier90.F b/src/wannier90.F index f568d5d697..e01bc20405 100644 --- a/src/wannier90.F +++ b/src/wannier90.F @@ -375,18 +375,18 @@ CONTAINS dist = SQRT((kpt_cart(1, 1) - vkpp(1))**2 & + (kpt_cart(2, 1) - vkpp(2))**2 + (kpt_cart(3, 1) - vkpp(3))**2) ! - IF ((dist .GT. kmesh_tol) .AND. (dist .GT. dnn0 + kmesh_tol)) THEN - IF (dist .LT. dnn1 - kmesh_tol) THEN + IF ((dist > kmesh_tol) .AND. (dist > dnn0 + kmesh_tol)) THEN + IF (dist < dnn1 - kmesh_tol) THEN dnn1 = dist ! found a closer shell counter = 0 END IF - IF (dist .GT. (dnn1 - kmesh_tol) .AND. dist .LT. (dnn1 + kmesh_tol)) THEN + IF (dist > (dnn1 - kmesh_tol) .AND. dist < (dnn1 + kmesh_tol)) THEN counter = counter + 1 ! count the multiplicity of the shell END IF END IF END DO END DO - IF (dnn1 .LT. eta - kmesh_tol) ndnntot = ndnntot + 1 + IF (dnn1 < eta - kmesh_tol) ndnntot = ndnntot + 1 dnn(nlist) = dnn1 multi(nlist) = counter dnn0 = dnn1 @@ -408,7 +408,7 @@ CONTAINS WRITE (stdout, '(1x,a)', advance='no') '| The following shells are used: ' DO ndnn = 1, num_shells - IF (ndnn .EQ. num_shells) THEN + IF (ndnn == num_shells) THEN WRITE (stdout, '(i3,1x)', advance='no') shell_list(ndnn) ELSE WRITE (stdout, '(i3,",")', advance='no') shell_list(ndnn) @@ -486,7 +486,7 @@ CONTAINS vkpp = vkpp2 + kpt_cart(:, nkp2) dist = SQRT((kpt_cart(1, nkp) - vkpp(1))**2 & + (kpt_cart(2, nkp) - vkpp(2))**2 + (kpt_cart(3, nkp) - vkpp(3))**2) - IF ((dist .GE. dnn(ndnn)*(1 - kmesh_tol)) .AND. (dist .LE. dnn(ndnn)*(1 + kmesh_tol))) THEN + IF ((dist >= dnn(ndnn)*(1 - kmesh_tol)) .AND. (dist <= dnn(ndnn)*(1 + kmesh_tol))) THEN nnx = nnx + 1 nnshell(nkp, ndnn) = nnshell(nkp, ndnn) + 1 nnlist(nkp, nnx) = nkp2 @@ -522,7 +522,7 @@ CONTAINS bb1 = bb1 + bk_local(i, nnx, 1)*bk_local(i, nnx, 1) bbn = bbn + bk_local(i, nnx, nkp)*bk_local(i, nnx, nkp) END DO - IF (ABS(SQRT(bb1) - SQRT(bbn)) .GT. kmesh_tol) THEN + IF (ABS(SQRT(bb1) - SQRT(bbn)) > kmesh_tol) THEN WRITE (stdout, '(1x,2f10.6)') bb1, bbn CPABORT('Non-symmetric k-point neighbours!') END IF @@ -546,11 +546,11 @@ CONTAINS ddelta = ddelta + wb_local(nnx)*bk_local(i, nnx, nkp)*bk_local(j, nnx, nkp) END DO END DO - IF ((i .EQ. j) .AND. (ABS(ddelta - 1.0_dp) .GT. kmesh_tol)) THEN + IF ((i == j) .AND. (ABS(ddelta - 1.0_dp) > kmesh_tol)) THEN WRITE (stdout, '(1x,2i3,f12.8)') i, j, ddelta CPABORT('Eq. (B1) not satisfied in kmesh_get (1)') END IF - IF ((i .NE. j) .AND. (ABS(ddelta) .GT. kmesh_tol)) THEN + IF ((i /= j) .AND. (ABS(ddelta) > kmesh_tol)) THEN WRITE (stdout, '(1x,2i3,f12.8)') i, j, ddelta CPABORT('Eq. (B1) not satisfied in kmesh_get (2)') END IF @@ -578,13 +578,13 @@ CONTAINS na = 0 DO nn = 1, nntot ifound = 0 - IF (na .NE. 0) THEN + IF (na /= 0) THEN DO nap = 1, na CALL utility_compar(bka(1, nap), bk_local(1, nn, 1), ispos, isneg) IF (isneg) ifound = 1 END DO END IF - IF (ifound .EQ. 0) THEN + IF (ifound == 0) THEN ! found new vector to add to set na = na + 1 bka(1, na) = bk_local(1, nn, 1) @@ -592,7 +592,7 @@ CONTAINS bka(3, na) = bk_local(3, nn, 1) END IF END DO - IF (na .NE. nnh) CPABORT('Did not find right number of bk directions') + IF (na /= nnh) CPABORT('Did not find right number of bk directions') WRITE (stdout, '(1x,a)') '| b_k Vectors (Bohr^-1) and Weights (Bohr^2) |' WRITE (stdout, '(1x,a)') '| ------------------------------------------ |' @@ -624,7 +624,7 @@ CONTAINS IF (ispos) neigh(nkp, na) = nn END DO ! check found - IF (neigh(nkp, na) .EQ. 0) THEN + IF (neigh(nkp, na) == 0) THEN WRITE (stdout, *) ' nkp,na=', nkp, na CPABORT('kmesh_get: failed to find neighbours for this kpoint') END IF @@ -928,7 +928,7 @@ CONTAINS vkpp = vkpp2 + kpt_cart(:, nkp2) dist = SQRT((kpt_cart(1, kpt) - vkpp(1))**2 & + (kpt_cart(2, kpt) - vkpp(2))**2 + (kpt_cart(3, kpt) - vkpp(3))**2) - IF ((dist .GE. shell_dist*(1.0_dp - kmesh_tol)) .AND. dist .LE. shell_dist*(1.0_dp + kmesh_tol)) THEN + IF ((dist >= shell_dist*(1.0_dp - kmesh_tol)) .AND. dist <= shell_dist*(1.0_dp + kmesh_tol)) THEN num_bvec = num_bvec + 1 bvector(:, num_bvec) = vkpp(:) - kpt_cart(:, kpt) END IF @@ -952,8 +952,8 @@ CONTAINS REAL(kind=dp), DIMENSION(3), INTENT(in) :: a, b LOGICAL, INTENT(out) :: ispos, isneg - ispos = SUM((a - b)**2) .LT. eps8 - isneg = SUM((a + b)**2) .LT. eps8 + ispos = SUM((a - b)**2) < eps8 + isneg = SUM((a + b)**2) < eps8 END SUBROUTINE utility_compar ! ************************************************************************************************** diff --git a/src/xas_env_types.F b/src/xas_env_types.F index 9ea9ee8c0f..53f885ad4e 100644 --- a/src/xas_env_types.F +++ b/src/xas_env_types.F @@ -365,7 +365,7 @@ CONTAINS NULLIFY (xas_env%unoccupied_orbs) END IF NULLIFY (xas_env%ao_mo_fm_pools) - IF (ASSOCIATED(xas_env%all_vectors) .AND. xas_env%nvirtual .GT. 0) THEN + IF (ASSOCIATED(xas_env%all_vectors) .AND. xas_env%nvirtual > 0) THEN CALL cp_fm_release(xas_env%all_vectors) DEALLOCATE (xas_env%all_vectors) NULLIFY (xas_env%all_vectors) diff --git a/src/xas_methods.F b/src/xas_methods.F index 9de16f26f8..0fc5fefa68 100644 --- a/src/xas_methods.F +++ b/src/xas_methods.F @@ -681,7 +681,7 @@ CONTAINS CALL get_mo_set(mos(my_spin), nao=nao, homo=homo, nmo=nmo, mo_coeff=mo_coeff, nelectron=nelectron) nvirtual2 = 0 - IF (xas_control%added_mos .GT. 0) THEN + IF (xas_control%added_mos > 0) THEN nvirtual2 = MIN(xas_control%added_mos, nao - nmo) xas_env%unoccupied_eps = xas_control%eps_added xas_env%unoccupied_max_iter = xas_control%max_iter_added @@ -827,7 +827,7 @@ CONTAINS CALL cp_fm_struct_release(tmp_fm_struct) !Array to store all the eigenstates: occupied and the required not occupied - IF (nvirtual2 .GT. 0) THEN + IF (nvirtual2 > 0) THEN ALLOCATE (xas_env%unoccupied_evals(nvirtual2)) NULLIFY (tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct, nrow_global=nao, & @@ -1641,7 +1641,7 @@ CONTAINS IF (output_unit > 0) WRITE (UNIT=output_unit, FMT="(I4)") state_of_atom(iat, istate) END IF END DO - IF (state_of_atom(iat, 1) == 0 .OR. state_of_atom(iat, 1) .GT. homo) THEN + IF (state_of_atom(iat, 1) == 0 .OR. state_of_atom(iat, 1) > homo) THEN CPABORT("A wrong state has been selected for excitation, check the Wannier centers") END IF END DO @@ -1715,7 +1715,7 @@ CONTAINS END IF END DO END IF - IF (state_of_atom(iat, 1) .GT. homo) THEN + IF (state_of_atom(iat, 1) > homo) THEN CPABORT("A wrong state has been selected for excitation, check the Wannier centers") END IF END DO diff --git a/src/xas_tdp_atom.F b/src/xas_tdp_atom.F index dec4f60fe7..9bcab345dd 100644 --- a/src/xas_tdp_atom.F +++ b/src/xas_tdp_atom.F @@ -354,9 +354,9 @@ CONTAINS !hack to convert string into integer READ (grid_info(igrid, 2), *, iostat=stat) na - IF (stat .NE. 0) CPABORT("The 'na' value for the GRID keyword must be an integer") + IF (stat /= 0) CPABORT("The 'na' value for the GRID keyword must be an integer") READ (grid_info(igrid, 3), *, iostat=stat) nr - IF (stat .NE. 0) CPABORT("The 'nr' value for the GRID keyword must be an integer") + IF (stat /= 0) CPABORT("The 'nr' value for the GRID keyword must be an integer") EXIT END IF END DO @@ -3120,7 +3120,7 @@ CONTAINS my_CG => harmonics%my_CG max_iso_not0 = harmonics%max_iso_not0 max_s_harm = harmonics%max_s_harm - CPASSERT(2*maxl .LE. indso(1, max_iso_not0)) + CPASSERT(2*maxl <= indso(1, max_iso_not0)) ALLOCATE (g1(nr), g2(nr), gg(nr, 0:2*maxl)) ALLOCATE (gfxcg(na, 0:2*maxl)) @@ -3138,7 +3138,7 @@ CONTAINS CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), & max_s_harm, lmax(iset1) + lmax(iset2), cg_list, cg_n_list, & max_iso_not0_local) - CPASSERT(max_iso_not0_local .LE. max_iso_not0) + CPASSERT(max_iso_not0_local <= max_iso_not0) n2 = nsoset(lmax(iset2)) DO ipgf1 = 1, npgf(iset1) diff --git a/src/xas_tdp_integrals.F b/src/xas_tdp_integrals.F index 53844fa2a2..295b4db797 100644 --- a/src/xas_tdp_integrals.F +++ b/src/xas_tdp_integrals.F @@ -193,7 +193,7 @@ CONTAINS !we check for rbc or rac because of symmetry in ab_nl CALL get_iterator_info(ac_iter, r=rac) rbc(:) = rac(:) - rab(:) - IF (.NOT. (ALL(ABS(rbc) .LE. 1.0E-8_dp) .OR. ALL(ABS(rac) .LE. 1.0E-8_dp))) CYCLE + IF (.NOT. (ALL(ABS(rbc) <= 1.0E-8_dp) .OR. ALL(ABS(rac) <= 1.0E-8_dp))) CYCLE END IF @@ -223,7 +223,7 @@ CONTAINS !we check for rbc or rac because of symmetry in ab_nl CALL get_iterator_info(ac_iter, r=rac) rbc(:) = rac(:) - rab(:) - IF (.NOT. (ALL(ABS(rbc) .LE. 1.0E-8_dp) .OR. ALL(ABS(rac) .LE. 1.0E-8_dp))) CYCLE + IF (.NOT. (ALL(ABS(rbc) <= 1.0E-8_dp) .OR. ALL(ABS(rac) <= 1.0E-8_dp))) CYCLE END IF @@ -946,7 +946,7 @@ CONTAINS !only take a,b,c if b,c (or a,c because of symmetry) share the same center CALL get_iterator_info(ac_iter, r=rac) rbc(:) = rac(:) - rab(:) - IF (.NOT. (ALL(ABS(rbc) .LE. 1.0E-8_dp) .OR. ALL(ABS(rac) .LE. 1.0E-8_dp))) CYCLE + IF (.NOT. (ALL(ABS(rbc) <= 1.0E-8_dp) .OR. ALL(ABS(rac) <= 1.0E-8_dp))) CYCLE END IF diff --git a/src/xas_tdp_kernel.F b/src/xas_tdp_kernel.F index a953b86a48..c43e6f52ff 100644 --- a/src/xas_tdp_kernel.F +++ b/src/xas_tdp_kernel.F @@ -1203,7 +1203,7 @@ CONTAINS jatom = ind(2) katom = ind(3) - IF (atom_k .NE. katom) CYCLE + IF (atom_k /= katom) CYCLE CALL dbt_get_block(ab_Q, ind, iabc, t_found) IF (.NOT. t_found) CYCLE diff --git a/src/xas_tdp_methods.F b/src/xas_tdp_methods.F index 7597674e11..f0f1de00a8 100644 --- a/src/xas_tdp_methods.F +++ b/src/xas_tdp_methods.F @@ -660,7 +660,7 @@ CONTAINS DO i = 1, nex_atoms at_ind = xas_tdp_env%ex_atom_indices(i) CALL get_atomic_kind(particle_set(at_ind)%atomic_kind, kind_number=j) - IF (ALL(ABS(xas_tdp_env%ex_kind_indices - j) .NE. 0)) THEN + IF (ALL(ABS(xas_tdp_env%ex_kind_indices - j) /= 0)) THEN k = k + 1 xas_tdp_env%ex_kind_indices(k) = j END IF @@ -714,7 +714,7 @@ CONTAINS CALL set_xas_tdp_env(xas_tdp_env, nex_atoms=nex_atoms, nex_kinds=nex_kinds) ! Verifying that the input was valid - IF (nmatch .NE. SIZE(xas_tdp_control%list_ex_kinds)) THEN + IF (nmatch /= SIZE(xas_tdp_control%list_ex_kinds)) THEN CPABORT("Invalid kind(s) for the KIND_LIST keyword.") END IF @@ -958,7 +958,7 @@ CONTAINS CALL rng_stream%shuffle(ex_atoms_of_kind(1:nex_atom)) nbatch = nex_atom/batch_size - IF (nbatch*batch_size .NE. nex_atom) nbatch = nbatch + 1 + IF (nbatch*batch_size /= nex_atom) nbatch = nbatch + 1 END SUBROUTINE get_ri_3c_batches @@ -1079,7 +1079,7 @@ CONTAINS !Overlap matrix sparsity occ = dbcsr_get_occupation(matrix_s(1)%matrix) - IF (ou .LE. 0) RETURN + IF (ou <= 0) RETURN !Reference calculation IF (xas_tdp_control%do_uks) THEN @@ -1241,7 +1241,7 @@ CONTAINS WRITE (UNIT=ou, FMT="(T3,A,I5)") & "GW2X| contraction batch size: ", xas_tdp_control%batch_size - IF ((INT(xas_tdp_control%c_os) .NE. 1) .OR. (INT(xas_tdp_control%c_ss) .NE. 1)) THEN + IF ((INT(xas_tdp_control%c_os) /= 1) .OR. (INT(xas_tdp_control%c_ss) /= 1)) THEN WRITE (UNIT=ou, FMT="(T3,A,F7.4,/,T3,A,F7.4)") & "GW2X| Same-spin scaling factor: ", xas_tdp_control%c_ss, & "GW2X| Opposite-spin scaling factor: ", xas_tdp_control%c_os @@ -2691,7 +2691,7 @@ CONTAINS !Check on NLUMO CALL section_vals_val_get(xas_tdp_section, "PRINT%PDOS%NLUMO", i_val=nlumo) - IF (nlumo .NE. 0) THEN + IF (nlumo /= 0) THEN CPWARN("NLUMO is irrelevant for XAS_TDP PDOS. It was overwritten to 0.") END IF CALL section_vals_val_set(xas_tdp_section, "PRINT%PDOS%NLUMO", i_val=0) @@ -2947,7 +2947,7 @@ CONTAINS IF (xas_tdp_control%n_excited > 0 .AND. xas_tdp_control%n_excited < nguess) THEN nguess = xas_tdp_control%n_excited/nspins ELSE IF (xas_tdp_control%e_range > 0.0_dp) THEN - nguess = COUNT(evals(nocc + 1:nao) - evals(nocc + 1) .LE. xas_tdp_control%e_range) + nguess = COUNT(evals(nocc + 1:nao) - evals(nocc + 1) <= xas_tdp_control%e_range) END IF !Give max weight to the first LUMOs diff --git a/src/xas_tdp_types.F b/src/xas_tdp_types.F index 730d4bdaa1..ab34e3c0d4 100644 --- a/src/xas_tdp_types.F +++ b/src/xas_tdp_types.F @@ -525,7 +525,7 @@ CONTAINS ALLOCATE (xas_tdp_control%grid_info(nrep, 3)) DO irep = 1, nrep CALL section_vals_val_get(xas_tdp_section, "GRID", i_rep_val=irep, c_vals=k_list) - IF (SIZE(k_list) .NE. 3) CPABORT("The GRID keyword needs three values") + IF (SIZE(k_list) /= 3) CPABORT("The GRID keyword needs three values") xas_tdp_control%grid_info(irep, :) = k_list END DO END IF @@ -552,11 +552,11 @@ CONTAINS i_val=xas_tdp_control%define_excited) IF (.NOT. ASSOCIATED(xas_tdp_control%list_ex_kinds)) THEN - IF (xas_tdp_control%define_excited .EQ. xas_tdp_by_index) THEN + IF (xas_tdp_control%define_excited == xas_tdp_by_index) THEN ALLOCATE (xas_tdp_control%list_ex_kinds(0)) - ELSE IF (xas_tdp_control%define_excited .EQ. xas_tdp_by_kind) THEN + ELSE IF (xas_tdp_control%define_excited == xas_tdp_by_kind) THEN CALL section_vals_val_get(xas_tdp_section, "DONOR_STATES%KIND_LIST", c_vals=k_list) @@ -570,11 +570,11 @@ CONTAINS END IF IF (.NOT. ASSOCIATED(xas_tdp_control%list_ex_atoms)) THEN - IF (xas_tdp_control%define_excited .EQ. xas_tdp_by_kind) THEN + IF (xas_tdp_control%define_excited == xas_tdp_by_kind) THEN ALLOCATE (xas_tdp_control%list_ex_atoms(0)) - ELSE IF (xas_tdp_control%define_excited .EQ. xas_tdp_by_index) THEN + ELSE IF (xas_tdp_control%define_excited == xas_tdp_by_index) THEN CALL section_vals_val_get(xas_tdp_section, "DONOR_STATES%ATOM_LIST", i_vals=a_list) @@ -593,7 +593,7 @@ CONTAINS ALLOCATE (xas_tdp_control%state_types(nrep, nexc)) DO irep = 1, nrep CALL section_vals_val_get(xas_tdp_section, "DONOR_STATES%STATE_TYPES", i_rep_val=irep, i_vals=t_list) - IF (SIZE(t_list) .NE. nexc) THEN + IF (SIZE(t_list) /= nexc) THEN CPABORT("The STATE_TYPES keywords do not have the correct number of entries.") END IF xas_tdp_control%state_types(irep, :) = t_list @@ -608,7 +608,7 @@ CONTAINS ! Deal with the KERNEL subsection CALL section_vals_val_get(xas_tdp_section, "KERNEL%XC_FUNCTIONAL%_SECTION_PARAMETERS_", & i_val=xc_param) - xas_tdp_control%do_xc = xc_param .NE. xc_none + xas_tdp_control%do_xc = xc_param /= xc_none CALL section_vals_val_get(xas_tdp_section, "KERNEL%EXACT_EXCHANGE%_SECTION_PARAMETERS_", & l_val=xas_tdp_control%do_hfx) diff --git a/src/xas_tdp_utils.F b/src/xas_tdp_utils.F index 535323c16c..db4735bde2 100644 --- a/src/xas_tdp_utils.F +++ b/src/xas_tdp_utils.F @@ -533,9 +533,9 @@ CONTAINS ot_elb = xas_tdp_env%lumo_evals(1)%array(1) IF (do_os) ot_elb = MIN(ot_elb, xas_tdp_env%lumo_evals(2)%array(1)) - ot_nevals = COUNT(xas_tdp_env%lumo_evals(1)%array - ot_elb .LE. xas_tdp_control%e_range) + ot_nevals = COUNT(xas_tdp_env%lumo_evals(1)%array - ot_elb <= xas_tdp_control%e_range) IF (do_os) ot_nevals = ot_nevals + & - COUNT(xas_tdp_env%lumo_evals(2)%array - ot_elb .LE. xas_tdp_control%e_range) + COUNT(xas_tdp_env%lumo_evals(2)%array - ot_elb <= xas_tdp_control%e_range) ELSE @@ -633,7 +633,7 @@ CONTAINS CALL dbcsr_multiply('N', 'N', 1.0_dp, donor_state%metric(2)%matrix, tmp_mat2, & 0.0_dp, tmp_mat, filter_eps=xas_tdp_control%eps_filter) CALL cp_dbcsr_sm_fm_multiply(tmp_mat, c_diff, c_sum, ncol=nrow) - WHERE (tmp_evals .NE. 0) scaling = -1.0_dp/tmp_evals + WHERE (tmp_evals /= 0) scaling = -1.0_dp/tmp_evals CALL cp_fm_column_scale(c_sum, scaling) ! Full TDDFT specific clean-up diff --git a/src/xas_tp_scf.F b/src/xas_tp_scf.F index 07717f03cd..7701a02966 100644 --- a/src/xas_tp_scf.F +++ b/src/xas_tp_scf.F @@ -540,7 +540,7 @@ CONTAINS component*component END DO ! i size - IF (sto_state_overlap .GT. max_overlap) THEN + IF (sto_state_overlap > max_overlap) THEN max_overlap = sto_state_overlap my_state = istate END IF @@ -558,7 +558,7 @@ CONTAINS CALL para_env%sync() !Calculate the virtual states from the KS matrix matrix_ks(1) - IF (nvirtual2 .GT. 0) THEN + IF (nvirtual2 > 0) THEN NULLIFY (mo_coeff) CALL get_mo_set(mos(my_spin), mo_coeff=mo_coeff, nmo=nmo) IF (output_unit > 0) THEN @@ -612,7 +612,7 @@ CONTAINS DO istate = 1, nmo all_evals(istate) = eigenvalues(istate) END DO - IF (nvirtual2 .GT. 0) THEN + IF (nvirtual2 > 0) THEN CALL cp_fm_to_fm(uno_orbs, all_vectors, ncol=nvirtual2, & source_start=1, target_start=1 + nmo) DO istate = 1, nvirtual2 diff --git a/src/xc/xc_tpss.F b/src/xc/xc_tpss.F index c744cdcd5e..063e6222c0 100644 --- a/src/xc/xc_tpss.F +++ b/src/xc/xc_tpss.F @@ -575,7 +575,7 @@ CONTAINS t561 = t197*t_s1 t562 = t201*t561 t569 = 0.1e1_dp/t208 - t571 = epsilon_cGGA .LT. epsilon_cGGA_1_0 + t571 = epsilon_cGGA < epsilon_cGGA_1_0 IF (t571) THEN marho = e_c_u_1_s1rho + t196*(0.2e1_dp*t541*t542 & *t_s1rho + t187*t197*(t546 + t549)*t205 - t554*t557*(t546 & @@ -606,7 +606,7 @@ CONTAINS t629 = t219*t_s2 t630 = t223*t629 t637 = 0.1e1_dp/t230 - t639 = epsilon_cGGA .LT. epsilon_cGGA_0_1 + t639 = epsilon_cGGA < epsilon_cGGA_0_1 IF (t639) THEN mbrho = e_c_u_1_s2rho + t218*(0.2e1_dp*t609*t610 & *t_s2rho + t187*t219*(t614 + t617)*t227 - t622*t625*(t614 & diff --git a/src/xc/xc_xpbe_hole_t_c_lr.F b/src/xc/xc_xpbe_hole_t_c_lr.F index 4724615844..1976977ffa 100644 --- a/src/xc/xc_xpbe_hole_t_c_lr.F +++ b/src/xc/xc_xpbe_hole_t_c_lr.F @@ -1244,13 +1244,13 @@ CONTAINS nm1 = n - 1 - IF (n .LT. 0 .OR. x .LT. 0.0_dp .OR. (x .EQ. 0.0_dp .AND. (n .EQ. 0 .OR. n .EQ. 1))) THEN + IF (n < 0 .OR. x < 0.0_dp .OR. (x == 0.0_dp .AND. (n == 0 .OR. n == 1))) THEN expint = HUGE(1.0_dp) - ELSE IF (n .EQ. 0) THEN !Special case. + ELSE IF (n == 0) THEN !Special case. expint = EXP(-x)/x - ELSE IF (x .EQ. 0.0_dp) THEN !Another special case. + ELSE IF (x == 0.0_dp) THEN !Another special case. expint = 1.0_dp/nm1 - ELSE IF (x .GT. 1.0_dp) THEN !Lentz's algorithm (5.2). + ELSE IF (x > 1.0_dp) THEN !Lentz's algorithm (5.2). b = x + n c = 1.0_dp/FPMIN d = 1.0_dp/b @@ -1262,13 +1262,13 @@ CONTAINS c = b + a/c del = c*d h = h*del - IF (ABS(del - 1.0_dp) .LT. EPS .OR. i == MAXIT) THEN + IF (ABS(del - 1.0_dp) < EPS .OR. i == MAXIT) THEN expint = h*EXP(-x) RETURN END IF END DO ELSE !Evaluate series. - IF (nm1 .NE. 0) THEN !Set first term. + IF (nm1 /= 0) THEN !Set first term. expint = 1.0_dp/nm1 ELSE expint = -LOG(x) - euler @@ -1276,7 +1276,7 @@ CONTAINS fact = 1.0_dp DO i = 1, MAXIT fact = -fact*x/i - IF (i .NE. nm1) THEN + IF (i /= nm1) THEN del = -fact/(i - nm1) ELSE psi = -euler !Compute I(n). @@ -1286,7 +1286,7 @@ CONTAINS del = fact*(-LOG(x) + psi) END IF expint = expint + del - IF (ABS(del) .LT. ABS(expint)*EPS) RETURN + IF (ABS(del) < ABS(expint)*EPS) RETURN END DO END IF RETURN diff --git a/src/xtb_matrices.F b/src/xtb_matrices.F index 454ea2d0d4..4d7ea9760e 100644 --- a/src/xtb_matrices.F +++ b/src/xtb_matrices.F @@ -1367,7 +1367,7 @@ CONTAINS ! *** Overlap condition number IF (.NOT. calculate_forces) THEN IF (cp_print_key_should_output(logger%iter_info, qs_env%input, & - "DFT%PRINT%OVERLAP_CONDITION") .NE. 0) THEN + "DFT%PRINT%OVERLAP_CONDITION") /= 0) THEN iw = cp_print_key_unit_nr(logger, qs_env%input, "DFT%PRINT%OVERLAP_CONDITION", & extension=".Log") CALL section_vals_val_get(qs_env%input, "DFT%PRINT%OVERLAP_CONDITION%1-NORM", l_val=norml1) diff --git a/src/xtb_parameters.F b/src/xtb_parameters.F index ba02a55dd3..276186b18e 100644 --- a/src/xtb_parameters.F +++ b/src/xtb_parameters.F @@ -615,7 +615,7 @@ CONTAINS kab = 1.0_dp custom = .FALSE. - IF (xtb_control%kab_nval .GT. 0) THEN + IF (xtb_control%kab_nval > 0) THEN DO j = 1, xtb_control%kab_nval IF ((za == xtb_control%kab_types(1, j) .AND. & zb == xtb_control%kab_types(2, j)) .OR. & diff --git a/tools/precommit/fortitude.toml b/tools/precommit/fortitude.toml index 99a1531111..f23a535a4f 100644 --- a/tools/precommit/fortitude.toml +++ b/tools/precommit/fortitude.toml @@ -7,7 +7,6 @@ ignore = [ "non-standard-file-extension", "implicit-external-procedures", # requires Fortran 2018 "missing-intent", - "deprecated-relational-operator", "missing-exit-or-cycle-label", "assumed-size", "unnamed-end-statement",