!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright (C) 2000 - 2017  CP2K developers group                                               !
!--------------------------------------------------------------------------------------------------!

! **************************************************************************************************
!> \brief routines that build the integrals of the Vxc potential calculated
!>      for the atomic density in the basis set of spherical primitives
! **************************************************************************************************
MODULE qs_vxc_atom
   USE atomic_kind_types,               ONLY: atomic_kind_type,&
                                              get_atomic_kind
   USE basis_set_types,                 ONLY: get_gto_basis_set,&
                                              gto_basis_set_type
   USE cp_control_types,                ONLY: dft_control_type
   USE cp_para_types,                   ONLY: cp_para_env_type
   USE input_constants,                 ONLY: tddfpt_excitations,&
                                              tddfpt_triplet,&
                                              xc_none
   USE input_section_types,             ONLY: section_vals_get_subs_vals,&
                                              section_vals_type,&
                                              section_vals_val_get
   USE kinds,                           ONLY: dp,&
                                              dp_size
   USE memory_utilities,                ONLY: reallocate
   USE message_passing,                 ONLY: mp_sum
   USE orbital_pointers,                ONLY: indso,&
                                              nsoset,&
                                              soset
   USE qs_energy_types,                 ONLY: qs_energy_type
   USE qs_environment_types,            ONLY: get_qs_env,&
                                              qs_environment_type
   USE qs_grid_atom,                    ONLY: grid_atom_type
   USE qs_harmonics_atom,               ONLY: get_none0_cg_list,&
                                              harmonics_atom_type
   USE qs_kind_types,                   ONLY: get_qs_kind,&
                                              has_nlcc,&
                                              qs_kind_type
   USE qs_linres_types,                 ONLY: nablavks_atom_type
   USE qs_p_env_types,                  ONLY: qs_p_env_type
   USE qs_rho_atom_types,               ONLY: get_rho_atom,&
                                              rho_atom_coeff,&
                                              rho_atom_type
   USE termination,                     ONLY: stop_memory
   USE util,                            ONLY: get_limit
   USE xc_atom,                         ONLY: fill_rho_set,&
                                              vxc_of_r_new,&
                                              xc_2nd_deriv_of_r,&
                                              xc_rho_set_atom_update
   USE xc_derivative_set_types,         ONLY: xc_derivative_set_type,&
                                              xc_dset_create,&
                                              xc_dset_release,&
                                              xc_dset_zero_all
   USE xc_derivatives,                  ONLY: xc_functionals_get_needs
   USE xc_rho_cflags_types,             ONLY: xc_rho_cflags_type
   USE xc_rho_set_types,                ONLY: xc_rho_set_create,&
                                              xc_rho_set_release,&
                                              xc_rho_set_type
#include "./base/base_uses.f90"

   IMPLICIT NONE

   PRIVATE

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

   PUBLIC :: calculate_vxc_atom, &
             calculate_xc_2nd_deriv_atom, &
             calc_rho_angular, &
             gaVxcgb_noGC

CONTAINS

! **************************************************************************************************
!> \brief ...
!> \param qs_env ...
!> \param energy_only ...
!> \param gradient_atom_set ...
!> \param adiabatic_rescale_factor ...
! **************************************************************************************************
   SUBROUTINE calculate_vxc_atom(qs_env, energy_only, gradient_atom_set, adiabatic_rescale_factor)

      TYPE(qs_environment_type), POINTER                 :: qs_env
      LOGICAL, INTENT(IN)                                :: energy_only
      TYPE(nablavks_atom_type), DIMENSION(:), OPTIONAL, &
         POINTER                                         :: gradient_atom_set
      REAL(dp), INTENT(IN), OPTIONAL                     :: adiabatic_rescale_factor

      CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_vxc_atom', &
         routineP = moduleN//':'//routineN

      INTEGER                                            :: bo(2), handle, ia, iat, iatom, idir, &
                                                            ikind, ir, ispin, mepos, myfun, na, &
                                                            natom, nr, nspins, num_pe
      INTEGER, DIMENSION(2, 3)                           :: bounds
      INTEGER, DIMENSION(:), POINTER                     :: atom_list
      LOGICAL                                            :: donlcc, epr_xc, gradient_f, lsd, nlcc, &
                                                            paw_atom, tau_f
      REAL(dp)                                           :: density_cut, exc_h, exc_s, gradient_cut, &
                                                            my_adiabatic_rescale_factor, tau_cut
      REAL(dp), DIMENSION(:, :), POINTER                 :: rho_h, rho_nlcc, rho_s, tau_h, tau_s, &
                                                            weight
      REAL(dp), DIMENSION(:, :, :), POINTER              :: vtau_h, vtau_s, vxc_h, vxc_s
      REAL(dp), DIMENSION(:, :, :, :), POINTER           :: drho_h, drho_s, vxg_h, vxg_s
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cp_para_env_type), POINTER                    :: para_env
      TYPE(dft_control_type), POINTER                    :: dft_control
      TYPE(grid_atom_type), POINTER                      :: grid_atom
      TYPE(harmonics_atom_type), POINTER                 :: harmonics
      TYPE(qs_energy_type), POINTER                      :: energy
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(qs_kind_type), POINTER                        :: qs_kind
      TYPE(rho_atom_coeff), DIMENSION(:), POINTER        :: dr_h, dr_s, r_h, r_s
      TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER     :: r_h_d, r_s_d, trho_h, trho_s
      TYPE(rho_atom_type), DIMENSION(:), POINTER         :: rho_atom_set
      TYPE(rho_atom_type), POINTER                       :: rho_atom
      TYPE(section_vals_type), POINTER                   :: input, xc_fun_section, xc_section
      TYPE(xc_derivative_set_type), POINTER              :: deriv_set
      TYPE(xc_rho_cflags_type)                           :: needs
      TYPE(xc_rho_set_type), POINTER                     :: rho_set_h, rho_set_s

