!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright 2000-2026 CP2K developers group <https://cp2k.org>                                   !
!                                                                                                  !
!   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
!--------------------------------------------------------------------------------------------------!

! **************************************************************************************************
!> \brief Routines for an energy correction on top of a Kohn-Sham calculation
!> \par History
!>       03.2014 created
!>       09.2019 Moved from KG to Kohn-Sham
!>       08.2022 Add Density-Corrected DFT methods
!>       04.2023 Add hybrid functionals for DC-DFT
!>       10.2024 Add external energy method
!> \author JGH
! **************************************************************************************************
MODULE energy_corrections
   USE accint_weights_forces,           ONLY: accint_weight_force
   USE admm_dm_methods,                 ONLY: admm_dm_calc_rho_aux
   USE admm_methods,                    ONLY: admm_mo_calc_rho_aux
   USE admm_types,                      ONLY: admm_type
   USE atomic_kind_types,               ONLY: atomic_kind_type,&
                                              get_atomic_kind,&
                                              get_atomic_kind_set
   USE basis_set_types,                 ONLY: get_gto_basis_set,&
                                              gto_basis_set_type
   USE bibliography,                    ONLY: Belleflamme2023,&
                                              cite_reference
   USE cell_types,                      ONLY: cell_type,&
                                              pbc
   USE cp_blacs_env,                    ONLY: cp_blacs_env_type
   USE cp_control_types,                ONLY: dft_control_type
   USE cp_dbcsr_api,                    ONLY: &
        dbcsr_add, dbcsr_copy, dbcsr_create, dbcsr_distribution_type, dbcsr_filter, &
        dbcsr_get_info, dbcsr_multiply, dbcsr_p_type, dbcsr_release, dbcsr_set, dbcsr_type, &
        dbcsr_type_symmetric
   USE cp_dbcsr_contrib,                ONLY: dbcsr_dot
   USE cp_dbcsr_cp2k_link,              ONLY: cp_dbcsr_alloc_block_from_nbl
   USE cp_dbcsr_operations,             ONLY: copy_dbcsr_to_fm,&
                                              cp_dbcsr_sm_fm_multiply,&
                                              dbcsr_allocate_matrix_set,&
                                              dbcsr_deallocate_matrix_set
   USE cp_files,                        ONLY: close_file,&
                                              open_file
   USE cp_fm_basic_linalg,              ONLY: cp_fm_scale_and_add,&
                                              cp_fm_trace
   USE cp_fm_struct,                    ONLY: cp_fm_struct_create,&
                                              cp_fm_struct_release,&
                                              cp_fm_struct_type
   USE cp_fm_types,                     ONLY: cp_fm_create,&
                                              cp_fm_get_info,&
                                              cp_fm_release,&
                                              cp_fm_set_submatrix,&
                                              cp_fm_to_fm,&
                                              cp_fm_type,&
                                              cp_fm_write_unformatted
   USE cp_log_handling,                 ONLY: cp_get_default_logger,&
                                              cp_logger_get_default_unit_nr,&
                                              cp_logger_type
   USE cp_output_handling,              ONLY: cp_p_file,&
                                              cp_print_key_finished_output,&
                                              cp_print_key_should_output,&
                                              cp_print_key_unit_nr
   USE cp_result_methods,               ONLY: cp_results_erase,&
                                              put_results
   USE cp_result_types,                 ONLY: cp_result_type
   USE cp_units,                        ONLY: cp_unit_from_cp2k
   USE distribution_1d_types,           ONLY: distribution_1d_type
   USE distribution_2d_types,           ONLY: distribution_2d_type
   USE ec_diag_solver,                  ONLY: ec_diag_solver_gamma,&
                                              ec_diag_solver_kp,&
                                              ec_ls_init,&
                                              ec_ls_solver,&
                                              ec_ot_diag_solver
   USE ec_efield_local,                 ONLY: ec_efield_integrals,&
                                              ec_efield_local_operator
   USE ec_env_types,                    ONLY: ec_env_potential_release,&
                                              energy_correction_type
   USE ec_external,                     ONLY: ec_ext_energy,&
                                              matrix_r_forces
   USE ec_methods,                      ONLY: create_kernel
   USE external_potential_types,        ONLY: all_potential_type,&
                                              get_potential,&
                                              gth_potential_type,&
                                              sgp_potential_type
   USE hartree_local_methods,           ONLY: Vh_1c_gg_integrals,&
                                              init_coulomb_local
   USE hartree_local_types,             ONLY: hartree_local_create,&
                                              hartree_local_release,&
                                              hartree_local_type
   USE hfx_exx,                         ONLY: add_exx_to_rhs,&
                                              calculate_exx
   USE input_constants,                 ONLY: &
        do_admm_aux_exch_func_none, ec_diagonalization, ec_functional_dc, ec_functional_ext, &
        ec_functional_harris, ec_matrix_sign, ec_matrix_tc2, ec_matrix_trs4, ec_ot_diag, &
        vdw_pairpot_dftd3, vdw_pairpot_dftd3bj, xc_vdw_fun_pairpot
   USE input_section_types,             ONLY: section_get_ival,&
                                              section_get_lval,&
                                              section_vals_duplicate,&
                                              section_vals_get,&
                                              section_vals_get_subs_vals,&
                                              section_vals_type,&
                                              section_vals_val_get,&
                                              section_vals_val_set
   USE kinds,                           ONLY: default_path_length,&
                                              default_string_length,&
                                              dp
   USE kpoint_io,                       ONLY: get_cell,&
                                              write_kpoints_file_header
   USE kpoint_methods,                  ONLY: kpoint_init_cell_index
   USE kpoint_types,                    ONLY: get_kpoint_info
   USE mao_basis,                       ONLY: mao_generate_basis
   USE mathlib,                         ONLY: det_3x3,&
                                              invmat_symm
   USE message_passing,                 ONLY: mp_para_env_type
   USE molecule_types,                  ONLY: molecule_type
   USE moments_utils,                   ONLY: get_reference_point
   USE parallel_gemm_api,               ONLY: parallel_gemm
   USE particle_types,                  ONLY: particle_type
   USE paw_proj_set_types,              ONLY: get_paw_proj_set,&
                                              paw_proj_set_type
   USE periodic_table,                  ONLY: ptable
   USE physcon,                         ONLY: bohr,&
                                              debye,&
                                              pascal
   USE pw_env_types,                    ONLY: pw_env_get,&
                                              pw_env_type
   USE pw_grid_types,                   ONLY: pw_grid_type
   USE pw_methods,                      ONLY: pw_axpy,&
                                              pw_copy,&
                                              pw_integral_ab,&
                                              pw_scale,&
                                              pw_transfer,&
                                              pw_zero
   USE pw_poisson_methods,              ONLY: pw_poisson_solve
   USE pw_poisson_types,                ONLY: pw_poisson_type
   USE pw_pool_types,                   ONLY: pw_pool_p_type,&
                                              pw_pool_type
   USE pw_types,                        ONLY: pw_c1d_gs_type,&
                                              pw_r3d_rs_type
   USE qs_collocate_density,            ONLY: calculate_rho_elec
   USE qs_core_energies,                ONLY: calculate_ecore_overlap,&
                                              calculate_ptrace
   USE qs_core_matrices,                ONLY: core_matrices,&
                                              kinetic_energy_matrix
   USE qs_dispersion_pairpot,           ONLY: calculate_dispersion_pairpot
   USE qs_dispersion_types,             ONLY: qs_dispersion_type
   USE qs_energy_types,                 ONLY: qs_energy_type
   USE qs_environment_types,            ONLY: get_qs_env,&
                                              qs_environment_type,&
                                              set_qs_env
   USE qs_force_types,                  ONLY: allocate_qs_force,&
                                              deallocate_qs_force,&
                                              qs_force_type,&
                                              total_qs_force,&
                                              zero_qs_force
   USE qs_gapw_densities,               ONLY: prepare_gapw_den
   USE qs_integrate_potential,          ONLY: integrate_v_core_rspace,&
                                              integrate_v_rspace
   USE qs_kind_types,                   ONLY: get_qs_kind,&
                                              get_qs_kind_set,&
                                              qs_kind_type
   USE qs_kinetic,                      ONLY: build_kinetic_matrix
   USE qs_ks_atom,                      ONLY: update_ks_atom
   USE qs_ks_methods,                   ONLY: calc_rho_tot_gspace
   USE qs_ks_reference,                 ONLY: ks_ref_potential,&
                                              ks_ref_potential_atom
   USE qs_ks_types,                     ONLY: qs_ks_env_type
   USE qs_local_rho_types,              ONLY: local_rho_set_create,&
                                              local_rho_set_release,&
                                              local_rho_type
   USE qs_moments,                      ONLY: build_local_moment_matrix
   USE qs_neighbor_list_types,          ONLY: neighbor_list_set_p_type
   USE qs_neighbor_lists,               ONLY: atom2d_build,&
                                              atom2d_cleanup,&
                                              build_neighbor_lists,&
                                              local_atoms_type,&
                                              pair_radius_setup
   USE qs_oce_methods,                  ONLY: build_oce_matrices
   USE qs_oce_types,                    ONLY: allocate_oce_set,&
                                              create_oce_set,&
                                              oce_matrix_type
   USE qs_overlap,                      ONLY: build_overlap_matrix
   USE qs_rho0_ggrid,                   ONLY: integrate_vhg0_rspace,&
                                              rho0_s_grid_create
   USE qs_rho0_methods,                 ONLY: init_rho0
   USE qs_rho_atom_methods,             ONLY: allocate_rho_atom_internals,&
                                              calculate_rho_atom_coeff
   USE qs_rho_types,                    ONLY: qs_rho_get,&
                                              qs_rho_type
   USE qs_vxc,                          ONLY: qs_vxc_create
   USE qs_vxc_atom,                     ONLY: calculate_vxc_atom
   USE response_solver,                 ONLY: response_calculation,&
                                              response_force
   USE string_utilities,                ONLY: uppercase
   USE task_list_methods,               ONLY: generate_qs_task_list
   USE task_list_types,                 ONLY: allocate_task_list,&
                                              deallocate_task_list,&
                                              task_list_type
   USE trexio_utils,                    ONLY: write_trexio
   USE virial_methods,                  ONLY: one_third_sum_diag,&
                                              write_stress_tensor,&
                                              write_stress_tensor_components
   USE virial_types,                    ONLY: symmetrize_virial,&
                                              virial_type,&
                                              zero_virial
   USE voronoi_interface,               ONLY: entry_voronoi_or_bqb
#include "./base/base_uses.f90"

   IMPLICIT NONE

   PRIVATE

   ! Global parameters

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'energy_corrections'

   PUBLIC :: energy_correction

CONTAINS

! **************************************************************************************************
!> \brief Energy Correction to a Kohn-Sham simulation
!>        Available energy corrections: (1) Harris energy functional
!>                                      (2) Density-corrected DFT
!>                                      (3) Energy from external source
!>
!> \param qs_env ...
!> \param ec_init ...
!> \param calculate_forces ...
!> \par History
!>       03.2014 created
!> \author JGH
! **************************************************************************************************
   SUBROUTINE energy_correction(qs_env, ec_init, calculate_forces)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      LOGICAL, INTENT(IN), OPTIONAL                      :: ec_init, calculate_forces

      CHARACTER(len=*), PARAMETER                        :: routineN = 'energy_correction'

      INTEGER                                            :: handle, unit_nr
      LOGICAL                                            :: my_calc_forces
      TYPE(cp_logger_type), POINTER                      :: logger
      TYPE(energy_correction_type), POINTER              :: ec_env
      TYPE(qs_energy_type), POINTER                      :: energy
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: ks_force
      TYPE(virial_type), POINTER                         :: virial

      CALL timeset(routineN, handle)

      logger => cp_get_default_logger()
      IF (logger%para_env%is_source()) THEN
         unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
      ELSE
         unit_nr = -1
      END IF

      CALL cite_reference(Belleflamme2023)

      NULLIFY (ec_env)
      CALL get_qs_env(qs_env, ec_env=ec_env)

      ! Skip energy correction if ground-state is NOT converged
      IF (.NOT. ec_env%do_skip) THEN

         ec_env%should_update = .TRUE.
         IF (PRESENT(ec_init)) ec_env%should_update = ec_init

         my_calc_forces = .FALSE.
         IF (PRESENT(calculate_forces)) my_calc_forces = calculate_forces

         IF (ec_env%should_update) THEN
            ec_env%old_etotal = 0.0_dp
            ec_env%etotal = 0.0_dp
            ec_env%eband = 0.0_dp
            ec_env%ehartree = 0.0_dp
            ec_env%ex = 0.0_dp
            ec_env%exc = 0.0_dp
            ec_env%vhxc = 0.0_dp
            ec_env%edispersion = 0.0_dp
            ec_env%exc_aux_fit = 0.0_dp
            ec_env%ekTS = 0.0_dp
            ec_env%exc1 = 0.0_dp
            ec_env%ehartree_1c = 0.0_dp
            ec_env%exc1_aux_fit = 0.0_dp

            ! Save total energy of reference calculation
            CALL get_qs_env(qs_env, energy=energy)
            ec_env%old_etotal = energy%total

         END IF

         IF (my_calc_forces) THEN
            IF (unit_nr > 0) THEN
               WRITE (unit_nr, '(T2,A,A,A,A,A)') "!", REPEAT("-", 25), &
                  " Energy Correction Forces ", REPEAT("-", 26), "!"
            END IF
            CALL get_qs_env(qs_env, force=ks_force, virial=virial)
            CALL zero_qs_force(ks_force)
            CALL zero_virial(virial, reset=.FALSE.)
         ELSE
            IF (unit_nr > 0) THEN
               WRITE (unit_nr, '(T2,A,A,A,A,A)') "!", REPEAT("-", 29), &
                  " Energy Correction ", REPEAT("-", 29), "!"
            END IF
         END IF

         ! Perform the energy correction
         CALL energy_correction_low(qs_env, ec_env, my_calc_forces, unit_nr)

         ! Update total energy in qs environment and amount fo correction
         IF (ec_env%should_update) THEN
            energy%nonscf_correction = ec_env%etotal - ec_env%old_etotal
            energy%total = ec_env%etotal
         END IF

         IF (.NOT. my_calc_forces .AND. unit_nr > 0) THEN
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Energy Correction ", energy%nonscf_correction
         END IF
         IF (unit_nr > 0) THEN
            WRITE (unit_nr, '(T2,A,A,A)') "!", REPEAT("-", 77), "!"
         END IF

      ELSE

         ! Ground-state energy calculation did not converge,
         ! do not calculate energy correction
         IF (unit_nr > 0) THEN
            WRITE (unit_nr, '(T2,A,A,A)') "!", REPEAT("-", 77), "!"
            WRITE (unit_nr, '(T2,A,A,A,A,A)') "!", REPEAT("-", 26), &
               " Skip Energy Correction ", REPEAT("-", 27), "!"
            WRITE (unit_nr, '(T2,A,A,A)') "!", REPEAT("-", 77), "!"
         END IF

      END IF

      CALL timestop(handle)

   END SUBROUTINE energy_correction

! **************************************************************************************************
!> \brief Energy Correction to a Kohn-Sham simulation
!>
!> \param qs_env ...
!> \param ec_env ...
!> \param calculate_forces ...
!> \param unit_nr ...
!> \par History
!>       03.2014 created
!> \author JGH
! **************************************************************************************************
   SUBROUTINE energy_correction_low(qs_env, ec_env, calculate_forces, unit_nr)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env
      LOGICAL, INTENT(IN)                                :: calculate_forces
      INTEGER, INTENT(IN)                                :: unit_nr

      INTEGER                                            :: ispin, nkind, nspins
      LOGICAL                                            :: debug_f, gapw, gapw_xc
      REAL(KIND=dp)                                      :: eps_fit, exc
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sap_oce
      TYPE(oce_matrix_type), POINTER                     :: oce
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(pw_env_type), POINTER                         :: pw_env
      TYPE(pw_pool_type), POINTER                        :: auxbas_pw_pool
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set

      IF (ec_env%should_update) THEN
         CALL ec_build_neighborlist(qs_env, ec_env)
         CALL ec_env_potential_release(ec_env)
         !
         CALL ks_ref_potential(qs_env, &
                               ec_env%vh_rspace, &
                               ec_env%vxc_rspace, &
                               ec_env%vtau_rspace, &
                               ec_env%vadmm_rspace, &
                               ec_env%ehartree, exc, &
                               vadmm_tau_rspace=ec_env%vadmm_tau_rspace)
         CALL ks_ref_potential_atom(qs_env, ec_env%local_rho_set, &
                                    ec_env%local_rho_set_admm, ec_env%vh_rspace)

         SELECT CASE (ec_env%energy_functional)
         CASE (ec_functional_harris)

            CALL ec_build_core_hamiltonian(qs_env, ec_env)
            CALL ec_build_ks_matrix(qs_env, ec_env)

            IF (ec_env%mao) THEN
               CPASSERT(.NOT. ec_env%do_kpoints)
               ! MAO basis
               IF (ASSOCIATED(ec_env%mao_coef)) CALL dbcsr_deallocate_matrix_set(ec_env%mao_coef)
               NULLIFY (ec_env%mao_coef)
               CALL mao_generate_basis(qs_env, ec_env%mao_coef, ref_basis_set="HARRIS", &
                                       max_iter=ec_env%mao_max_iter, eps_grad=ec_env%mao_eps_grad, &
                                       eps1_mao=ec_env%mao_eps1, iolevel=ec_env%mao_iolevel, unit_nr=unit_nr)
            END IF

            CALL ec_ks_solver(qs_env, ec_env)

            CALL evaluate_ec_core_matrix_traces(qs_env, ec_env)

            IF (ec_env%write_harris_wfn) THEN
               CALL harris_wfn_output(qs_env, ec_env, unit_nr)
            END IF

         CASE (ec_functional_dc)
            CPASSERT(.NOT. ec_env%do_kpoints)

            ! Prepare Density-corrected DFT (DC-DFT) calculation
            CALL ec_dc_energy(qs_env, ec_env, calculate_forces=.FALSE.)

            ! Rebuild KS matrix with DC-DFT XC functional evaluated in ground-state density.
            ! KS matrix might contain unwanted contributions
            ! Calculate Hartree and XC related energies here
            CALL ec_build_ks_matrix(qs_env, ec_env)

         CASE (ec_functional_ext)
            CPASSERT(.NOT. ec_env%do_kpoints)

            CALL ec_ext_energy(qs_env, ec_env, calculate_forces=.FALSE.)

         CASE DEFAULT
            CPABORT("unknown energy correction")
         END SELECT

         ! dispersion through pairpotentials
         CALL ec_disp(qs_env, ec_env, calculate_forces=.FALSE.)

         ! Calculate total energy
         CALL ec_energy(ec_env, unit_nr)

      END IF

      IF (calculate_forces) THEN

         debug_f = ec_env%debug_forces .OR. ec_env%debug_stress

         CALL get_qs_env(qs_env=qs_env, dft_control=dft_control)
         nspins = dft_control%nspins
         gapw = dft_control%qs_control%gapw
         gapw_xc = dft_control%qs_control%gapw_xc
         IF (gapw .OR. gapw_xc) THEN
            CALL get_qs_env(qs_env=qs_env, nkind=nkind, &
                            qs_kind_set=qs_kind_set, particle_set=particle_set)
            NULLIFY (oce, sap_oce)
            CALL get_qs_env(qs_env=qs_env, oce=oce, sap_oce=sap_oce)
            CALL create_oce_set(oce)
            CALL allocate_oce_set(oce, nkind)
            eps_fit = dft_control%qs_control%gapw_control%eps_fit
            CALL build_oce_matrices(oce%intac, .TRUE., 1, qs_kind_set, particle_set, &
                                    sap_oce, eps_fit)
            CALL set_qs_env(qs_env, oce=oce)
         END IF

         CALL ec_disp(qs_env, ec_env, calculate_forces=.TRUE.)

         SELECT CASE (ec_env%energy_functional)
         CASE (ec_functional_harris)

            CALL ec_build_core_hamiltonian_force(qs_env, ec_env, &
                                                 ec_env%matrix_p, &
                                                 ec_env%matrix_s, &
                                                 ec_env%matrix_w)
            CALL ec_build_ks_matrix_force(qs_env, ec_env)
            IF (ec_env%debug_external) THEN
               CALL write_response_interface(qs_env, ec_env)
               CALL init_response_deriv(qs_env, ec_env)
            END IF

         CASE (ec_functional_dc)

            CPASSERT(.NOT. ec_env%do_kpoints)
            ! Prepare Density-corrected DFT (DC-DFT) calculation
            ! by getting ground-state matrices
            CALL ec_dc_energy(qs_env, ec_env, calculate_forces=.TRUE.)

            CALL ec_build_core_hamiltonian_force(qs_env, ec_env, &
                                                 ec_env%matrix_p, &
                                                 ec_env%matrix_s, &
                                                 ec_env%matrix_w)
            CALL ec_dc_build_ks_matrix_force(qs_env, ec_env)
            IF (ec_env%debug_external) THEN
               CALL write_response_interface(qs_env, ec_env)
               CALL init_response_deriv(qs_env, ec_env)
            END IF

         CASE (ec_functional_ext)

            CPASSERT(.NOT. ec_env%do_kpoints)
            CALL ec_ext_energy(qs_env, ec_env, calculate_forces=.TRUE.)
            CALL init_response_deriv(qs_env, ec_env)
            ! orthogonality force
            CALL matrix_r_forces(qs_env, ec_env%cpmos, ec_env%mo_occ, &
                                 ec_env%matrix_w(1, 1)%matrix, unit_nr, &
                                 ec_env%debug_forces, ec_env%debug_stress)

         CASE DEFAULT
            CPABORT("unknown energy correction")
         END SELECT

         IF (ec_env%do_error) THEN
            ALLOCATE (ec_env%cpref(nspins))
            DO ispin = 1, nspins
               CALL cp_fm_create(ec_env%cpref(ispin), ec_env%cpmos(ispin)%matrix_struct)
               CALL cp_fm_to_fm(ec_env%cpmos(ispin), ec_env%cpref(ispin))
            END DO
         END IF

         CALL response_calculation(qs_env, ec_env)

         ! Allocate response density on real space grid for use in properties
         ! Calculated in response_force
         CALL get_qs_env(qs_env=qs_env, pw_env=pw_env)

         CPASSERT(ASSOCIATED(pw_env))
         CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool)
         ALLOCATE (ec_env%rhoz_r(nspins))
         DO ispin = 1, nspins
            CALL auxbas_pw_pool%create_pw(ec_env%rhoz_r(ispin))
         END DO

         CALL response_force(qs_env, &
                             vh_rspace=ec_env%vh_rspace, &
                             vxc_rspace=ec_env%vxc_rspace, &
                             vtau_rspace=ec_env%vtau_rspace, &
                             vadmm_rspace=ec_env%vadmm_rspace, &
                             vadmm_tau_rspace=ec_env%vadmm_tau_rspace, &
                             matrix_hz=ec_env%matrix_hz, &
                             matrix_pz=ec_env%matrix_z, &
                             matrix_pz_admm=ec_env%z_admm, &
                             matrix_wz=ec_env%matrix_wz, &
                             rhopz_r=ec_env%rhoz_r, &
                             zehartree=ec_env%ehartree, &
                             zexc=ec_env%exc, &
                             zexc_aux_fit=ec_env%exc_aux_fit, &
                             p_env=ec_env%p_env, &
                             debug=debug_f)

         CALL output_response_deriv(qs_env, ec_env, unit_nr)

         CALL ec_properties(qs_env, ec_env)

         IF (ec_env%do_error) THEN
            CALL response_force_error(qs_env, ec_env, unit_nr)
         END IF

         ! Deallocate Harris density and response density on grid
         IF (ASSOCIATED(ec_env%rhoout_r)) THEN
            DO ispin = 1, nspins
               CALL auxbas_pw_pool%give_back_pw(ec_env%rhoout_r(ispin))
            END DO
            DEALLOCATE (ec_env%rhoout_r)
         END IF
         IF (ASSOCIATED(ec_env%rhoz_r)) THEN
            DO ispin = 1, nspins
               CALL auxbas_pw_pool%give_back_pw(ec_env%rhoz_r(ispin))
            END DO
            DEALLOCATE (ec_env%rhoz_r)
         END IF

         ! Deallocate matrices
         IF (ASSOCIATED(ec_env%matrix_ks)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_ks)
         IF (ASSOCIATED(ec_env%matrix_h)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_h)
         IF (ASSOCIATED(ec_env%matrix_s)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_s)
         IF (ASSOCIATED(ec_env%matrix_t)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_t)
         IF (ASSOCIATED(ec_env%matrix_p)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_p)
         IF (ASSOCIATED(ec_env%matrix_w)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_w)
         IF (ASSOCIATED(ec_env%matrix_hz)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_hz)
         IF (ASSOCIATED(ec_env%matrix_wz)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_wz)
         IF (ASSOCIATED(ec_env%matrix_z)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_z)

      END IF

   END SUBROUTINE energy_correction_low

