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

! **************************************************************************************************
!> \brief Provides the low level routines to build both the exchange and the
!>        Coulomb Fock matrices.. This routines support d-orbitals and should
!>        be changed only if one knows exactly what he is doing..
!> \author Teodoro Laino [tlaino] (05.2009) - Split and module reorganization
!> \par History
!>      Teodoro Laino (04.2008) [tlaino] - University of Zurich : d-orbitals
!>      Teodoro Laino (09.2008) [tlaino] - University of Zurich : Speed-up
!>      Teodoro Laino (09.2008) [tlaino] - University of Zurich : Periodic SE
! **************************************************************************************************
MODULE se_fock_matrix_integrals

   USE kinds, ONLY: dp
   USE semi_empirical_int_arrays, ONLY: se_orbital_pointer
   USE semi_empirical_integrals, ONLY: drotint, &
                                       drotnuc, &
                                       rotint, &
                                       rotnuc
   USE semi_empirical_store_int_types, ONLY: semi_empirical_si_type
   USE semi_empirical_types, ONLY: se_int_control_type, &
                                   se_taper_type, &
                                   semi_empirical_type
#include "./base/base_uses.f90"

   #:include "ewalds_multipole_sr.fypp"

   IMPLICIT NONE
   PRIVATE

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'se_fock_matrix_integrals'
   LOGICAL, PARAMETER, PRIVATE          :: debug_this_module = .FALSE.

   PUBLIC :: fock2_1el, dfock2_1el, fock1_2el, fock2_1el_ew, fock2C_ew, &
             fock2C, dfock2C, fock2E, dfock2E, fock2_1el_r3, dfock2_1el_r3, &
             fock2C_r3, dfock2C_r3, se_coulomb_ij_interaction

CONTAINS