! -------------------------------------------------------------------------

      CALL timeset(routineN, handle)

      NULLIFY (atom_list)
      NULLIFY (qs_kind_set)
      NULLIFY (atomic_kind_set)
      NULLIFY (qs_kind)
      NULLIFY (deriv_set)
      NULLIFY (energy)
      NULLIFY (grid_atom)
      NULLIFY (harmonics)
      NULLIFY (input)
      NULLIFY (para_env)
      NULLIFY (rho_atom)
      NULLIFY (rho_atom_set)
      NULLIFY (rho_set_h)
      NULLIFY (rho_set_s)

      epr_xc = .FALSE.
      IF (PRESENT(gradient_atom_set)) THEN
         epr_xc = .TRUE.
      END IF

      IF (PRESENT(adiabatic_rescale_factor)) THEN
         my_adiabatic_rescale_factor = adiabatic_rescale_factor
      ELSE
         my_adiabatic_rescale_factor = 1.0_dp
      END IF

      CALL get_qs_env(qs_env=qs_env, &
                      dft_control=dft_control, &
                      para_env=para_env, &
                      energy=energy, &
                      atomic_kind_set=atomic_kind_set, &
                      qs_kind_set=qs_kind_set, &
                      input=input, &
                      rho_atom_set=rho_atom_set)

      nlcc = has_nlcc(qs_kind_set)

      IF (epr_xc) THEN
         xc_section => section_vals_get_subs_vals(input, &
                                                  "PROPERTIES%LINRES%EPR%PRINT%G_TENSOR%XC")
      ELSE
         xc_section => section_vals_get_subs_vals(input, "DFT%XC")
      END IF
      xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
      CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", &
                                i_val=myfun)

      IF (myfun == xc_none) THEN
         energy%exc1 = 0.0_dp
         rho_atom_set(:)%exc_h = 0.0_dp
         rho_atom_set(:)%exc_s = 0.0_dp
      ELSE
         CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", &
                                   r_val=density_cut)
         CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", &
                                   r_val=gradient_cut)
         CALL section_vals_val_get(xc_section, "TAU_CUTOFF", &
                                   r_val=tau_cut)

         lsd = dft_control%lsd
         nspins = dft_control%nspins
         needs = xc_functionals_get_needs(xc_fun_section, &
                                          lsd=lsd, &
                                          add_basic_components=.TRUE.)

         ! whatever the xc, if epr_xc, drho_spin is needed
         IF (epr_xc) needs%drho_spin = .TRUE.

         gradient_f = (needs%drho .OR. needs%drho_spin)
         tau_f = (needs%tau .OR. needs%tau_spin)

         ! Initialize energy contribution from the one center XC terms to zero
         energy%exc1 = 0.0_dp

         ! Nullify some pointers for work-arrays
         NULLIFY (rho_h, drho_h, rho_s, drho_s, weight)
         NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
         NULLIFY (tau_h, tau_s)
         NULLIFY (vtau_h, vtau_s)

         ! Here starts the loop over all the atoms

         DO ikind = 1, SIZE(atomic_kind_set)
            CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
            CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom, &
                             harmonics=harmonics, grid_atom=grid_atom)

            IF (.NOT. paw_atom) CYCLE

            nr = grid_atom%nr
            na = grid_atom%ng_sphere

            ! Prepare the structures needed to calculate and store the xc derivatives

            ! Array dimension: here anly one dimensional arrays are used,
            ! i.e. only the first column of deriv_data is read.
            ! The other to dimensions  are set to size equal 1
            bounds(1:2, 1:3) = 1
            bounds(2, 1) = na
            bounds(2, 2) = nr

            ! create a place where to put the derivatives
            CALL xc_dset_create(deriv_set, local_bounds=bounds)
            ! create the place where to store the argument for the functionals
            CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
                                   drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
            CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
                                   drho_cutoff=gradient_cut, tau_cutoff=tau_cut)

            ! allocate the required 3d arrays where to store rho and drho
            CALL xc_rho_set_atom_update(rho_set_h, needs, nspins, bounds)
            CALL xc_rho_set_atom_update(rho_set_s, needs, nspins, bounds)

            CALL reallocate(rho_h, 1, na, 1, nspins)
            CALL reallocate(rho_s, 1, na, 1, nspins)
            weight => grid_atom%weight
            CALL reallocate(vxc_h, 1, na, 1, nr, 1, nspins)
            CALL reallocate(vxc_s, 1, na, 1, nr, 1, nspins)

            IF (gradient_f) THEN
               CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
               CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
               CALL reallocate(vxg_h, 1, 3, 1, na, 1, nr, 1, nspins)
               CALL reallocate(vxg_s, 1, 3, 1, na, 1, nr, 1, nspins)
            END IF

            IF (tau_f) THEN
               CALL reallocate(tau_h, 1, na, 1, nspins)
               CALL reallocate(tau_s, 1, na, 1, nspins)
               CALL reallocate(vtau_h, 1, na, 1, nr, 1, nspins)
               CALL reallocate(vtau_s, 1, na, 1, nr, 1, nspins)
            END IF

            ! NLCC: prepare rho and drho of the core charge for this KIND
            donlcc = .FALSE.
            IF (nlcc) THEN
               NULLIFY (rho_nlcc)
               rho_nlcc => qs_kind_set(ikind)%nlcc_pot
               IF (ASSOCIATED(rho_nlcc)) donlcc = .TRUE.
            END IF

            ! Distribute the atoms of this kind

            num_pe = para_env%num_pe
            mepos = para_env%mepos
            bo = get_limit(natom, num_pe, mepos)

            DO iat = bo(1), bo(2)
               iatom = atom_list(iat)

               rho_atom_set(iatom)%exc_h = 0.0_dp
               rho_atom_set(iatom)%exc_s = 0.0_dp

               rho_atom => rho_atom_set(iatom)
               IF (gradient_f) THEN
                  NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
                  CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, &
                                    rho_rad_s=r_s, drho_rad_h=dr_h, &
                                    drho_rad_s=dr_s, rho_rad_h_d=r_h_d, &
                                    rho_rad_s_d=r_s_d)
                  drho_h = 0.0_dp
                  drho_s = 0.0_dp
               ELSE
                  NULLIFY (r_h, r_s)
                  CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s)
               END IF
               IF (tau_f) THEN
                  NULLIFY (trho_h, trho_s)
                  CALL get_rho_atom(rho_atom=rho_atom, trho_rad_h=trho_h, trho_rad_s=trho_s)
               END IF

               DO ir = 1, nr
                  CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
                                        ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
                                        r_h_d, r_s_d, drho_h, drho_s)
                  IF (tau_f) THEN
                     CALL calc_tau_angular(grid_atom, harmonics, nspins, ir, &
                                           trho_h, trho_s, tau_h, tau_s)
                  END IF
                  IF (donlcc) THEN
                     CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
                                        ir, rho_nlcc(:, 1), rho_h, rho_s, rho_nlcc(:, 2), drho_h, drho_s)
                  END IF
                  CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
                  CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
               END DO

               !-------------------!
               ! hard atom density !
               !-------------------!
               CALL xc_dset_zero_all(deriv_set)
               CALL vxc_of_r_new(xc_fun_section, rho_set_h, deriv_set, 1, needs, weight, &
                                 lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h, energy_only=energy_only, &
                                 epr_xc=epr_xc, adiabatic_rescale_factor=my_adiabatic_rescale_factor)
               rho_atom%exc_h = rho_atom%exc_h+exc_h

               !-------------------!
               ! soft atom density !
               !-------------------!
               CALL xc_dset_zero_all(deriv_set)
               CALL vxc_of_r_new(xc_fun_section, rho_set_s, deriv_set, 1, needs, weight, &
                                 lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s, energy_only=energy_only, &
                                 epr_xc=epr_xc, adiabatic_rescale_factor=my_adiabatic_rescale_factor)
               rho_atom%exc_s = rho_atom%exc_s+exc_s

               IF (epr_xc) THEN
                  DO ispin = 1, nspins
                     DO idir = 1, 3
                        DO ir = 1, nr
                           DO ia = 1, na
                              gradient_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef(ir, ia) = &
                                 gradient_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef(ir, ia) &
                                 +vxg_h(idir, ia, ir, ispin)
                              gradient_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef(ir, ia) = &
                                 gradient_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef(ir, ia) &
                                 +vxg_s(idir, ia, ir, ispin)
                           END DO ! ia
                        END DO ! ir
                     END DO ! idir
                  END DO ! ispin
               END IF

               ! Add contributions to the exc energy

               energy%exc1 = energy%exc1+rho_atom%exc_h-rho_atom%exc_s

               ! Integration to get the matrix elements relative to the vxc_atom
               ! here the products with the primitives is done: gaVxcgb
               ! internal transformation to get the integral in cartesian Gaussians

               IF (.NOT. energy_only) THEN
                  qs_kind => qs_kind_set(ikind)
                  IF (gradient_f) THEN
                     CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, qs_kind, &
                                     rho_atom, nspins)
                  ELSE
                     CALL gaVxcgb_noGC(vxc_h, vxc_s, qs_kind, rho_atom, nspins)
                  END IF
                  IF (tau_f) THEN
                     CALL dgaVtaudgb(vtau_h, vtau_s, qs_kind, rho_atom, nspins)
                  END IF
               END IF ! energy_only
               NULLIFY (r_h, r_s, dr_h, dr_s)
            END DO ! iat

            ! Release the xc structure used to store the xc derivatives
            CALL xc_dset_release(deriv_set)
            CALL xc_rho_set_release(rho_set_h)
            CALL xc_rho_set_release(rho_set_s)

         END DO ! ikind

         CALL mp_sum(energy%exc1, para_env%group)

         IF (ASSOCIATED(rho_h)) THEN
            DEALLOCATE (rho_h)
         END IF

         IF (ASSOCIATED(rho_s)) THEN
            DEALLOCATE (rho_s)
         END IF

         IF (ASSOCIATED(vxc_h)) THEN
            DEALLOCATE (vxc_h)
         END IF

         IF (ASSOCIATED(vxc_s)) THEN
            DEALLOCATE (vxc_s)
         END IF

         IF (gradient_f) THEN

            IF (ASSOCIATED(drho_h)) THEN
               DEALLOCATE (drho_h)
            END IF

            IF (ASSOCIATED(drho_s)) THEN
               DEALLOCATE (drho_s)
            END IF

            IF (ASSOCIATED(vxg_h)) THEN
               DEALLOCATE (vxg_h)
            END IF

            IF (ASSOCIATED(vxg_s)) THEN
               DEALLOCATE (vxg_s)
            END IF

         END IF

         IF (tau_f) THEN

            IF (ASSOCIATED(tau_h)) THEN
               DEALLOCATE (tau_h)
            END IF

            IF (ASSOCIATED(tau_s)) THEN
               DEALLOCATE (tau_s)
            END IF

            IF (ASSOCIATED(vtau_h)) THEN
               DEALLOCATE (vtau_h)
            END IF

            IF (ASSOCIATED(vtau_s)) THEN
               DEALLOCATE (vtau_s)
            END IF

         END IF

      END IF !xc_none

      CALL timestop(handle)

   END SUBROUTINE calculate_vxc_atom

! **************************************************************************************************
!> \brief ...
!> \param p_env ...
!> \param qs_env ...
!> \param xc_section ...
!> \param do_tddft ...
!> \param do_triplet ...
! **************************************************************************************************
   SUBROUTINE calculate_xc_2nd_deriv_atom(p_env, qs_env, xc_section, do_tddft, do_triplet)

      TYPE(qs_p_env_type), POINTER                       :: p_env
      TYPE(qs_environment_type), POINTER                 :: qs_env
      TYPE(section_vals_type), POINTER                   :: xc_section
      LOGICAL, INTENT(IN), OPTIONAL                      :: do_tddft, do_triplet

      CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_xc_2nd_deriv_atom', &
         routineP = moduleN//':'//routineN

      INTEGER                                            :: atom, excitations, handle, iatom, ikind, &
                                                            ir, na, natom, nr, nspins, res_etype
      INTEGER, DIMENSION(2)                              :: local_loop_limit
      INTEGER, DIMENSION(2, 3)                           :: bounds
      INTEGER, DIMENSION(:), POINTER                     :: atom_list
      LOGICAL                                            :: gradient_functional, lsd, lsd_singlets, &
                                                            my_do_tddft, paw_atom, tau_f
      REAL(KIND=dp)                                      :: density_cut, gradient_cut, rtot, tau_cut
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: rho1_h, rho1_s, rho_h, rho_s, tau1_h, &
                                                            tau1_s, tau_h, tau_s, weight
      REAL(KIND=dp), DIMENSION(:, :, :), POINTER         :: vxc_h, vxc_s
      REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER      :: drho1_h, drho1_s, drho_h, drho_s, vxg_h, &
                                                            vxg_s
      TYPE(atomic_kind_type), DIMENSION(:), POINTER      :: atomic_kind_set
      TYPE(cp_para_env_type), POINTER                    :: para_env
      TYPE(grid_atom_type), POINTER                      :: grid_atom
      TYPE(harmonics_atom_type), POINTER                 :: harmonics
      TYPE(qs_energy_type), POINTER                      :: energy
      TYPE(qs_kind_type), DIMENSION(:), POINTER          :: qs_kind_set
      TYPE(rho_atom_coeff), DIMENSION(:), POINTER        :: dr1_h, dr1_s, dr_h, dr_s, r1_h, r1_s, &
                                                            r_h, r_s
      TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER     :: r1_h_d, r1_s_d, r_h_d, r_s_d
      TYPE(rho_atom_type), DIMENSION(:), POINTER         :: rho1_atom_set, rho_atom_set
      TYPE(rho_atom_type), POINTER                       :: rho1_atom, rho_atom
      TYPE(section_vals_type), POINTER                   :: input, xc_fun_section
      TYPE(xc_derivative_set_type), POINTER              :: deriv_set
      TYPE(xc_rho_cflags_type)                           :: needs
      TYPE(xc_rho_set_type), POINTER                     :: rho1_set_h, rho1_set_s, rho_set_h, &
                                                            rho_set_s