! **************************************************************************************************
!> \brief Output response information to TREXIO file (for testing external method read in)
!> \param qs_env ...
!> \param ec_env ...
!> \author JHU
! **************************************************************************************************
   SUBROUTINE write_response_interface(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      TYPE(section_vals_type), POINTER                   :: section, trexio_section

      section => section_vals_get_subs_vals(qs_env%input, "DFT%PRINT%TREXIO")
      NULLIFY (trexio_section)
      CALL section_vals_duplicate(section, trexio_section)
      CALL section_vals_val_set(trexio_section, "FILENAME", c_val=ec_env%exresp_fn)
      CALL section_vals_val_set(trexio_section, "CARTESIAN", l_val=.FALSE.)
      CALL write_trexio(qs_env, trexio_section, ec_env%matrix_hz)

   END SUBROUTINE write_response_interface

! **************************************************************************************************
!> \brief Initialize arrays for response derivatives
!> \param qs_env ...
!> \param ec_env ...
!> \author JHU
! **************************************************************************************************
   SUBROUTINE init_response_deriv(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      INTEGER                                            :: natom
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: force
      TYPE(virial_type), POINTER                         :: virial

      CALL get_qs_env(qs_env, natom=natom)
      ALLOCATE (ec_env%rf(3, natom))
      ec_env%rf = 0.0_dp
      ec_env%rpv = 0.0_dp
      CALL get_qs_env(qs_env, force=force, virial=virial)

      CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
      CALL total_qs_force(ec_env%rf, force, atomic_kind_set)

      IF (virial%pv_availability .AND. (.NOT. virial%pv_numer)) THEN
         ec_env%rpv = virial%pv_virial
      END IF

   END SUBROUTINE init_response_deriv

! **************************************************************************************************
!> \brief Write the reponse forces to file
!> \param qs_env ...
!> \param ec_env ...
!> \param unit_nr ...
!> \author JHU
! **************************************************************************************************
   SUBROUTINE output_response_deriv(qs_env, ec_env, unit_nr)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env
      INTEGER, INTENT(IN)                                :: unit_nr

      CHARACTER(LEN=default_string_length)               :: unit_string
      INTEGER                                            :: funit, ia, natom
      REAL(KIND=dp)                                      :: evol, fconv
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: ftot
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cell_type), POINTER                           :: cell
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: force
      TYPE(virial_type), POINTER                         :: virial

      IF (ASSOCIATED(ec_env%rf)) THEN
         CALL get_qs_env(qs_env, natom=natom)
         ALLOCATE (ftot(3, natom))
         ftot = 0.0_dp
         CALL get_qs_env(qs_env, force=force, virial=virial, para_env=para_env)

         CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
         CALL total_qs_force(ftot, force, atomic_kind_set)
         ec_env%rf(1:3, 1:natom) = ftot(1:3, 1:natom) - ec_env%rf(1:3, 1:natom)
         CALL para_env%sum(ec_env%rf)
         DEALLOCATE (ftot)

         IF (virial%pv_availability .AND. (.NOT. virial%pv_numer)) THEN
            ec_env%rpv = virial%pv_virial - ec_env%rpv
            CALL para_env%sum(ec_env%rpv)
            ! Volume terms
            evol = ec_env%exc + ec_env%exc_aux_fit + 2.0_dp*ec_env%ehartree
            ec_env%rpv(1, 1) = ec_env%rpv(1, 1) - evol
            ec_env%rpv(2, 2) = ec_env%rpv(2, 2) - evol
            ec_env%rpv(3, 3) = ec_env%rpv(3, 3) - evol
         END IF

         CALL get_qs_env(qs_env, particle_set=particle_set, cell=cell)
         ! Conversion factor a.u. -> GPa
         unit_string = "GPa"
         fconv = cp_unit_from_cp2k(1.0_dp/cell%deth, TRIM(unit_string))
         IF (unit_nr > 0) THEN
            WRITE (unit_nr, '(/,T2,A)') "Write EXTERNAL Response Derivative: "//TRIM(ec_env%exresult_fn)

            CALL open_file(ec_env%exresult_fn, file_status="REPLACE", file_form="FORMATTED", &
                           file_action="WRITE", unit_number=funit)
            WRITE (funit, "(T8,A,T58,A)") "COORDINATES [Bohr]", "RESPONSE FORCES [Hartree/Bohr]"
            DO ia = 1, natom
               WRITE (funit, "(2(3F15.8,5x))") particle_set(ia)%r(1:3), ec_env%rf(1:3, ia)
            END DO
            WRITE (funit, *)
            WRITE (funit, "(T8,A,T58,A)") "CELL [Bohr]", "RESPONSE PRESSURE [GPa]"
            DO ia = 1, 3
               WRITE (funit, "(3F15.8,5x,3F15.8)") cell%hmat(ia, 1:3), -fconv*ec_env%rpv(ia, 1:3)
            END DO

            CALL close_file(funit)
         END IF
      END IF

   END SUBROUTINE output_response_deriv

! **************************************************************************************************
!> \brief Calculates the traces of the core matrices and the density matrix.
!> \param qs_env ...
!> \param ec_env ...
!> \author Ole Schuett
!>         adapted for energy correction fbelle
! **************************************************************************************************
   SUBROUTINE evaluate_ec_core_matrix_traces(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER :: routineN = 'evaluate_ec_core_matrix_traces'

      INTEGER                                            :: handle
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(qs_energy_type), POINTER                      :: energy

      CALL timeset(routineN, handle)
      NULLIFY (energy)

      CALL get_qs_env(qs_env, dft_control=dft_control, energy=energy)

      ! Core hamiltonian energy
      CALL calculate_ptrace(ec_env%matrix_h, ec_env%matrix_p, energy%core, dft_control%nspins)

      ! kinetic energy
      CALL calculate_ptrace(ec_env%matrix_t, ec_env%matrix_p, energy%kinetic, dft_control%nspins)

      CALL timestop(handle)

   END SUBROUTINE evaluate_ec_core_matrix_traces

! **************************************************************************************************
!> \brief Prepare DC-DFT calculation by copying unaffected ground-state matrices (core Hamiltonian,
!>        density matrix) into energy correction environment and rebuild the overlap matrix
!>
!> \param qs_env ...
!> \param ec_env ...
!> \param calculate_forces ...
!> \par History
!>      07.2022 created
!> \author fbelle
! **************************************************************************************************
   SUBROUTINE ec_dc_energy(qs_env, ec_env, calculate_forces)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env
      LOGICAL, INTENT(IN)                                :: calculate_forces

      CHARACTER(LEN=*), PARAMETER                        :: routineN = 'ec_dc_energy'

      CHARACTER(LEN=default_string_length)               :: headline
      INTEGER                                            :: handle, ispin, nspins
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: matrix_h, matrix_p, matrix_s, matrix_w
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(qs_energy_type), POINTER                      :: energy
      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(qs_rho_type), POINTER                         :: rho

      CALL timeset(routineN, handle)

      NULLIFY (dft_control, ks_env, matrix_h, matrix_p, matrix_s, matrix_w, rho)
      CALL get_qs_env(qs_env=qs_env, &
                      dft_control=dft_control, &
                      ks_env=ks_env, &
                      matrix_h_kp=matrix_h, &
                      matrix_s_kp=matrix_s, &
                      matrix_w_kp=matrix_w, &
                      rho=rho)
      CALL qs_rho_get(rho, rho_ao_kp=matrix_p)
      nspins = dft_control%nspins

      ! For density-corrected DFT only the ground-state matrices are required
      ! Comply with ec_env environment for property calculations later
      CALL build_overlap_matrix(ks_env, matrixkp_s=ec_env%matrix_s, &
                                matrix_name="OVERLAP MATRIX", &
                                basis_type_a="HARRIS", &
                                basis_type_b="HARRIS", &
                                sab_nl=ec_env%sab_orb)

      ! Core Hamiltonian matrix
      IF (ASSOCIATED(ec_env%matrix_h)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_h)
      CALL dbcsr_allocate_matrix_set(ec_env%matrix_h, 1, 1)
      headline = "CORE HAMILTONIAN MATRIX"
      ALLOCATE (ec_env%matrix_h(1, 1)%matrix)
      CALL dbcsr_create(ec_env%matrix_h(1, 1)%matrix, name=TRIM(headline), &
                        template=matrix_s(1, 1)%matrix, matrix_type=dbcsr_type_symmetric)
      CALL cp_dbcsr_alloc_block_from_nbl(ec_env%matrix_h(1, 1)%matrix, ec_env%sab_orb)
      CALL dbcsr_copy(ec_env%matrix_h(1, 1)%matrix, matrix_h(1, 1)%matrix)

      ! Density matrix
      IF (ASSOCIATED(ec_env%matrix_p)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_p)
      CALL dbcsr_allocate_matrix_set(ec_env%matrix_p, nspins, 1)
      headline = "DENSITY MATRIX"
      DO ispin = 1, nspins
         ALLOCATE (ec_env%matrix_p(ispin, 1)%matrix)
         CALL dbcsr_create(ec_env%matrix_p(ispin, 1)%matrix, name=TRIM(headline), &
                           template=matrix_s(1, 1)%matrix, matrix_type=dbcsr_type_symmetric)
         CALL cp_dbcsr_alloc_block_from_nbl(ec_env%matrix_p(ispin, 1)%matrix, ec_env%sab_orb)
         CALL dbcsr_copy(ec_env%matrix_p(ispin, 1)%matrix, matrix_p(ispin, 1)%matrix)
      END DO

      IF (calculate_forces) THEN

         ! Energy-weighted density matrix
         IF (ASSOCIATED(ec_env%matrix_w)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_w)
         CALL dbcsr_allocate_matrix_set(ec_env%matrix_w, nspins, 1)
         headline = "ENERGY-WEIGHTED DENSITY MATRIX"
         DO ispin = 1, nspins
            ALLOCATE (ec_env%matrix_w(ispin, 1)%matrix)
            CALL dbcsr_create(ec_env%matrix_w(ispin, 1)%matrix, name=TRIM(headline), &
                              template=matrix_s(1, 1)%matrix, matrix_type=dbcsr_type_symmetric)
            CALL cp_dbcsr_alloc_block_from_nbl(ec_env%matrix_w(ispin, 1)%matrix, ec_env%sab_orb)
            CALL dbcsr_copy(ec_env%matrix_w(ispin, 1)%matrix, matrix_w(ispin, 1)%matrix)
         END DO

      END IF

      ! Electronic entropy term
      CALL get_qs_env(qs_env=qs_env, energy=energy)
      ec_env%ekTS = energy%ktS

      ! External field (nonperiodic case)
      ec_env%efield_nuclear = 0.0_dp
      ec_env%efield_elec = 0.0_dp
      CALL ec_efield_local_operator(qs_env, ec_env, calculate_forces=.FALSE.)

      CALL timestop(handle)

   END SUBROUTINE ec_dc_energy

! **************************************************************************************************
!> \brief Kohn-Sham matrix contributions to force in DC-DFT
!>        also calculate right-hand-side matrix B for response equations AX=B
!> \param qs_env ...
!> \param ec_env ...
!> \par History
!>      08.2022 adapted from qs_ks_build_kohn_sham_matrix
!> \author fbelle
! **************************************************************************************************
   SUBROUTINE ec_dc_build_ks_matrix_force(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER :: routineN = 'ec_dc_build_ks_matrix_force'

      CHARACTER(LEN=default_string_length)               :: basis_type, unit_string
      INTEGER                                            :: handle, i, iounit, ispin, natom, nspins
      LOGICAL                                            :: debug_forces, debug_stress, do_ec_hfx, &
                                                            gapw, gapw_xc, use_virial
      REAL(dp)                                           :: dummy_real, dummy_real2(2), ehartree, &
                                                            ehartree_1c, eovrl, exc, exc1, fconv
      REAL(dp), ALLOCATABLE, DIMENSION(:, :)             :: ftot
      REAL(dp), DIMENSION(3)                             :: fodeb, fodeb2
      REAL(KIND=dp), DIMENSION(3, 3)                     :: h_stress, pv_loc, stdeb, sttot
      TYPE(admm_type), POINTER                           :: admm_env
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cell_type), POINTER                           :: cell
      TYPE(cp_logger_type), POINTER                      :: logger
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: matrix_s, scrm
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: matrix_p
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(hartree_local_type), POINTER                  :: hartree_local
      TYPE(local_rho_type), POINTER                      :: local_rho_set
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_orb
      TYPE(oce_matrix_type), POINTER                     :: oce
      TYPE(pw_c1d_gs_type)                               :: rho_tot_gspace, v_hartree_gspace
      TYPE(pw_env_type), POINTER                         :: pw_env
      TYPE(pw_grid_type), POINTER                        :: pw_grid
      TYPE(pw_poisson_type), POINTER                     :: poisson_env
      TYPE(pw_pool_type), POINTER                        :: auxbas_pw_pool
      TYPE(pw_r3d_rs_type)                               :: v_hartree_rspace
      TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER        :: rho_r, v_rspace, v_rspace_in, &
                                                            v_tau_rspace
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: force
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(qs_rho_type), POINTER                         :: rho, rho1, rho_struct, rho_xc
      TYPE(section_vals_type), POINTER                   :: ec_hfx_sections
      TYPE(task_list_type), POINTER                      :: task_list
      TYPE(virial_type), POINTER                         :: virial

      CALL timeset(routineN, handle)

      debug_forces = ec_env%debug_forces
      debug_stress = ec_env%debug_stress

      logger => cp_get_default_logger()
      IF (logger%para_env%is_source()) THEN
         iounit = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
      ELSE
         iounit = -1
      END IF

      NULLIFY (atomic_kind_set, cell, dft_control, force, ks_env, &
               matrix_p, matrix_s, para_env, pw_env, rho, sab_orb, virial)
      CALL get_qs_env(qs_env=qs_env, &
                      cell=cell, &
                      dft_control=dft_control, &
                      force=force, &
                      ks_env=ks_env, &
                      matrix_s=matrix_s, &
                      para_env=para_env, &
                      pw_env=pw_env, &
                      rho=rho, &
                      rho_xc=rho_xc, &
                      virial=virial)
      CPASSERT(ASSOCIATED(pw_env))

      nspins = dft_control%nspins
      use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer)

      fconv = 1.0E-9_dp*pascal/cell%deth
      IF (debug_stress .AND. use_virial) THEN
         sttot = virial%pv_virial
      END IF

      ! check for GAPW/GAPW_XC
      gapw = dft_control%qs_control%gapw
      gapw_xc = dft_control%qs_control%gapw_xc
      IF (gapw_xc) THEN
         CPASSERT(ASSOCIATED(rho_xc))
      END IF
      IF (gapw .OR. gapw_xc) THEN
         IF (use_virial) THEN
            CPABORT("DC-DFT + GAPW + Stress NYA")
         END IF
      END IF

      ! Get density matrix of reference calculation
      CALL qs_rho_get(rho, rho_ao_kp=matrix_p)

      NULLIFY (hartree_local, local_rho_set)
      IF (gapw .OR. gapw_xc) THEN
         CALL get_qs_env(qs_env, &
                         atomic_kind_set=atomic_kind_set, &
                         qs_kind_set=qs_kind_set)
         CALL local_rho_set_create(local_rho_set)
         CALL allocate_rho_atom_internals(local_rho_set%rho_atom_set, atomic_kind_set, &
                                          qs_kind_set, dft_control, para_env)
         IF (gapw) THEN
            CALL get_qs_env(qs_env, natom=natom)
            CALL init_rho0(local_rho_set, qs_env, dft_control%qs_control%gapw_control)
            CALL rho0_s_grid_create(pw_env, local_rho_set%rho0_mpole)
            CALL hartree_local_create(hartree_local)
            CALL init_coulomb_local(hartree_local, natom)
         END IF

         CALL get_qs_env(qs_env=qs_env, oce=oce, sab_orb=sab_orb)
         CALL calculate_rho_atom_coeff(qs_env, matrix_p, local_rho_set%rho_atom_set, &
                                       qs_kind_set, oce, sab_orb, para_env)
         CALL prepare_gapw_den(qs_env, local_rho_set, do_rho0=gapw)
      END IF

      NULLIFY (auxbas_pw_pool, poisson_env)
      ! gets the tmp grids
      CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, &
                      poisson_env=poisson_env)

      ! Calculate the Hartree potential
      CALL auxbas_pw_pool%create_pw(v_hartree_gspace)
      CALL auxbas_pw_pool%create_pw(rho_tot_gspace)
      CALL auxbas_pw_pool%create_pw(v_hartree_rspace)

      ! Get the total input density in g-space [ions + electrons]
      CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho)

      ! v_H[n_in]
      IF (use_virial) THEN

         ! Stress tensor - Volume and Green function contribution
         h_stress(:, :) = 0.0_dp
         CALL pw_poisson_solve(poisson_env, &
                               density=rho_tot_gspace, &
                               ehartree=ehartree, &
                               vhartree=v_hartree_gspace, &
                               h_stress=h_stress)

         virial%pv_ehartree = virial%pv_ehartree + h_stress/REAL(para_env%num_pe, dp)
         virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe, dp)

         IF (debug_stress) THEN
            stdeb = fconv*(h_stress/REAL(para_env%num_pe, dp))
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| GREEN 1st V_H[n_in]*n_in  ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF

      ELSE
         CALL pw_poisson_solve(poisson_env, rho_tot_gspace, ehartree, &
                               v_hartree_gspace)
      END IF

      CALL pw_transfer(v_hartree_gspace, v_hartree_rspace)
      CALL pw_scale(v_hartree_rspace, v_hartree_rspace%pw_grid%dvol)

      ! Save density on real space grid for use in properties
      CALL qs_rho_get(rho, rho_r=rho_r)
      ALLOCATE (ec_env%rhoout_r(nspins))
      DO ispin = 1, nspins
         CALL auxbas_pw_pool%create_pw(ec_env%rhoout_r(ispin))
         CALL pw_copy(rho_r(ispin), ec_env%rhoout_r(ispin))
      END DO

      ! Getting nuclear force contribution from the core charge density
      ! Vh(rho_c + rho_in)
      IF (debug_forces) fodeb(1:3) = force(1)%rho_core(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_ehartree
      CALL integrate_v_core_rspace(v_hartree_rspace, qs_env)
      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%rho_core(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Vtot*dncore", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_ehartree - stdeb)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| Vtot*dncore', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      ! v_XC[n_in]_DC
      ! v_rspace and v_tau_rspace are generated from the auxbas pool
      NULLIFY (v_rspace, v_tau_rspace)

      ! only activate stress calculation if
      IF (use_virial) virial%pv_calculate = .TRUE.

      ! Exchange-correlation potential
      IF (gapw_xc) THEN
         CALL get_qs_env(qs_env=qs_env, rho_xc=rho_struct)
      ELSE
         CALL get_qs_env(qs_env=qs_env, rho=rho_struct)
      END IF
      CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_struct, xc_section=ec_env%xc_section, &
                         vxc_rho=v_rspace, vxc_tau=v_tau_rspace, exc=exc, just_energy=.FALSE.)

      IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
      !
      NULLIFY (rho1)
      CALL accint_weight_force(qs_env, rho_struct, rho1, 0, ec_env%xc_section)
      !
      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Fxc*dw        ", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_virial - stdeb)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| INT Fxc*dw        ', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      IF (.NOT. ASSOCIATED(v_rspace)) THEN
         ALLOCATE (v_rspace(nspins))
         DO ispin = 1, nspins
            CALL auxbas_pw_pool%create_pw(v_rspace(ispin))
            CALL pw_zero(v_rspace(ispin))
         END DO
      END IF

      IF (use_virial) THEN
         virial%pv_exc = virial%pv_exc - virial%pv_xc
         virial%pv_virial = virial%pv_virial - virial%pv_xc
         ! virial%pv_xc will be zeroed in the xc routines
      END IF

      ! initialize srcm matrix
      NULLIFY (scrm)
      CALL dbcsr_allocate_matrix_set(scrm, nspins)
      DO ispin = 1, nspins
         ALLOCATE (scrm(ispin)%matrix)
         CALL dbcsr_create(scrm(ispin)%matrix, template=ec_env%matrix_ks(ispin, 1)%matrix)
         CALL dbcsr_copy(scrm(ispin)%matrix, ec_env%matrix_ks(ispin, 1)%matrix)
         CALL dbcsr_set(scrm(ispin)%matrix, 0.0_dp)
      END DO

      pw_grid => v_hartree_rspace%pw_grid
      ALLOCATE (v_rspace_in(nspins))
      DO ispin = 1, nspins
         CALL v_rspace_in(ispin)%create(pw_grid)
      END DO

      ! v_rspace_in = v_H[n_in] + v_xc[n_in] calculated in ks_ref_potential
      DO ispin = 1, nspins
         ! v_xc[n_in]_GS
         CALL pw_transfer(ec_env%vxc_rspace(ispin), v_rspace_in(ispin))
         IF (.NOT. gapw_xc) THEN
            ! add v_H[n_in] this is not really needed, see further down
            !               but we do it for historical reasons
            ! for gapw_xc we have to skip it as it is not integrated on the same grid
            CALL pw_axpy(ec_env%vh_rspace, v_rspace_in(ispin))
         END IF
      END DO

      ! If hybrid functional in DC-DFT
      ec_hfx_sections => section_vals_get_subs_vals(qs_env%input, "DFT%ENERGY_CORRECTION%XC%HF")
      CALL section_vals_get(ec_hfx_sections, explicit=do_ec_hfx)

      IF (do_ec_hfx) THEN

         IF ((gapw .OR. gapw_xc) .AND. ec_env%do_ec_admm) THEN
            CALL get_qs_env(qs_env, admm_env=admm_env)
            IF (admm_env%aux_exch_func /= do_admm_aux_exch_func_none) THEN
               ! define proper xc_section
               CPABORT("GAPW HFX ADMM + Energy Correction NYA")
            END IF
         END IF

         IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
         IF (debug_forces) fodeb2(1:3) = force(1)%overlap_admm(1:3, 1)

         ! Calculate direct HFX forces here
         ! Virial contribution (fock_4c) done inside calculate_exx
         dummy_real = 0.0_dp
         CALL calculate_exx(qs_env=qs_env, &
                            unit_nr=iounit, &
                            hfx_sections=ec_hfx_sections, &
                            x_data=ec_env%x_data, &
                            do_gw=.FALSE., &
                            do_admm=ec_env%do_ec_admm, &
                            calc_forces=.TRUE., &
                            reuse_hfx=ec_env%reuse_hfx, &
                            do_im_time=.FALSE., &
                            E_ex_from_GW=dummy_real, &
                            E_admm_from_GW=dummy_real2, &
                            t3=dummy_real)

         IF (debug_forces) THEN
            fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
            CALL para_env%sum(fodeb)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*hfx_DC ", fodeb

            fodeb2(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb2(1:3)
            CALL para_env%sum(fodeb2)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*hfx_DC*S ", fodeb2
         END IF
         IF (debug_stress .AND. use_virial) THEN
            stdeb = -1.0_dp*fconv*virial%pv_fock_4c
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| P*hfx_DC ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF

      END IF

      ! Stress-tensor contribution derivative of integrand
      ! int v_Hxc[n_in]*n_out
      IF (use_virial) THEN
         pv_loc = virial%pv_virial
      END IF

      basis_type = "HARRIS"
      IF (gapw .OR. gapw_xc) THEN
         task_list => ec_env%task_list_soft
      ELSE
         task_list => ec_env%task_list
      END IF

      IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial

      DO ispin = 1, nspins
         ! Add v_H[n_in] + v_xc[n_in] = v_rspace
         CALL pw_scale(v_rspace(ispin), v_rspace(ispin)%pw_grid%dvol)
         IF (gapw_xc) THEN
            ! integrate over potential <a|Vxc|b>
            CALL integrate_v_rspace(v_rspace=v_rspace(ispin), &
                                    hmat=scrm(ispin), &
                                    pmat=matrix_p(ispin, 1), &
                                    qs_env=qs_env, &
                                    calculate_forces=.TRUE., &
                                    basis_type=basis_type, &
                                    task_list_external=task_list)
            ! integrate over potential <a|Vh|b>
            CALL integrate_v_rspace(v_rspace=v_hartree_rspace, &
                                    hmat=scrm(ispin), &
                                    pmat=matrix_p(ispin, 1), &
                                    qs_env=qs_env, &
                                    calculate_forces=.TRUE., &
                                    basis_type=basis_type, &
                                    task_list_external=ec_env%task_list)
         ELSE
            CALL pw_axpy(v_hartree_rspace, v_rspace(ispin))
            ! integrate over potential <a|V|b>
            CALL integrate_v_rspace(v_rspace=v_rspace(ispin), &
                                    hmat=scrm(ispin), &
                                    pmat=matrix_p(ispin, 1), &
                                    qs_env=qs_env, &
                                    calculate_forces=.TRUE., &
                                    basis_type=basis_type, &
                                    task_list_external=task_list)
         END IF
      END DO

      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pout*dVhxc ", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_virial - stdeb)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| INT Pout*dVhxc   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      IF (ASSOCIATED(v_tau_rspace)) THEN
         IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
         IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
         DO ispin = 1, nspins
            CALL pw_scale(v_tau_rspace(ispin), v_tau_rspace(ispin)%pw_grid%dvol)
            ! integrate over Tau-potential <nabla.a|V|nabla.b>
            CALL integrate_v_rspace(v_rspace=v_tau_rspace(ispin), &
                                    hmat=scrm(ispin), &
                                    pmat=matrix_p(ispin, 1), &
                                    qs_env=qs_env, &
                                    calculate_forces=.TRUE., &
                                    compute_tau=.TRUE., &
                                    basis_type=basis_type, &
                                    task_list_external=task_list)
         END DO

         IF (debug_forces) THEN
            fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
            CALL para_env%sum(fodeb)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pout*dVhxc_tau ", fodeb
         END IF
         IF (debug_stress .AND. use_virial) THEN
            stdeb = fconv*(virial%pv_virial - stdeb)
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| INT Pout*dVhxc_tau   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF
      END IF

      IF (gapw .OR. gapw_xc) THEN
         exc1 = 0.0_dp
         CALL calculate_vxc_atom(qs_env, .FALSE., exc1, &
                                 rho_atom_set_external=local_rho_set%rho_atom_set, &
                                 xc_section_external=ec_env%xc_section)
      END IF
      IF (gapw) THEN
         IF (debug_forces) fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1)
         CALL integrate_vhg0_rspace(qs_env, v_hartree_rspace, para_env, &
                                    calculate_forces=.TRUE., local_rho_set=local_rho_set)
         IF (debug_forces) THEN
            fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1) - fodeb(1:3)
            CALL para_env%sum(fodeb)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*g0s_Vh_elec ", fodeb
         END IF
         ehartree_1c = 0.0_dp
         CALL Vh_1c_gg_integrals(qs_env, ehartree_1c, hartree_local%ecoul_1c, local_rho_set, &
                                 para_env, tddft=.FALSE., core_2nd=.FALSE.)
      END IF

      IF (gapw .OR. gapw_xc) THEN
         ! Single atom contributions in the KS matrix ***
         IF (debug_forces) fodeb(1:3) = force(1)%vhxc_atom(1:3, 1)
         CALL update_ks_atom(qs_env, scrm, matrix_p, forces=.TRUE., &
                             rho_atom_external=local_rho_set%rho_atom_set)
         IF (debug_forces) THEN
            fodeb(1:3) = force(1)%vhxc_atom(1:3, 1) - fodeb(1:3)
            CALL para_env%sum(fodeb)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*vhxc_atom ", fodeb
         END IF
      END IF

      ! Stress-tensor
      IF (use_virial) THEN
         virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
      END IF

      ! delete scrm matrix
      CALL dbcsr_deallocate_matrix_set(scrm)

      !----------------------------------------------------
      ! Right-hand-side matrix B for linear response equations AX = B
      !----------------------------------------------------

      ! RHS = int v_Hxc[n]_DC - v_Hxc[n]_GS dr + alpha_DC * E_X[n] - alpha_gs * E_X[n]
      !     = int v_Hxc[n]_DC - v_Hxc[n]_GS dr + alpha_DC / alpha_GS * E_X[n]_GS - E_X[n]_GS
      !
      ! with v_Hxc[n] = v_H[n] + v_xc[n]
      !
      ! Actually v_H[n_in] same for DC and GS, just there for convenience (v_H skipped for GAPW_XC)
      !          v_xc[n_in]_GS = 0 if GS is HF BUT =/0 if hybrid
      !          so, we keep this general form

      NULLIFY (ec_env%matrix_hz)
      CALL dbcsr_allocate_matrix_set(ec_env%matrix_hz, nspins)
      DO ispin = 1, nspins
         ALLOCATE (ec_env%matrix_hz(ispin)%matrix)
         CALL dbcsr_create(ec_env%matrix_hz(ispin)%matrix, template=matrix_s(1)%matrix)
         CALL dbcsr_copy(ec_env%matrix_hz(ispin)%matrix, matrix_s(1)%matrix)
         CALL dbcsr_set(ec_env%matrix_hz(ispin)%matrix, 0.0_dp)
      END DO

      DO ispin = 1, nspins
         ! v_rspace = v_rspace - v_rspace_in
         !          = v_Hxc[n_in]_DC - v_Hxc[n_in]_GS
         CALL pw_axpy(v_rspace_in(ispin), v_rspace(ispin), -1.0_dp)
      END DO

      DO ispin = 1, nspins
         CALL integrate_v_rspace(v_rspace=v_rspace(ispin), &
                                 hmat=ec_env%matrix_hz(ispin), &
                                 pmat=matrix_p(ispin, 1), &
                                 qs_env=qs_env, &
                                 calculate_forces=.FALSE., &
                                 basis_type=basis_type, &
                                 task_list_external=task_list)
      END DO

      ! Check if mGGA functionals are used
      IF (dft_control%use_kinetic_energy_density) THEN

         ! If DC-DFT without mGGA functional, this needs to be allocated now.
         IF (.NOT. ASSOCIATED(v_tau_rspace)) THEN
            ALLOCATE (v_tau_rspace(nspins))
            DO ispin = 1, nspins
               CALL auxbas_pw_pool%create_pw(v_tau_rspace(ispin))
               CALL pw_zero(v_tau_rspace(ispin))
            END DO
         END IF

         DO ispin = 1, nspins
            ! v_tau_rspace = v_Hxc_tau[n_in]_DC - v_Hxc_tau[n_in]_GS
            IF (ASSOCIATED(ec_env%vtau_rspace)) THEN
               CALL pw_axpy(ec_env%vtau_rspace(ispin), v_tau_rspace(ispin), -1.0_dp)
            END IF
            ! integrate over Tau-potential <nabla.a|V|nabla.b>
            CALL integrate_v_rspace(v_rspace=v_tau_rspace(ispin), &
                                    hmat=ec_env%matrix_hz(ispin), &
                                    pmat=matrix_p(ispin, 1), &
                                    qs_env=qs_env, &
                                    calculate_forces=.FALSE., compute_tau=.TRUE., &
                                    basis_type=basis_type, &
                                    task_list_external=task_list)
         END DO
      END IF

      IF (gapw .OR. gapw_xc) THEN
         ! Single atom contributions in the KS matrix ***
         ! DC-DFT
         CALL update_ks_atom(qs_env, ec_env%matrix_hz, matrix_p, .FALSE., &
                             rho_atom_external=local_rho_set%rho_atom_set, kintegral=1.0_dp)
         ! Ref
         CALL update_ks_atom(qs_env, ec_env%matrix_hz, matrix_p, .FALSE., &
                             rho_atom_external=ec_env%local_rho_set%rho_atom_set, kintegral=-1.0_dp)
      END IF

      ! Need to also subtract HFX contribution of reference calculation from ec_env%matrix_hz
      ! and/or add HFX contribution if DC-DFT ueses hybrid XC-functional
      CALL add_exx_to_rhs(rhs=ec_env%matrix_hz, &
                          qs_env=qs_env, &
                          ext_hfx_section=ec_hfx_sections, &
                          x_data=ec_env%x_data, &
                          recalc_integrals=.FALSE., &
                          do_admm=ec_env%do_ec_admm, &
                          do_ec=.TRUE., &
                          do_exx=.FALSE., &
                          reuse_hfx=ec_env%reuse_hfx)

      ! Core overlap
      IF (debug_forces) fodeb(1:3) = force(1)%core_overlap(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_ecore_overlap
      CALL calculate_ecore_overlap(qs_env, para_env, .TRUE., E_overlap_core=eovrl)
      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%core_overlap(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: CoreOverlap", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(stdeb - virial%pv_ecore_overlap)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| CoreOverlap   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      IF (debug_forces) THEN
         CALL get_qs_env(qs_env, natom=natom, atomic_kind_set=atomic_kind_set)
         ALLOCATE (ftot(3, natom))
         CALL total_qs_force(ftot, force, atomic_kind_set)
         fodeb(1:3) = ftot(1:3, 1)
         DEALLOCATE (ftot)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Force Explicit", fodeb
      END IF

      ! return gapw arrays
      IF (gapw .OR. gapw_xc) THEN
         CALL local_rho_set_release(local_rho_set)
      END IF
      IF (gapw) THEN
         CALL hartree_local_release(hartree_local)
      END IF

      ! return pw grids
      DO ispin = 1, nspins
         CALL auxbas_pw_pool%give_back_pw(v_rspace(ispin))
         CALL auxbas_pw_pool%give_back_pw(v_rspace_in(ispin))
         IF (ASSOCIATED(v_tau_rspace)) THEN
            CALL auxbas_pw_pool%give_back_pw(v_tau_rspace(ispin))
         END IF
      END DO

      DEALLOCATE (v_rspace, v_rspace_in)
      IF (ASSOCIATED(v_tau_rspace)) DEALLOCATE (v_tau_rspace)
      !
      CALL auxbas_pw_pool%give_back_pw(rho_tot_gspace)
      CALL auxbas_pw_pool%give_back_pw(v_hartree_gspace)
      CALL auxbas_pw_pool%give_back_pw(v_hartree_rspace)

      ! Stress tensor - volume terms need to be stored,
      ! for a sign correction in QS at the end of qs_force
      IF (use_virial) THEN
         IF (qs_env%energy_correction) THEN
            ec_env%ehartree = ehartree
            ec_env%exc = exc
         END IF
      END IF

      IF (debug_stress .AND. use_virial) THEN
         ! In total: -1.0*E_H
         stdeb = -1.0_dp*fconv*ehartree
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| VOL 1st v_H[n_in]*n_in', one_third_sum_diag(stdeb), det_3x3(stdeb)

         stdeb = -1.0_dp*fconv*exc
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| VOL 1st E_XC_DC[n_in]', one_third_sum_diag(stdeb), det_3x3(stdeb)

         ! For debugging, create a second virial environment,
         ! apply volume terms immediately
         BLOCK
            TYPE(virial_type) :: virdeb
            virdeb = virial

            CALL para_env%sum(virdeb%pv_overlap)
            CALL para_env%sum(virdeb%pv_ekinetic)
            CALL para_env%sum(virdeb%pv_ppl)
            CALL para_env%sum(virdeb%pv_ppnl)
            CALL para_env%sum(virdeb%pv_ecore_overlap)
            CALL para_env%sum(virdeb%pv_ehartree)
            CALL para_env%sum(virdeb%pv_exc)
            CALL para_env%sum(virdeb%pv_exx)
            CALL para_env%sum(virdeb%pv_vdw)
            CALL para_env%sum(virdeb%pv_mp2)
            CALL para_env%sum(virdeb%pv_nlcc)
            CALL para_env%sum(virdeb%pv_gapw)
            CALL para_env%sum(virdeb%pv_lrigpw)
            CALL para_env%sum(virdeb%pv_virial)
            CALL symmetrize_virial(virdeb)

            ! apply stress-tensor 1st terms
            DO i = 1, 3
               virdeb%pv_ehartree(i, i) = virdeb%pv_ehartree(i, i) - 2.0_dp*ehartree
               virdeb%pv_virial(i, i) = virdeb%pv_virial(i, i) - exc &
                                        - 2.0_dp*ehartree
               virdeb%pv_exc(i, i) = virdeb%pv_exc(i, i) - exc
               ! The factor 2 is a hack. It compensates the plus sign in h_stress/pw_poisson_solve.
               ! The sign in pw_poisson_solve is correct for FIST, but not for QS.
               ! There should be a more elegant solution to that ...
            END DO

            CALL para_env%sum(sttot)
            stdeb = fconv*(virdeb%pv_virial - sttot)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| Explicit electronic stress   ', one_third_sum_diag(stdeb), det_3x3(stdeb)

            stdeb = fconv*(virdeb%pv_virial)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| Explicit total stress   ', one_third_sum_diag(stdeb), det_3x3(stdeb)

            unit_string = "GPa" ! old default
            CALL write_stress_tensor_components(virdeb, iounit, cell, unit_string)
            CALL write_stress_tensor(virdeb%pv_virial, iounit, cell, unit_string, .FALSE.)

         END BLOCK
      END IF

      CALL timestop(handle)

   END SUBROUTINE ec_dc_build_ks_matrix_force

! **************************************************************************************************
!> \brief ...
!> \param qs_env ...
!> \param ec_env ...
!> \param calculate_forces ...
! **************************************************************************************************
   SUBROUTINE ec_disp(qs_env, ec_env, calculate_forces)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env
      LOGICAL, INTENT(IN)                                :: calculate_forces

      REAL(KIND=dp)                                      :: edisp, egcp

      egcp = 0.0_dp
      CALL calculate_dispersion_pairpot(qs_env, ec_env%dispersion_env, edisp, calculate_forces)
      IF (.NOT. calculate_forces) THEN
         ec_env%edispersion = ec_env%edispersion + edisp + egcp
      END IF

   END SUBROUTINE ec_disp

! **************************************************************************************************
!> \brief Construction of the Core Hamiltonian Matrix
!>        Short version of qs_core_hamiltonian
!> \param qs_env ...
!> \param ec_env ...
!> \author Creation (03.2014,JGH)
! **************************************************************************************************
   SUBROUTINE ec_build_core_hamiltonian(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER :: routineN = 'ec_build_core_hamiltonian'

      CHARACTER(LEN=default_string_length)               :: basis_type
      INTEGER                                            :: handle, img, nder, nhfimg, nimages
      LOGICAL                                            :: calculate_forces, use_virial
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(dbcsr_type), POINTER                          :: smat
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_orb, sac_ae, sac_ppl, sap_ppnl
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(qs_ks_env_type), POINTER                      :: ks_env

      CALL timeset(routineN, handle)

      NULLIFY (atomic_kind_set, dft_control, ks_env, particle_set, &
               qs_kind_set)

      CALL get_qs_env(qs_env=qs_env, &
                      atomic_kind_set=atomic_kind_set, &
                      dft_control=dft_control, &
                      particle_set=particle_set, &
                      qs_kind_set=qs_kind_set, &
                      ks_env=ks_env)

      ! no k-points possible
      nimages = dft_control%nimages
      IF (nimages /= 1) THEN
         CPABORT("K-points for Harris functional not implemented")
      END IF

      ! check for GAPW/GAPW_XC
      IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN
         CPABORT("Harris functional for GAPW not implemented")
      END IF

      ! Do not calculate forces or stress tensor here
      use_virial = .FALSE.
      calculate_forces = .FALSE.

      ! get neighbor lists, we need the full sab_orb list from the ec_env
      NULLIFY (sab_orb, sac_ae, sac_ppl, sap_ppnl)
      sab_orb => ec_env%sab_orb
      sac_ae => ec_env%sac_ae
      sac_ppl => ec_env%sac_ppl
      sap_ppnl => ec_env%sap_ppnl

      basis_type = "HARRIS"

      nder = 0
      ! Overlap and kinetic energy matrices
      CALL build_overlap_matrix(ks_env, matrixkp_s=ec_env%matrix_s, &
                                matrix_name="OVERLAP MATRIX", &
                                basis_type_a=basis_type, &
                                basis_type_b=basis_type, &
                                sab_nl=sab_orb, ext_kpoints=ec_env%kpoints)
      CALL build_kinetic_matrix(ks_env, matrixkp_t=ec_env%matrix_t, &
                                matrix_name="KINETIC ENERGY MATRIX", &
                                basis_type=basis_type, &
                                sab_nl=sab_orb, ext_kpoints=ec_env%kpoints)

      ! initialize H matrix
      nhfimg = SIZE(ec_env%matrix_s, 2)
      CALL dbcsr_allocate_matrix_set(ec_env%matrix_h, 1, nhfimg)
      DO img = 1, nhfimg
         ALLOCATE (ec_env%matrix_h(1, img)%matrix)
         smat => ec_env%matrix_s(1, img)%matrix
         CALL dbcsr_create(ec_env%matrix_h(1, img)%matrix, template=smat)
         CALL cp_dbcsr_alloc_block_from_nbl(ec_env%matrix_h(1, img)%matrix, sab_orb)
      END DO

      ! add kinetic energy
      DO img = 1, nhfimg
         CALL dbcsr_copy(ec_env%matrix_h(1, img)%matrix, ec_env%matrix_t(1, img)%matrix, &
                         keep_sparsity=.TRUE., name="CORE HAMILTONIAN MATRIX")
      END DO

      CALL core_matrices(qs_env, ec_env%matrix_h, ec_env%matrix_p, calculate_forces, nder, &
                         ec_env=ec_env, ec_env_matrices=.TRUE., ext_kpoints=ec_env%kpoints, &
                         basis_type=basis_type)

      ! External field (nonperiodic case)
      ec_env%efield_nuclear = 0.0_dp
      CALL ec_efield_local_operator(qs_env, ec_env, calculate_forces)

      CALL timestop(handle)

   END SUBROUTINE ec_build_core_hamiltonian

! **************************************************************************************************
!> \brief Solve KS equation for a given matrix
!>        calculate the complete KS matrix
!> \param qs_env ...
!> \param ec_env ...
!> \par History
!>      03.2014 adapted from qs_ks_build_kohn_sham_matrix [JGH]
!> \author JGH
! **************************************************************************************************
   SUBROUTINE ec_build_ks_matrix(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER :: routineN = 'ec_build_ks_matrix'

      CHARACTER(LEN=default_string_length)               :: headline
      INTEGER                                            :: handle, img, iounit, ispin, natom, &
                                                            nhfimg, nimages, nspins
      LOGICAL                                            :: calculate_forces, &
                                                            do_adiabatic_rescaling, do_ec_hfx, &
                                                            gapw, gapw_xc, hfx_treat_lsd_in_core, &
                                                            use_virial
      REAL(dp)                                           :: dummy_real, dummy_real2(2), eexc, eh1c, &
                                                            evhxc, exc1, t3
      TYPE(admm_type), POINTER                           :: admm_env
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cp_logger_type), POINTER                      :: logger
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: ks_mat, ps_mat
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: rho_ao_kp
      TYPE(dbcsr_type), POINTER                          :: smat
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(hartree_local_type), POINTER                  :: hartree_local
      TYPE(local_rho_type), POINTER                      :: local_rho_set_ec
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab
      TYPE(oce_matrix_type), POINTER                     :: oce
      TYPE(pw_env_type), POINTER                         :: pw_env
      TYPE(pw_pool_type), POINTER                        :: auxbas_pw_pool
      TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER        :: rho_r, tau_r, v_rspace, v_tau_rspace
      TYPE(qs_energy_type), POINTER                      :: energy
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(qs_rho_type), POINTER                         :: rho, rho_xc
      TYPE(section_vals_type), POINTER                   :: adiabatic_rescaling_section, &
                                                            ec_hfx_sections, ec_section

      CALL timeset(routineN, handle)

      logger => cp_get_default_logger()
      IF (logger%para_env%is_source()) THEN
         iounit = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
      ELSE
         iounit = -1
      END IF

      ! get all information on the electronic density
      NULLIFY (auxbas_pw_pool, dft_control, energy, ks_env, rho, rho_r, tau_r)
      CALL get_qs_env(qs_env=qs_env, &
                      dft_control=dft_control, &
                      ks_env=ks_env, &
                      rho=rho, rho_xc=rho_xc)
      nspins = dft_control%nspins
      nimages = dft_control%nimages  ! this is from the ref calculation
      calculate_forces = .FALSE.
      use_virial = .FALSE.

      gapw = dft_control%qs_control%gapw
      gapw_xc = dft_control%qs_control%gapw_xc

      ! Kohn-Sham matrix
      IF (ASSOCIATED(ec_env%matrix_ks)) CALL dbcsr_deallocate_matrix_set(ec_env%matrix_ks)
      nhfimg = SIZE(ec_env%matrix_s, 2)
      dft_control%nimages = nhfimg
      CALL dbcsr_allocate_matrix_set(ec_env%matrix_ks, nspins, nhfimg)
      DO ispin = 1, nspins
         headline = "KOHN-SHAM MATRIX"
         DO img = 1, nhfimg
            ALLOCATE (ec_env%matrix_ks(ispin, img)%matrix)
            smat => ec_env%matrix_s(1, img)%matrix
            CALL dbcsr_create(ec_env%matrix_ks(ispin, img)%matrix, name=TRIM(headline), &
                              template=smat, matrix_type=dbcsr_type_symmetric)
            CALL cp_dbcsr_alloc_block_from_nbl(ec_env%matrix_ks(ispin, img)%matrix, &
                                               ec_env%sab_orb)
            CALL dbcsr_set(ec_env%matrix_ks(ispin, img)%matrix, 0.0_dp)
         END DO
      END DO

      NULLIFY (pw_env)
      CALL get_qs_env(qs_env=qs_env, pw_env=pw_env)
      CPASSERT(ASSOCIATED(pw_env))

      ! Exact exchange contribution (hybrid functionals)
      ec_section => section_vals_get_subs_vals(qs_env%input, "DFT%ENERGY_CORRECTION")
      ec_hfx_sections => section_vals_get_subs_vals(ec_section, "XC%HF")
      CALL section_vals_get(ec_hfx_sections, explicit=do_ec_hfx)

      IF (do_ec_hfx) THEN

         ! Check what works
         adiabatic_rescaling_section => section_vals_get_subs_vals(ec_section, "XC%ADIABATIC_RESCALING")
         CALL section_vals_get(adiabatic_rescaling_section, explicit=do_adiabatic_rescaling)
         IF (do_adiabatic_rescaling) THEN
            CALL cp_abort(__LOCATION__, "Adiabatic rescaling NYI for energy correction")
         END IF
         CALL section_vals_val_get(ec_hfx_sections, "TREAT_LSD_IN_CORE", l_val=hfx_treat_lsd_in_core)
         IF (hfx_treat_lsd_in_core) THEN
            CALL cp_abort(__LOCATION__, "HFX_TREAT_LSD_IN_CORE NYI for energy correction")
         END IF
         IF (ec_env%do_kpoints) THEN
            CALL cp_abort(__LOCATION__, "HFX and K-points NYI for energy correction")
         END IF

         ! calculate the density matrix for the fitted mo_coeffs
         IF (dft_control%do_admm) THEN
            IF (dft_control%do_admm_mo) THEN
               CPASSERT(.NOT. qs_env%run_rtp)
               CALL admm_mo_calc_rho_aux(qs_env)
            ELSEIF (dft_control%do_admm_dm) THEN
               CALL admm_dm_calc_rho_aux(qs_env)
            END IF
         END IF

         ! Get exact exchange energy
         dummy_real = 0.0_dp
         t3 = 0.0_dp
         CALL get_qs_env(qs_env, energy=energy)
         CALL calculate_exx(qs_env=qs_env, &
                            unit_nr=iounit, &
                            hfx_sections=ec_hfx_sections, &
                            x_data=ec_env%x_data, &
                            do_gw=.FALSE., &
                            do_admm=ec_env%do_ec_admm, &
                            calc_forces=.FALSE., &
                            reuse_hfx=ec_env%reuse_hfx, &
                            do_im_time=.FALSE., &
                            E_ex_from_GW=dummy_real, &
                            E_admm_from_GW=dummy_real2, &
                            t3=dummy_real)

         ! Save exchange energy
         ec_env%ex = energy%ex
         ! Save EXX ADMM XC correction
         IF (ec_env%do_ec_admm) THEN
            ec_env%exc_aux_fit = energy%exc_aux_fit + energy%exc
         END IF

         ! Add exact echange contribution of EC to EC Hamiltonian
         ! do_ec = .FALSE prevents subtraction of HFX contribution of reference calculation
         ! do_exx = .FALSE. prevents subtraction of reference XC contribution
         ks_mat => ec_env%matrix_ks(:, 1)
         CALL add_exx_to_rhs(rhs=ks_mat, &
                             qs_env=qs_env, &
                             ext_hfx_section=ec_hfx_sections, &
                             x_data=ec_env%x_data, &
                             recalc_integrals=.FALSE., &
                             do_admm=ec_env%do_ec_admm, &
                             do_ec=.FALSE., &
                             do_exx=.FALSE., &
                             reuse_hfx=ec_env%reuse_hfx)

      END IF

      ! v_rspace and v_tau_rspace are generated from the auxbas pool
      CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool)
      NULLIFY (v_rspace, v_tau_rspace)
      IF (dft_control%qs_control%gapw_xc) THEN
         CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_xc, xc_section=ec_env%xc_section, &
                            vxc_rho=v_rspace, vxc_tau=v_tau_rspace, exc=eexc, just_energy=.FALSE.)
      ELSE
         CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho, xc_section=ec_env%xc_section, &
                            vxc_rho=v_rspace, vxc_tau=v_tau_rspace, exc=eexc, just_energy=.FALSE.)
      END IF

      IF (.NOT. ASSOCIATED(v_rspace)) THEN
         ALLOCATE (v_rspace(nspins))
         DO ispin = 1, nspins
            CALL auxbas_pw_pool%create_pw(v_rspace(ispin))
            CALL pw_zero(v_rspace(ispin))
         END DO
      END IF

      evhxc = 0.0_dp
      CALL qs_rho_get(rho, rho_r=rho_r)
      IF (ASSOCIATED(v_tau_rspace)) THEN
         CALL qs_rho_get(rho, tau_r=tau_r)
      END IF
      DO ispin = 1, nspins
         ! Add v_hartree + v_xc = v_rspace
         CALL pw_scale(v_rspace(ispin), v_rspace(ispin)%pw_grid%dvol)
         CALL pw_axpy(ec_env%vh_rspace, v_rspace(ispin))
         ! integrate over potential <a|V|b>
         ks_mat => ec_env%matrix_ks(ispin, :)
         CALL integrate_v_rspace(v_rspace=v_rspace(ispin), &
                                 hmat_kp=ks_mat, &
                                 qs_env=qs_env, &
                                 calculate_forces=.FALSE., &
                                 basis_type="HARRIS", &
                                 task_list_external=ec_env%task_list)

         IF (ASSOCIATED(v_tau_rspace)) THEN
            ! integrate over Tau-potential <nabla.a|V|nabla.b>
            CALL pw_scale(v_tau_rspace(ispin), v_tau_rspace(ispin)%pw_grid%dvol)
            CALL integrate_v_rspace(v_rspace=v_tau_rspace(ispin), &
                                    hmat_kp=ks_mat, &
                                    qs_env=qs_env, &
                                    calculate_forces=.FALSE., &
                                    compute_tau=.TRUE., &
                                    basis_type="HARRIS", &
                                    task_list_external=ec_env%task_list)
         END IF

         ! calclulate Int(vhxc*rho)dr and Int(vtau*tau)dr
         evhxc = evhxc + pw_integral_ab(rho_r(ispin), v_rspace(ispin))/ &
                 v_rspace(1)%pw_grid%dvol
         IF (ASSOCIATED(v_tau_rspace)) THEN
            evhxc = evhxc + pw_integral_ab(tau_r(ispin), v_tau_rspace(ispin))/ &
                    v_tau_rspace(ispin)%pw_grid%dvol
         END IF

      END DO

      IF (gapw .OR. gapw_xc) THEN
         ! check for basis, we can only do basis=orbital
         IF (ec_env%basis_inconsistent) THEN
            CPABORT("Energy corrction [GAPW] only with BASIS=ORBITAL possible")
         END IF

         NULLIFY (hartree_local, local_rho_set_ec)
         CALL get_qs_env(qs_env, para_env=para_env, &
                         atomic_kind_set=atomic_kind_set, &
                         qs_kind_set=qs_kind_set)
         CALL local_rho_set_create(local_rho_set_ec)
         CALL allocate_rho_atom_internals(local_rho_set_ec%rho_atom_set, atomic_kind_set, &
                                          qs_kind_set, dft_control, para_env)
         IF (gapw) THEN
            CALL get_qs_env(qs_env, natom=natom)
            CALL init_rho0(local_rho_set_ec, qs_env, dft_control%qs_control%gapw_control)
            CALL rho0_s_grid_create(pw_env, local_rho_set_ec%rho0_mpole)
            CALL hartree_local_create(hartree_local)
            CALL init_coulomb_local(hartree_local, natom)
         END IF

         CALL get_qs_env(qs_env=qs_env, oce=oce, sab_orb=sab)
         CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp)
         CALL calculate_rho_atom_coeff(qs_env, rho_ao_kp, local_rho_set_ec%rho_atom_set, &
                                       qs_kind_set, oce, sab, para_env)
         CALL prepare_gapw_den(qs_env, local_rho_set_ec, do_rho0=gapw)

         CALL calculate_vxc_atom(qs_env, .FALSE., exc1=exc1, xc_section_external=ec_env%xc_section, &
                                 rho_atom_set_external=local_rho_set_ec%rho_atom_set)
         ec_env%exc1 = exc1

         IF (gapw) THEN
            CALL Vh_1c_gg_integrals(qs_env, eh1c, hartree_local%ecoul_1c, local_rho_set_ec, para_env, .FALSE.)
            CALL integrate_vhg0_rspace(qs_env, ec_env%vh_rspace, para_env, calculate_forces=.FALSE., &
                                       local_rho_set=local_rho_set_ec)
            ec_env%ehartree_1c = eh1c
         END IF
         IF (dft_control%do_admm) THEN
            CALL get_qs_env(qs_env, admm_env=admm_env)
            IF (admm_env%aux_exch_func /= do_admm_aux_exch_func_none) THEN
               ! define proper xc_section
               CPABORT("GAPW HFX ADMM + Energy Correction NYA")
            END IF
         END IF

         ks_mat => ec_env%matrix_ks(:, 1)
         ps_mat => ec_env%matrix_p(:, 1)
         CALL update_ks_atom(qs_env, ks_mat, ps_mat, forces=.FALSE., &
                             rho_atom_external=local_rho_set_ec%rho_atom_set)

         CALL local_rho_set_release(local_rho_set_ec)
         IF (gapw) THEN
            CALL hartree_local_release(hartree_local)
         END IF

      END IF

      ! return pw grids
      DO ispin = 1, nspins
         CALL auxbas_pw_pool%give_back_pw(v_rspace(ispin))
         IF (ASSOCIATED(v_tau_rspace)) THEN
            CALL auxbas_pw_pool%give_back_pw(v_tau_rspace(ispin))
         END IF
      END DO
      DEALLOCATE (v_rspace)
      IF (ASSOCIATED(v_tau_rspace)) DEALLOCATE (v_tau_rspace)

      ! energies
      ec_env%exc = eexc
      ec_env%vhxc = evhxc

      ! add the core matrix
      DO ispin = 1, nspins
         DO img = 1, nhfimg
            CALL dbcsr_add(ec_env%matrix_ks(ispin, img)%matrix, ec_env%matrix_h(1, img)%matrix, &
                           alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
            CALL dbcsr_filter(ec_env%matrix_ks(ispin, img)%matrix, &
                              dft_control%qs_control%eps_filter_matrix)
         END DO
      END DO

      dft_control%nimages = nimages

      CALL timestop(handle)

   END SUBROUTINE ec_build_ks_matrix

! **************************************************************************************************
!> \brief Construction of the Core Hamiltonian Matrix
!>        Short version of qs_core_hamiltonian
!> \param qs_env ...
!> \param ec_env ...
!> \param matrix_p ...
!> \param matrix_s ...
!> \param matrix_w ...
!> \author Creation (03.2014,JGH)
! **************************************************************************************************
   SUBROUTINE ec_build_core_hamiltonian_force(qs_env, ec_env, matrix_p, matrix_s, matrix_w)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: matrix_p, matrix_s, matrix_w

      CHARACTER(LEN=*), PARAMETER :: routineN = 'ec_build_core_hamiltonian_force'

      CHARACTER(LEN=default_string_length)               :: basis_type
      INTEGER                                            :: handle, img, iounit, nder, nhfimg, &
                                                            nimages
      LOGICAL                                            :: calculate_forces, debug_forces, &
                                                            debug_stress, use_virial
      REAL(KIND=dp)                                      :: fconv
      REAL(KIND=dp), DIMENSION(3)                        :: fodeb
      REAL(KIND=dp), DIMENSION(3, 3)                     :: stdeb, sttot
      TYPE(cell_type), POINTER                           :: cell
      TYPE(cp_logger_type), POINTER                      :: logger
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: scrm
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_orb
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: force
      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(virial_type), POINTER                         :: virial

      CALL timeset(routineN, handle)

      debug_forces = ec_env%debug_forces
      debug_stress = ec_env%debug_stress

      logger => cp_get_default_logger()
      IF (logger%para_env%is_source()) THEN
         iounit = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
      ELSE
         iounit = -1
      END IF

      calculate_forces = .TRUE.

      basis_type = "HARRIS"

      ! no k-points possible
      NULLIFY (cell, dft_control, force, ks_env, para_env, virial)
      CALL get_qs_env(qs_env=qs_env, &
                      cell=cell, &
                      dft_control=dft_control, &
                      force=force, &
                      ks_env=ks_env, &
                      para_env=para_env, &
                      virial=virial)
      nimages = dft_control%nimages
      IF (nimages /= 1) THEN
         CPABORT("K-points for Harris functional not implemented")
      END IF
      ! check for GAPW/GAPW_XC
      IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN
         IF (ec_env%energy_functional == ec_functional_harris) THEN
            CPABORT("Harris functional for GAPW not implemented")
         END IF
      END IF

      ! check for virial
      use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer)

      fconv = 1.0E-9_dp*pascal/cell%deth
      IF (debug_stress .AND. use_virial) THEN
         sttot = virial%pv_virial
      END IF

      ! get neighbor lists, we need the full sab_orb list from the ec_env
      sab_orb => ec_env%sab_orb

      ! initialize src matrix
      nhfimg = SIZE(matrix_s, 2)
      NULLIFY (scrm)
      CALL dbcsr_allocate_matrix_set(scrm, 1, nhfimg)
      DO img = 1, nhfimg
         ALLOCATE (scrm(1, img)%matrix)
         CALL dbcsr_create(scrm(1, img)%matrix, template=matrix_s(1, img)%matrix)
         CALL cp_dbcsr_alloc_block_from_nbl(scrm(1, img)%matrix, sab_orb)
      END DO

      nder = 1
      IF (SIZE(matrix_p, 1) == 2) THEN
         DO img = 1, nhfimg
            CALL dbcsr_add(matrix_w(1, img)%matrix, matrix_w(2, img)%matrix, &
                           alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
         END DO
      END IF

      ! Overlap and kinetic energy matrices
      IF (debug_forces) fodeb(1:3) = force(1)%overlap(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_overlap
      CALL build_overlap_matrix(ks_env, matrixkp_s=scrm, &
                                matrix_name="OVERLAP MATRIX", &
                                basis_type_a=basis_type, &
                                basis_type_b=basis_type, &
                                sab_nl=sab_orb, calculate_forces=.TRUE., &
                                matrixkp_p=matrix_w, ext_kpoints=ec_env%kpoints)

      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%overlap(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Wout*dS    ", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_overlap - stdeb)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| Wout*dS', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      CALL kinetic_energy_matrix(qs_env, matrixkp_t=scrm, matrix_p=matrix_p, &
                                 calculate_forces=.TRUE., sab_orb=sab_orb, &
                                 basis_type=basis_type, ext_kpoints=ec_env%kpoints, &
                                 debug_forces=debug_forces, debug_stress=debug_stress)

      CALL core_matrices(qs_env, scrm, matrix_p, calculate_forces, nder, &
                         ec_env=ec_env, ec_env_matrices=.FALSE., basis_type=basis_type, &
                         ext_kpoints=ec_env%kpoints, &
                         debug_forces=debug_forces, debug_stress=debug_stress)

      ! External field (nonperiodic case)
      ec_env%efield_nuclear = 0.0_dp
      IF (calculate_forces .AND. debug_forces) fodeb(1:3) = force(1)%efield(1:3, 1)
      CALL ec_efield_local_operator(qs_env, ec_env, calculate_forces)
      IF (calculate_forces .AND. debug_forces) THEN
         fodeb(1:3) = force(1)%efield(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pout*dEfield", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_virial - sttot)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| Stress Pout*dHcore   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") ' '
      END IF

      ! delete scr matrix
      CALL dbcsr_deallocate_matrix_set(scrm)

      CALL timestop(handle)

   END SUBROUTINE ec_build_core_hamiltonian_force

! **************************************************************************************************
!> \brief Solve KS equation for a given matrix
!> \brief calculate the complete KS matrix
!> \param qs_env ...
!> \param ec_env ...
!> \par History
!>      03.2014 adapted from qs_ks_build_kohn_sham_matrix [JGH]
!> \author JGH
! **************************************************************************************************
   SUBROUTINE ec_build_ks_matrix_force(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER :: routineN = 'ec_build_ks_matrix_force'

      CHARACTER(LEN=default_string_length)               :: unit_string
      INTEGER                                            :: handle, i, img, iounit, ispin, natom, &
                                                            nhfimg, nimages, nspins
      LOGICAL                                            :: debug_forces, debug_stress, do_ec_hfx, &
                                                            use_virial
      REAL(dp)                                           :: dehartree, dummy_real, dummy_real2(2), &
                                                            eexc, ehartree, eovrl, exc, fconv
      REAL(dp), ALLOCATABLE, DIMENSION(:, :)             :: ftot
      REAL(dp), DIMENSION(3)                             :: fodeb
      REAL(KIND=dp), DIMENSION(3, 3)                     :: h_stress, pv_loc, stdeb, sttot
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cell_type), POINTER                           :: cell
      TYPE(cp_logger_type), POINTER                      :: logger
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: matrix_ks, rho_ao, scrmat
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: matrix_p, matrix_s, scrm
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_orb
      TYPE(pw_c1d_gs_type)                               :: rho_tot_gspace, rhodn_tot_gspace, &
                                                            v_hartree_gspace
      TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER        :: rho_g, rhoout_g
      TYPE(pw_c1d_gs_type), POINTER                      :: rho_core
      TYPE(pw_env_type), POINTER                         :: pw_env
      TYPE(pw_poisson_type), POINTER                     :: poisson_env
      TYPE(pw_pool_type), POINTER                        :: auxbas_pw_pool
      TYPE(pw_r3d_rs_type)                               :: dv_hartree_rspace, v_hartree_rspace, &
                                                            vtot_rspace
      TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER        :: rho_r, rhoout_r, tau_r, tauout_r, &
                                                            v_rspace, v_tau_rspace, v_xc, v_xc_tau
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: force
      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(qs_rho_type), POINTER                         :: rho
      TYPE(section_vals_type), POINTER                   :: ec_hfx_sections, xc_section
      TYPE(virial_type), POINTER                         :: virial

      CALL timeset(routineN, handle)

      debug_forces = ec_env%debug_forces
      debug_stress = ec_env%debug_stress

      logger => cp_get_default_logger()
      IF (logger%para_env%is_source()) THEN
         iounit = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
      ELSE
         iounit = -1
      END IF

      ! get all information on the electronic density
      NULLIFY (atomic_kind_set, cell, dft_control, force, ks_env, &
               matrix_ks, matrix_p, matrix_s, para_env, rho, rho_core, &
               rho_g, rho_r, sab_orb, tau_r, virial)
      CALL get_qs_env(qs_env=qs_env, &
                      cell=cell, &
                      dft_control=dft_control, &
                      force=force, &
                      ks_env=ks_env, &
                      matrix_ks=matrix_ks, &
                      para_env=para_env, &
                      rho=rho, &
                      sab_orb=sab_orb, &
                      virial=virial)

      nspins = dft_control%nspins
      use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer)

      ! Conversion factor a.u. -> GPa
      unit_string = "GPa"
      fconv = cp_unit_from_cp2k(1.0_dp/cell%deth, TRIM(unit_string))

      IF (debug_stress .AND. use_virial) THEN
         sttot = virial%pv_virial
      END IF

      NULLIFY (pw_env)
      CALL get_qs_env(qs_env=qs_env, pw_env=pw_env)
      CPASSERT(ASSOCIATED(pw_env))

      NULLIFY (auxbas_pw_pool, poisson_env)
      ! gets the tmp grids
      CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, &
                      poisson_env=poisson_env)

      ! Calculate the Hartree potential
      CALL auxbas_pw_pool%create_pw(v_hartree_gspace)
      CALL auxbas_pw_pool%create_pw(rhodn_tot_gspace)
      CALL auxbas_pw_pool%create_pw(v_hartree_rspace)

      CALL pw_transfer(ec_env%vh_rspace, v_hartree_rspace)

      ! calculate output density on grid
      ! rho_in(R):   CALL qs_rho_get(rho, rho_r=rho_r)
      ! rho_in(G):   CALL qs_rho_get(rho, rho_g=rho_g)
      CALL qs_rho_get(rho, rho_r=rho_r, rho_g=rho_g, tau_r=tau_r)
      NULLIFY (rhoout_r, rhoout_g)
      ALLOCATE (rhoout_r(nspins), rhoout_g(nspins))
      DO ispin = 1, nspins
         CALL auxbas_pw_pool%create_pw(rhoout_r(ispin))
         CALL auxbas_pw_pool%create_pw(rhoout_g(ispin))
      END DO
      CALL auxbas_pw_pool%create_pw(dv_hartree_rspace)
      CALL auxbas_pw_pool%create_pw(vtot_rspace)

      ! set local number of images
      nhfimg = SIZE(ec_env%matrix_s, 2)
      nimages = dft_control%nimages
      dft_control%nimages = nhfimg

      CALL pw_zero(rhodn_tot_gspace)
      DO ispin = 1, nspins
         rho_ao => ec_env%matrix_p(ispin, :)
         CALL calculate_rho_elec(ks_env=ks_env, matrix_p_kp=rho_ao, &
                                 rho=rhoout_r(ispin), &
                                 rho_gspace=rhoout_g(ispin), &
                                 basis_type="HARRIS", &
                                 task_list_external=ec_env%task_list)
      END DO

      ! Save Harris on real space grid for use in properties
      ALLOCATE (ec_env%rhoout_r(nspins))
      DO ispin = 1, nspins
         CALL auxbas_pw_pool%create_pw(ec_env%rhoout_r(ispin))
         CALL pw_copy(rhoout_r(ispin), ec_env%rhoout_r(ispin))
      END DO

      NULLIFY (tauout_r)
      IF (dft_control%use_kinetic_energy_density) THEN
         BLOCK
            TYPE(pw_c1d_gs_type) :: tauout_g
            ALLOCATE (tauout_r(nspins))
            DO ispin = 1, nspins
               CALL auxbas_pw_pool%create_pw(tauout_r(ispin))
            END DO
            CALL auxbas_pw_pool%create_pw(tauout_g)

            DO ispin = 1, nspins
               CALL calculate_rho_elec(ks_env=ks_env, matrix_p=ec_env%matrix_p(ispin, 1)%matrix, &
                                       rho=tauout_r(ispin), &
                                       rho_gspace=tauout_g, &
                                       compute_tau=.TRUE., &
                                       basis_type="HARRIS", &
                                       task_list_external=ec_env%task_list)
            END DO

            CALL auxbas_pw_pool%give_back_pw(tauout_g)
         END BLOCK
      END IF

      ! reset nimages to base method
      dft_control%nimages = nimages

      IF (use_virial) THEN

         ! Calculate the Hartree potential
         CALL auxbas_pw_pool%create_pw(rho_tot_gspace)

         ! Get the total input density in g-space [ions + electrons]
         CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho)

         ! make rho_tot_gspace with output density
         CALL get_qs_env(qs_env=qs_env, rho_core=rho_core)
         CALL pw_copy(rho_core, rhodn_tot_gspace)
         DO ispin = 1, dft_control%nspins
            CALL pw_axpy(rhoout_g(ispin), rhodn_tot_gspace)
         END DO

         ! Volume and Green function terms
         h_stress(:, :) = 0.0_dp
         CALL pw_poisson_solve(poisson_env, &
                               density=rho_tot_gspace, &  ! n_in
                               ehartree=ehartree, &
                               vhartree=v_hartree_gspace, & ! v_H[n_in]
                               h_stress=h_stress, &
                               aux_density=rhodn_tot_gspace) ! n_out

         virial%pv_ehartree = virial%pv_ehartree + h_stress/REAL(para_env%num_pe, dp)
         virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe, dp)

         IF (debug_stress) THEN
            stdeb = fconv*(h_stress/REAL(para_env%num_pe, dp))
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| GREEN 1st v_H[n_in]*n_out  ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF

         ! activate stress calculation
         virial%pv_calculate = .TRUE.

         NULLIFY (v_rspace, v_tau_rspace)
         CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho, xc_section=ec_env%xc_section, &
                            vxc_rho=v_rspace, vxc_tau=v_tau_rspace, exc=exc, just_energy=.FALSE.)

         ! Stress tensor XC-functional GGA contribution
         virial%pv_exc = virial%pv_exc - virial%pv_xc
         virial%pv_virial = virial%pv_virial - virial%pv_xc

         IF (debug_stress) THEN
            stdeb = -1.0_dp*fconv*virial%pv_xc
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| GGA 1st E_xc[Pin]   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF

         IF (ASSOCIATED(v_rspace)) THEN
            DO ispin = 1, nspins
               CALL auxbas_pw_pool%give_back_pw(v_rspace(ispin))
            END DO
            DEALLOCATE (v_rspace)
         END IF
         IF (ASSOCIATED(v_tau_rspace)) THEN
            DO ispin = 1, nspins
               CALL auxbas_pw_pool%give_back_pw(v_tau_rspace(ispin))
            END DO
            DEALLOCATE (v_tau_rspace)
         END IF
         CALL pw_zero(rhodn_tot_gspace)

      END IF

      ! rho_out - rho_in
      DO ispin = 1, nspins
         CALL pw_axpy(rho_r(ispin), rhoout_r(ispin), -1.0_dp)
         CALL pw_axpy(rho_g(ispin), rhoout_g(ispin), -1.0_dp)
         CALL pw_axpy(rhoout_g(ispin), rhodn_tot_gspace)
         IF (dft_control%use_kinetic_energy_density) CALL pw_axpy(tau_r(ispin), tauout_r(ispin), -1.0_dp)
      END DO

      ! calculate associated hartree potential
      IF (use_virial) THEN

         ! Stress tensor - 2nd derivative Volume and Green function contribution
         h_stress(:, :) = 0.0_dp
         CALL pw_poisson_solve(poisson_env, &
                               density=rhodn_tot_gspace, &  ! delta_n
                               ehartree=dehartree, &
                               vhartree=v_hartree_gspace, & ! v_H[delta_n]
                               h_stress=h_stress, &
                               aux_density=rho_tot_gspace)  ! n_in

         CALL auxbas_pw_pool%give_back_pw(rho_tot_gspace)

         virial%pv_ehartree = virial%pv_ehartree + h_stress/REAL(para_env%num_pe, dp)
         virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe, dp)

         IF (debug_stress) THEN
            stdeb = fconv*(h_stress/REAL(para_env%num_pe, dp))
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| GREEN 2nd V_H[dP]*n_in  ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF

      ELSE
         ! v_H[dn]
         CALL pw_poisson_solve(poisson_env, rhodn_tot_gspace, dehartree, &
                               v_hartree_gspace)
      END IF

      CALL pw_transfer(v_hartree_gspace, dv_hartree_rspace)
      CALL pw_scale(dv_hartree_rspace, dv_hartree_rspace%pw_grid%dvol)
      ! Getting nuclear force contribution from the core charge density
      ! Vh(rho_in + rho_c) + Vh(rho_out - rho_in)
      CALL pw_transfer(v_hartree_rspace, vtot_rspace)
      CALL pw_axpy(dv_hartree_rspace, vtot_rspace)
      IF (debug_forces) fodeb(1:3) = force(1)%rho_core(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_ehartree
      CALL integrate_v_core_rspace(vtot_rspace, qs_env)
      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%rho_core(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Vtot*dncore", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_ehartree - stdeb)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| Vtot*dncore', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF
      !
      ! Pulay force from Tr P_in (V_H(drho)+ Fxc(rho_in)*drho)
      ! RHS of CPKS equations: (V_H(drho)+ Fxc(rho_in)*drho)*C0
      ! Fxc*drho term
      xc_section => ec_env%xc_section

      IF (use_virial) virial%pv_xc = 0.0_dp
      NULLIFY (v_xc, v_xc_tau)
      CALL create_kernel(qs_env, &
                         vxc=v_xc, &
                         vxc_tau=v_xc_tau, &
                         rho=rho, &
                         rho1_r=rhoout_r, &
                         rho1_g=rhoout_g, &
                         tau1_r=tauout_r, &
                         xc_section=xc_section, &
                         compute_virial=use_virial, &
                         virial_xc=virial%pv_xc)

      IF (use_virial) THEN
         ! Stress-tensor XC-functional 2nd GGA terms
         virial%pv_exc = virial%pv_exc + virial%pv_xc
         virial%pv_virial = virial%pv_virial + virial%pv_xc
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = 1.0_dp*fconv*virial%pv_xc
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| GGA 2nd f_Hxc[dP]*Pin   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF
      !
      CALL get_qs_env(qs_env=qs_env, rho=rho, matrix_s_kp=matrix_s)
      NULLIFY (ec_env%matrix_hz)
      CALL dbcsr_allocate_matrix_set(ec_env%matrix_hz, nspins)
      DO ispin = 1, nspins
         ALLOCATE (ec_env%matrix_hz(ispin)%matrix)
         CALL dbcsr_create(ec_env%matrix_hz(ispin)%matrix, template=matrix_s(1, 1)%matrix)
         CALL dbcsr_copy(ec_env%matrix_hz(ispin)%matrix, matrix_s(1, 1)%matrix)
         CALL dbcsr_set(ec_env%matrix_hz(ispin)%matrix, 0.0_dp)
      END DO
      CALL qs_rho_get(rho, rho_ao_kp=matrix_p)
      ! vtot = v_xc(ispin) + dv_hartree
      IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial

      ! Stress-tensor 2nd derivative integral contribution
      IF (use_virial) THEN
         pv_loc = virial%pv_virial
      END IF

      DO ispin = 1, nspins
         CALL pw_scale(v_xc(ispin), v_xc(ispin)%pw_grid%dvol)
         CALL pw_axpy(dv_hartree_rspace, v_xc(ispin))
         CALL integrate_v_rspace(v_rspace=v_xc(ispin), &
                                 hmat=ec_env%matrix_hz(ispin), &
                                 pmat=matrix_p(ispin, 1), &
                                 qs_env=qs_env, &
                                 calculate_forces=.TRUE.)
      END DO

      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pin*dKdrho", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_virial - stdeb)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| INT 2nd f_Hxc[dP]*Pin    ', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      IF (ASSOCIATED(v_xc_tau)) THEN
         IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
         IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial

         DO ispin = 1, nspins
            CALL pw_scale(v_xc_tau(ispin), v_xc_tau(ispin)%pw_grid%dvol)
            CALL integrate_v_rspace(v_rspace=v_xc_tau(ispin), &
                                    hmat=ec_env%matrix_hz(ispin), &
                                    pmat=matrix_p(ispin, 1), &
                                    qs_env=qs_env, &
                                    compute_tau=.TRUE., &
                                    calculate_forces=.TRUE.)
         END DO

         IF (debug_forces) THEN
            fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
            CALL para_env%sum(fodeb)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pin*dKtaudtau", fodeb
         END IF
         IF (debug_stress .AND. use_virial) THEN
            stdeb = fconv*(virial%pv_virial - stdeb)
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| INT 2nd f_xctau[dP]*Pin    ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF
      END IF
      ! Stress-tensor 2nd derivative integral contribution
      IF (use_virial) THEN
         virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
      END IF

      ! v_rspace and v_tau_rspace are generated from the auxbas pool
      NULLIFY (v_rspace, v_tau_rspace)

      CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho, xc_section=ec_env%xc_section, &
                         vxc_rho=v_rspace, vxc_tau=v_tau_rspace, exc=eexc, just_energy=.FALSE.)

      IF (use_virial) THEN
         eexc = 0.0_dp
         IF (ASSOCIATED(v_rspace)) THEN
            DO ispin = 1, nspins
               ! 2nd deriv xc-volume term
               eexc = eexc + pw_integral_ab(rhoout_r(ispin), v_rspace(ispin))
            END DO
         END IF
         IF (ASSOCIATED(v_tau_rspace)) THEN
            DO ispin = 1, nspins
               ! 2nd deriv xc-volume term
               eexc = eexc + pw_integral_ab(tauout_r(ispin), v_tau_rspace(ispin))
            END DO
         END IF
      END IF

      IF (.NOT. ASSOCIATED(v_rspace)) THEN
         ALLOCATE (v_rspace(nspins))
         DO ispin = 1, nspins
            CALL auxbas_pw_pool%create_pw(v_rspace(ispin))
            CALL pw_zero(v_rspace(ispin))
         END DO
      END IF

      ! Stress-tensor contribution derivative of integrand
      ! int v_Hxc[n^în]*n^out
      IF (use_virial) THEN
         pv_loc = virial%pv_virial
      END IF
      ! set local number of images
      dft_control%nimages = nhfimg

      ! initialize srcm matrix
      NULLIFY (scrm)
      CALL dbcsr_allocate_matrix_set(scrm, nspins, nhfimg)
      DO ispin = 1, nspins
         DO img = 1, nhfimg
            ALLOCATE (scrm(ispin, img)%matrix)
            CALL dbcsr_create(scrm(ispin, img)%matrix, template=ec_env%matrix_ks(ispin, img)%matrix)
            CALL dbcsr_copy(scrm(ispin, img)%matrix, ec_env%matrix_ks(ispin, img)%matrix)
            CALL dbcsr_set(scrm(ispin, img)%matrix, 0.0_dp)
         END DO
      END DO

      IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
      DO ispin = 1, nspins
         ! Add v_hartree + v_xc = v_rspace
         CALL pw_scale(v_rspace(ispin), v_rspace(ispin)%pw_grid%dvol)
         CALL pw_axpy(v_hartree_rspace, v_rspace(ispin))
         ! integrate over potential <a|V|b>
         rho_ao => ec_env%matrix_p(ispin, :)
         scrmat => scrm(ispin, :)
         CALL integrate_v_rspace(v_rspace=v_rspace(ispin), &
                                 hmat_kp=scrmat, &
                                 pmat_kp=rho_ao, &
                                 qs_env=qs_env, &
                                 calculate_forces=.TRUE., &
                                 basis_type="HARRIS", &
                                 task_list_external=ec_env%task_list)
      END DO

      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pout*dVhxc ", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(virial%pv_virial - stdeb)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| INT Pout*dVhxc   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      ! Stress-tensor
      IF (use_virial) THEN
         virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
      END IF

      ! reset nimages to base method
      dft_control%nimages = nimages

      IF (ASSOCIATED(v_tau_rspace)) THEN
         IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
         DO ispin = 1, nspins
            ! integrate over Tau-potential <nabla.a|V|nabla.b>
            CALL pw_scale(v_tau_rspace(ispin), v_tau_rspace(ispin)%pw_grid%dvol)
            rho_ao => ec_env%matrix_p(ispin, :)
            scrmat => scrm(ispin, :)
            CALL integrate_v_rspace(v_rspace=v_tau_rspace(ispin), &
                                    hmat_kp=scrmat, &
                                    pmat_kp=rho_ao, &
                                    qs_env=qs_env, &
                                    calculate_forces=.TRUE., &
                                    compute_tau=.TRUE., &
                                    basis_type="HARRIS", &
                                    task_list_external=ec_env%task_list)
         END DO
         IF (debug_forces) THEN
            fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
            CALL para_env%sum(fodeb)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pout*dVhxc_tau ", fodeb
         END IF
      END IF

      !------------------------------------------------------------------------------
      ! HFX direct force
      !------------------------------------------------------------------------------

      ! If hybrid functional
      ec_hfx_sections => section_vals_get_subs_vals(qs_env%input, "DFT%ENERGY_CORRECTION%XC%HF")
      CALL section_vals_get(ec_hfx_sections, explicit=do_ec_hfx)

      IF (do_ec_hfx) THEN

         IF (ec_env%do_kpoints) THEN
            CALL cp_abort(__LOCATION__, "HFX and K-points NYI for energy correction")
         END IF

         IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
         IF (use_virial) virial%pv_fock_4c = 0.0_dp

         CALL calculate_exx(qs_env=qs_env, &
                            unit_nr=iounit, &
                            hfx_sections=ec_hfx_sections, &
                            x_data=ec_env%x_data, &
                            do_gw=.FALSE., &
                            do_admm=ec_env%do_ec_admm, &
                            calc_forces=.TRUE., &
                            reuse_hfx=ec_env%reuse_hfx, &
                            do_im_time=.FALSE., &
                            E_ex_from_GW=dummy_real, &
                            E_admm_from_GW=dummy_real2, &
                            t3=dummy_real)

         IF (use_virial) THEN
            virial%pv_exx = virial%pv_exx - virial%pv_fock_4c
            virial%pv_virial = virial%pv_virial - virial%pv_fock_4c
            virial%pv_calculate = .FALSE.
         END IF
         IF (debug_forces) THEN
            fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
            CALL para_env%sum(fodeb)
            IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Pout*hfx ", fodeb
         END IF
         IF (debug_stress .AND. use_virial) THEN
            stdeb = -1.0_dp*fconv*virial%pv_fock_4c
            CALL para_env%sum(stdeb)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| Pout*hfx  ', one_third_sum_diag(stdeb), det_3x3(stdeb)
         END IF

      END IF

      ! delete scrm matrix
      CALL dbcsr_deallocate_matrix_set(scrm)

      ! return pw grids
      CALL auxbas_pw_pool%give_back_pw(v_hartree_rspace)
      DO ispin = 1, nspins
         CALL auxbas_pw_pool%give_back_pw(v_rspace(ispin))
         IF (ASSOCIATED(v_tau_rspace)) THEN
            CALL auxbas_pw_pool%give_back_pw(v_tau_rspace(ispin))
         END IF
      END DO
      IF (ASSOCIATED(v_tau_rspace)) DEALLOCATE (v_tau_rspace)

      ! Core overlap
      IF (debug_forces) fodeb(1:3) = force(1)%core_overlap(1:3, 1)
      IF (debug_stress .AND. use_virial) stdeb = virial%pv_ecore_overlap
      CALL calculate_ecore_overlap(qs_env, para_env, .TRUE., E_overlap_core=eovrl)
      IF (debug_forces) THEN
         fodeb(1:3) = force(1)%core_overlap(1:3, 1) - fodeb(1:3)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: CoreOverlap", fodeb
      END IF
      IF (debug_stress .AND. use_virial) THEN
         stdeb = fconv*(stdeb - virial%pv_ecore_overlap)
         CALL para_env%sum(stdeb)
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| CoreOverlap   ', one_third_sum_diag(stdeb), det_3x3(stdeb)
      END IF

      IF (debug_forces) THEN
         CALL get_qs_env(qs_env, natom=natom, atomic_kind_set=atomic_kind_set)
         ALLOCATE (ftot(3, natom))
         CALL total_qs_force(ftot, force, atomic_kind_set)
         fodeb(1:3) = ftot(1:3, 1)
         DEALLOCATE (ftot)
         CALL para_env%sum(fodeb)
         IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Force Explicit", fodeb
      END IF

      DEALLOCATE (v_rspace)
      !
      CALL auxbas_pw_pool%give_back_pw(dv_hartree_rspace)
      CALL auxbas_pw_pool%give_back_pw(vtot_rspace)
      DO ispin = 1, nspins
         CALL auxbas_pw_pool%give_back_pw(rhoout_r(ispin))
         CALL auxbas_pw_pool%give_back_pw(rhoout_g(ispin))
         CALL auxbas_pw_pool%give_back_pw(v_xc(ispin))
      END DO
      DEALLOCATE (rhoout_r, rhoout_g, v_xc)
      IF (ASSOCIATED(tauout_r)) THEN
         DO ispin = 1, nspins
            CALL auxbas_pw_pool%give_back_pw(tauout_r(ispin))
         END DO
         DEALLOCATE (tauout_r)
      END IF
      IF (ASSOCIATED(v_xc_tau)) THEN
         DO ispin = 1, nspins
            CALL auxbas_pw_pool%give_back_pw(v_xc_tau(ispin))
         END DO
         DEALLOCATE (v_xc_tau)
      END IF
      CALL auxbas_pw_pool%give_back_pw(v_hartree_gspace)
      CALL auxbas_pw_pool%give_back_pw(rhodn_tot_gspace)

      ! Stress tensor - volume terms need to be stored,
      ! for a sign correction in QS at the end of qs_force
      IF (use_virial) THEN
         IF (qs_env%energy_correction) THEN
            ec_env%ehartree = ehartree + dehartree
            ec_env%exc = exc + eexc
         END IF
      END IF

      IF (debug_stress .AND. use_virial) THEN
         ! In total: -1.0*E_H
         stdeb = -1.0_dp*fconv*ehartree
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| VOL 1st v_H[n_in]*n_out', one_third_sum_diag(stdeb), det_3x3(stdeb)

         stdeb = -1.0_dp*fconv*exc
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| VOL 1st E_XC[n_in]', one_third_sum_diag(stdeb), det_3x3(stdeb)

         stdeb = -1.0_dp*fconv*dehartree
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| VOL 2nd v_H[dP]*n_in', one_third_sum_diag(stdeb), det_3x3(stdeb)

         stdeb = -1.0_dp*fconv*eexc
         IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
            'STRESS| VOL 2nd v_XC[n_in]*dP', one_third_sum_diag(stdeb), det_3x3(stdeb)

         ! For debugging, create a second virial environment,
         ! apply volume terms immediately
         BLOCK
            TYPE(virial_type) :: virdeb
            virdeb = virial

            CALL para_env%sum(virdeb%pv_overlap)
            CALL para_env%sum(virdeb%pv_ekinetic)
            CALL para_env%sum(virdeb%pv_ppl)
            CALL para_env%sum(virdeb%pv_ppnl)
            CALL para_env%sum(virdeb%pv_ecore_overlap)
            CALL para_env%sum(virdeb%pv_ehartree)
            CALL para_env%sum(virdeb%pv_exc)
            CALL para_env%sum(virdeb%pv_exx)
            CALL para_env%sum(virdeb%pv_vdw)
            CALL para_env%sum(virdeb%pv_mp2)
            CALL para_env%sum(virdeb%pv_nlcc)
            CALL para_env%sum(virdeb%pv_gapw)
            CALL para_env%sum(virdeb%pv_lrigpw)
            CALL para_env%sum(virdeb%pv_virial)
            CALL symmetrize_virial(virdeb)

            ! apply stress-tensor 1st and 2nd volume terms
            DO i = 1, 3
               virdeb%pv_ehartree(i, i) = virdeb%pv_ehartree(i, i) - 2.0_dp*(ehartree + dehartree)
               virdeb%pv_virial(i, i) = virdeb%pv_virial(i, i) - exc - eexc &
                                        - 2.0_dp*(ehartree + dehartree)
               virdeb%pv_exc(i, i) = virdeb%pv_exc(i, i) - exc - eexc
               ! The factor 2 is a hack. It compensates the plus sign in h_stress/pw_poisson_solve.
               ! The sign in pw_poisson_solve is correct for FIST, but not for QS.
               ! There should be a more elegant solution to that ...
            END DO

            CALL para_env%sum(sttot)
            stdeb = fconv*(virdeb%pv_virial - sttot)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| Explicit electronic stress   ', one_third_sum_diag(stdeb), det_3x3(stdeb)

            stdeb = fconv*(virdeb%pv_virial)
            IF (iounit > 0) WRITE (UNIT=iounit, FMT="(T2,A,T41,2(1X,ES19.11))") &
               'STRESS| Explicit total stress   ', one_third_sum_diag(stdeb), det_3x3(stdeb)

            CALL write_stress_tensor_components(virdeb, iounit, cell, unit_string)
            CALL write_stress_tensor(virdeb%pv_virial, iounit, cell, unit_string, .FALSE.)

         END BLOCK
      END IF

      CALL timestop(handle)

   END SUBROUTINE ec_build_ks_matrix_force

! **************************************************************************************************
!> \brief Solve KS equation for a given matrix
!> \param qs_env ...
!> \param ec_env ...
!> \par History
!>      03.2014 created [JGH]
!> \author JGH
! **************************************************************************************************
   SUBROUTINE ec_ks_solver(qs_env, ec_env)

      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER                        :: routineN = 'ec_ks_solver'

      CHARACTER(LEN=default_string_length)               :: headline
      INTEGER                                            :: handle, img, ispin, nhfimg, nspins
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: ksmat, pmat, smat, wmat
      TYPE(dbcsr_type), POINTER                          :: tsmat
      TYPE(dft_control_type), POINTER                    :: dft_control

      CALL timeset(routineN, handle)

      CALL get_qs_env(qs_env=qs_env, dft_control=dft_control)
      nspins = dft_control%nspins
      nhfimg = SIZE(ec_env%matrix_s, 2)

      ! create density matrix
      IF (.NOT. ASSOCIATED(ec_env%matrix_p)) THEN
         headline = "DENSITY MATRIX"
         CALL dbcsr_allocate_matrix_set(ec_env%matrix_p, nspins, nhfimg)
         DO ispin = 1, nspins
            DO img = 1, nhfimg
               tsmat => ec_env%matrix_s(1, img)%matrix
               ALLOCATE (ec_env%matrix_p(ispin, img)%matrix)
               CALL dbcsr_create(ec_env%matrix_p(ispin, img)%matrix, &
                                 name=TRIM(headline), template=tsmat)
               CALL cp_dbcsr_alloc_block_from_nbl(ec_env%matrix_p(ispin, img)%matrix, &
                                                  ec_env%sab_orb)
            END DO
         END DO
      END IF
      ! create energy weighted density matrix
      IF (.NOT. ASSOCIATED(ec_env%matrix_w)) THEN
         headline = "ENERGY WEIGHTED DENSITY MATRIX"
         CALL dbcsr_allocate_matrix_set(ec_env%matrix_w, nspins, nhfimg)
         DO ispin = 1, nspins
            DO img = 1, nhfimg
               tsmat => ec_env%matrix_s(1, img)%matrix
               ALLOCATE (ec_env%matrix_w(ispin, img)%matrix)
               CALL dbcsr_create(ec_env%matrix_w(ispin, img)%matrix, &
                                 name=TRIM(headline), template=tsmat)
               CALL cp_dbcsr_alloc_block_from_nbl(ec_env%matrix_w(ispin, img)%matrix, &
                                                  ec_env%sab_orb)
            END DO
         END DO
      END IF

      IF (ec_env%mao) THEN
         CALL mao_create_matrices(ec_env, ksmat, smat, pmat, wmat)
      ELSE
         ksmat => ec_env%matrix_ks
         smat => ec_env%matrix_s
         pmat => ec_env%matrix_p
         wmat => ec_env%matrix_w
      END IF

      IF (ec_env%do_kpoints) THEN
         IF (ec_env%ks_solver /= ec_diagonalization) THEN
            CALL cp_abort(__LOCATION__, "Harris functional with k-points "// &
                          "needs diagonalization solver")
         END IF
      END IF

      SELECT CASE (ec_env%ks_solver)
      CASE (ec_diagonalization)
         IF (ec_env%do_kpoints) THEN
            CALL ec_diag_solver_kp(qs_env, ec_env, ksmat, smat, pmat, wmat)
         ELSE
            CALL ec_diag_solver_gamma(qs_env, ec_env, ksmat, smat, pmat, wmat)
         END IF
      CASE (ec_ot_diag)
         CALL ec_ot_diag_solver(qs_env, ec_env, ksmat, smat, pmat, wmat)
      CASE (ec_matrix_sign, ec_matrix_trs4, ec_matrix_tc2)
         CALL ec_ls_init(qs_env, ksmat, smat)
         CALL ec_ls_solver(qs_env, pmat, wmat, ec_ls_method=ec_env%ks_solver)
      CASE DEFAULT
         CPABORT("Option invalid or unavailable for ec_env%ks_solver")
      END SELECT

      IF (ec_env%mao) THEN
         CALL mao_release_matrices(ec_env, ksmat, smat, pmat, wmat)
      END IF

      CALL timestop(handle)

   END SUBROUTINE ec_ks_solver

! **************************************************************************************************
!> \brief Create matrices with MAO sizes
!> \param ec_env ...
!> \param ksmat ...
!> \param smat ...
!> \param pmat ...
!> \param wmat ...
!> \par History
!>      08.2016 created [JGH]
!> \author JGH
! **************************************************************************************************
   SUBROUTINE mao_create_matrices(ec_env, ksmat, smat, pmat, wmat)

      TYPE(energy_correction_type), POINTER              :: ec_env
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: ksmat, smat, pmat, wmat

      CHARACTER(LEN=*), PARAMETER :: routineN = 'mao_create_matrices'

      INTEGER                                            :: handle, ispin, nspins
      INTEGER, DIMENSION(:), POINTER                     :: col_blk_sizes
      TYPE(dbcsr_distribution_type)                      :: dbcsr_dist
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: mao_coef
      TYPE(dbcsr_type)                                   :: cgmat

      CALL timeset(routineN, handle)

      mao_coef => ec_env%mao_coef

      NULLIFY (ksmat, smat, pmat, wmat)
      nspins = SIZE(ec_env%matrix_ks, 1)
      CALL dbcsr_get_info(mao_coef(1)%matrix, col_blk_size=col_blk_sizes, distribution=dbcsr_dist)
      CALL dbcsr_allocate_matrix_set(ksmat, nspins, 1)
      CALL dbcsr_allocate_matrix_set(smat, nspins, 1)
      DO ispin = 1, nspins
         ALLOCATE (ksmat(ispin, 1)%matrix)
         CALL dbcsr_create(ksmat(ispin, 1)%matrix, dist=dbcsr_dist, name="MAO KS mat", &
                           matrix_type=dbcsr_type_symmetric, row_blk_size=col_blk_sizes, &
                           col_blk_size=col_blk_sizes)
         ALLOCATE (smat(ispin, 1)%matrix)
         CALL dbcsr_create(smat(ispin, 1)%matrix, dist=dbcsr_dist, name="MAO S mat", &
                           matrix_type=dbcsr_type_symmetric, row_blk_size=col_blk_sizes, &
                           col_blk_size=col_blk_sizes)
      END DO
      !
      CALL dbcsr_create(cgmat, name="TEMP matrix", template=mao_coef(1)%matrix)
      DO ispin = 1, nspins
         CALL dbcsr_multiply("N", "N", 1.0_dp, ec_env%matrix_s(1, 1)%matrix, mao_coef(ispin)%matrix, &
                             0.0_dp, cgmat)
         CALL dbcsr_multiply("T", "N", 1.0_dp, mao_coef(ispin)%matrix, cgmat, 0.0_dp, smat(ispin, 1)%matrix)
         CALL dbcsr_multiply("N", "N", 1.0_dp, ec_env%matrix_ks(1, 1)%matrix, mao_coef(ispin)%matrix, &
                             0.0_dp, cgmat)
         CALL dbcsr_multiply("T", "N", 1.0_dp, mao_coef(ispin)%matrix, cgmat, 0.0_dp, ksmat(ispin, 1)%matrix)
      END DO
      CALL dbcsr_release(cgmat)

      CALL dbcsr_allocate_matrix_set(pmat, nspins, 1)
      DO ispin = 1, nspins
         ALLOCATE (pmat(ispin, 1)%matrix)
         CALL dbcsr_create(pmat(ispin, 1)%matrix, template=smat(1, 1)%matrix, name="MAO P mat")
         CALL cp_dbcsr_alloc_block_from_nbl(pmat(ispin, 1)%matrix, ec_env%sab_orb)
      END DO

      CALL dbcsr_allocate_matrix_set(wmat, nspins, 1)
      DO ispin = 1, nspins
         ALLOCATE (wmat(ispin, 1)%matrix)
         CALL dbcsr_create(wmat(ispin, 1)%matrix, template=smat(1, 1)%matrix, name="MAO W mat")
         CALL cp_dbcsr_alloc_block_from_nbl(wmat(ispin, 1)%matrix, ec_env%sab_orb)
      END DO

      CALL timestop(handle)

   END SUBROUTINE mao_create_matrices

! **************************************************************************************************
!> \brief Release matrices with MAO sizes
!> \param ec_env ...
!> \param ksmat ...
!> \param smat ...
!> \param pmat ...
!> \param wmat ...
!> \par History
!>      08.2016 created [JGH]
!> \author JGH
! **************************************************************************************************
   SUBROUTINE mao_release_matrices(ec_env, ksmat, smat, pmat, wmat)

      TYPE(energy_correction_type), POINTER              :: ec_env
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: ksmat, smat, pmat, wmat

      CHARACTER(LEN=*), PARAMETER :: routineN = 'mao_release_matrices'

      INTEGER                                            :: handle, ispin, nspins
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: mao_coef
      TYPE(dbcsr_type)                                   :: cgmat

      CALL timeset(routineN, handle)

      mao_coef => ec_env%mao_coef
      nspins = SIZE(mao_coef, 1)

      ! save pmat/wmat in full basis format
      CALL dbcsr_create(cgmat, name="TEMP matrix", template=mao_coef(1)%matrix)
      DO ispin = 1, nspins
         CALL dbcsr_multiply("N", "N", 1.0_dp, mao_coef(ispin)%matrix, pmat(ispin, 1)%matrix, 0.0_dp, cgmat)
         CALL dbcsr_multiply("N", "T", 1.0_dp, mao_coef(ispin)%matrix, cgmat, 0.0_dp, &
                             ec_env%matrix_p(ispin, 1)%matrix, retain_sparsity=.TRUE.)
         CALL dbcsr_multiply("N", "N", 1.0_dp, mao_coef(ispin)%matrix, wmat(ispin, 1)%matrix, 0.0_dp, cgmat)
         CALL dbcsr_multiply("N", "T", 1.0_dp, mao_coef(ispin)%matrix, cgmat, 0.0_dp, &
                             ec_env%matrix_w(ispin, 1)%matrix, retain_sparsity=.TRUE.)
      END DO
      CALL dbcsr_release(cgmat)

      CALL dbcsr_deallocate_matrix_set(ksmat)
      CALL dbcsr_deallocate_matrix_set(smat)
      CALL dbcsr_deallocate_matrix_set(pmat)
      CALL dbcsr_deallocate_matrix_set(wmat)

      CALL timestop(handle)

   END SUBROUTINE mao_release_matrices

! **************************************************************************************************
!> \brief Calculate the energy correction
!> \param ec_env ...
!> \param unit_nr ...
!> \author Creation (03.2014,JGH)
! **************************************************************************************************
   SUBROUTINE ec_energy(ec_env, unit_nr)
      TYPE(energy_correction_type)                       :: ec_env
      INTEGER, INTENT(IN)                                :: unit_nr

      CHARACTER(LEN=*), PARAMETER                        :: routineN = 'ec_energy'

      INTEGER                                            :: handle, nspins
      REAL(KIND=dp)                                      :: eband, trace

      CALL timeset(routineN, handle)

      nspins = SIZE(ec_env%matrix_p, 1)
      CALL calculate_ptrace(ec_env%matrix_s, ec_env%matrix_p, trace, nspins)
      IF (unit_nr > 0) WRITE (unit_nr, '(T3,A,T65,F16.10)') 'Tr[PS] ', trace

      ! Total energy depends on energy correction method
      SELECT CASE (ec_env%energy_functional)
      CASE (ec_functional_harris)

         ! Get energy of "band structure" term
         CALL calculate_ptrace(ec_env%matrix_ks, ec_env%matrix_p, eband, nspins, .TRUE.)
         ec_env%eband = eband + ec_env%efield_nuclear

         ! Add Harris functional "correction" terms
         ec_env%etotal = ec_env%eband + ec_env%ehartree + ec_env%exc - ec_env%vhxc + ec_env%ekTS + &
                         ec_env%edispersion - ec_env%ex
         IF (unit_nr > 0) THEN
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Eband    ", ec_env%eband
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Ehartree ", ec_env%ehartree
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Exc      ", ec_env%exc
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Ex       ", ec_env%ex
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Evhxc    ", ec_env%vhxc
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Edisp    ", ec_env%edispersion
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Entropy  ", ec_env%ekTS
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Etotal Harris Functional   ", ec_env%etotal
         END IF

      CASE (ec_functional_dc)

         ! Core hamiltonian energy
         CALL calculate_ptrace(ec_env%matrix_h, ec_env%matrix_p, ec_env%ecore, nspins)

         ec_env%ecore = ec_env%ecore + ec_env%efield_nuclear
         ec_env%etotal = ec_env%ecore + ec_env%ehartree + ec_env%ehartree_1c + &
                         ec_env%exc + ec_env%exc1 + ec_env%ekTS + ec_env%edispersion + &
                         ec_env%ex + ec_env%exc_aux_fit + ec_env%exc1_aux_fit

         IF (unit_nr > 0) THEN
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Ecore    ", ec_env%ecore
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Ehartree ", ec_env%ehartree + ec_env%ehartree_1c
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Exc      ", ec_env%exc + ec_env%exc1
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Ex       ", ec_env%ex
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Exc_aux_fit", ec_env%exc_aux_fit + ec_env%exc1_aux_fit
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Edisp    ", ec_env%edispersion
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Entropy  ", ec_env%ekTS
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Etotal Energy Functional   ", ec_env%etotal
         END IF

      CASE (ec_functional_ext)

         ec_env%etotal = ec_env%ex
         IF (unit_nr > 0) THEN
            WRITE (unit_nr, '(T3,A,T56,F25.15)') "Etotal Energy Functional   ", ec_env%etotal
         END IF

      CASE DEFAULT

         CPABORT("Option invalid or unavailable for ec_env%energy_functional")

      END SELECT

      CALL timestop(handle)

   END SUBROUTINE ec_energy

! **************************************************************************************************
!> \brief builds either the full neighborlist or neighborlists of molecular
!> \brief subsets, depending on parameter values
!> \param qs_env ...
!> \param ec_env ...
!> \par History
!>       2012.07 created [Martin Haeufel]
!>       2016.07 Adapted for Harris functional [JGH]
!> \author Martin Haeufel
! **************************************************************************************************
   SUBROUTINE ec_build_neighborlist(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER :: routineN = 'ec_build_neighborlist'

      INTEGER                                            :: handle, ikind, nimages, nkind, zat
      LOGICAL :: all_potential_present, gth_potential_present, paw_atom, paw_atom_present, &
         sgp_potential_present, skip_load_balance_distributed
      LOGICAL, ALLOCATABLE, DIMENSION(:)                 :: all_present, default_present, &
                                                            oce_present, orb_present, ppl_present, &
                                                            ppnl_present
      REAL(dp)                                           :: subcells
      REAL(dp), ALLOCATABLE, DIMENSION(:)                :: all_radius, c_radius, oce_radius, &
                                                            orb_radius, ppl_radius, ppnl_radius
      REAL(dp), ALLOCATABLE, DIMENSION(:, :)             :: pair_radius
      TYPE(all_potential_type), POINTER                  :: all_potential
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cell_type), POINTER                           :: cell
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(distribution_1d_type), POINTER                :: distribution_1d
      TYPE(distribution_2d_type), POINTER                :: distribution_2d
      TYPE(gth_potential_type), POINTER                  :: gth_potential
      TYPE(gto_basis_set_type), POINTER                  :: basis_set
      TYPE(local_atoms_type), ALLOCATABLE, DIMENSION(:)  :: atom2d
      TYPE(molecule_type), DIMENSION(:), POINTER         :: molecule_set
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(neighbor_list_set_p_type), DIMENSION(:), &
         POINTER                                         :: sab_cn, sab_vdw
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(paw_proj_set_type), POINTER                   :: paw_proj
      TYPE(qs_dispersion_type), POINTER                  :: dispersion_env
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(qs_kind_type), POINTER                        :: qs_kind
      TYPE(qs_ks_env_type), POINTER                      :: ks_env
      TYPE(sgp_potential_type), POINTER                  :: sgp_potential

      CALL timeset(routineN, handle)

      CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set)
      CALL get_qs_kind_set(qs_kind_set, &
                           paw_atom_present=paw_atom_present, &
                           all_potential_present=all_potential_present, &
                           gth_potential_present=gth_potential_present, &
                           sgp_potential_present=sgp_potential_present)
      nkind = SIZE(qs_kind_set)
      ALLOCATE (c_radius(nkind), default_present(nkind))
      ALLOCATE (orb_radius(nkind), all_radius(nkind), ppl_radius(nkind), ppnl_radius(nkind))
      ALLOCATE (orb_present(nkind), all_present(nkind), ppl_present(nkind), ppnl_present(nkind))
      ALLOCATE (pair_radius(nkind, nkind))
      ALLOCATE (atom2d(nkind))

      CALL get_qs_env(qs_env, &
                      atomic_kind_set=atomic_kind_set, &
                      cell=cell, &
                      distribution_2d=distribution_2d, &
                      local_particles=distribution_1d, &
                      particle_set=particle_set, &
                      molecule_set=molecule_set)

      CALL atom2d_build(atom2d, distribution_1d, distribution_2d, atomic_kind_set, &
                        molecule_set, .FALSE., particle_set)

      DO ikind = 1, nkind
         CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom2d(ikind)%list)
         qs_kind => qs_kind_set(ikind)
         CALL get_qs_kind(qs_kind=qs_kind, basis_set=basis_set, basis_type="HARRIS")
         IF (ASSOCIATED(basis_set)) THEN
            orb_present(ikind) = .TRUE.
            CALL get_gto_basis_set(gto_basis_set=basis_set, kind_radius=orb_radius(ikind))
         ELSE
            orb_present(ikind) = .FALSE.
            orb_radius(ikind) = 0.0_dp
         END IF
         CALL get_qs_kind(qs_kind, all_potential=all_potential, &
                          gth_potential=gth_potential, sgp_potential=sgp_potential)
         IF (gth_potential_present .OR. sgp_potential_present) THEN
            IF (ASSOCIATED(gth_potential)) THEN
               CALL get_potential(potential=gth_potential, &
                                  ppl_present=ppl_present(ikind), &
                                  ppl_radius=ppl_radius(ikind), &
                                  ppnl_present=ppnl_present(ikind), &
                                  ppnl_radius=ppnl_radius(ikind))
            ELSE IF (ASSOCIATED(sgp_potential)) THEN
               CALL get_potential(potential=sgp_potential, &
                                  ppl_present=ppl_present(ikind), &
                                  ppl_radius=ppl_radius(ikind), &
                                  ppnl_present=ppnl_present(ikind), &
                                  ppnl_radius=ppnl_radius(ikind))
            ELSE
               ppl_present(ikind) = .FALSE.
               ppl_radius(ikind) = 0.0_dp
               ppnl_present(ikind) = .FALSE.
               ppnl_radius(ikind) = 0.0_dp
            END IF
         END IF
         ! Check the presence of an all electron potential or ERFC potential
         IF (all_potential_present .OR. sgp_potential_present) THEN
            all_present(ikind) = .FALSE.
            all_radius(ikind) = 0.0_dp
            IF (ASSOCIATED(all_potential)) THEN
               all_present(ikind) = .TRUE.
               CALL get_potential(potential=all_potential, core_charge_radius=all_radius(ikind))
            ELSE IF (ASSOCIATED(sgp_potential)) THEN
               IF (sgp_potential%ecp_local) THEN
                  all_present(ikind) = .TRUE.
                  CALL get_potential(potential=sgp_potential, core_charge_radius=all_radius(ikind))
               END IF
            END IF
         END IF
      END DO

      CALL section_vals_val_get(qs_env%input, "DFT%SUBCELLS", r_val=subcells)

      ! overlap
      CALL pair_radius_setup(orb_present, orb_present, orb_radius, orb_radius, pair_radius)
      CALL build_neighbor_lists(ec_env%sab_orb, particle_set, atom2d, cell, pair_radius, &
                                subcells=subcells, nlname="sab_orb")
      ! kpoints
      IF (ec_env%do_kpoints) THEN
         ! pair_radius maybe needs adjustment for HFX?
         CALL build_neighbor_lists(ec_env%sab_kp, particle_set, atom2d, cell, pair_radius, &
                                   subcells=subcells, nlname="sab_kp")
         IF (ec_env%do_ec_hfx) THEN
            CALL build_neighbor_lists(ec_env%sab_kp_nosym, particle_set, atom2d, cell, pair_radius, &
                                      subcells=subcells, nlname="sab_kp_nosym", symmetric=.FALSE.)
         END IF
         CALL get_qs_env(qs_env=qs_env, para_env=para_env)
         CALL kpoint_init_cell_index(ec_env%kpoints, ec_env%sab_kp, para_env, nimages)
      END IF

      ! pseudopotential/AE
      IF (all_potential_present .OR. sgp_potential_present) THEN
         IF (ANY(all_present)) THEN
            CALL pair_radius_setup(orb_present, all_present, orb_radius, all_radius, pair_radius)
            CALL build_neighbor_lists(ec_env%sac_ae, particle_set, atom2d, cell, pair_radius, &
                                      subcells=subcells, operator_type="ABC", nlname="sac_ae")
         END IF
      END IF

      IF (gth_potential_present .OR. sgp_potential_present) THEN
         IF (ANY(ppl_present)) THEN
            CALL pair_radius_setup(orb_present, ppl_present, orb_radius, ppl_radius, pair_radius)
            CALL build_neighbor_lists(ec_env%sac_ppl, particle_set, atom2d, cell, pair_radius, &
                                      subcells=subcells, operator_type="ABC", nlname="sac_ppl")
         END IF

         IF (ANY(ppnl_present)) THEN
            CALL pair_radius_setup(orb_present, ppnl_present, orb_radius, ppnl_radius, pair_radius)
            CALL build_neighbor_lists(ec_env%sap_ppnl, particle_set, atom2d, cell, pair_radius, &
                                      subcells=subcells, operator_type="ABBA", nlname="sap_ppnl")
         END IF
      END IF

      ! Build the neighbor lists for the vdW pair potential
      c_radius(:) = 0.0_dp
      dispersion_env => ec_env%dispersion_env
      sab_vdw => dispersion_env%sab_vdw
      sab_cn => dispersion_env%sab_cn
      IF (dispersion_env%type == xc_vdw_fun_pairpot) THEN
         c_radius(:) = dispersion_env%rc_disp
         default_present = .TRUE. !include all atoms in vdW (even without basis)
         CALL pair_radius_setup(default_present, default_present, c_radius, c_radius, pair_radius)
         CALL build_neighbor_lists(sab_vdw, particle_set, atom2d, cell, pair_radius, &
                                   subcells=subcells, operator_type="PP", nlname="sab_vdw")
         dispersion_env%sab_vdw => sab_vdw
         IF (dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. &
             dispersion_env%pp_type == vdw_pairpot_dftd3bj) THEN
            ! Build the neighbor lists for coordination numbers as needed by the DFT-D3 method
            DO ikind = 1, nkind
               CALL get_atomic_kind(atomic_kind_set(ikind), z=zat)
               c_radius(ikind) = 4._dp*ptable(zat)%covalent_radius*bohr
            END DO
            CALL pair_radius_setup(default_present, default_present, c_radius, c_radius, pair_radius)
            CALL build_neighbor_lists(sab_cn, particle_set, atom2d, cell, pair_radius, &
                                      subcells=subcells, operator_type="PP", nlname="sab_cn")
            dispersion_env%sab_cn => sab_cn
         END IF
      END IF

      ! PAW
      IF (paw_atom_present) THEN
         IF (paw_atom_present) THEN
            ALLOCATE (oce_present(nkind), oce_radius(nkind))
            oce_radius = 0.0_dp
         END IF
         DO ikind = 1, nkind
            ! Warning: we use the same paw_proj_set as for the reference method
            CALL get_qs_kind(qs_kind_set(ikind), paw_proj_set=paw_proj, paw_atom=paw_atom)
            IF (paw_atom) THEN
               oce_present(ikind) = .TRUE.
               CALL get_paw_proj_set(paw_proj_set=paw_proj, rcprj=oce_radius(ikind))
            ELSE
               oce_present(ikind) = .FALSE.
            END IF
         END DO

         ! Build orbital-GAPW projector overlap list
         IF (ANY(oce_present)) THEN
            CALL pair_radius_setup(orb_present, oce_present, orb_radius, oce_radius, pair_radius)
            CALL build_neighbor_lists(ec_env%sap_oce, particle_set, atom2d, cell, pair_radius, &
                                      subcells=subcells, operator_type="ABBA", nlname="sap_oce")
         END IF
         DEALLOCATE (oce_present, oce_radius)
      END IF

      ! Release work storage
      CALL atom2d_cleanup(atom2d)
      DEALLOCATE (atom2d)
      DEALLOCATE (orb_present, default_present, all_present, ppl_present, ppnl_present)
      DEALLOCATE (orb_radius, all_radius, ppl_radius, ppnl_radius, c_radius)
      DEALLOCATE (pair_radius)

      ! Task list
      CALL get_qs_env(qs_env, ks_env=ks_env, dft_control=dft_control)
      skip_load_balance_distributed = dft_control%qs_control%skip_load_balance_distributed
      IF (ASSOCIATED(ec_env%task_list)) CALL deallocate_task_list(ec_env%task_list)
      CALL allocate_task_list(ec_env%task_list)
      CALL generate_qs_task_list(ks_env, ec_env%task_list, basis_type="HARRIS", &
                                 reorder_rs_grid_ranks=.FALSE., &
                                 skip_load_balance_distributed=skip_load_balance_distributed, &
                                 sab_orb_external=ec_env%sab_orb, &
                                 ext_kpoints=ec_env%kpoints)
      ! Task list soft
      IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN
         IF (ASSOCIATED(ec_env%task_list_soft)) CALL deallocate_task_list(ec_env%task_list_soft)
         CALL allocate_task_list(ec_env%task_list_soft)
         CALL generate_qs_task_list(ks_env, ec_env%task_list_soft, basis_type="HARRIS_SOFT", &
                                    reorder_rs_grid_ranks=.FALSE., &
                                    skip_load_balance_distributed=skip_load_balance_distributed, &
                                    sab_orb_external=ec_env%sab_orb, &
                                    ext_kpoints=ec_env%kpoints)
      END IF

      CALL timestop(handle)

   END SUBROUTINE ec_build_neighborlist