! **************************************************************************************************
!> \brief  Construction of 2-center 1-electron Fock Matrix
!> \param sepi ...
!> \param sepj ...
!> \param rij ...
!> \param ksi_block DIMENSION(sepi%natorb, sepi%natorb)
!> \param ksj_block DIMENSION(sepi%natorb, sepi%natorb)
!> \param pi_block ...
!> \param pj_block ...
!> \param ecore ...
!> \param itype ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param store_int_env ...
!> \date   04.2008 [tlaino]
!> \author Teodoro Laino [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE fock2_1el(sepi, sepj, rij, ksi_block, ksj_block, pi_block, pj_block, &
                        ecore, itype, anag, se_int_control, se_taper, store_int_env)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: ksi_block, ksj_block
      REAL(KIND=dp), &
         DIMENSION(sepi%natorb, sepi%natorb), INTENT(IN) :: pi_block
      REAL(KIND=dp), &
         DIMENSION(sepj%natorb, sepj%natorb), INTENT(IN) :: pj_block
      REAL(KIND=dp), DIMENSION(2), INTENT(INOUT)         :: ecore
      INTEGER, INTENT(IN)                                :: itype
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(semi_empirical_si_type), POINTER              :: store_int_env

      INTEGER                                            :: i1, i1L, i2, j1, j1L
      REAL(KIND=dp), DIMENSION(45)                       :: e1b, e2a

! Compute integrals

      CALL rotnuc(sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype, anag=anag, &
                  se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env)
      !
      ! Add the electron-nuclear attraction term for atom sepi
      !
      i2 = 0
      DO i1L = 1, sepi%natorb
         i1 = se_orbital_pointer(i1L)
         DO j1L = 1, i1L - 1
            j1 = se_orbital_pointer(j1L)
            i2 = i2 + 1
            ksi_block(i1, j1) = ksi_block(i1, j1) + e1b(i2)
            ksi_block(j1, i1) = ksi_block(i1, j1)
            ecore(1) = ecore(1) + 2.0_dp*e1b(i2)*pi_block(i1, j1)
         END DO
         j1 = se_orbital_pointer(j1L)
         i2 = i2 + 1
         ksi_block(i1, j1) = ksi_block(i1, j1) + e1b(i2)
         ecore(1) = ecore(1) + e1b(i2)*pi_block(i1, j1)
      END DO
      !
      ! Add the electron-nuclear attraction term for atom sepj
      !
      i2 = 0
      DO i1L = 1, sepj%natorb
         i1 = se_orbital_pointer(i1L)
         DO j1L = 1, i1L - 1
            j1 = se_orbital_pointer(j1L)
            i2 = i2 + 1
            ksj_block(i1, j1) = ksj_block(i1, j1) + e2a(i2)
            ksj_block(j1, i1) = ksj_block(i1, j1)
            ecore(2) = ecore(2) + 2.0_dp*e2a(i2)*pj_block(i1, j1)
         END DO
         j1 = se_orbital_pointer(j1L)
         i2 = i2 + 1
         ksj_block(i1, j1) = ksj_block(i1, j1) + e2a(i2)
         ecore(2) = ecore(2) + e2a(i2)*pj_block(i1, j1)
      END DO

   END SUBROUTINE fock2_1el

! **************************************************************************************************
!> \brief Derivatives of 2-center 1-electron Fock Matrix
!> \param sepi ...
!> \param sepj ...
!> \param rij ...
!> \param pi_block ...
!> \param pj_block ...
!> \param itype ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param force ...
!> \param delta ...
!> \date 04.2008 [tlaino]
!> \author Teodoro Laino [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE dfock2_1el(sepi, sepj, rij, pi_block, pj_block, itype, anag, &
                         se_int_control, se_taper, force, delta)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      REAL(KIND=dp), &
         DIMENSION(sepi%natorb, sepi%natorb), INTENT(IN) :: pi_block
      REAL(KIND=dp), &
         DIMENSION(sepj%natorb, sepj%natorb), INTENT(IN) :: pj_block
      INTEGER, INTENT(IN)                                :: itype
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      REAL(KIND=dp), DIMENSION(3), INTENT(INOUT)         :: force
      REAL(KIND=dp), INTENT(IN)                          :: delta

      INTEGER                                            :: i1, i1L, i2, j1, j1L
      REAL(KIND=dp)                                      :: tmp
      REAL(KIND=dp), DIMENSION(3, 45)                    :: de1b, de2a

! Compute integrals

      CALL drotnuc(sepi, sepj, rij, de1b=de1b, de2a=de2a, itype=itype, anag=anag, &
                   se_int_control=se_int_control, se_taper=se_taper, delta=delta)
      !
      ! Add the electron-nuclear attraction term for atom sepi
      !
      i2 = 0
      DO i1L = 1, sepi%natorb
         i1 = se_orbital_pointer(i1L)
         DO j1L = 1, i1L - 1
            j1 = se_orbital_pointer(j1L)
            i2 = i2 + 1
            tmp = 2.0_dp*pi_block(i1, j1)
            force(1) = force(1) + de1b(1, i2)*tmp
            force(2) = force(2) + de1b(2, i2)*tmp
            force(3) = force(3) + de1b(3, i2)*tmp
         END DO
         j1 = se_orbital_pointer(j1L)
         i2 = i2 + 1
         force(1) = force(1) + de1b(1, i2)*pi_block(i1, j1)
         force(2) = force(2) + de1b(2, i2)*pi_block(i1, j1)
         force(3) = force(3) + de1b(3, i2)*pi_block(i1, j1)
      END DO
      !
      ! Add the electron-nuclear attraction term for atom sepj
      !
      i2 = 0
      DO i1L = 1, sepj%natorb
         i1 = se_orbital_pointer(i1L)
         DO j1L = 1, i1L - 1
            j1 = se_orbital_pointer(j1L)
            i2 = i2 + 1
            tmp = 2.0_dp*pj_block(i1, j1)
            force(1) = force(1) + de2a(1, i2)*tmp
            force(2) = force(2) + de2a(2, i2)*tmp
            force(3) = force(3) + de2a(3, i2)*tmp
         END DO
         j1 = se_orbital_pointer(j1L)
         i2 = i2 + 1
         force(1) = force(1) + de2a(1, i2)*pj_block(i1, j1)
         force(2) = force(2) + de2a(2, i2)*pj_block(i1, j1)
         force(3) = force(3) + de2a(3, i2)*pj_block(i1, j1)
      END DO

   END SUBROUTINE dfock2_1el

! **************************************************************************************************
!> \brief Construction of 1-center 2-electron Fock Matrix
!> \param sep ...
!> \param p_tot ...
!> \param p_mat ...
!> \param f_mat DIMENSION(sep%natorb, sep%natorb)
!> \param factor ...
!> \date 04.2008 [tlaino]
!> \author Teodoro Laino [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE fock1_2el(sep, p_tot, p_mat, f_mat, factor)
      TYPE(semi_empirical_type), POINTER                 :: sep
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: p_tot
      REAL(KIND=dp), DIMENSION(sep%natorb, sep%natorb), &
         INTENT(IN)                                      :: p_mat
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: f_mat
      REAL(KIND=dp), INTENT(IN)                          :: factor

      INTEGER                                            :: i, ijw, ikw, iL, im, j, jL, jlw, jm, k, &
                                                            kL, klw, l, lL
      REAL(KIND=dp)                                      :: sum

!   One-center coulomb and exchange terms for semiempirical_type sep
!
!  F(i,j)=F(i,j)+sum(k,l)((PA(k,l)+PB(k,l))*<i,j|k,l>
!                        -(PA(k,l)        )*<i,k|j,l>), k,l on type sep.
!

      DO iL = 1, sep%natorb
         i = se_orbital_pointer(iL)
         DO jL = 1, iL
            j = se_orbital_pointer(jL)

            !    `J' Address IJ in W
            ijw = (iL*(iL - 1))/2 + jL
            sum = 0.0_dp
            DO kL = 1, sep%natorb
               k = se_orbital_pointer(kL)
               DO lL = 1, sep%natorb
                  l = se_orbital_pointer(lL)

                  !    `J' Address KL in W
                  im = MAX(kL, lL)
                  jm = MIN(kL, lL)
                  klw = (im*(im - 1))/2 + jm

                  !    `K' Address IK in W
                  im = MAX(kL, jL)
                  jm = MIN(kL, jL)
                  ikw = (im*(im - 1))/2 + jm

                  !    `K' Address JL in W
                  im = MAX(lL, iL)
                  jm = MIN(lL, iL)
                  jlw = (im*(im - 1))/2 + jm

                  sum = sum + p_tot(k, l)*sep%w(ijw, klw) - p_mat(k, l)*sep%w(ikw, jlw)
               END DO
            END DO
            f_mat(i, j) = f_mat(i, j) + factor*sum
            f_mat(j, i) = f_mat(i, j)
         END DO
      END DO
   END SUBROUTINE fock1_2el

! **************************************************************************************************
!> \brief Construction of 2-center 1-electron Fock Matrix (Ewald self term)
!> \param sep ...
!> \param rij ...
!> \param ks_block DIMENSION(sep%natorb, sep%natorb)
!> \param p_block ...
!> \param ecore ...
!> \param itype ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param store_int_env ...
!> \date 04.2009 [jgh]
!> \author jgh - University of Zurich
! **************************************************************************************************
   SUBROUTINE fock2_1el_ew(sep, rij, ks_block, p_block, ecore, itype, anag, &
                           se_int_control, se_taper, store_int_env)
      TYPE(semi_empirical_type), POINTER                 :: sep
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: ks_block
      REAL(KIND=dp), DIMENSION(sep%natorb, sep%natorb), &
         INTENT(IN)                                      :: p_block
      REAL(KIND=dp), INTENT(INOUT)                       :: ecore
      INTEGER, INTENT(IN)                                :: itype
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(semi_empirical_si_type), POINTER              :: store_int_env

      INTEGER                                            :: i1, i1L, i2, j1, j1L, n
      REAL(KIND=dp), DIMENSION(45)                       :: e1b, e2a

! Compute integrals

      CALL rotnuc(sep, sep, rij, e1b=e1b, e2a=e2a, itype=itype, anag=anag, &
                  se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env)
      !
      ! Add the electron-nuclear attraction term for atom sep
      ! e1b == e2a
      !
      n = (sep%natorb*(sep%natorb + 1))/2
      i2 = 0
      DO i1L = 1, sep%natorb
         i1 = se_orbital_pointer(i1L)
         DO j1L = 1, i1L - 1
            j1 = se_orbital_pointer(j1L)
            i2 = i2 + 1
            ks_block(i1, j1) = ks_block(i1, j1) + e1b(i2)
            ks_block(j1, i1) = ks_block(i1, j1)
            ecore = ecore + 2._dp*e1b(i2)*p_block(i1, j1)
         END DO
         ! i1L == j1L
         i2 = i2 + 1
         ks_block(i1, i1) = ks_block(i1, i1) + e1b(i2)
         ecore = ecore + e1b(i2)*p_block(i1, i1)
      END DO

   END SUBROUTINE fock2_1el_ew

! **************************************************************************************************
!> \brief  Construction of 2-center Fock Matrix - Coulomb Self Terms (Ewald)
!> \param sep ...
!> \param rij ...
!> \param p_tot ...
!> \param f_mat DIMENSION(sep%natorb, sep%natorb)
!> \param factor ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param store_int_env ...
!> \date 04.2009 [jgh]
!> \author jgh - University of Zurich
! **************************************************************************************************
   SUBROUTINE fock2C_ew(sep, rij, p_tot, f_mat, factor, anag, se_int_control, &
                        se_taper, store_int_env)
      TYPE(semi_empirical_type), POINTER                 :: sep
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: p_tot
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: f_mat
      REAL(KIND=dp), INTENT(IN)                          :: factor
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(semi_empirical_si_type), POINTER              :: store_int_env

      INTEGER                                            :: i, iL, j, jL, k, kL, kr, l, lL, natorb
      REAL(KIND=dp)                                      :: a, aa, bb
      REAL(KIND=dp), DIMENSION(2025)                     :: w

! Evaluate integrals

      CALL rotint(sep, sep, rij, w, anag=anag, se_int_control=se_int_control, &
                  se_taper=se_taper, store_int_env=store_int_env)
      kr = 0
      natorb = sep%natorb
      DO iL = 1, natorb
         i = se_orbital_pointer(iL)
         aa = 2.0_dp
         DO jL = 1, iL
            j = se_orbital_pointer(jL)
            IF (i == j) THEN
               aa = 1.0_dp
            END IF
            DO kL = 1, natorb
               k = se_orbital_pointer(kL)
               bb = 2.0_dp
               DO lL = 1, kL
                  l = se_orbital_pointer(lL)
                  IF (k == l) THEN
                     bb = 1.0_dp
                  END IF
                  kr = kr + 1
                  a = 0.5_dp*w(kr)*factor
                  ! Coulomb
                  f_mat(i, j) = f_mat(i, j) + bb*a*p_tot(k, l)
                  f_mat(k, l) = f_mat(k, l) + aa*a*p_tot(i, j)
                  f_mat(j, i) = f_mat(i, j)
                  f_mat(l, k) = f_mat(k, l)
               END DO
            END DO
         END DO
      END DO

   END SUBROUTINE fock2C_ew

! **************************************************************************************************
!> \brief  Construction of 2-center Fock Matrix - Coulomb Terms
!> \param sepi ...
!> \param sepj ...
!> \param rij ...
!> \param switch ...
!> \param pi_tot ...
!> \param fi_mat DIMENSION(sepi%natorb, sepi%natorb)
!> \param pj_tot DIMENSION(sepj%natorb, sepj%natorb)
!> \param fj_mat ...
!> \param factor ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param store_int_env ...
!> \date 04.2008 [tlaino]
!> \author Teodoro Laino [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE fock2C(sepi, sepj, rij, switch, pi_tot, fi_mat, pj_tot, fj_mat, &
                     factor, anag, se_int_control, se_taper, store_int_env)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      LOGICAL, INTENT(IN)                                :: switch
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: pi_tot
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: fi_mat
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: pj_tot
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: fj_mat
      REAL(KIND=dp), INTENT(IN)                          :: factor
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(semi_empirical_si_type), POINTER              :: store_int_env

      INTEGER                                            :: i, iL, j, jL, k, kL, kr, l, lL, natorb(2)
      REAL(KIND=dp)                                      :: a, aa, bb, irij(3)
      REAL(KIND=dp), DIMENSION(2025)                     :: w

! Evaluate integrals

      IF (.NOT. switch) THEN
         CALL rotint(sepi, sepj, rij, w, anag=anag, se_int_control=se_int_control, &
                     se_taper=se_taper, store_int_env=store_int_env)
      ELSE
         irij = -rij
         CALL rotint(sepj, sepi, irij, w, anag=anag, se_int_control=se_int_control, &
                     se_taper=se_taper, store_int_env=store_int_env)
      END IF
      kr = 0
      natorb(1) = sepi%natorb
      natorb(2) = sepj%natorb
      IF (switch) THEN
         natorb(1) = sepj%natorb
         natorb(2) = sepi%natorb
      END IF
      DO iL = 1, natorb(1)
         i = se_orbital_pointer(iL)
         aa = 2.0_dp
         DO jL = 1, iL
            j = se_orbital_pointer(jL)
            IF (i == j) THEN
               aa = 1.0_dp
            END IF
            DO kL = 1, natorb(2)
               k = se_orbital_pointer(kL)
               bb = 2.0_dp
               DO lL = 1, kL
                  l = se_orbital_pointer(lL)
                  IF (k == l) THEN
                     bb = 1.0_dp
                  END IF
                  kr = kr + 1
                  a = w(kr)*factor
                  ! Coulomb
                  IF (.NOT. switch) THEN
                     fi_mat(i, j) = fi_mat(i, j) + bb*a*pj_tot(k, l)
                     fj_mat(k, l) = fj_mat(k, l) + aa*a*pi_tot(i, j)
                     fi_mat(j, i) = fi_mat(i, j)
                     fj_mat(l, k) = fj_mat(k, l)
                  ELSE
                     fj_mat(i, j) = fj_mat(i, j) + bb*a*pi_tot(k, l)
                     fi_mat(k, l) = fi_mat(k, l) + aa*a*pj_tot(i, j)
                     fj_mat(j, i) = fj_mat(i, j)
                     fi_mat(l, k) = fi_mat(k, l)
                  END IF
               END DO
            END DO
         END DO
      END DO

   END SUBROUTINE fock2C

! **************************************************************************************************
!> \brief Derivatives of 2-center Fock Matrix - Coulomb Terms
!> \param sepi ...
!> \param sepj ...
!> \param rij ...
!> \param switch ...
!> \param pi_tot ...
!> \param pj_tot ...
!> \param factor ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param force ...
!> \param delta ...
!> \date 04.2008 [tlaino]
!> \author Teodoro Laino [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE dfock2C(sepi, sepj, rij, switch, pi_tot, pj_tot, factor, anag, &
                      se_int_control, se_taper, force, delta)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      LOGICAL, INTENT(IN)                                :: switch
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: pi_tot, pj_tot
      REAL(KIND=dp), INTENT(IN)                          :: factor
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      REAL(KIND=dp), DIMENSION(3), INTENT(INOUT)         :: force
      REAL(KIND=dp), INTENT(IN)                          :: delta

      INTEGER                                            :: i, iL, j, jL, k, kL, kr, l, lL, natorb(2)
      REAL(KIND=dp)                                      :: aa, bb, tmp
      REAL(KIND=dp), DIMENSION(3)                        :: a, irij
      REAL(KIND=dp), DIMENSION(3, 2025)                  :: dw

! Evaluate integrals' derivatives

      IF (.NOT. switch) THEN
         CALL drotint(sepi, sepj, rij, dw, delta, anag=anag, se_int_control=se_int_control, &
                      se_taper=se_taper)
      ELSE
         irij = -rij
         CALL drotint(sepj, sepi, irij, dw, delta, anag=anag, se_int_control=se_int_control, &
                      se_taper=se_taper)
      END IF

      kr = 0
      natorb(1) = sepi%natorb
      natorb(2) = sepj%natorb
      IF (switch) THEN
         natorb(1) = sepj%natorb
         natorb(2) = sepi%natorb
      END IF
      DO iL = 1, natorb(1)
         i = se_orbital_pointer(iL)
         aa = 2.0_dp
         DO jL = 1, iL
            j = se_orbital_pointer(jL)
            IF (i == j) THEN
               aa = 1.0_dp
            END IF
            DO kL = 1, natorb(2)
               k = se_orbital_pointer(kL)
               bb = 2.0_dp
               DO lL = 1, kL
                  l = se_orbital_pointer(lL)
                  IF (k == l) THEN
                     bb = 1.0_dp
                  END IF
                  kr = kr + 1
                  a(1) = dw(1, kr)*factor
                  a(2) = dw(2, kr)*factor
                  a(3) = dw(3, kr)*factor
                  ! Coulomb
                  IF (.NOT. switch) THEN
                     tmp = bb*aa*pj_tot(k, l)*pi_tot(i, j)
                  ELSE
                     tmp = bb*aa*pi_tot(k, l)*pj_tot(i, j)
                  END IF
                  force(1) = force(1) + a(1)*tmp
                  force(2) = force(2) + a(2)*tmp
                  force(3) = force(3) + a(3)*tmp
               END DO
            END DO
         END DO
      END DO
   END SUBROUTINE dfock2C

! **************************************************************************************************
!> \brief Construction of 2-center Fock Matrix - General Driver
!> \param sepi ...
!> \param sepj ...
!> \param rij ...
!> \param switch ...
!> \param isize ...
!> \param pi_mat ...
!> \param fi_mat DIMENSION(isize(1), isize(2))
!> \param factor ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param store_int_env ...
!> \date 04.2008 [tlaino]
!> \author Teodoro Laino [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE fock2E(sepi, sepj, rij, switch, isize, pi_mat, fi_mat, factor, &
                     anag, se_int_control, se_taper, store_int_env)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      LOGICAL, INTENT(IN)                                :: switch
      INTEGER, DIMENSION(2), INTENT(IN)                  :: isize
      REAL(KIND=dp), DIMENSION(isize(1), isize(2)), &
         INTENT(IN)                                      :: pi_mat
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: fi_mat
      REAL(KIND=dp), INTENT(IN)                          :: factor
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(semi_empirical_si_type), POINTER              :: store_int_env

      INTEGER                                            :: i, iL, j, jL, k, kL, kr, l, lL, natorb(2)
      REAL(KIND=dp)                                      :: a, aa, bb, irij(3)
      REAL(KIND=dp), DIMENSION(2025)                     :: w

! Evaluate integrals

      IF (.NOT. switch) THEN
         CALL rotint(sepi, sepj, rij, w, anag=anag, se_int_control=se_int_control, &
                     se_taper=se_taper, store_int_env=store_int_env)
      ELSE
         irij = -rij
         CALL rotint(sepj, sepi, irij, w, anag=anag, se_int_control=se_int_control, &
                     se_taper=se_taper, store_int_env=store_int_env)
      END IF
      kr = 0
      natorb(1) = sepi%natorb
      natorb(2) = sepj%natorb
      IF (switch) THEN
         natorb(1) = sepj%natorb
         natorb(2) = sepi%natorb
      END IF
      DO iL = 1, natorb(1)
         i = se_orbital_pointer(iL)
         aa = 2.0_dp
         DO jL = 1, iL
            j = se_orbital_pointer(jL)
            IF (i == j) THEN
               aa = 1.0_dp
            END IF
            DO kL = 1, natorb(2)
               k = se_orbital_pointer(kL)
               bb = 2.0_dp
               DO lL = 1, kL
                  l = se_orbital_pointer(lL)
                  IF (k == l) THEN
                     bb = 1.0_dp
                  END IF
                  kr = kr + 1
                  a = w(kr)*factor
                  ! Exchange
                  a = a*aa*bb*0.25_dp
                  fi_mat(i, k) = fi_mat(i, k) - a*pi_mat(j, l)
                  fi_mat(i, l) = fi_mat(i, l) - a*pi_mat(j, k)
                  fi_mat(j, k) = fi_mat(j, k) - a*pi_mat(i, l)
                  fi_mat(j, l) = fi_mat(j, l) - a*pi_mat(i, k)
               END DO
            END DO
         END DO
      END DO

   END SUBROUTINE fock2E

! **************************************************************************************************
!> \brief Derivatives of 2-center Fock Matrix - General Driver
!> \param sepi ...
!> \param sepj ...
!> \param rij ...
!> \param switch ...
!> \param isize ...
!> \param pi_mat ...
!> \param factor ...
!> \param anag ...
!> \param se_int_control ...
!> \param se_taper ...
!> \param force ...
!> \param delta ...
!> \date 04.2008 [tlaino]
!> \author Teodoro Laino [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE dfock2E(sepi, sepj, rij, switch, isize, pi_mat, factor, anag, &
                      se_int_control, se_taper, force, delta)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rij
      LOGICAL, INTENT(IN)                                :: switch
      INTEGER, DIMENSION(2), INTENT(IN)                  :: isize
      REAL(KIND=dp), DIMENSION(isize(1), isize(2)), &
         INTENT(IN)                                      :: pi_mat
      REAL(KIND=dp), INTENT(IN)                          :: factor
      LOGICAL, INTENT(IN)                                :: anag
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper
      REAL(KIND=dp), DIMENSION(3), INTENT(INOUT)         :: force
      REAL(KIND=dp), INTENT(IN)                          :: delta

      INTEGER                                            :: i, iL, j, jL, k, kL, kr, l, lL, natorb(2)
      REAL(KIND=dp)                                      :: aa, bb, tmp, tmp1, tmp2, tmp3, tmp4
      REAL(KIND=dp), DIMENSION(3)                        :: a, irij
      REAL(KIND=dp), DIMENSION(3, 2025)                  :: dw

! Evaluate integrals' derivatives

      IF (.NOT. switch) THEN
         CALL drotint(sepi, sepj, rij, dw, delta, anag=anag, se_int_control=se_int_control, &
                      se_taper=se_taper)
      ELSE
         irij = -rij
         CALL drotint(sepj, sepi, irij, dw, delta, anag=anag, se_int_control=se_int_control, &
                      se_taper=se_taper)
      END IF

      kr = 0
      natorb(1) = sepi%natorb
      natorb(2) = sepj%natorb
      IF (switch) THEN
         natorb(1) = sepj%natorb
         natorb(2) = sepi%natorb
      END IF
      DO iL = 1, natorb(1)
         i = se_orbital_pointer(iL)
         aa = 2.0_dp
         DO jL = 1, iL
            j = se_orbital_pointer(jL)
            IF (i == j) THEN
               aa = 1.0_dp
            END IF
            DO kL = 1, natorb(2)
               k = se_orbital_pointer(kL)
               bb = 2.0_dp
               DO lL = 1, kL
                  l = se_orbital_pointer(lL)
                  IF (k == l) THEN
                     bb = 1.0_dp
                  END IF
                  kr = kr + 1
                  tmp = factor*aa*bb*0.25_dp
                  a(1) = dw(1, kr)*tmp
                  a(2) = dw(2, kr)*tmp
                  a(3) = dw(3, kr)*tmp
                  ! Exchange
                  tmp1 = pi_mat(j, l)*pi_mat(i, k)
                  tmp2 = pi_mat(j, k)*pi_mat(i, l)
                  tmp3 = pi_mat(i, l)*pi_mat(j, k)
                  tmp4 = pi_mat(i, k)*pi_mat(j, l)

                  force(1) = force(1) - a(1)*tmp1
                  force(1) = force(1) - a(1)*tmp2
                  force(1) = force(1) - a(1)*tmp3
                  force(1) = force(1) - a(1)*tmp4

                  force(2) = force(2) - a(2)*tmp1
                  force(2) = force(2) - a(2)*tmp2
                  force(2) = force(2) - a(2)*tmp3
                  force(2) = force(2) - a(2)*tmp4

                  force(3) = force(3) - a(3)*tmp1
                  force(3) = force(3) - a(3)*tmp2
                  force(3) = force(3) - a(3)*tmp3
                  force(3) = force(3) - a(3)*tmp4
               END DO
            END DO
         END DO
      END DO
   END SUBROUTINE dfock2E

! **************************************************************************************************
!> \brief  Construction of 2-center 1-electron Fock Matrix for the residual
!>         (1/R^3) integral part
!> \param sepi ...
!> \param sepj ...
!> \param ksi_block DIMENSION(sepi%natorb, sepi%natorb)
!> \param ksj_block DIMENSION(sepj%natorb, sepj%natorb)
!> \param pi_block ...
!> \param pj_block ...
!> \param e1b ...
!> \param e2a ...
!> \param ecore ...
!> \param rp ...
!> \date   12.2008 [tlaino]
!> \author Teodoro Laino [tlaino]
! **************************************************************************************************
   SUBROUTINE fock2_1el_r3(sepi, sepj, ksi_block, ksj_block, pi_block, pj_block, &
                           e1b, e2a, ecore, rp)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: ksi_block, ksj_block
      REAL(KIND=dp), &
         DIMENSION(sepi%natorb, sepi%natorb), INTENT(IN) :: pi_block
      REAL(KIND=dp), &
         DIMENSION(sepj%natorb, sepj%natorb), INTENT(IN) :: pj_block
      REAL(KIND=dp), DIMENSION(:), INTENT(IN)            :: e1b, e2a
      REAL(KIND=dp), DIMENSION(2), INTENT(INOUT)         :: ecore
      REAL(KIND=dp), INTENT(IN)                          :: rp

      INTEGER                                            :: i1, i1L, i2

!
! Add the electron-nuclear residual attraction term for atom sepi
!

      i2 = 0
      DO i1L = 1, sepi%natorb
         i2 = i2 + 1
         i1 = se_orbital_pointer(i1L)
         ksi_block(i1, i1) = ksi_block(i1, i1) + e1b(i2)*rp
         ecore(1) = ecore(1) + e1b(i2)*rp*pi_block(i1, i1)
      END DO
      !
      ! Add the electron-nuclear residual attraction term for atom sepj
      !
      i2 = 0
      DO i1L = 1, sepj%natorb
         i2 = i2 + 1
         i1 = se_orbital_pointer(i1L)
         ksj_block(i1, i1) = ksj_block(i1, i1) + e2a(i2)*rp
         ecore(2) = ecore(2) + e2a(i2)*rp*pj_block(i1, i1)
      END DO

   END SUBROUTINE fock2_1el_r3

! **************************************************************************************************
!> \brief  Derivatives of 2-center 1-electron Fock Matrix residual (1/R^3)
!>         integral part
!> \param sepi ...
!> \param sepj ...
!> \param drp ...
!> \param pi_block ...
!> \param pj_block ...
!> \param force ...
!> \param e1b ...
!> \param e2a ...
!> \date   12.2008 [tlaino]
!> \author Teodoro Laino [tlaino]
! **************************************************************************************************
   SUBROUTINE dfock2_1el_r3(sepi, sepj, drp, pi_block, pj_block, force, e1b, e2a)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: drp
      REAL(KIND=dp), &
         DIMENSION(sepi%natorb, sepi%natorb), INTENT(IN) :: pi_block
      REAL(KIND=dp), &
         DIMENSION(sepj%natorb, sepj%natorb), INTENT(IN) :: pj_block
      REAL(KIND=dp), DIMENSION(3), INTENT(INOUT)         :: force
      REAL(KIND=dp), DIMENSION(:), INTENT(IN)            :: e1b, e2a

      INTEGER                                            :: i1, i1L, i2
      REAL(KIND=dp)                                      :: tmp

!
! Add the electron-nuclear residual attraction term for atom sepi
!

      i2 = 0
      DO i1L = 1, sepi%natorb
         i1 = se_orbital_pointer(i1L)
         i2 = i2 + 1
         tmp = e1b(i2)*pi_block(i1, i1)
         force(1) = force(1) + tmp*drp(1)
         force(2) = force(2) + tmp*drp(2)
         force(3) = force(3) + tmp*drp(3)
      END DO
      !
      ! Add the electron-nuclear attraction term for atom sepj
      !
      i2 = 0
      DO i1L = 1, sepj%natorb
         i1 = se_orbital_pointer(i1L)
         i2 = i2 + 1
         tmp = e2a(i2)*pj_block(i1, i1)
         force(1) = force(1) + tmp*drp(1)
         force(2) = force(2) + tmp*drp(2)
         force(3) = force(3) + tmp*drp(3)
      END DO

   END SUBROUTINE dfock2_1el_r3

! **************************************************************************************************
!> \brief  Construction of 2-center Fock Matrix - Coulomb Terms for the residual
!>         (1/R^3) integral part
!> \param sepi ...
!> \param sepj ...
!> \param switch ...
!> \param pi_tot ...
!> \param fi_mat DIMENSION(sepi%natorb, sepi%natorb)
!> \param pj_tot ...
!> \param fj_mat DIMENSION(sepj%natorb, sepj%natorb)
!> \param factor ...
!> \param w ...
!> \param rp ...
!> \date   12.2008 [tlaino]
!> \author Teodoro Laino [tlaino]
! **************************************************************************************************
   SUBROUTINE fock2C_r3(sepi, sepj, switch, pi_tot, fi_mat, pj_tot, fj_mat, &
                        factor, w, rp)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      LOGICAL, INTENT(IN)                                :: switch
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: pi_tot
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: fi_mat
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: pj_tot
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: fj_mat
      REAL(KIND=dp), INTENT(IN)                          :: factor
      REAL(KIND=dp), DIMENSION(81), INTENT(IN)           :: w
      REAL(KIND=dp), INTENT(IN)                          :: rp

      INTEGER                                            :: i, iL, ind, j, k, kL, kr, natorb(2)
      REAL(KIND=dp)                                      :: a, w_l(81)

      natorb(1) = sepi%natorb
      natorb(2) = sepj%natorb
      IF (switch) THEN
         natorb(1) = sepj%natorb
         natorb(2) = sepi%natorb
         ! Reshuffle the integral array (natural storage order is sepi/sepj)
         kr = 0
         DO i = 1, sepj%natorb
            DO j = 1, sepi%natorb
               kr = kr + 1
               ind = (j - 1)*sepj%natorb + i
               w_l(kr) = w(ind)
            END DO
         END DO
      ELSE
         w_l = w
      END IF

      ! Modify the Fock Matrix
      kr = 0
      DO iL = 1, natorb(1)
         i = se_orbital_pointer(iL)
         DO kL = 1, natorb(2)
            k = se_orbital_pointer(kL)
            kr = kr + 1
            a = w_l(kr)*factor*rp
            ! Coulomb
            IF (.NOT. switch) THEN
               fi_mat(i, i) = fi_mat(i, i) + a*pj_tot(k, k)
               fj_mat(k, k) = fj_mat(k, k) + a*pi_tot(i, i)
            ELSE
               fj_mat(i, i) = fj_mat(i, i) + a*pi_tot(k, k)
               fi_mat(k, k) = fi_mat(k, k) + a*pj_tot(i, i)
            END IF
         END DO
      END DO

   END SUBROUTINE fock2C_r3

! **************************************************************************************************
!> \brief  Derivatives of 2-center Fock Matrix - Coulomb Terms for the residual
!>         (1/R^3) integral part
!> \param sepi ...
!> \param sepj ...
!> \param switch ...
!> \param pi_tot ...
!> \param pj_tot ...
!> \param factor ...
!> \param w ...
!> \param drp ...
!> \param force ...
!> \date   12.2008 [tlaino]
!> \author Teodoro Laino [tlaino]
! **************************************************************************************************
   SUBROUTINE dfock2C_r3(sepi, sepj, switch, pi_tot, pj_tot, factor, w, drp, &
                         force)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      LOGICAL, INTENT(IN)                                :: switch
      REAL(KIND=dp), DIMENSION(45, 45), INTENT(IN)       :: pi_tot, pj_tot
      REAL(KIND=dp), INTENT(IN)                          :: factor
      REAL(KIND=dp), DIMENSION(81), INTENT(IN)           :: w
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: drp
      REAL(KIND=dp), DIMENSION(3), INTENT(INOUT)         :: force

      INTEGER                                            :: i, iL, ind, j, k, kL, kr, natorb(2)
      REAL(KIND=dp)                                      :: a(3), tmp, w_l(81)

      natorb(1) = sepi%natorb
      natorb(2) = sepj%natorb
      IF (switch) THEN
         natorb(1) = sepj%natorb
         natorb(2) = sepi%natorb
         ! Reshuffle the integral array (natural storage order is sepi/sepj)
         kr = 0
         DO i = 1, sepj%natorb
            DO j = 1, sepi%natorb
               kr = kr + 1
               ind = (j - 1)*sepj%natorb + i
               w_l(kr) = w(ind)
            END DO
         END DO
      ELSE
         w_l = w
      END IF

      ! Modify the Fock Matrix
      kr = 0
      DO iL = 1, natorb(1)
         i = se_orbital_pointer(iL)
         DO kL = 1, natorb(2)
            k = se_orbital_pointer(kL)
            kr = kr + 1
            tmp = w_l(kr)*factor
            a(1) = tmp*drp(1)
            a(2) = tmp*drp(2)
            a(3) = tmp*drp(3)
            ! Coulomb
            IF (.NOT. switch) THEN
               tmp = pj_tot(k, k)*pi_tot(i, i)
            ELSE
               tmp = pi_tot(k, k)*pj_tot(i, i)
            END IF
            force(1) = force(1) + a(1)*tmp
            force(2) = force(2) + a(2)*tmp
            force(3) = force(3) + a(3)*tmp
         END DO
      END DO

   END SUBROUTINE dfock2C_r3

! **************************************************************************************************
!> \brief  Coulomb interaction multipolar correction
!> \param atom_a ...
!> \param atom_b ...
!> \param my_task ...
!> \param do_forces ...
!> \param do_efield ...
!> \param do_stress ...
!> \param charges ...
!> \param dipoles ...
!> \param quadrupoles ...
!> \param force_ab ...
!> \param efield0 ...
!> \param efield1 ...
!> \param efield2 ...
!> \param rab2 ...
!> \param rab ...
!> \param integral_value ...
!> \param ptens11 ...
!> \param ptens12 ...
!> \param ptens13 ...
!> \param ptens21 ...
!> \param ptens22 ...
!> \param ptens23 ...
!> \param ptens31 ...
!> \param ptens32 ...
!> \param ptens33 ...
!> \date   05.2009 [tlaino]
!> \author Teodoro Laino [tlaino]
! **************************************************************************************************
   SUBROUTINE se_coulomb_ij_interaction(atom_a, atom_b, my_task, do_forces, do_efield, &
                                        do_stress, charges, dipoles, quadrupoles, force_ab, efield0, efield1, efield2, &
                                        rab2, rab, integral_value, ptens11, ptens12, ptens13, ptens21, ptens22, ptens23, &
                                        ptens31, ptens32, ptens33)
      INTEGER, INTENT(IN)                                :: atom_a, atom_b
      LOGICAL, DIMENSION(3)                              :: my_task
      LOGICAL, INTENT(IN)                                :: do_forces, do_efield, do_stress
      REAL(KIND=dp), DIMENSION(:), POINTER               :: charges
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: dipoles
      REAL(KIND=dp), DIMENSION(:, :, :), POINTER         :: quadrupoles
      REAL(KIND=dp), DIMENSION(3), INTENT(OUT)           :: force_ab
      REAL(KIND=dp), DIMENSION(:), POINTER               :: efield0
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: efield1, efield2
      REAL(KIND=dp), INTENT(IN)                          :: rab2
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: rab
      REAL(KIND=dp), INTENT(OUT), OPTIONAL               :: integral_value
      REAL(KIND=dp), INTENT(INOUT)                       :: ptens11, ptens12, ptens13, ptens21, &
                                                            ptens22, ptens23, ptens31, ptens32, &
                                                            ptens33

      INTEGER                                            :: a, b, c, d, e, i, j, k
      LOGICAL                                            :: do_efield0, do_efield1, do_efield2, &
                                                            force_eval
      LOGICAL, DIMENSION(3)                              :: do_task
      LOGICAL, DIMENSION(3, 3)                           :: task
      REAL(KIND=dp) :: ch_i, ch_j, ef0_i, ef0_j, eloc, energy, fac, fac_ij, ir, irab2, r, tij, &
                       tmp, tmp1, tmp11, tmp12, tmp13, tmp2, tmp21, tmp22, tmp23, tmp31, tmp32, tmp33, tmp_ij, &
                       tmp_ji
      REAL(KIND=dp), DIMENSION(0:5)                      :: f
      REAL(KIND=dp), DIMENSION(3)                        :: dp_i, dp_j, ef1_i, ef1_j, fr, tij_a
      REAL(KIND=dp), DIMENSION(3, 3)                     :: ef2_i, ef2_j, qp_i, qp_j, tij_ab
      REAL(KIND=dp), DIMENSION(3, 3, 3)                  :: tij_abc
      REAL(KIND=dp), DIMENSION(3, 3, 3, 3)               :: tij_abcd
      REAL(KIND=dp), DIMENSION(3, 3, 3, 3, 3)            :: tij_abcde

      do_task = my_task
      energy = 0.0_dp
      DO i = 1, 3
         IF (do_task(i)) THEN
            SELECT CASE (i)
            CASE (1)
               do_task(1) = (charges(atom_a) /= 0.0_dp) .OR. (charges(atom_b) /= 0.0_dp)
            CASE (2)
               do_task(2) = (ANY(dipoles(:, atom_a) /= 0.0_dp)) .OR. (ANY(dipoles(:, atom_b) /= 0.0_dp))
            CASE (3)
               do_task(3) = (ANY(quadrupoles(:, :, atom_a) /= 0.0_dp)) .OR. (ANY(quadrupoles(:, :, atom_b) /= 0.0_dp))
            END SELECT
         END IF
      END DO
      DO i = 1, 3
         DO j = i, 3
            task(j, i) = do_task(i) .AND. do_task(j)
            task(i, j) = task(j, i)
         END DO
      END DO
      do_efield0 = do_efield .AND. ASSOCIATED(efield0)
      do_efield1 = do_efield .AND. ASSOCIATED(efield1)
      do_efield2 = do_efield .AND. ASSOCIATED(efield2)

      fac_ij = 1.0_dp
      IF (atom_a == atom_b) fac_ij = 0.5_dp

      $: ewalds_multipole_sr_macro(mode="PURE_COULOMB")

      IF (PRESENT(integral_value)) THEN
         integral_value = eloc
      END IF
      IF (do_forces) THEN
         force_ab = fr
      END IF
   END SUBROUTINE se_coulomb_ij_interaction

END MODULE se_fock_matrix_integrals