! -------------------------------------------------------------------------

      CALL timeset(routineN, handle)

      NULLIFY (qs_kind_set, energy, para_env)
      NULLIFY (rho_h, rho_s, drho_h, drho_s, weight)
      NULLIFY (rho1_h, rho1_s, drho1_h, drho1_s)
      NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
      NULLIFY (tau_h, tau_s, tau1_h, tau1_s)

      my_do_tddft = .TRUE.
      IF (PRESENT(do_tddft)) my_do_tddft = do_tddft

      CALL get_qs_env(qs_env=qs_env, &
                      para_env=para_env, &
                      energy=energy, &
                      input=input, &
                      qs_kind_set=qs_kind_set, &
                      atomic_kind_set=atomic_kind_set, &
                      rho_atom_set=rho_atom_set)

      rho1_atom_set => p_env%local_rho_set%rho_atom_set

      CALL section_vals_val_get(input, "DFT%LSD", l_val=lsd)
      CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", &
                                r_val=density_cut)
      CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", &
                                r_val=gradient_cut)
      CALL section_vals_val_get(xc_section, "TAU_CUTOFF", &
                                r_val=tau_cut)
      IF (my_do_tddft) THEN
         CALL section_vals_val_get(input, "DFT%EXCITATIONS", &
                                   i_val=excitations)
         CALL section_vals_val_get(input, "DFT%TDDFPT%LSD_SINGLETS", &
                                   l_val=lsd_singlets)
         CALL section_vals_val_get(input, "DFT%TDDFPT%RES_ETYPE", &
                                   i_val=res_etype)
      ENDIF
      xc_fun_section => section_vals_get_subs_vals(xc_section, &
                                                   "XC_FUNCTIONAL")
      IF (lsd) THEN
         nspins = 2
      ELSE
         nspins = 1
      END IF
      needs = xc_functionals_get_needs(xc_fun_section, lsd=lsd, &
                                       add_basic_components=.TRUE.)
      gradient_functional = needs%drho .OR. needs%drho_spin
      tau_f = (needs%tau .OR. needs%tau_spin)
      IF (tau_f) THEN
         CPABORT("Tau functionals not implemented for GAPW 2nd derivatives")
      END IF

      IF (my_do_tddft) THEN
         IF (excitations == tddfpt_excitations) THEN
            IF (nspins == 1 .AND. (lsd_singlets .OR. res_etype == tddfpt_triplet)) THEN
               lsd = .TRUE.
            END IF
         END IF
      ELSE
         IF (PRESENT(do_triplet)) THEN
            IF (nspins == 1 .AND. do_triplet) THEN
               lsd = .TRUE.
            ENDIF
         ENDIF
      ENDIF

!  Here starts the loop over all the atoms
      DO ikind = 1, SIZE(atomic_kind_set)

         NULLIFY (atom_list, harmonics, grid_atom)
         CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
         CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom, &
                          harmonics=harmonics, grid_atom=grid_atom)
         IF (.NOT. paw_atom) CYCLE

         nr = grid_atom%nr
         na = grid_atom%ng_sphere

         ! Array dimension: here anly one dimensional arrays are used,
         ! i.e. only the first column of deriv_data is read.
         ! The other to dimensions  are set to size equal 1.
         bounds(1:2, 1:3) = 1
         bounds(2, 1) = na
         bounds(2, 2) = nr

         NULLIFY (deriv_set, rho_set_h, rho_set_s, rho1_set_h, rho1_set_s)
         CALL xc_dset_create(deriv_set, local_bounds=bounds)
         CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
                                drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
         CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
                                drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
         CALL xc_rho_set_create(rho1_set_h, bounds, rho_cutoff=density_cut, &
                                drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
         CALL xc_rho_set_create(rho1_set_s, bounds, rho_cutoff=density_cut, &
                                drho_cutoff=gradient_cut, tau_cutoff=tau_cut)

         ! allocate the required 3d arrays where to store rho and drho
         IF (nspins == 1 .AND. .NOT. lsd) THEN
            CALL xc_rho_set_atom_update(rho_set_h, needs, 1, bounds)
            CALL xc_rho_set_atom_update(rho1_set_h, needs, 1, bounds)
            CALL xc_rho_set_atom_update(rho_set_s, needs, 1, bounds)
            CALL xc_rho_set_atom_update(rho1_set_s, needs, 1, bounds)
         ELSE
            CALL xc_rho_set_atom_update(rho_set_h, needs, 2, bounds)
            CALL xc_rho_set_atom_update(rho1_set_h, needs, 2, bounds)
            CALL xc_rho_set_atom_update(rho_set_s, needs, 2, bounds)
            CALL xc_rho_set_atom_update(rho1_set_s, needs, 2, bounds)
         END IF

         ALLOCATE (rho_h(1:na, 1:nspins), rho1_h(1:na, 1:nspins), &
                   rho_s(1:na, 1:nspins), rho1_s(1:na, 1:nspins))

         ALLOCATE (vxc_h(1:na, 1:nr, 1:nspins), vxc_s(1:na, 1:nr, 1:nspins))
         vxc_h = 0.0_dp
         vxc_s = 0.0_dp

         weight => grid_atom%weight

         IF (gradient_functional) THEN
            ALLOCATE (drho_h(1:4, 1:na, 1:nr, 1:nspins), drho1_h(1:4, 1:na, 1:nr, 1:nspins), &
                      drho_s(1:4, 1:na, 1:nr, 1:nspins), drho1_s(1:4, 1:na, 1:nr, 1:nspins))

            ALLOCATE (vxg_h(1:3, 1:na, 1:nr, 1:nspins), vxg_s(1:3, 1:na, 1:nr, 1:nspins))
            vxg_h = 0.0_dp
            vxg_s = 0.0_dp
         END IF

         ! parallelization
         local_loop_limit = get_limit(natom, para_env%num_pe, para_env%mepos)

         DO iatom = local_loop_limit(1), local_loop_limit(2) !1,natom
            atom = atom_list(iatom)

            rho_atom_set(atom)%exc_h = 0.0_dp
            rho_atom_set(atom)%exc_s = 0.0_dp
            rho1_atom_set(atom)%exc_h = 0.0_dp
            rho1_atom_set(atom)%exc_s = 0.0_dp

            rho_atom => rho_atom_set(atom)
            rho1_atom => rho1_atom_set(atom)
            NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
            NULLIFY (r1_h, r1_s, dr1_h, dr1_s, r1_h_d, r1_s_d)
            IF (gradient_functional) THEN
               CALL get_rho_atom(rho_atom=rho_atom, &
                                 rho_rad_h=r_h, rho_rad_s=r_s, &
                                 drho_rad_h=dr_h, drho_rad_s=dr_s, &
                                 rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
               CALL get_rho_atom(rho_atom=rho1_atom, &
                                 rho_rad_h=r1_h, rho_rad_s=r1_s, &
                                 drho_rad_h=dr1_h, drho_rad_s=dr1_s, &
                                 rho_rad_h_d=r1_h_d, rho_rad_s_d=r1_s_d)
               drho_h = 0.0_dp; drho_s = 0.0_dp
               drho1_h = 0.0_dp; drho1_s = 0.0_dp
            ELSE
               CALL get_rho_atom(rho_atom=rho_atom, &
                                 rho_rad_h=r_h, rho_rad_s=r_s)
               CALL get_rho_atom(rho_atom=rho1_atom, &
                                 rho_rad_h=r1_h, rho_rad_s=r1_s)
            END IF

            rtot = 0.0_dp

            DO ir = 1, nr

               CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, &
                                     ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, r_h_d, r_s_d, &
                                     drho_h, drho_s)
               CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, &
                                     ir, r1_h, r1_s, rho1_h, rho1_s, dr1_h, dr1_s, r1_h_d, r1_s_d, &
                                     drho1_h, drho1_s)

               CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
               CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, tau1_h, na, ir)
               CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
               CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, tau1_s, na, ir)

            END DO

            CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
                                   rho_set=rho_set_h, rho1_set=rho1_set_h, &
                                   deriv_set=deriv_set, &
                                   w=weight, vxc=vxc_h, vxg=vxg_h)
            CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
                                   rho_set=rho_set_s, rho1_set=rho1_set_s, &
                                   deriv_set=deriv_set, &
                                   w=weight, vxc=vxc_s, vxg=vxg_s)

            IF (gradient_functional) THEN
               CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, qs_kind_set(ikind), &
                               rho1_atom, nspins)
            ELSE
               CALL gaVxcgb_noGC(vxc_h, vxc_s, qs_kind_set(ikind), &
                                 rho1_atom, nspins)
            ENDIF

            NULLIFY (r_h, r_s, dr_h, dr_s)

         END DO

         ! some cleanup
         NULLIFY (weight)
         DEALLOCATE (rho_h, rho_s, rho1_h, rho1_s, vxc_h, vxc_s)
         IF (gradient_functional) THEN
            DEALLOCATE (drho_h, drho_s, vxg_h, vxg_s)
            DEALLOCATE (drho1_h, drho1_s)
         END IF

         CALL xc_dset_release(deriv_set)
         CALL xc_rho_set_release(rho_set_h)
         CALL xc_rho_set_release(rho1_set_h)
         CALL xc_rho_set_release(rho_set_s)
         CALL xc_rho_set_release(rho1_set_s)

      END DO

      CALL timestop(handle)

   END SUBROUTINE calculate_xc_2nd_deriv_atom