! **************************************************************************************************
!> \brief ...
!> \param qs_env ...
!> \param ec_env ...
! **************************************************************************************************
   SUBROUTINE ec_properties(qs_env, ec_env)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env

      CHARACTER(LEN=*), PARAMETER                        :: routineN = 'ec_properties'

      CHARACTER(LEN=8), DIMENSION(3)                     :: rlab
      CHARACTER(LEN=default_path_length)                 :: filename, my_pos_voro
      CHARACTER(LEN=default_string_length)               :: description
      INTEGER :: akind, handle, i, ia, iatom, idir, ikind, iounit, ispin, maxmom, nspins, &
         reference, should_print_bqb, should_print_voro, unit_nr, unit_nr_voro
      LOGICAL                                            :: append_voro, magnetic, periodic, &
                                                            voro_print_txt
      REAL(KIND=dp)                                      :: charge, dd, focc, tmp
      REAL(KIND=dp), DIMENSION(3)                        :: cdip, pdip, rcc, rdip, ria, tdip
      REAL(KIND=dp), DIMENSION(:), POINTER               :: ref_point
      TYPE(atomic_kind_type), POINTER                    :: atomic_kind
      TYPE(cell_type), POINTER                           :: cell
      TYPE(cp_logger_type), POINTER                      :: logger
      TYPE(cp_result_type), POINTER                      :: results
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: matrix_s, moments
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(distribution_1d_type), POINTER                :: local_particles
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(pw_env_type), POINTER                         :: pw_env
      TYPE(pw_pool_p_type), DIMENSION(:), POINTER        :: pw_pools
      TYPE(pw_pool_type), POINTER                        :: auxbas_pw_pool
      TYPE(pw_r3d_rs_type)                               :: rho_elec_rspace
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(section_vals_type), POINTER                   :: ec_section, print_key, print_key_bqb, &
                                                            print_key_voro

      CALL timeset(routineN, handle)

      rlab(1) = "X"
      rlab(2) = "Y"
      rlab(3) = "Z"

      logger => cp_get_default_logger()
      IF (logger%para_env%is_source()) THEN
         iounit = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
      ELSE
         iounit = -1
      END IF

      NULLIFY (dft_control)
      CALL get_qs_env(qs_env, dft_control=dft_control)
      nspins = dft_control%nspins

      ec_section => section_vals_get_subs_vals(qs_env%input, "DFT%ENERGY_CORRECTION")
      print_key => section_vals_get_subs_vals(section_vals=ec_section, &
                                              subsection_name="PRINT%MOMENTS")

      IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), cp_p_file)) THEN

         IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN
            CPABORT("Properties for GAPW in EC NYA")
         END IF

         maxmom = section_get_ival(section_vals=ec_section, &
                                   keyword_name="PRINT%MOMENTS%MAX_MOMENT")
         periodic = section_get_lval(section_vals=ec_section, &
                                     keyword_name="PRINT%MOMENTS%PERIODIC")
         reference = section_get_ival(section_vals=ec_section, &
                                      keyword_name="PRINT%MOMENTS%REFERENCE")
         magnetic = section_get_lval(section_vals=ec_section, &
                                     keyword_name="PRINT%MOMENTS%MAGNETIC")
         NULLIFY (ref_point)
         CALL section_vals_val_get(ec_section, "PRINT%MOMENTS%REF_POINT", r_vals=ref_point)
         unit_nr = cp_print_key_unit_nr(logger=logger, basis_section=ec_section, &
                                        print_key_path="PRINT%MOMENTS", extension=".dat", &
                                        middle_name="moments", log_filename=.FALSE.)

         IF (iounit > 0) THEN
            IF (unit_nr /= iounit .AND. unit_nr > 0) THEN
               INQUIRE (UNIT=unit_nr, NAME=filename)
               WRITE (UNIT=iounit, FMT="(/,T2,A,2(/,T3,A),/)") &
                  "MOMENTS", "The electric/magnetic moments are written to file:", &
                  TRIM(filename)
            ELSE
               WRITE (UNIT=iounit, FMT="(/,T2,A)") "ELECTRIC/MAGNETIC MOMENTS"
            END IF
         END IF

         IF (periodic) THEN
            CPABORT("Periodic moments not implemented with EC")
         ELSE
            CPASSERT(maxmom < 2)
            CPASSERT(.NOT. magnetic)
            IF (maxmom == 1) THEN
               CALL get_qs_env(qs_env=qs_env, cell=cell, para_env=para_env)
               ! reference point
               CALL get_reference_point(rcc, qs_env=qs_env, reference=reference, ref_point=ref_point)
               ! nuclear contribution
               cdip = 0.0_dp
               CALL get_qs_env(qs_env=qs_env, particle_set=particle_set, &
                               qs_kind_set=qs_kind_set, local_particles=local_particles)
               DO ikind = 1, SIZE(local_particles%n_el)
                  DO ia = 1, local_particles%n_el(ikind)
                     iatom = local_particles%list(ikind)%array(ia)
                     ! fold atomic positions back into unit cell
                     ria = pbc(particle_set(iatom)%r - rcc, cell) + rcc
                     ria = ria - rcc
                     atomic_kind => particle_set(iatom)%atomic_kind
                     CALL get_atomic_kind(atomic_kind, kind_number=akind)
                     CALL get_qs_kind(qs_kind_set(akind), core_charge=charge)
                     cdip(1:3) = cdip(1:3) - charge*ria(1:3)
                  END DO
               END DO
               CALL para_env%sum(cdip)
               !
               ! direct density contribution
               CALL ec_efield_integrals(qs_env, ec_env, rcc)
               !
               pdip = 0.0_dp
               DO ispin = 1, nspins
                  DO idir = 1, 3
                     CALL dbcsr_dot(ec_env%matrix_p(ispin, 1)%matrix, &
                                    ec_env%efield%dipmat(idir)%matrix, tmp)
                     pdip(idir) = pdip(idir) + tmp
                  END DO
               END DO
               !
               ! response contribution
               CALL get_qs_env(qs_env=qs_env, matrix_s=matrix_s)
               NULLIFY (moments)
               CALL dbcsr_allocate_matrix_set(moments, 4)
               DO i = 1, 4
                  ALLOCATE (moments(i)%matrix)
                  CALL dbcsr_copy(moments(i)%matrix, matrix_s(1)%matrix, "Moments")
                  CALL dbcsr_set(moments(i)%matrix, 0.0_dp)
               END DO
               CALL build_local_moment_matrix(qs_env, moments, 1, ref_point=rcc)
               !
               focc = 2.0_dp
               IF (nspins == 2) focc = 1.0_dp
               rdip = 0.0_dp
               DO ispin = 1, nspins
                  DO idir = 1, 3
                     CALL dbcsr_dot(ec_env%matrix_z(ispin)%matrix, moments(idir)%matrix, tmp)
                     rdip(idir) = rdip(idir) + tmp
                  END DO
               END DO
               CALL dbcsr_deallocate_matrix_set(moments)
               !
               tdip = -(rdip + pdip + cdip)
               IF (unit_nr > 0) THEN
                  WRITE (unit_nr, "(T3,A)") "Dipoles are based on the traditional operator."
                  dd = SQRT(SUM(tdip(1:3)**2))*debye
                  WRITE (unit_nr, "(T3,A)") "Dipole moment [Debye]"
                  WRITE (unit_nr, "(T5,3(A,A,F14.8,1X),T60,A,T67,F14.8)") &
                     (TRIM(rlab(i)), "=", tdip(i)*debye, i=1, 3), "Total=", dd
               END IF
            END IF
         END IF

         CALL cp_print_key_finished_output(unit_nr=unit_nr, logger=logger, &
                                           basis_section=ec_section, print_key_path="PRINT%MOMENTS")
         CALL get_qs_env(qs_env=qs_env, results=results)
         description = "[DIPOLE]"
         CALL cp_results_erase(results=results, description=description)
         CALL put_results(results=results, description=description, values=tdip(1:3))
      END IF

      ! Do a Voronoi Integration or write a compressed BQB File
      print_key_voro => section_vals_get_subs_vals(ec_section, "PRINT%VORONOI")
      print_key_bqb => section_vals_get_subs_vals(ec_section, "PRINT%E_DENSITY_BQB")
      IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key_voro), cp_p_file)) THEN
         should_print_voro = 1
      ELSE
         should_print_voro = 0
      END IF
      IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key_bqb), cp_p_file)) THEN
         should_print_bqb = 1
      ELSE
         should_print_bqb = 0
      END IF
      IF ((should_print_voro /= 0) .OR. (should_print_bqb /= 0)) THEN

         IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN
            CPABORT("Properties for GAPW in EC NYA")
         END IF

         CALL get_qs_env(qs_env=qs_env, &
                         pw_env=pw_env)
         CALL pw_env_get(pw_env=pw_env, &
                         auxbas_pw_pool=auxbas_pw_pool, &
                         pw_pools=pw_pools)
         CALL auxbas_pw_pool%create_pw(pw=rho_elec_rspace)

         IF (dft_control%nspins > 1) THEN

            ! add Pout and Pz
            CALL pw_copy(ec_env%rhoout_r(1), rho_elec_rspace)
            CALL pw_axpy(ec_env%rhoout_r(2), rho_elec_rspace)

            CALL pw_axpy(ec_env%rhoz_r(1), rho_elec_rspace)
            CALL pw_axpy(ec_env%rhoz_r(2), rho_elec_rspace)
         ELSE

            ! add Pout and Pz
            CALL pw_copy(ec_env%rhoout_r(1), rho_elec_rspace)
            CALL pw_axpy(ec_env%rhoz_r(1), rho_elec_rspace)
         END IF ! nspins

         IF (should_print_voro /= 0) THEN
            CALL section_vals_val_get(print_key_voro, "OUTPUT_TEXT", l_val=voro_print_txt)
            IF (voro_print_txt) THEN
               append_voro = section_get_lval(ec_section, "PRINT%VORONOI%APPEND")
               my_pos_voro = "REWIND"
               IF (append_voro) THEN
                  my_pos_voro = "APPEND"
               END IF
               unit_nr_voro = cp_print_key_unit_nr(logger, ec_section, "PRINT%VORONOI", extension=".voronoi", &
                                                   file_position=my_pos_voro, log_filename=.FALSE.)
            ELSE
               unit_nr_voro = 0
            END IF
         ELSE
            unit_nr_voro = 0
         END IF

         CALL entry_voronoi_or_bqb(should_print_voro, should_print_bqb, print_key_voro, print_key_bqb, &
                                   unit_nr_voro, qs_env, rho_elec_rspace)

         CALL auxbas_pw_pool%give_back_pw(rho_elec_rspace)

         IF (unit_nr_voro > 0) THEN
            CALL cp_print_key_finished_output(unit_nr_voro, logger, ec_section, "PRINT%VORONOI")
         END IF

      END IF

      CALL timestop(handle)

   END SUBROUTINE ec_properties
! **************************************************************************************************
!> \brief ...
!> \param qs_env ...
!> \param ec_env ...
!> \param unit_nr ...
! **************************************************************************************************
   SUBROUTINE harris_wfn_output(qs_env, ec_env, unit_nr)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env
      INTEGER, INTENT(IN)                                :: unit_nr

      CHARACTER(LEN=*), PARAMETER                        :: routineN = 'harris_wfn_output'

      INTEGER                                            :: handle, ic, ires, ispin, nimages, nsize, &
                                                            nspin
      INTEGER, DIMENSION(3)                              :: cell
      INTEGER, DIMENSION(:, :, :), POINTER               :: cell_to_index
      TYPE(cp_blacs_env_type), POINTER                   :: blacs_env
      TYPE(cp_fm_struct_type), POINTER                   :: fm_struct
      TYPE(cp_fm_type)                                   :: fmat
      TYPE(cp_logger_type), POINTER                      :: logger
      TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER       :: denmat
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(section_vals_type), POINTER                   :: ec_section

      MARK_USED(unit_nr)

      CALL timeset(routineN, handle)

      logger => cp_get_default_logger()

      ec_section => section_vals_get_subs_vals(qs_env%input, "DFT%ENERGY_CORRECTION")
      CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set, particle_set=particle_set)

      IF (ec_env%do_kpoints) THEN
         ires = cp_print_key_unit_nr(logger, ec_section, "PRINT%HARRIS_OUTPUT_WFN", &
                                     extension=".kp", file_status="REPLACE", file_action="WRITE", &
                                     file_form="UNFORMATTED", middle_name="Harris")

         CALL write_kpoints_file_header(qs_kind_set, particle_set, ires, basis_type="HARRIS")

         denmat => ec_env%matrix_p
         nspin = SIZE(denmat, 1)
         nimages = SIZE(denmat, 2)
         NULLIFY (cell_to_index)
         IF (nimages > 1) THEN
            CALL get_kpoint_info(kpoint=ec_env%kpoints, cell_to_index=cell_to_index)
         END IF
         CALL dbcsr_get_info(denmat(1, 1)%matrix, nfullrows_total=nsize)
         NULLIFY (blacs_env, para_env)
         CALL get_qs_env(qs_env=qs_env, blacs_env=blacs_env, para_env=para_env)
         NULLIFY (fm_struct)
         CALL cp_fm_struct_create(fm_struct, context=blacs_env, nrow_global=nsize, &
                                  ncol_global=nsize, para_env=para_env)
         CALL cp_fm_create(fmat, fm_struct)
         CALL cp_fm_struct_release(fm_struct)

         DO ispin = 1, nspin
            IF (ires > 0) WRITE (ires) ispin, nspin, nimages
            DO ic = 1, nimages
               IF (nimages > 1) THEN
                  cell = get_cell(ic, cell_to_index)
               ELSE
                  cell = 0
               END IF
               IF (ires > 0) WRITE (ires) ic, cell
               CALL copy_dbcsr_to_fm(denmat(ispin, ic)%matrix, fmat)
               CALL cp_fm_write_unformatted(fmat, ires)
            END DO
         END DO

         CALL cp_print_key_finished_output(ires, logger, ec_section, "PRINT%HARRIS_OUTPUT_WFN")
         CALL cp_fm_release(fmat)
      ELSE
         CALL cp_warn(__LOCATION__, &
                      "Orbital energy correction potential is an experimental feature. "// &
                      "Use it with extreme care")
      END IF

      CALL timestop(handle)

   END SUBROUTINE harris_wfn_output