! **************************************************************************************************
!> \brief ...
!> \param grid_atom ...
!> \param harmonics ...
!> \param nspins ...
!> \param grad_func ...
!> \param ir ...
!> \param r_h ...
!> \param r_s ...
!> \param rho_h ...
!> \param rho_s ...
!> \param dr_h ...
!> \param dr_s ...
!> \param r_h_d ...
!> \param r_s_d ...
!> \param drho_h ...
!> \param drho_s ...
! **************************************************************************************************
   SUBROUTINE calc_rho_angular(grid_atom, harmonics, nspins, grad_func, &
                               ir, r_h, r_s, rho_h, rho_s, &
                               dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s)

      TYPE(grid_atom_type), POINTER                      :: grid_atom
      TYPE(harmonics_atom_type), POINTER                 :: harmonics
      INTEGER, INTENT(IN)                                :: nspins
      LOGICAL, INTENT(IN)                                :: grad_func
      INTEGER, INTENT(IN)                                :: ir
      TYPE(rho_atom_coeff), DIMENSION(:), POINTER        :: r_h, r_s
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: rho_h, rho_s
      TYPE(rho_atom_coeff), DIMENSION(:), POINTER        :: dr_h, dr_s
      TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER     :: r_h_d, r_s_d
      REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER      :: drho_h, drho_s

      CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_rho_angular', &
         routineP = moduleN//':'//routineN

      INTEGER                                            :: ia, iso, ispin, na
      REAL(KIND=dp)                                      :: rad, urad

      CPASSERT(ASSOCIATED(r_h))
      CPASSERT(ASSOCIATED(r_s))
      CPASSERT(ASSOCIATED(rho_h))
      CPASSERT(ASSOCIATED(rho_s))
      IF (grad_func) THEN
         CPASSERT(ASSOCIATED(dr_h))
         CPASSERT(ASSOCIATED(dr_s))
         CPASSERT(ASSOCIATED(r_h_d))
         CPASSERT(ASSOCIATED(r_s_d))
         CPASSERT(ASSOCIATED(drho_h))
         CPASSERT(ASSOCIATED(drho_s))
      END IF

      na = grid_atom%ng_sphere
      rad = grid_atom%rad(ir)
      urad = grid_atom%oorad2l(ir, 1)
      rho_h = 0.0_dp; rho_s = 0.0_dp
      DO ispin = 1, nspins
         DO iso = 1, harmonics%max_iso_not0
            DO ia = 1, na
               rho_h(ia, ispin) = rho_h(ia, ispin)+ &
                                  r_h(ispin)%r_coef(ir, iso)* &
                                  harmonics%slm(ia, iso)
               rho_s(ia, ispin) = rho_s(ia, ispin)+ &
                                  r_s(ispin)%r_coef(ir, iso)* &
                                  harmonics%slm(ia, iso)
            END DO ! ia
         END DO ! iso
      END DO ! ispin

      IF (grad_func) THEN
         DO ispin = 1, nspins
            DO iso = 1, harmonics%max_iso_not0
               DO ia = 1, na

!              components of the gradient of rho1 hard
                  drho_h(1, ia, ir, ispin) = drho_h(1, ia, ir, ispin)+ &
                                             dr_h(ispin)%r_coef(ir, iso)* &
                                             harmonics%a(1, ia)*harmonics%slm(ia, iso)+ &
                                             r_h_d(1, ispin)%r_coef(ir, iso)* &
                                             harmonics%slm(ia, iso)

                  drho_h(2, ia, ir, ispin) = drho_h(2, ia, ir, ispin)+ &
                                             dr_h(ispin)%r_coef(ir, iso)* &
                                             harmonics%a(2, ia)*harmonics%slm(ia, iso)+ &
                                             r_h_d(2, ispin)%r_coef(ir, iso)* &
                                             harmonics%slm(ia, iso)

                  drho_h(3, ia, ir, ispin) = drho_h(3, ia, ir, ispin)+ &
                                             dr_h(ispin)%r_coef(ir, iso)* &
                                             harmonics%a(3, ia)*harmonics%slm(ia, iso)+ &
                                             r_h_d(3, ispin)%r_coef(ir, iso)* &
                                             harmonics%slm(ia, iso)

!              components of the gradient of rho1 soft
                  drho_s(1, ia, ir, ispin) = drho_s(1, ia, ir, ispin)+ &
                                             dr_s(ispin)%r_coef(ir, iso)* &
                                             harmonics%a(1, ia)*harmonics%slm(ia, iso)+ &
                                             r_s_d(1, ispin)%r_coef(ir, iso)* &
                                             harmonics%slm(ia, iso)

                  drho_s(2, ia, ir, ispin) = drho_s(2, ia, ir, ispin)+ &
                                             dr_s(ispin)%r_coef(ir, iso)* &
                                             harmonics%a(2, ia)*harmonics%slm(ia, iso)+ &
                                             r_s_d(2, ispin)%r_coef(ir, iso)* &
                                             harmonics%slm(ia, iso)

                  drho_s(3, ia, ir, ispin) = drho_s(3, ia, ir, ispin)+ &
                                             dr_s(ispin)%r_coef(ir, iso)* &
                                             harmonics%a(3, ia)*harmonics%slm(ia, iso)+ &
                                             r_s_d(3, ispin)%r_coef(ir, iso)* &
                                             harmonics%slm(ia, iso)

                  drho_h(4, ia, ir, ispin) = SQRT( &
                                             drho_h(1, ia, ir, ispin)*drho_h(1, ia, ir, ispin)+ &
                                             drho_h(2, ia, ir, ispin)*drho_h(2, ia, ir, ispin)+ &
                                             drho_h(3, ia, ir, ispin)*drho_h(3, ia, ir, ispin))

                  drho_s(4, ia, ir, ispin) = SQRT( &
                                             drho_s(1, ia, ir, ispin)*drho_s(1, ia, ir, ispin)+ &
                                             drho_s(2, ia, ir, ispin)*drho_s(2, ia, ir, ispin)+ &
                                             drho_s(3, ia, ir, ispin)*drho_s(3, ia, ir, ispin))

               END DO ! ia
            END DO ! iso
         END DO ! ispin
      END IF

   END SUBROUTINE calc_rho_angular