! **************************************************************************************************
!> \brief ...
!> \param qs_env ...
!> \param ec_env ...
!> \param unit_nr ...
! **************************************************************************************************
   SUBROUTINE response_force_error(qs_env, ec_env, unit_nr)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(energy_correction_type), POINTER              :: ec_env
      INTEGER, INTENT(IN)                                :: unit_nr

      CHARACTER(LEN=10)                                  :: eformat
      INTEGER                                            :: feunit, funit, i, ia, ib, ispin, mref, &
                                                            na, nao, natom, nb, norb, nref, &
                                                            nsample, nspins
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: natom_of_kind, rlist, t2cind
      LOGICAL                                            :: debug_f, do_resp, is_source
      REAL(KIND=dp)                                      :: focc, rfac, vres
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:)           :: tvec, yvec
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: eforce, fmlocal, fmreord, smat
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :)     :: smpforce
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cp_fm_struct_type), POINTER                   :: fm_struct, fm_struct_mat
      TYPE(cp_fm_type)                                   :: hmats
      TYPE(cp_fm_type), DIMENSION(:, :), POINTER         :: rpmos, Spmos
      TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: matrix_s
      TYPE(dbcsr_type), POINTER                          :: mats
      TYPE(mp_para_env_type), POINTER                    :: para_env
      TYPE(qs_force_type), DIMENSION(:), POINTER         :: ks_force, res_force
      TYPE(virial_type)                                  :: res_virial
      TYPE(virial_type), POINTER                         :: ks_virial

      IF (unit_nr > 0) THEN
         WRITE (unit_nr, '(/,T2,A,A,A,A,A)') "!", REPEAT("-", 25), &
            " Response Force Error Est. ", REPEAT("-", 25), "!"
         SELECT CASE (ec_env%error_method)
         CASE ("F")
            WRITE (unit_nr, '(T2,A)') " Response Force Error Est. using full RHS"
         CASE ("D")
            WRITE (unit_nr, '(T2,A)') " Response Force Error Est. using delta RHS"
         CASE ("E")
            WRITE (unit_nr, '(T2,A)') " Response Force Error Est. using extrapolated RHS"
            WRITE (unit_nr, '(T2,A,E20.10)') " Extrapolation cutoff:", ec_env%error_cutoff
            WRITE (unit_nr, '(T2,A,I10)') " Max. extrapolation size:", ec_env%error_subspace
         CASE DEFAULT
            CPABORT("Unknown Error Estimation Method")
         END SELECT
      END IF

      IF (ABS(ec_env%orbrot_index) > 1.E-8_dp .OR. ec_env%phase_index > 1.E-8_dp) THEN
         CPABORT("Response error calculation for rotated orbital sets not implemented")
      END IF

      SELECT CASE (ec_env%energy_functional)
      CASE (ec_functional_harris)
         CPWARN('Response force error calculation not possible for Harris functional.')
      CASE (ec_functional_dc)
         CPWARN('Response force error calculation not possible for DCDFT.')
      CASE (ec_functional_ext)

         ! backup force array
         CALL get_qs_env(qs_env, force=ks_force, virial=ks_virial, &
                         atomic_kind_set=atomic_kind_set)
         CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, natom_of_kind=natom_of_kind)
         NULLIFY (res_force)
         CALL allocate_qs_force(res_force, natom_of_kind)
         DEALLOCATE (natom_of_kind)
         CALL zero_qs_force(res_force)
         res_virial = ks_virial
         CALL zero_virial(ks_virial, reset=.FALSE.)
         CALL set_qs_env(qs_env, force=res_force)
         !
         CALL get_qs_env(qs_env, natom=natom)
         ALLOCATE (eforce(3, natom))
         !
         CALL get_qs_env(qs_env, para_env=para_env)
         is_source = para_env%is_source()
         !
         nspins = SIZE(ec_env%mo_occ)
         CALL cp_fm_get_info(ec_env%mo_occ(1), nrow_global=nao)
         !
         IF (is_source) THEN
            CALL open_file(ec_env%exresperr_fn, file_status="OLD", file_action="READ", &
                           file_form="FORMATTED", unit_number=funit)
            READ (funit, '(A)') eformat
            CALL uppercase(eformat)
            READ (funit, *) nsample
         END IF
         CALL para_env%bcast(nsample, para_env%source)
         CALL para_env%bcast(eformat, para_env%source)
         !
         CALL cp_fm_get_info(ec_env%mo_occ(1), matrix_struct=fm_struct)
         CALL cp_fm_struct_create(fm_struct_mat, template_fmstruct=fm_struct, &
                                  nrow_global=nao, ncol_global=nao)
         ALLOCATE (fmlocal(nao, nao))
         IF (ADJUSTL(TRIM(eformat)) == "TREXIO") THEN
            ALLOCATE (fmreord(nao, nao))
            CALL get_t2cindex(qs_env, t2cind)
         END IF
         ALLOCATE (rpmos(nsample, nspins))
         ALLOCATE (smpforce(3, natom, nsample))
         smpforce = 0.0_dp
         !
         focc = 2.0_dp
         IF (nspins == 1) focc = 4.0_dp
         CALL cp_fm_create(hmats, fm_struct_mat)
         !
         DO i = 1, nsample
            DO ispin = 1, nspins
               CALL cp_fm_create(rpmos(i, ispin), fm_struct)
               IF (is_source) THEN
                  READ (funit, *) na, nb
                  CPASSERT(na == nao .AND. nb == nao)
                  READ (funit, *) fmlocal
               ELSE
                  fmlocal = 0.0_dp
               END IF
               CALL para_env%bcast(fmlocal)
               !
               SELECT CASE (ADJUSTL(TRIM(eformat)))
               CASE ("CP2K")
                  ! nothing to do
               CASE ("TREXIO")
                  ! reshuffel indices
                  DO ia = 1, nao
                     DO ib = 1, nao
                        fmreord(ia, ib) = fmlocal(t2cind(ia), t2cind(ib))
                     END DO
                  END DO
                  fmlocal(1:nao, 1:nao) = fmreord(1:nao, 1:nao)
               CASE DEFAULT
                  CPABORT("Error file dE/dC: unknown format")
               END SELECT
               !
               CALL cp_fm_set_submatrix(hmats, fmlocal, 1, 1, nao, nao)
               CALL cp_fm_get_info(rpmos(i, ispin), ncol_global=norb)
               CALL parallel_gemm('N', 'N', nao, norb, nao, focc, hmats, &
                                  ec_env%mo_occ(ispin), 0.0_dp, rpmos(i, ispin))
               IF (ec_env%error_method == "D" .OR. ec_env%error_method == "E") THEN
                  CALL cp_fm_scale_and_add(1.0_dp, rpmos(i, ispin), -1.0_dp, ec_env%cpref(ispin))
               END IF
            END DO
         END DO
         CALL cp_fm_struct_release(fm_struct_mat)
         IF (ADJUSTL(TRIM(eformat)) == "TREXIO") THEN
            DEALLOCATE (fmreord, t2cind)
         END IF

         IF (is_source) THEN
            CALL close_file(funit)
         END IF

         IF (unit_nr > 0) THEN
            CALL open_file(ec_env%exresult_fn, file_status="OLD", file_form="FORMATTED", &
                           file_action="WRITE", file_position="APPEND", unit_number=feunit)
            WRITE (feunit, "(/,6X,A)") " Response Forces from error sampling [Hartree/Bohr]"
            i = 0
            WRITE (feunit, "(5X,I8)") i
            DO ia = 1, natom
               WRITE (feunit, "(5X,3F20.12)") ec_env%rf(1:3, ia)
            END DO
         END IF

         debug_f = ec_env%debug_forces .OR. ec_env%debug_stress

         IF (ec_env%error_method == "E") THEN
            CALL get_qs_env(qs_env, matrix_s=matrix_s)
            mats => matrix_s(1)%matrix
            ALLOCATE (Spmos(nsample, nspins))
            DO i = 1, nsample
               DO ispin = 1, nspins
                  CALL cp_fm_create(Spmos(i, ispin), fm_struct, set_zero=.TRUE.)
                  CALL cp_dbcsr_sm_fm_multiply(mats, rpmos(i, ispin), Spmos(i, ispin), norb)
               END DO
            END DO
         END IF

         mref = ec_env%error_subspace
         mref = MIN(mref, nsample)
         nref = 0
         ALLOCATE (smat(mref, mref), tvec(mref), yvec(mref), rlist(mref))
         rlist = 0

         CALL cp_fm_release(ec_env%cpmos)

         DO i = 1, nsample
            IF (unit_nr > 0) THEN
               WRITE (unit_nr, '(T2,A,I6)') " Response Force Number ", i
            END IF
            !
            CALL zero_qs_force(res_force)
            CALL zero_virial(ks_virial, reset=.FALSE.)
            DO ispin = 1, nspins
               CALL dbcsr_set(ec_env%matrix_hz(ispin)%matrix, 0.0_dp)
            END DO
            !
            ALLOCATE (ec_env%cpmos(nspins))
            DO ispin = 1, nspins
               CALL cp_fm_create(ec_env%cpmos(ispin), fm_struct)
            END DO
            !
            do_resp = .TRUE.
            IF (ec_env%error_method == "F" .OR. ec_env%error_method == "D") THEN
               DO ispin = 1, nspins
                  CALL cp_fm_to_fm(rpmos(i, ispin), ec_env%cpmos(ispin))
               END DO
            ELSE IF (ec_env%error_method == "E") THEN
               CALL cp_extrapolate(rpmos, Spmos, i, nref, rlist, smat, tvec, yvec, vres)
               IF (vres > ec_env%error_cutoff .OR. nref < MIN(5, mref)) THEN
                  DO ispin = 1, nspins
                     CALL cp_fm_to_fm(rpmos(i, ispin), ec_env%cpmos(ispin))
                  END DO
                  DO ib = 1, nref
                     ia = rlist(ib)
                     rfac = -yvec(ib)
                     DO ispin = 1, nspins
                        CALL cp_fm_scale_and_add(1.0_dp, ec_env%cpmos(ispin), &
                                                 rfac, rpmos(ia, ispin))
                     END DO
                  END DO
               ELSE
                  do_resp = .FALSE.
               END IF
               IF (unit_nr > 0) THEN
                  WRITE (unit_nr, '(T2,A,T60,I4,T69,F12.8)') &
                     " Response Vector Extrapolation [nref|delta] = ", nref, vres
               END IF
            ELSE
               CPABORT("Unknown Error Estimation Method")
            END IF

            IF (do_resp) THEN
               CALL matrix_r_forces(qs_env, ec_env%cpmos, ec_env%mo_occ, &
                                    ec_env%matrix_w(1, 1)%matrix, unit_nr, &
                                    ec_env%debug_forces, ec_env%debug_stress)

               CALL response_calculation(qs_env, ec_env, silent=.TRUE.)

               CALL response_force(qs_env, &
                                   vh_rspace=ec_env%vh_rspace, &
                                   vxc_rspace=ec_env%vxc_rspace, &
                                   vtau_rspace=ec_env%vtau_rspace, &
                                   vadmm_rspace=ec_env%vadmm_rspace, &
                                   vadmm_tau_rspace=ec_env%vadmm_tau_rspace, &
                                   matrix_hz=ec_env%matrix_hz, &
                                   matrix_pz=ec_env%matrix_z, &
                                   matrix_pz_admm=ec_env%z_admm, &
                                   matrix_wz=ec_env%matrix_wz, &
                                   rhopz_r=ec_env%rhoz_r, &
                                   zehartree=ec_env%ehartree, &
                                   zexc=ec_env%exc, &
                                   zexc_aux_fit=ec_env%exc_aux_fit, &
                                   p_env=ec_env%p_env, &
                                   debug=debug_f)
               CALL total_qs_force(eforce, res_force, atomic_kind_set)
               CALL para_env%sum(eforce)
            ELSE
               IF (unit_nr > 0) THEN
                  WRITE (unit_nr, '(T2,A)') " Response Force Calculation is skipped. "
               END IF
               eforce = 0.0_dp
            END IF
            !
            IF (ec_env%error_method == "D") THEN
               eforce(1:3, 1:natom) = eforce(1:3, 1:natom) + ec_env%rf(1:3, 1:natom)
               smpforce(1:3, 1:natom, i) = eforce(1:3, 1:natom)
            ELSE IF (ec_env%error_method == "E") THEN
               DO ib = 1, nref
                  ia = rlist(ib)
                  rfac = yvec(ib)
                  eforce(1:3, 1:natom) = eforce(1:3, 1:natom) + rfac*smpforce(1:3, 1:natom, ia)
               END DO
               smpforce(1:3, 1:natom, i) = eforce(1:3, 1:natom)
               eforce(1:3, 1:natom) = eforce(1:3, 1:natom) + ec_env%rf(1:3, 1:natom)
               IF (do_resp .AND. nref < mref) THEN
                  nref = nref + 1
                  rlist(nref) = i
               END IF
            ELSE
               smpforce(1:3, 1:natom, i) = eforce(1:3, 1:natom)
            END IF

            IF (unit_nr > 0) THEN
               WRITE (unit_nr, *) " FORCES"
               DO ia = 1, natom
                  WRITE (unit_nr, "(i7,3F11.6,6X,3F11.6)") ia, eforce(1:3, ia), &
                     (eforce(1:3, ia) - ec_env%rf(1:3, ia))
               END DO
               WRITE (unit_nr, *)
               ! force file
               WRITE (feunit, "(5X,I8)") i
               DO ia = 1, natom
                  WRITE (feunit, "(5X,3F20.12)") eforce(1:3, ia)
               END DO
            END IF

            CALL cp_fm_release(ec_env%cpmos)

         END DO

         IF (unit_nr > 0) THEN
            CALL close_file(feunit)
         END IF

         DEALLOCATE (smat, tvec, yvec, rlist)

         CALL cp_fm_release(hmats)
         CALL cp_fm_release(rpmos)
         IF (ec_env%error_method == "E") THEN
            CALL cp_fm_release(Spmos)
         END IF

         DEALLOCATE (eforce, smpforce)

         ! reset force array
         CALL get_qs_env(qs_env, force=res_force, virial=ks_virial)
         CALL set_qs_env(qs_env, force=ks_force)
         CALL deallocate_qs_force(res_force)
         ks_virial = res_virial

      CASE DEFAULT
         CPABORT("unknown energy correction")
      END SELECT

   END SUBROUTINE response_force_error

! **************************************************************************************************
!> \brief ...
!> \param rpmos ...
!> \param Spmos ...
!> \param ip ...
!> \param nref ...
!> \param rlist ...
!> \param smat ...
!> \param tvec ...
!> \param yvec ...
!> \param vres ...
! **************************************************************************************************
   SUBROUTINE cp_extrapolate(rpmos, Spmos, ip, nref, rlist, smat, tvec, yvec, vres)
      TYPE(cp_fm_type), DIMENSION(:, :), POINTER         :: rpmos, Spmos
      INTEGER, INTENT(IN)                                :: ip, nref
      INTEGER, DIMENSION(:), INTENT(IN)                  :: rlist
      REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT)      :: smat
      REAL(KIND=dp), DIMENSION(:), INTENT(INOUT)         :: tvec, yvec
      REAL(KIND=dp), INTENT(OUT)                         :: vres

      INTEGER                                            :: i, ia, j, ja
      REAL(KIND=dp)                                      :: aval
      REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: sinv

      smat = 0.0_dp
      tvec = 0.0_dp
      yvec = 0.0_dp
      aval = 0.0_dp

      IF (nref > 0) THEN
         ALLOCATE (sinv(nref, nref))
         !
         DO i = 1, nref
            ia = rlist(i)
            tvec(i) = ctrace(rpmos(ip, :), Spmos(ia, :))
            DO j = i + 1, nref
               ja = rlist(j)
               smat(j, i) = ctrace(rpmos(ja, :), Spmos(ia, :))
               smat(i, j) = smat(j, i)
            END DO
            smat(i, i) = ctrace(rpmos(ia, :), Spmos(ia, :))
         END DO
         aval = ctrace(rpmos(ip, :), Spmos(ip, :))
         !
         sinv(1:nref, 1:nref) = smat(1:nref, 1:nref)
         CALL invmat_symm(sinv(1:nref, 1:nref))
         !
         yvec(1:nref) = MATMUL(sinv(1:nref, 1:nref), tvec(1:nref))
         !
         vres = aval - SUM(yvec(1:nref)*tvec(1:nref))
         vres = SQRT(ABS(vres))
         !
         DEALLOCATE (sinv)
      ELSE
         vres = 1.0_dp
      END IF

   END SUBROUTINE cp_extrapolate