! **************************************************************************************************
!> \brief ...
!> \param grid_atom ...
!> \param harmonics ...
!> \param nspins ...
!> \param ir ...
!> \param trho_h ...
!> \param trho_s ...
!> \param tau_h ...
!> \param tau_s ...
! **************************************************************************************************
   SUBROUTINE calc_tau_angular(grid_atom, harmonics, nspins, ir, &
                               trho_h, trho_s, tau_h, tau_s)

      TYPE(grid_atom_type), POINTER                      :: grid_atom
      TYPE(harmonics_atom_type), POINTER                 :: harmonics
      INTEGER, INTENT(IN)                                :: nspins, ir
      TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER     :: trho_h, trho_s
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: tau_h, tau_s

      CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_tau_angular', &
         routineP = moduleN//':'//routineN

      INTEGER                                            :: ia, iso, ispin, na

      CPASSERT(ASSOCIATED(trho_h))
      CPASSERT(ASSOCIATED(trho_s))
      CPASSERT(ASSOCIATED(tau_h))
      CPASSERT(ASSOCIATED(tau_s))

      na = grid_atom%ng_sphere
      tau_h = 0.0_dp
      tau_s = 0.0_dp

      DO ispin = 1, nspins
         DO iso = 1, harmonics%max_iso_not0
            DO ia = 1, na
               tau_h(ia, ispin) = tau_h(ia, ispin)+ &
                                  trho_h(1, ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
               tau_h(ia, ispin) = tau_h(ia, ispin)+ &
                                  trho_h(3, ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
               tau_s(ia, ispin) = tau_s(ia, ispin)+ &
                                  trho_s(1, ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
               tau_s(ia, ispin) = tau_s(ia, ispin)+ &
                                  trho_s(3, ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
            END DO ! ia
         END DO ! iso
         DO iso = 1, harmonics%max_iso_not0
            DO ia = 1, na
               tau_h(ia, ispin) = tau_h(ia, ispin)+ &
                                  trho_h(2, ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)*grid_atom%usin_azi(ia)**2
               tau_s(ia, ispin) = tau_s(ia, ispin)+ &
                                  trho_s(2, ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)*grid_atom%usin_azi(ia)**2
            END DO ! ia
         END DO ! iso
      END DO ! ispin

   END SUBROUTINE calc_tau_angular
! **************************************************************************************************
!> \brief ...
!> \param grid_atom ...
!> \param nspins ...
!> \param grad_func ...
!> \param ir ...
!> \param rho_nlcc ...
!> \param rho_h ...
!> \param rho_s ...
!> \param drho_nlcc ...
!> \param drho_h ...
!> \param drho_s ...
! **************************************************************************************************
   SUBROUTINE calc_rho_nlcc(grid_atom, nspins, grad_func, &
                            ir, rho_nlcc, rho_h, rho_s, drho_nlcc, drho_h, drho_s)

      TYPE(grid_atom_type), POINTER                      :: grid_atom
      INTEGER, INTENT(IN)                                :: nspins
      LOGICAL, INTENT(IN)                                :: grad_func
      INTEGER, INTENT(IN)                                :: ir
      REAL(KIND=dp), DIMENSION(:)                        :: rho_nlcc
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: rho_h, rho_s
      REAL(KIND=dp), DIMENSION(:)                        :: drho_nlcc
      REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER      :: drho_h, drho_s

      CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_rho_nlcc', routineP = moduleN//':'//routineN

      INTEGER                                            :: ia, ispin, na
      REAL(KIND=dp)                                      :: drho, dx, dy, dz, rad, rho, urad, xsp

      CPASSERT(ASSOCIATED(rho_h))
      CPASSERT(ASSOCIATED(rho_s))
      IF (grad_func) THEN
         CPASSERT(ASSOCIATED(drho_h))
         CPASSERT(ASSOCIATED(drho_s))
      END IF

      na = grid_atom%ng_sphere
      rad = grid_atom%rad(ir)
      urad = grid_atom%oorad2l(ir, 1)

      xsp = REAL(nspins, KIND=dp)
      rho = rho_nlcc(ir)/xsp
      DO ispin = 1, nspins
         rho_h(1:na, ispin) = rho_h(1:na, ispin)+rho
         rho_s(1:na, ispin) = rho_s(1:na, ispin)+rho
      END DO ! ispin

      IF (grad_func) THEN
         drho = drho_nlcc(ir)/xsp
         DO ispin = 1, nspins
            DO ia = 1, na
               IF (grid_atom%azi(ia) == 0.0_dp) THEN
                  dx = 0.0_dp
                  dy = 0.0_dp
               ELSE
                  dx = grid_atom%sin_pol(ia)*grid_atom%sin_azi(ia)
                  dy = grid_atom%sin_pol(ia)*grid_atom%cos_azi(ia)
               END IF
               dz = grid_atom%cos_pol(ia)
               ! components of the gradient of rho1 hard
               drho_h(1, ia, ir, ispin) = drho_h(1, ia, ir, ispin)+drho*dx
               drho_h(2, ia, ir, ispin) = drho_h(2, ia, ir, ispin)+drho*dy
               drho_h(3, ia, ir, ispin) = drho_h(3, ia, ir, ispin)+drho*dz
               ! components of the gradient of rho1 soft
               drho_s(1, ia, ir, ispin) = drho_s(1, ia, ir, ispin)+drho*dx
               drho_s(2, ia, ir, ispin) = drho_s(2, ia, ir, ispin)+drho*dy
               drho_s(3, ia, ir, ispin) = drho_s(3, ia, ir, ispin)+drho*dz
               ! norm of gradient
               drho_h(4, ia, ir, ispin) = SQRT( &
                                          drho_h(1, ia, ir, ispin)*drho_h(1, ia, ir, ispin)+ &
                                          drho_h(2, ia, ir, ispin)*drho_h(2, ia, ir, ispin)+ &
                                          drho_h(3, ia, ir, ispin)*drho_h(3, ia, ir, ispin))

               drho_s(4, ia, ir, ispin) = SQRT( &
                                          drho_s(1, ia, ir, ispin)*drho_s(1, ia, ir, ispin)+ &
                                          drho_s(2, ia, ir, ispin)*drho_s(2, ia, ir, ispin)+ &
                                          drho_s(3, ia, ir, ispin)*drho_s(3, ia, ir, ispin))
            END DO ! ia
         END DO ! ispin
      END IF

   END SUBROUTINE calc_rho_nlcc

! **************************************************************************************************
!> \brief ...
!> \param vxc_h ...
!> \param vxc_s ...
!> \param qs_kind ...
!> \param rho_atom ...
!> \param nspins ...
! **************************************************************************************************
   SUBROUTINE gaVxcgb_noGC(vxc_h, vxc_s, qs_kind, rho_atom, nspins)

      REAL(dp), DIMENSION(:, :, :), POINTER              :: vxc_h, vxc_s
      TYPE(qs_kind_type), INTENT(IN)                     :: qs_kind
      TYPE(rho_atom_type), POINTER                       :: rho_atom
      INTEGER, INTENT(IN)                                :: nspins

      CHARACTER(len=*), PARAMETER :: routineN = 'gaVxcgb_noGC', routineP = moduleN//':'//routineN

      INTEGER :: handle, ia, ic, icg, ipgf1, ipgf2, ir, iset1, iset2, iso, iso1, iso2, ispin, &
         istat, l, ld, lmax12, lmax_expansion, lmin12, m1, m2, max_iso_not0, max_iso_not0_local, &
         max_s_harm, maxl, maxso, n1, n2, na, ngau1, ngau2, nngau1, nr, nset, size1
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: cg_n_list
      INTEGER, ALLOCATABLE, DIMENSION(:, :, :)           :: cg_list
      INTEGER, DIMENSION(:), POINTER                     :: lmax, lmin, npgf
      REAL(dp), ALLOCATABLE, DIMENSION(:)                :: g1, g2
      REAL(dp), ALLOCATABLE, DIMENSION(:, :)             :: gg, gVg_h, gVg_s, matso_h, matso_s, vx
      REAL(dp), DIMENSION(:, :), POINTER                 :: zet
      REAL(dp), DIMENSION(:, :, :), POINTER              :: my_CG
      TYPE(grid_atom_type), POINTER                      :: grid_atom
      TYPE(gto_basis_set_type), POINTER                  :: orb_basis
      TYPE(harmonics_atom_type), POINTER                 :: harmonics
      TYPE(rho_atom_coeff), DIMENSION(:), POINTER        :: int_hh, int_ss

! -------------------------------------------------------------------------

      CALL timeset(routineN, handle)

      NULLIFY (lmin, lmax, npgf, zet, my_CG, harmonics, grid_atom)

      CALL get_qs_kind(qs_kind, basis_set=orb_basis, &
                       harmonics=harmonics, grid_atom=grid_atom)

      CALL get_gto_basis_set(gto_basis_set=orb_basis, lmax=lmax, lmin=lmin, &
                             maxso=maxso, maxl=maxl, npgf=npgf, &
                             nset=nset, zet=zet)

      nr = grid_atom%nr
      na = grid_atom%ng_sphere
      my_CG => harmonics%my_CG
      max_iso_not0 = harmonics%max_iso_not0
      lmax_expansion = indso(1, max_iso_not0)
      max_s_harm = harmonics%max_s_harm

      ALLOCATE (g1(nr), g2(nr), gg(nr, 0:2*maxl), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "g1,g2,gg", (2*nr+2*maxl*nr)*dp_size)

      ALLOCATE (gVg_h(na, 0:2*maxl), gVg_s(na, 0:2*maxl), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "gVg_h,gVg_s", 4*na*maxl*dp_size)

      ALLOCATE (matso_h(nsoset(maxl), nsoset(maxl)), &
                matso_s(nsoset(maxl), nsoset(maxl)), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "matso_h,matso_s", &
                                       2*nsoset(maxl)*nsoset(maxl)*dp_size)

      ALLOCATE (vx(na, nr), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "vx", na*nr*dp_size)

      ALLOCATE (cg_list(2, nsoset(maxl)**2, max_s_harm), cg_n_list(max_s_harm))

      NULLIFY (int_hh, int_ss)

      CALL get_rho_atom(rho_atom=rho_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)

      g1 = 0.0_dp
      g2 = 0.0_dp
      m1 = 0
      DO iset1 = 1, nset
         n1 = nsoset(lmax(iset1))
         m2 = 0
         DO iset2 = 1, nset
            CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
                                   max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local)
            CPASSERT(max_iso_not0_local .LE. max_iso_not0)

            n2 = nsoset(lmax(iset2))
            DO ipgf1 = 1, npgf(iset1)
               ngau1 = n1*(ipgf1-1)+m1
               size1 = nsoset(lmax(iset1))-nsoset(lmin(iset1)-1)
               nngau1 = nsoset(lmin(iset1)-1)+ngau1

               g1(1:nr) = EXP(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr))
               DO ipgf2 = 1, npgf(iset2)
                  ngau2 = n2*(ipgf2-1)+m2

                  g2(1:nr) = EXP(-zet(ipgf2, iset2)*grid_atom%rad2(1:nr))
                  lmin12 = lmin(iset1)+lmin(iset2)
                  lmax12 = lmax(iset1)+lmax(iset2)

                  ! reduce expansion local densities
                  IF (lmin12 .LE. lmax_expansion) THEN

                     gg = 0.0_dp
                     IF (lmin12 == 0) THEN
                        gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr)
                     ELSE
                        gg(1:nr, lmin12) = grid_atom%rad2l(1:nr, lmin12)*g1(1:nr)*g2(1:nr)
                     END IF

                     ! limit the expansion of the local densities to a max L
                     IF (lmax12 .GT. lmax_expansion) lmax12 = lmax_expansion

                     DO l = lmin12+1, lmax12
                        gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l-1)
                     END DO

                     DO ispin = 1, nspins
                        ld = lmax12+1
                        DO ir = 1, nr
                           vx(1:na, ir) = vxc_h(1:na, ir, ispin)
                        END DO
                        CALL dgemm('N', 'N', na, ld, nr, 1.0_dp, vx(1:na, 1:nr), na, &
                                   gg(1:nr, 0:lmax12), nr, 0.0_dp, gVg_h(1:na, 0:lmax12), na)
                        DO ir = 1, nr
                           vx(1:na, ir) = vxc_s(1:na, ir, ispin)
                        END DO
                        CALL dgemm('N', 'N', na, ld, nr, 1.0_dp, vx(1:na, 1:nr), na, &
                                   gg(1:nr, 0:lmax12), nr, 0.0_dp, gVg_s(1:na, 0:lmax12), na)

                        matso_h = 0.0_dp
                        matso_s = 0.0_dp
                        DO iso = 1, max_iso_not0_local
                           DO icg = 1, cg_n_list(iso)
                              iso1 = cg_list(1, icg, iso)
                              iso2 = cg_list(2, icg, iso)
                              l = indso(1, iso1)+indso(1, iso2)

                              CPASSERT(l <= lmax_expansion)
                              DO ia = 1, na
                                 matso_h(iso1, iso2) = matso_h(iso1, iso2)+ &
                                                       gVg_h(ia, l)* &
                                                       my_CG(iso1, iso2, iso)* &
                                                       harmonics%slm(ia, iso)
                                 matso_s(iso1, iso2) = matso_s(iso1, iso2)+ &
                                                       gVg_s(ia, l)* &
                                                       my_CG(iso1, iso2, iso)* &
                                                       harmonics%slm(ia, iso)
                              END DO
                           END DO
                        END DO