! **************************************************************************************************
!> \brief ...
!> \param ca ...
!> \param cb ...
!> \return ...
! **************************************************************************************************
   FUNCTION ctrace(ca, cb)
      TYPE(cp_fm_type), DIMENSION(:)                     :: ca, cb
      REAL(KIND=dp)                                      :: ctrace

      INTEGER                                            :: is, ns
      REAL(KIND=dp)                                      :: trace

      ns = SIZE(ca)
      ctrace = 0.0_dp
      DO is = 1, ns
         trace = 0.0_dp
         CALL cp_fm_trace(ca(is), cb(is), trace)
         ctrace = ctrace + trace
      END DO

   END FUNCTION ctrace

! **************************************************************************************************
!> \brief ...
!> \param qs_env ...
!> \param t2cind ...
! **************************************************************************************************
   SUBROUTINE get_t2cindex(qs_env, t2cind)
      TYPE(qs_environment_type), POINTER                 :: qs_env
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: t2cind

      INTEGER                                            :: i, iatom, ikind, is, iset, ishell, k, l, &
                                                            m, natom, nset, nsgf, numshell
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: lshell
      INTEGER, DIMENSION(:), POINTER                     :: nshell
      INTEGER, DIMENSION(:, :), POINTER                  :: lval
      TYPE(gto_basis_set_type), POINTER                  :: basis_set
      TYPE(particle_type), DIMENSION(:), POINTER         :: particle_set
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set

      ! Reorder index for basis functions from TREXIO to CP2K

      CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set, particle_set=particle_set, natom=natom)
      CALL get_qs_kind_set(qs_kind_set, nshell=numshell, nsgf=nsgf)

      ALLOCATE (t2cind(nsgf))
      ALLOCATE (lshell(numshell))

      ishell = 0
      DO iatom = 1, natom
         CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind)
         CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_set, basis_type="ORB")
         CALL get_gto_basis_set(basis_set, nset=nset, nshell=nshell, l=lval)
         DO iset = 1, nset
            DO is = 1, nshell(iset)
               ishell = ishell + 1
               l = lval(is, iset)
               lshell(ishell) = l
            END DO
         END DO
      END DO

      i = 0
      DO ishell = 1, numshell
         l = lshell(ishell)
         DO k = 1, 2*l + 1
            m = (-1)**k*FLOOR(REAL(k, KIND=dp)/2.0_dp)
            t2cind(i + l + 1 + m) = i + k
         END DO
         i = i + 2*l + 1
      END DO

      DEALLOCATE (lshell)

   END SUBROUTINE get_t2cindex

END MODULE energy_corrections