!             Write in the global matrix
                        DO ic = nsoset(lmin(iset2)-1)+1, nsoset(lmax(iset2))
                           iso1 = nsoset(lmin(iset1)-1)+1
                           iso2 = ngau2+ic
                           CALL daxpy(size1, 1.0_dp, matso_h(iso1, ic), 1, &
                                      int_hh(ispin)%r_coef(nngau1+1, iso2), 1)
                           CALL daxpy(size1, 1.0_dp, matso_s(iso1, ic), 1, &
                                      int_ss(ispin)%r_coef(nngau1+1, iso2), 1)
                        END DO

                     END DO ! ispin

                  END IF ! lmax_expansion

               END DO ! ipfg2
            END DO ! ipfg1
            m2 = m2+maxso
         END DO ! iset2
         m1 = m1+maxso
      END DO ! iset1

      DEALLOCATE (g1, g2, gg, matso_h, matso_s, gVg_s, gVg_h, vx)

      DEALLOCATE (cg_list, cg_n_list)

      CALL timestop(handle)

   END SUBROUTINE gaVxcgb_noGC

! **************************************************************************************************
!> \brief ...
!> \param vxc_h ...
!> \param vxc_s ...
!> \param vxg_h ...
!> \param vxg_s ...
!> \param qs_kind ...
!> \param rho_atom ...
!> \param nspins ...
! **************************************************************************************************
   SUBROUTINE gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, qs_kind, rho_atom, &
                         nspins)

      REAL(dp), DIMENSION(:, :, :), POINTER              :: vxc_h, vxc_s
      REAL(dp), DIMENSION(:, :, :, :), POINTER           :: vxg_h, vxg_s
      TYPE(qs_kind_type), INTENT(IN)                     :: qs_kind
      TYPE(rho_atom_type), POINTER                       :: rho_atom
      INTEGER, INTENT(IN)                                :: nspins

      CHARACTER(len=*), PARAMETER :: routineN = 'gaVxcgb_GC', routineP = moduleN//':'//routineN

      INTEGER :: dmax_iso_not0, dmax_iso_not0_local, handle, ia, ic, icg, ipgf1, ipgf2, ir, iset1, &
         iset2, iso, iso1, iso2, ispin, istat, l, lmax12, lmax_expansion, lmin12, m1, m2, &
         max_iso_not0, max_iso_not0_local, max_s_harm, maxl, maxso, n1, n2, na, ngau1, ngau2, &
         nngau1, nr, nset, size1
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: cg_n_list, dcg_n_list
      INTEGER, ALLOCATABLE, DIMENSION(:, :, :)           :: cg_list, dcg_list
      INTEGER, DIMENSION(:), POINTER                     :: lmax, lmin, npgf
      REAL(dp)                                           :: urad
      REAL(dp), ALLOCATABLE, DIMENSION(:)                :: g1, g2
      REAL(dp), ALLOCATABLE, DIMENSION(:, :)             :: dgg, gg, gVXCg_h, gVXCg_s, matso_h, &
                                                            matso_s
      REAL(dp), ALLOCATABLE, DIMENSION(:, :, :)          :: gVXGg_h, gVXGg_s
      REAL(dp), DIMENSION(:, :), POINTER                 :: zet
      REAL(dp), DIMENSION(:, :, :), POINTER              :: my_CG
      REAL(dp), DIMENSION(:, :, :, :), POINTER           :: my_CG_dxyz
      TYPE(grid_atom_type), POINTER                      :: grid_atom
      TYPE(gto_basis_set_type), POINTER                  :: orb_basis
      TYPE(harmonics_atom_type), POINTER                 :: harmonics
      TYPE(rho_atom_coeff), DIMENSION(:), POINTER        :: int_hh, int_ss

! -------------------------------------------------------------------------

      CALL timeset(routineN, handle)

      NULLIFY (lmin, lmax, npgf, zet, my_CG, my_CG_dxyz, harmonics, grid_atom)

      CALL get_qs_kind(qs_kind, basis_set=orb_basis, &
                       harmonics=harmonics, grid_atom=grid_atom)

      CALL get_gto_basis_set(gto_basis_set=orb_basis, lmax=lmax, lmin=lmin, &
                             maxso=maxso, maxl=maxl, npgf=npgf, &
                             nset=nset, zet=zet)

      nr = grid_atom%nr
      na = grid_atom%ng_sphere
      my_CG => harmonics%my_CG
      my_CG_dxyz => harmonics%my_CG_dxyz
      max_iso_not0 = harmonics%max_iso_not0
      dmax_iso_not0 = harmonics%dmax_iso_not0
      lmax_expansion = indso(1, max_iso_not0)
      max_s_harm = harmonics%max_s_harm

      ALLOCATE (g1(nr), g2(nr), gg(nr, 0:2*maxl), dgg(nr, 0:2*maxl), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "g1,g2,gg,dgg", (2*nr+4*nr*maxl)*dp_size)

      ALLOCATE (gVXCg_h(na, 0:2*maxl), gVXCg_s(na, 0:2*maxl), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "gVXCg_h,gVXCg_s", 4*na*maxl*dp_size)
      ALLOCATE (gVXGg_h(3, na, 0:2*maxl), gVXGg_s(3, na, 0:2*maxl), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "gVXCg_h,gVXCg_s", 12*na*maxl*dp_size)
      ALLOCATE (cg_list(2, nsoset(maxl)**2, max_s_harm), cg_n_list(max_s_harm), &
                dcg_list(2, nsoset(maxl)**2, max_s_harm), dcg_n_list(max_s_harm))

      NULLIFY (int_hh, int_ss)

      ALLOCATE (matso_h(nsoset(maxl), nsoset(maxl)), &
                matso_s(nsoset(maxl), nsoset(maxl)), STAT=istat)
      IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, &
                                       "matso_h,matso_s", 2*nsoset(maxl)*nsoset(maxl)*dp_size)

      CALL get_rho_atom(rho_atom=rho_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)

      DO ispin = 1, nspins

         g1 = 0.0_dp
         g2 = 0.0_dp
         m1 = 0
         DO iset1 = 1, nset
            n1 = nsoset(lmax(iset1))
            m2 = 0
            DO iset2 = 1, nset
               CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
                                      max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local)
               CPASSERT(max_iso_not0_local .LE. max_iso_not0)
               CALL get_none0_cg_list(my_CG_dxyz, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
                                      max_s_harm, lmax_expansion, dcg_list, dcg_n_list, dmax_iso_not0_local)
               !CPASSERT(dmax_iso_not0_local.LE.dmax_iso_not0)

               n2 = nsoset(lmax(iset2))
               DO ipgf1 = 1, npgf(iset1)
                  ngau1 = n1*(ipgf1-1)+m1
                  size1 = nsoset(lmax(iset1))-nsoset(lmin(iset1)-1)
                  nngau1 = nsoset(lmin(iset1)-1)+ngau1

                  g1(1:nr) = EXP(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr))
                  DO ipgf2 = 1, npgf(iset2)
                     ngau2 = n2*(ipgf2-1)+m2

                     g2(1:nr) = EXP(-zet(ipgf2, iset2)*grid_atom%rad2(1:nr))
                     lmin12 = lmin(iset1)+lmin(iset2)
                     lmax12 = lmax(iset1)+lmax(iset2)

                     !test reduce expansion local densities
                     IF (lmin12 .LE. lmax_expansion) THEN

                        gg = 0.0_dp
                        dgg = 0.0_dp

                        IF (lmin12 == 0) THEN
                           gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr)
                        ELSE
                           gg(1:nr, lmin12) = grid_atom%rad2l(1:nr, lmin12)*g1(1:nr)*g2(1:nr)
                        END IF

                        !test reduce expansion local densities
                        IF (lmax12 .GT. lmax_expansion) lmax12 = lmax_expansion

                        DO l = lmin12+1, lmax12
                           gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l-1)
                           dgg(1:nr, l-1) = dgg(1:nr, l-1)-2.0_dp*(zet(ipgf1, iset1)+ &
                                                                   zet(ipgf2, iset2))*gg(1:nr, l)
                        END DO
                        dgg(1:nr, lmax12) = dgg(1:nr, lmax12)-2.0_dp*(zet(ipgf1, iset1)+ &
                                                                      zet(ipgf2, iset2))*grid_atom%rad(1:nr)* &
                                            gg(1:nr, lmax12)

                        gVXCg_h = 0.0_dp
                        gVXCg_s = 0.0_dp
                        gVXGg_h = 0.0_dp
                        gVXGg_s = 0.0_dp

                        ! Cross Term
                        DO l = lmin12, lmax12
                           DO ia = 1, na
                              DO ir = 1, nr
                                 gVXCg_h(ia, l) = gVXCg_h(ia, l)+ &
                                                  gg(ir, l)*vxc_h(ia, ir, ispin)+ &
                                                  dgg(ir, l)* &
                                                  (vxg_h(1, ia, ir, ispin)*harmonics%a(1, ia)+ &
                                                   vxg_h(2, ia, ir, ispin)*harmonics%a(2, ia)+ &
                                                   vxg_h(3, ia, ir, ispin)*harmonics%a(3, ia))

                                 gVXCg_s(ia, l) = gVXCg_s(ia, l)+ &
                                                  gg(ir, l)*vxc_s(ia, ir, ispin)+ &
                                                  dgg(ir, l)* &
                                                  (vxg_s(1, ia, ir, ispin)*harmonics%a(1, ia)+ &
                                                   vxg_s(2, ia, ir, ispin)*harmonics%a(2, ia)+ &
                                                   vxg_s(3, ia, ir, ispin)*harmonics%a(3, ia))

                                 urad = grid_atom%oorad2l(ir, 1)

                                 gVXGg_h(1, ia, l) = gVXGg_h(1, ia, l)+ &
                                                     vxg_h(1, ia, ir, ispin)* &
                                                     gg(ir, l)*urad

                                 gVXGg_h(2, ia, l) = gVXGg_h(2, ia, l)+ &
                                                     vxg_h(2, ia, ir, ispin)* &
                                                     gg(ir, l)*urad

                                 gVXGg_h(3, ia, l) = gVXGg_h(3, ia, l)+ &
                                                     vxg_h(3, ia, ir, ispin)* &
                                                     gg(ir, l)*urad

                                 gVXGg_s(1, ia, l) = gVXGg_s(1, ia, l)+ &
                                                     vxg_s(1, ia, ir, ispin)* &
                                                     gg(ir, l)*urad

                                 gVXGg_s(2, ia, l) = gVXGg_s(2, ia, l)+ &
                                                     vxg_s(2, ia, ir, ispin)* &
                                                     gg(ir, l)*urad

                                 gVXGg_s(3, ia, l) = gVXGg_s(3, ia, l)+ &
                                                     vxg_s(3, ia, ir, ispin)* &
                                                     gg(ir, l)*urad

                              ENDDO ! ir
                           ENDDO ! ia
                        ENDDO ! l

                        matso_h = 0.0_dp
                        matso_s = 0.0_dp
                        DO iso = 1, max_iso_not0_local
                           DO icg = 1, cg_n_list(iso)
                              iso1 = cg_list(1, icg, iso)
                              iso2 = cg_list(2, icg, iso)

                              l = indso(1, iso1)+indso(1, iso2)

                              !test reduce expansion local densities
                              CPASSERT(l <= lmax_expansion)
                              DO ia = 1, na
                                 matso_h(iso1, iso2) = matso_h(iso1, iso2)+ &
                                                       gVXCg_h(ia, l)* &
                                                       harmonics%slm(ia, iso)* &
                                                       my_CG(iso1, iso2, iso)
                                 matso_s(iso1, iso2) = matso_s(iso1, iso2)+ &
                                                       gVXCg_s(ia, l)* &
                                                       harmonics%slm(ia, iso)* &
                                                       my_CG(iso1, iso2, iso)
                              END DO ! ia

                              !test reduce expansion local densities

                           END DO

                        END DO ! iso

                        DO iso = 1, dmax_iso_not0_local
                           DO icg = 1, dcg_n_list(iso)
                              iso1 = dcg_list(1, icg, iso)
                              iso2 = dcg_list(2, icg, iso)

                              l = indso(1, iso1)+indso(1, iso2)
                              !test reduce expansion local densities
                              CPASSERT(l <= lmax_expansion)
                              DO ia = 1, na
                                 matso_h(iso1, iso2) = matso_h(iso1, iso2)+ &
                                                       (gVXGg_h(1, ia, l)*my_CG_dxyz(1, iso1, iso2, iso)+ &
                                                        gVXGg_h(2, ia, l)*my_CG_dxyz(2, iso1, iso2, iso)+ &
                                                        gVXGg_h(3, ia, l)*my_CG_dxyz(3, iso1, iso2, iso))* &
                                                       harmonics%slm(ia, iso)

                                 matso_s(iso1, iso2) = matso_s(iso1, iso2)+ &
                                                       (gVXGg_s(1, ia, l)*my_CG_dxyz(1, iso1, iso2, iso)+ &
                                                        gVXGg_s(2, ia, l)*my_CG_dxyz(2, iso1, iso2, iso)+ &
                                                        gVXGg_s(3, ia, l)*my_CG_dxyz(3, iso1, iso2, iso))* &
                                                       harmonics%slm(ia, iso)

                              END DO ! ia

                              !test reduce expansion local densities

                           END DO ! icg
                        END DO ! iso
                        !test reduce expansion local densities
                     END IF ! lmax_expansion

!             Write in the global matrix
                     DO ic = nsoset(lmin(iset2)-1)+1, nsoset(lmax(iset2))
                        iso1 = nsoset(lmin(iset1)-1)+1
                        iso2 = ngau2+ic
                        CALL daxpy(size1, 1.0_dp, matso_h(iso1, ic), 1, &
                                   int_hh(ispin)%r_coef(nngau1+1, iso2), 1)
                        CALL daxpy(size1, 1.0_dp, matso_s(iso1, ic), 1, &
                                   int_ss(ispin)%r_coef(nngau1+1, iso2), 1)
                     END DO

                  END DO ! ipfg2
               END DO ! ipfg1
               m2 = m2+maxso
            END DO ! iset2
            m1 = m1+maxso
         END DO ! iset1
      END DO ! ispin

      DEALLOCATE (g1, g2, gg, dgg, matso_h, matso_s, gVXCg_h, gVXCg_s, gVXGg_h, gVXGg_s)
      DEALLOCATE (cg_list, cg_n_list, dcg_list, dcg_n_list)

      CALL timestop(handle)

   END SUBROUTINE gaVxcgb_GC

! **************************************************************************************************
!> \brief ...
!> \param vtau_h ...
!> \param vtau_s ...
!> \param qs_kind ...
!> \param rho_atom ...
!> \param nspins ...
! **************************************************************************************************
   SUBROUTINE dgaVtaudgb(vtau_h, vtau_s, qs_kind, rho_atom, nspins)

      REAL(dp), DIMENSION(:, :, :), POINTER              :: vtau_h, vtau_s
      TYPE(qs_kind_type), INTENT(IN)                     :: qs_kind
      TYPE(rho_atom_type), POINTER                       :: rho_atom
      INTEGER, INTENT(IN)                                :: nspins

      CHARACTER(len=*), PARAMETER :: routineN = 'dgaVtaudgb', routineP = moduleN//':'//routineN

      INTEGER :: dmax_iso_not0_local, handle, ic, icg, ipgf1, ipgf2, iset1, iset2, iso, iso1, &
         iso2, isom1, isom2, ispin, l1, l2, lmax12, lmax_expansion, lmin12, m1, m2, max_iso_not0, &
         max_iso_not0_local, max_s_harm, maxiso, maxl, maxso, mm1, mm2, n1, n2, na, ngau1, ngau2, &
         nngau1, nr, nset, size1
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: cg_n_list, dcg_n_list
      INTEGER, ALLOCATABLE, DIMENSION(:, :, :)           :: cg_list, dcg_list
      INTEGER, DIMENSION(:), POINTER                     :: lmax, lmin, npgf
      REAL(dp), ALLOCATABLE, DIMENSION(:)                :: dd, g1, g2, gg, gr, ww
      REAL(dp), ALLOCATABLE, DIMENSION(:, :)             :: dgr, dvth, dvts, matso_h, matso_s, vth, &
                                                            vts
      REAL(dp), ALLOCATABLE, DIMENSION(:, :, :)          :: fgr
      REAL(dp), DIMENSION(:, :), POINTER                 :: zet
      REAL(dp), DIMENSION(:, :, :), POINTER              :: my_CG, my_dCG
      TYPE(grid_atom_type), POINTER                      :: grid_atom
      TYPE(gto_basis_set_type), POINTER                  :: orb_basis
      TYPE(harmonics_atom_type), POINTER                 :: harmonics
      TYPE(rho_atom_coeff), DIMENSION(:), POINTER        :: int_hh, int_ss

! -------------------------------------------------------------------------

      CALL timeset(routineN, handle)

      NULLIFY (harmonics, grid_atom)
      CALL get_qs_kind(qs_kind, basis_set=orb_basis, &
                       harmonics=harmonics, grid_atom=grid_atom)

      NULLIFY (lmin, lmax, npgf, zet)
      CALL get_gto_basis_set(gto_basis_set=orb_basis, lmax=lmax, lmin=lmin, &
                             maxso=maxso, maxl=maxl, npgf=npgf, &
                             nset=nset, zet=zet)

      my_CG => harmonics%my_CG
      my_dCG => harmonics%my_dCG
      max_iso_not0 = harmonics%max_iso_not0
      lmax_expansion = indso(1, max_iso_not0)
      max_s_harm = harmonics%max_s_harm

      nr = grid_atom%nr
      na = grid_atom%ng_sphere
      ALLOCATE (g1(nr), g2(nr), gg(nr), dd(nr), gr(nr), ww(na))
      ALLOCATE (fgr(nr, 0:maxl, 0:maxl), dgr(nr, 0:lmax_expansion))

      ALLOCATE (cg_list(2, nsoset(maxl)**2, max_s_harm), cg_n_list(max_s_harm), &
                dcg_list(2, nsoset(maxl)**2, max_s_harm), dcg_n_list(max_s_harm))

      ALLOCATE (matso_h(nsoset(maxl), nsoset(maxl)), &
                matso_s(nsoset(maxl), nsoset(maxl)))

      NULLIFY (int_hh, int_ss)
      CALL get_rho_atom(rho_atom=rho_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)

      vtau_h = 0.5_dp*vtau_h
      vtau_s = 0.5_dp*vtau_s

      DO ispin = 1, nspins
         maxiso = SIZE(harmonics%slm, 2)
         ALLOCATE (vth(nr, maxiso), vts(nr, maxiso))
         ALLOCATE (dvth(nr, maxiso), dvts(nr, maxiso))
         DO iso = 1, maxiso
            ww(1:na) = harmonics%slm(1:na, iso)
            vth(1:nr, iso) = MATMUL(ww(1:na), vtau_h(1:na, 1:nr, ispin))
            vts(1:nr, iso) = MATMUL(ww(1:na), vtau_s(1:na, 1:nr, ispin))
            ww(1:na) = harmonics%slm(1:na, iso)*grid_atom%usin_azi(1:na)**2
            dvth(1:nr, iso) = MATMUL(ww(1:na), vtau_h(1:na, 1:nr, ispin))
            dvts(1:nr, iso) = MATMUL(ww(1:na), vtau_s(1:na, 1:nr, ispin))
         END DO
         m1 = 0
         DO iset1 = 1, nset
            n1 = nsoset(lmax(iset1))
            m2 = 0
            DO iset2 = 1, nset
               CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
                                      max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local)
               CPASSERT(max_iso_not0_local .LE. max_iso_not0)
               CALL get_none0_cg_list(my_dCG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
                                      max_s_harm, lmax_expansion, dcg_list, dcg_n_list, dmax_iso_not0_local)

               n2 = nsoset(lmax(iset2))
               DO ipgf1 = 1, npgf(iset1)
                  ngau1 = n1*(ipgf1-1)+m1
                  size1 = nsoset(lmax(iset1))-nsoset(lmin(iset1)-1)
                  nngau1 = nsoset(lmin(iset1)-1)+ngau1
                  g1(1:nr) = EXP(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr))
                  DO ipgf2 = 1, npgf(iset2)
                     ngau2 = n2*(ipgf2-1)+m2
                     g2(1:nr) = EXP(-zet(ipgf2, iset2)*grid_atom%rad2(1:nr))
                     lmin12 = lmin(iset1)+lmin(iset2)
                     lmax12 = lmax(iset1)+lmax(iset2)

                     IF (lmin12 .LE. lmax_expansion) THEN
                        fgr = 0._dp
                        dgr = 0._dp
                        DO l1 = 0, maxl
                           DO l2 = 0, maxl
                              IF (l1+l2 > lmax_expansion) CYCLE
                              IF (l1+l2 > 0) THEN
                                 gg(1:nr) = g1(1:nr)*g2(1:nr)*grid_atom%rad2l(1:nr, l1+l2)
                              ELSE
                                 gg(1:nr) = g1(1:nr)*g2(1:nr)
                              END IF
                              dd(1:nr) = REAL(l1*l2, dp)/grid_atom%rad2(1:nr)- &
                                         2._dp*REAL(l1, dp)*zet(ipgf2, iset2)- &
                                         2._dp*REAL(l2, dp)*zet(ipgf1, iset1)+ &
                                         4._dp*zet(ipgf1, iset1)*zet(ipgf2, iset2)*grid_atom%rad2(1:nr)
                              fgr(1:nr, l1, l2) = dd(1:nr)*gg(1:nr)
                              dgr(1:nr, l1+l2) = gg(1:nr)/grid_atom%rad2(1:nr)
                           END DO
                        END DO
                     END IF

                     matso_h = 0.0_dp
                     matso_s = 0.0_dp
                     IF (lmin12 .LE. lmax_expansion) THEN
                        DO iso = 1, max_iso_not0_local
                           DO icg = 1, cg_n_list(iso)
                              iso1 = cg_list(1, icg, iso)
                              iso2 = cg_list(2, icg, iso)

                              l1 = indso(1, iso1)
                              l2 = indso(1, iso2)
                              mm1 = indso(2, iso1)
                              mm2 = indso(2, iso2)
                              isom1 = soset(l1, -mm1)
                              isom2 = soset(l2, -mm2)

                              IF (l1+l2 > lmax_expansion) CYCLE

                              matso_h(iso1, iso2) = matso_h(iso1, iso2)+my_CG(iso1, iso2, iso)* &
                                                    DOT_PRODUCT(vth(1:nr, ispin), fgr(1:nr, l1, l2))
                              matso_s(iso1, iso2) = matso_s(iso1, iso2)+my_CG(iso1, iso2, iso)* &
                                                    DOT_PRODUCT(vts(1:nr, ispin), fgr(1:nr, l1, l2))
                              ! d azimuthal
                              matso_h(iso1, iso2) = matso_h(iso1, iso2)+REAL(mm1*mm2, dp)*my_CG(isom1, isom2, iso)* &
                                                    DOT_PRODUCT(vth(1:nr, ispin), dgr(1:nr, l1+l2))
                              matso_s(iso1, iso2) = matso_s(iso1, iso2)+REAL(mm1*mm2, dp)*my_CG(isom1, isom2, iso)* &
                                                    DOT_PRODUCT(vts(1:nr, ispin), dgr(1:nr, l1+l2))
                           END DO
                        END DO
                     END IF
                     ! d polar
                     DO iso = 1, dmax_iso_not0_local
                        DO icg = 1, dcg_n_list(iso)
                           iso1 = dcg_list(1, icg, iso)
                           iso2 = dcg_list(2, icg, iso)

                           l1 = indso(1, iso1)
                           l2 = indso(1, iso2)
                           matso_h(iso1, iso2) = matso_h(iso1, iso2)+my_dCG(iso1, iso2, iso)* &
                                                 DOT_PRODUCT(dvth(1:nr, ispin), dgr(1:nr, l1+l2))
                           matso_s(iso1, iso2) = matso_s(iso1, iso2)+my_dCG(iso1, iso2, iso)* &
                                                 DOT_PRODUCT(dvts(1:nr, ispin), dgr(1:nr, l1+l2))
                        END DO
                     END DO

                     ! Write in the global matrix
                     DO ic = nsoset(lmin(iset2)-1)+1, nsoset(lmax(iset2))
                        iso1 = nsoset(lmin(iset1)-1)+1
                        iso2 = ngau2+ic
                        CALL daxpy(size1, 1.0_dp, matso_h(iso1, ic), 1, int_hh(ispin)%r_coef(nngau1+1, iso2), 1)
                        CALL daxpy(size1, 1.0_dp, matso_s(iso1, ic), 1, int_ss(ispin)%r_coef(nngau1+1, iso2), 1)
                     END DO

                  END DO ! ipfg2
               END DO ! ipfg1
               m2 = m2+maxso
            END DO ! iset2
            m1 = m1+maxso
         END DO ! iset1
         DEALLOCATE (vth, vts, dvth, dvts)
      END DO ! ispin

      DEALLOCATE (matso_h, matso_s)
      DEALLOCATE (g1, g2, gg, dd, gr, ww)
      DEALLOCATE (fgr, dgr)
      DEALLOCATE (cg_list, cg_n_list, dcg_list, dcg_n_list)

      vtau_h = 2._dp*vtau_h
      vtau_s = 2._dp*vtau_s

      CALL timestop(handle)

   END SUBROUTINE dgaVtaudgb

END MODULE qs_vxc_atom
