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

! **************************************************************************************************
!> \brief Integrals for semi-empiric methods
!> \par History
!>      JGH (27.10.2004) : separate routine for nuclear attraction integrals
!>      JGH (13.03.2006) : tapering function
!>      Teodoro Laino (03.2008) [tlaino] - University of Zurich : new driver
!>                 for computing integrals
!> \author JGH (11.10.2004)
! **************************************************************************************************
MODULE semi_empirical_int_num

   USE input_constants,                 ONLY: do_method_am1,&
                                              do_method_pchg,&
                                              do_method_pdg,&
                                              do_method_pm3,&
                                              do_method_pm6,&
                                              do_method_pm6fm,&
                                              do_method_undef,&
                                              do_se_IS_kdso_d
   USE kinds,                           ONLY: dp
   USE multipole_types,                 ONLY: do_multipole_none
   USE physcon,                         ONLY: angstrom,&
                                              evolt
   USE semi_empirical_int_arrays,       ONLY: &
        ijkl_ind, ijkl_sym, inddd, inddp, indexa, indexb, indpp, int2c_type, l_index, rij_threshold
   USE semi_empirical_int_utils,        ONLY: ijkl_d,&
                                              ijkl_sp,&
                                              rot_2el_2c_first,&
                                              rotmat,&
                                              store_2el_2c_diag
   USE semi_empirical_types,            ONLY: rotmat_create,&
                                              rotmat_release,&
                                              rotmat_type,&
                                              se_int_control_type,&
                                              se_int_screen_type,&
                                              se_taper_type,&
                                              semi_empirical_type,&
                                              setup_se_int_control_type
   USE taper_types,                     ONLY: taper_eval
#include "./base/base_uses.f90"

   IMPLICIT NONE

   PRIVATE
#include "semi_empirical_int_args.h"

   LOGICAL, PARAMETER, PRIVATE          :: debug_this_module = .FALSE.
   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'semi_empirical_int_num'
   PUBLIC :: rotint_num, rotnuc_num, corecore_num, &
             drotint_num, drotnuc_num, dcorecore_num, &
             ssss_nucint_num, core_nucint_num, terep_num, &
             nucint_sp_num, terep_sp_num, terep_d_num, &
             nucint_d_num, corecore_el_num, dcorecore_el_num

CONTAINS

! **************************************************************************************************
!> \brief Computes the two particle interactions in the lab frame
!> \param sepi Atomic parameters of first atom
!> \param sepj Atomic parameters of second atom
!> \param rijv Coordinate vector i -> j
!> \param w Array of two-electron repulsion integrals.
!> \param se_int_control input parameters that control the calculation of SE
!>                           integrals (shortrange, R3 residual, screening type)
!> \param se_taper ...
!> \note routine adapted from mopac7 (rotate)
!>       written by Ernest R. Davidson, Indiana University.
!>       Teodoro Laino [tlaino] - University of Zurich 04.2008 : major rewriting
! **************************************************************************************************
   SUBROUTINE rotint_num(sepi, sepj, rijv, w, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: rijv
      REAL(dp), DIMENSION(2025), INTENT(OUT)             :: w
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      INTEGER                                            :: i, i1, ii, ij, ij1, iminus, istep, &
                                                            iw_loc, j, j1, jj, k, kk, kl, l, &
                                                            limij, limkl, mm
      LOGICAL, DIMENSION(45, 45)                         :: logv
      REAL(dp)                                           :: rij
      REAL(KIND=dp)                                      :: cc, wrepp
      REAL(KIND=dp), DIMENSION(2025)                     :: ww
      REAL(KIND=dp), DIMENSION(45, 45)                   :: v
      REAL(KIND=dp), DIMENSION(491)                      :: rep
      TYPE(rotmat_type), POINTER                         :: ij_matrix

      NULLIFY (ij_matrix)
      rij = DOT_PRODUCT(rijv, rijv)
      IF (rij > rij_threshold) THEN
         ! The repulsion integrals over molecular frame (w) are stored in the
         ! order in which they will later be used.  ie.  (i,j/k,l) where
         ! j.le.i  and  l.le.k     and l varies most rapidly and i least
         ! rapidly.  (anti-normal computer storage)
         rij = SQRT(rij)

         ! Create the rotation matrix
         CALL rotmat_create(ij_matrix)
         CALL rotmat(sepi, sepj, rijv, rij, ij_matrix, do_derivatives=.FALSE.)

         ! Compute Integrals in Diatomic Frame
         CALL terep_num(sepi, sepj, rij, rep, se_taper=se_taper, se_int_control=se_int_control)

         ! Rotate Integrals
         ii = sepi%natorb
         kk = sepj%natorb
         IF (ii*kk > 0) THEN
            limij = sepi%atm_int_size
            limkl = sepj%atm_int_size
            istep = limkl*limij
            DO i1 = 1, istep
               ww(i1) = 0.0_dp
            END DO

            ! First step in rotation of integrals
            CALL rot_2el_2c_first(sepi, sepj, rijv, se_int_control, se_taper, .FALSE., ii, kk, rep, &
                                  logv, ij_matrix, v, lgrad=.FALSE.)

            ! Second step in rotation of integrals
            DO i1 = 1, ii
               DO j1 = 1, i1
                  ij = indexa(i1, j1)
                  jj = indexb(i1, j1)
                  mm = int2c_type(jj)
                  DO k = 1, kk
                     DO l = 1, k
                        kl = indexb(k, l)
                        IF (logv(ij, kl)) THEN
                           wrepp = v(ij, kl)
                           SELECT CASE (mm)
                           CASE (1)
                              ! (SS/)
                              i = 1
                              j = 1
                              iw_loc = (indexb(i, j)-1)*limkl+kl
                              ww(iw_loc) = wrepp
                           CASE (2)
                              ! (SP/)
                              j = 1
                              DO i = 1, 3
                                 iw_loc = (indexb(i+1, j)-1)*limkl+kl
                                 ww(iw_loc) = ww(iw_loc)+ij_matrix%sp(i1-1, i)*wrepp
                              END DO
                           CASE (3)
                              ! (PP/)
                              DO i = 1, 3
                                 cc = ij_matrix%pp(i, i1-1, j1-1)
                                 iw_loc = (indexb(i+1, i+1)-1)*limkl+kl
                                 ww(iw_loc) = ww(iw_loc)+cc*wrepp
                                 iminus = i-1
                                 IF (iminus /= 0) THEN
                                    DO j = 1, iminus
                                       cc = ij_matrix%pp(1+i+j, i1-1, j1-1)
                                       iw_loc = (indexb(i+1, j+1)-1)*limkl+kl
                                       ww(iw_loc) = ww(iw_loc)+cc*wrepp
                                    END DO
                                 END IF
                              END DO
                           CASE (4)
                              ! (SD/)
                              j = 1
                              DO i = 1, 5
                                 iw_loc = (indexb(i+4, j)-1)*limkl+kl
                                 ww(iw_loc) = ww(iw_loc)+ij_matrix%sd(i1-4, i)*wrepp
                              END DO
                           CASE (5)
                              ! (DP/)
                              DO i = 1, 5
                                 DO j = 1, 3
                                    iw_loc = (indexb(i+4, j+1)-1)*limkl+kl
                                    ij1 = 3*(i-1)+j
                                    ww(iw_loc) = ww(iw_loc)+ij_matrix%pd(ij1, i1-4, j1-1)*wrepp
                                 END DO
                              END DO
                           CASE (6)
                              ! (DD/)
                              DO i = 1, 5
                                 cc = ij_matrix%dd(i, i1-4, j1-4)
                                 iw_loc = (indexb(i+4, i+4)-1)*limkl+kl
                                 ww(iw_loc) = ww(iw_loc)+cc*wrepp
                                 iminus = i-1
                                 IF (iminus /= 0) THEN
                                    DO j = 1, iminus
                                       ij1 = inddd(i, j)
                                       cc = ij_matrix%dd(ij1, i1-4, j1-4)
                                       iw_loc = (indexb(i+4, j+4)-1)*limkl+kl
                                       ww(iw_loc) = ww(iw_loc)+cc*wrepp
                                    END DO
                                 END IF
                              END DO
                           END SELECT
                        END IF
                     END DO
                  END DO
               END DO
            END DO
         END IF
         CALL rotmat_release(ij_matrix)

         ! Store two electron integrals in the triangular format
         CALL store_2el_2c_diag(limij, limkl, ww, w)
      ENDIF
   END SUBROUTINE rotint_num

! **************************************************************************************************
!> \brief Calculates the derivative pf two-electron repulsion integrals and the
!>      nuclear attraction integrals w.r.t. |r|
!> \param sepi paramters of atom i
!> \param sepj paramters of atom j
!> \param rij interatomic distance
!> \param rep array of two-electron repulsion integrals
!> \param se_taper ...
!> \param se_int_control input parameters that control the calculation of SE
!>                         integrals (shortrange, R3 residual, screening type)
!> \par History
!>      03.2008 created [tlaino]
!> \author Teodoro Laino [tlaino] - Zurich University
! **************************************************************************************************
   SUBROUTINE terep_num(sepi, sepj, rij, rep, se_taper, se_int_control)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), INTENT(IN)                               :: rij
      REAL(dp), DIMENSION(491), INTENT(OUT)              :: rep
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control

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

      REAL(KIND=dp)                                      :: ft
      TYPE(se_int_screen_type)                           :: se_int_screen

      ft = taper_eval(se_taper%taper, rij)
      ! In case of dumped integrals compute an additional taper term
      IF (se_int_control%integral_screening == do_se_IS_kdso_d) THEN
         se_int_screen%ft = taper_eval(se_taper%taper_add, rij)
      END IF

      ! Contribution from sp shells
      CALL terep_sp_num(sepi, sepj, rij, rep, se_int_control, se_int_screen, ft)

      IF (sepi%dorb .OR. sepj%dorb) THEN
         ! Compute the contribution from d shells
         CALL terep_d_num(sepi, sepj, rij, rep, se_int_control, se_int_screen, &
                          ft)
      END IF

   END SUBROUTINE terep_num

! **************************************************************************************************
!> \brief Calculates the  two-electron repulsion integrals - sp shell only
!> \param sepi paramters of atom i
!> \param sepj paramters of atom j
!> \param rij ...
!> \param rep array of two-electron repulsion integrals
!> \param se_int_control input parameters that control the calculation of SE
!>                         integrals (shortrange, R3 residual, screening type)
!> \param se_int_screen contains information for computing the screened
!>                         integrals KDSO-D
!> \param ft ...
!> \par History
!>      Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver
!>                 for computing integrals
! **************************************************************************************************
   SUBROUTINE terep_sp_num(sepi, sepj, rij, rep, se_int_control, se_int_screen, &
                           ft)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), INTENT(IN)                               :: rij
      REAL(dp), DIMENSION(491), INTENT(OUT)              :: rep
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_int_screen_type), INTENT(IN)               :: se_int_screen
      REAL(dp), INTENT(IN)                               :: ft

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

      INTEGER                                            :: i, ij, j, k, kl, l, lasti, lastj, li, &
                                                            lj, lk, ll, nold, numb
      REAL(KIND=dp)                                      :: tmp

      lasti = sepi%natorb
      lastj = sepj%natorb
      DO i = 1, MIN(lasti, 4)
         li = l_index(i)
         DO j = 1, i
            lj = l_index(j)
            ij = indexa(i, j)
            DO k = 1, MIN(lastj, 4)
               lk = l_index(k)
               DO l = 1, k
                  ll = l_index(l)
                  kl = indexa(k, l)

                  numb = ijkl_ind(ij, kl)
                  IF (numb > 0) THEN
                     nold = ijkl_sym(numb)
                     IF (nold > 0) THEN
                        rep(numb) = rep(nold)
                     ELSE IF (nold < 0) THEN
                        rep(numb) = -rep(-nold)
                     ELSE IF (nold == 0) THEN
                        tmp = ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, 0, rij, &
                                      se_int_control, se_int_screen, do_method_undef) &
                              *ft
                        rep(numb) = tmp
                     END IF
                  END IF
               END DO
            END DO
         END DO
      END DO
   END SUBROUTINE terep_sp_num

! **************************************************************************************************
!> \brief Calculates the  two-electron repulsion integrals - d shell only
!> \param sepi ...
!> \param sepj ...
!> \param rij interatomic distance
!> \param rep array of two-electron repulsion integrals
!> \param se_int_control input parameters that control the calculation of SE
!>                         integrals (shortrange, R3 residual, screening type)
!> \param se_int_screen contains information for computing the screened
!>                         integrals KDSO-D
!> \param ft ...
!> \par History
!>      Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver
!>                 for computing integrals
! **************************************************************************************************
   SUBROUTINE terep_d_num(sepi, sepj, rij, rep, se_int_control, se_int_screen, &
                          ft)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), INTENT(IN)                               :: rij
      REAL(dp), DIMENSION(491), INTENT(INOUT)            :: rep
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_int_screen_type), INTENT(IN)               :: se_int_screen
      REAL(dp), INTENT(IN)                               :: ft

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

      INTEGER                                            :: i, ij, j, k, kl, l, lasti, lastj, li, &
                                                            lj, lk, ll, nold, numb
      REAL(KIND=dp)                                      :: tmp

      lasti = sepi%natorb
      lastj = sepj%natorb
      DO i = 1, lasti
         li = l_index(i)
         DO j = 1, i
            lj = l_index(j)
            ij = indexa(i, j)
            DO k = 1, lastj
               lk = l_index(k)
               DO l = 1, k
                  ll = l_index(l)
                  kl = indexa(k, l)

                  numb = ijkl_ind(ij, kl)
                  ! From 1 to 34 we store integrals involving sp shells
                  IF (numb > 34) THEN
                     nold = ijkl_sym(numb)
                     IF (nold > 34) THEN
                        rep(numb) = rep(nold)
                     ELSE IF (nold < -34) THEN
                        rep(numb) = -rep(-nold)
                     ELSE IF (nold == 0) THEN
                        tmp = ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, 0, rij, &
                                     se_int_control, se_int_screen, do_method_undef) &
                              *ft
                        rep(numb) = tmp
                     END IF
                  END IF
               END DO
            END DO
         END DO
      END DO

   END SUBROUTINE terep_d_num

! **************************************************************************************************
!> \brief Computes the two-particle interactions.
!> \param sepi Atomic parameters of first atom
!> \param sepj Atomic parameters of second atom
!> \param rijv Coordinate vector i -> j
!> \param e1b Array of electron-nuclear attraction integrals,
!>                       e1b = Electron on atom ni attracting nucleus of nj.
!> \param e2a Array of electron-nuclear attraction integrals,
!>                       e2a = Electron on atom nj attracting nucleus of ni.
!> \param itype ...
!> \param se_int_control ...
!> \param se_taper ...
!> \note routine adapted from mopac7 (rotate)
!>       written by Ernest R. Davidson, Indiana University.
!>       Teodoro Laino [tlaino] - University of Zurich 04.2008 : major rewriting
!>       Teodoro Laino [tlaino] - University of Zurich 04.2008 : removed the core-core part
! **************************************************************************************************
   SUBROUTINE rotnuc_num(sepi, sepj, rijv, e1b, e2a, itype, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: rijv
      REAL(dp), DIMENSION(45), INTENT(OUT), OPTIONAL     :: e1b, e2a
      INTEGER, INTENT(IN)                                :: itype
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      INTEGER                                            :: i, idd, idp, ind1, ind2, ipp, j, &
                                                            last_orbital(2), m, n
      LOGICAL                                            :: l_e1b, l_e2a, task(2)
      REAL(dp)                                           :: rij
      REAL(dp), DIMENSION(10, 2)                         :: core
      REAL(dp), DIMENSION(45)                            :: tmp
      TYPE(rotmat_type), POINTER                         :: ij_matrix

      NULLIFY (ij_matrix)
      l_e1b = PRESENT(e1b)
      l_e2a = PRESENT(e2a)
      rij = DOT_PRODUCT(rijv, rijv)

      IF (rij > rij_threshold) THEN
         rij = SQRT(rij)
         ! Create the rotation matrix
         CALL rotmat_create(ij_matrix)
         CALL rotmat(sepi, sepj, rijv, rij, ij_matrix, do_derivatives=.FALSE.)

         ! Compute Integrals in Diatomic Frame
         CALL core_nucint_num(sepi, sepj, rij, core=core, itype=itype, se_taper=se_taper, &
                              se_int_control=se_int_control)

         ! Copy parameters over to arrays for do loop.
         last_orbital(1) = sepi%natorb
         last_orbital(2) = sepj%natorb
         task(1) = l_e1b
         task(2) = l_e2a
         DO n = 1, 2
            IF (.NOT. task(n)) CYCLE
            DO i = 1, last_orbital(n)
               ind1 = i-1
               DO j = 1, i
                  ind2 = j-1
                  m = (i*(i-1))/2+j
                  ! Perform Rotations ...
                  IF (ind2 == 0) THEN
                     IF (ind1 == 0) THEN
                        ! Type of Integral (SS/)
                        tmp(m) = core(1, n)
                     ELSE IF (ind1 < 4) THEN
                        ! Type of Integral (SP/)
                        tmp(m) = ij_matrix%sp(1, ind1)*core(2, n)
                     ELSE
                        ! Type of Integral (SD/)
                        tmp(m) = ij_matrix%sd(1, ind1-3)*core(5, n)
                     END IF
                  ELSE IF (ind2 < 4) THEN
                     IF (ind1 < 4) THEN
                        ! Type of Integral (PP/)
                        ipp = indpp(ind1, ind2)
                        tmp(m) = core(3, n)*ij_matrix%pp(ipp, 1, 1)+ &
                                 core(4, n)*(ij_matrix%pp(ipp, 2, 2)+ij_matrix%pp(ipp, 3, 3))
                     ELSE
                        ! Type of Integral (PD/)
                        idp = inddp(ind1-3, ind2)
                        tmp(m) = core(6, n)*ij_matrix%pd(idp, 1, 1)+ &
                                 core(8, n)*(ij_matrix%pd(idp, 2, 2)+ij_matrix%pd(idp, 3, 3))
                     END IF
                  ELSE
                     ! Type of Integral (DD/)
                     idd = inddd(ind1-3, ind2-3)
                     tmp(m) = core(7, n)*ij_matrix%dd(idd, 1, 1)+ &
                              core(9, n)*(ij_matrix%dd(idd, 2, 2)+ij_matrix%dd(idd, 3, 3))+ &
                              core(10, n)*(ij_matrix%dd(idd, 4, 4)+ij_matrix%dd(idd, 5, 5))
                  END IF
               END DO
            END DO
            IF (n == 1) THEN
               DO i = 1, sepi%atm_int_size
                  e1b(i) = -tmp(i)
               END DO
            END IF
            IF (n == 2) THEN
               DO i = 1, sepj%atm_int_size
                  e2a(i) = -tmp(i)
               END DO
            END IF
         END DO
         CALL rotmat_release(ij_matrix)
      END IF
   END SUBROUTINE rotnuc_num

! **************************************************************************************************
!> \brief Computes the core-core interactions.
!> \param sepi Atomic parameters of first atom
!> \param sepj Atomic parameters of second atom
!> \param rijv Coordinate vector i -> j
!> \param enuc nuclear-nuclear repulsion term.
!> \param itype ...
!> \param se_int_control input parameters that control the calculation of SE
!>                           integrals (shortrange, R3 residual, screening type)
!> \param se_taper ...
!> \note routine adapted from mopac7 (rotate)
!>       written by Ernest R. Davidson, Indiana University.
!>       Teodoro Laino [tlaino] - University of Zurich 04.2008 : major rewriting
!>       Teodoro Laino [tlaino] - University of Zurich 04.2008 : splitted from rotnuc
! **************************************************************************************************
   SUBROUTINE corecore_num(sepi, sepj, rijv, enuc, itype, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: rijv
      REAL(dp), INTENT(OUT)                              :: enuc
      INTEGER, INTENT(IN)                                :: itype
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      INTEGER                                            :: ig, nt
      REAL(dp)                                           :: aab, alpi, alpj, apdg, ax, dai, daj, &
                                                            dbi, dbj, pai, paj, pbi, pbj, qcorr, &
                                                            rij, rija, scale, ssss, ssss_sr, tmp, &
                                                            xab, zaf, zbf, zz
      REAL(dp), DIMENSION(4)                             :: fni1, fni2, fni3, fnj1, fnj2, fnj3
      TYPE(se_int_control_type)                          :: se_int_control_off

      rij = DOT_PRODUCT(rijv, rijv)
      enuc = 0.0_dp
      IF (rij > rij_threshold) THEN
         rij = SQRT(rij)
         CALL setup_se_int_control_type(se_int_control_off, shortrange=.FALSE., do_ewald_r3=.FALSE., &
                                        do_ewald_gks=.FALSE., integral_screening=se_int_control%integral_screening, &
                                        max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.)
         CALL ssss_nucint_num(sepi, sepj, rij, ssss=ssss, itype=itype, se_taper=se_taper, &
                              se_int_control=se_int_control_off)
         ! In case let's compute the short-range part of the (ss|ss) integral
         IF (se_int_control%shortrange) THEN
            CALL ssss_nucint_num(sepi, sepj, rij, ssss=ssss_sr, itype=itype, se_taper=se_taper, &
                                 se_int_control=se_int_control)
         ELSE
            ssss_sr = ssss
         END IF
         zz = sepi%zeff*sepj%zeff
         ! Nuclear-Nuclear electrostatic contribution
         enuc = zz*ssss_sr
         ! Method dependent correction terms
         IF (itype /= do_method_pm6 .AND. itype /= do_method_pm6fm) THEN
            alpi = sepi%alp
            alpj = sepj%alp
            scale = EXP(-alpi*rij)+EXP(-alpj*rij)

            nt = sepi%z+sepj%z
            IF (nt == 8 .OR. nt == 9) THEN
               IF (sepi%z == 7 .OR. sepi%z == 8) scale = scale+(angstrom*rij-1._dp)*EXP(-alpi*rij)
               IF (sepj%z == 7 .OR. sepj%z == 8) scale = scale+(angstrom*rij-1._dp)*EXP(-alpj*rij)
            ENDIF
            scale = ABS(scale*zz*ssss)
            zz = zz/rij
            IF (itype == do_method_am1 .OR. itype == do_method_pm3 .OR. itype == do_method_pdg) THEN
               IF (itype == do_method_am1 .AND. sepi%z == 5) THEN
                  !special case AM1 Boron
                  SELECT CASE (sepj%z)
                  CASE DEFAULT
                     nt = 1
                  CASE (1)
                     nt = 2
                  CASE (6)
                     nt = 3
                  CASE (9, 17, 35, 53)
                     nt = 4
                  END SELECT
                  fni1(:) = sepi%bfn1(:, nt)
                  fni2(:) = sepi%bfn2(:, nt)
                  fni3(:) = sepi%bfn3(:, nt)
               ELSE
                  fni1(:) = sepi%fn1(:)
                  fni2(:) = sepi%fn2(:)
                  fni3(:) = sepi%fn3(:)
               END IF
               IF (itype == do_method_am1 .AND. sepj%z == 5) THEN
                  !special case AM1 Boron
                  SELECT CASE (sepi%z)
                  CASE DEFAULT
                     nt = 1
                  CASE (1)
                     nt = 2
                  CASE (6)
                     nt = 3
                  CASE (9, 17, 35, 53)
                     nt = 4
                  END SELECT
                  fnj1(:) = sepj%bfn1(:, nt)
                  fnj2(:) = sepj%bfn2(:, nt)
                  fnj3(:) = sepj%bfn3(:, nt)
               ELSE
                  fnj1(:) = sepj%fn1(:)
                  fnj2(:) = sepj%fn2(:)
                  fnj3(:) = sepj%fn3(:)
               END IF
               ! AM1/PM3/PDG correction to nuclear repulsion
               DO ig = 1, SIZE(fni1)
                  IF (ABS(fni1(ig)) > 0._dp) THEN
                     ax = fni2(ig)*(rij-fni3(ig))**2
                     IF (ax <= 25._dp) THEN
                        scale = scale+zz*fni1(ig)*EXP(-ax)
                     ENDIF
                  ENDIF
                  IF (ABS(fnj1(ig)) > 0._dp) THEN
                     ax = fnj2(ig)*(rij-fnj3(ig))**2
                     IF (ax <= 25._dp) THEN
                        scale = scale+zz*fnj1(ig)*EXP(-ax)
                     ENDIF
                  ENDIF
               END DO
            ENDIF
            IF (itype == do_method_pdg) THEN
               ! PDDG function
               zaf = sepi%zeff/nt
               zbf = sepj%zeff/nt
               pai = sepi%pre(1)
               pbi = sepi%pre(2)
               paj = sepj%pre(1)
               pbj = sepj%pre(2)
               dai = sepi%d(1)
               dbi = sepi%d(2)
               daj = sepj%d(1)
               dbj = sepj%d(2)
               apdg = 10._dp*angstrom**2
               qcorr = &
                  (zaf*pai+zbf*paj)*EXP(-apdg*(rij-dai-daj)**2)+ &
                  (zaf*pai+zbf*pbj)*EXP(-apdg*(rij-dai-dbj)**2)+ &
                  (zaf*pbi+zbf*paj)*EXP(-apdg*(rij-dbi-daj)**2)+ &
                  (zaf*pbi+zbf*pbj)*EXP(-apdg*(rij-dbi-dbj)**2)
            ELSEIF (itype == do_method_pchg) THEN
               qcorr = 0.0_dp
               scale = 0.0_dp
            ELSE
               qcorr = 0.0_dp
            END IF
         ELSE
            rija = rij*angstrom
            scale = zz*ssss
            ! PM6 core-core terms
            xab = sepi%xab(sepj%z)
            aab = sepi%aab(sepj%z)
            IF ((sepi%z == 1 .AND. (sepj%z == 6 .OR. sepj%z == 7 .OR. sepj%z == 8)) .OR. &
                (sepj%z == 1 .AND. (sepi%z == 6 .OR. sepi%z == 7 .OR. sepi%z == 8))) THEN
               ! Special Case O-H or N-H or C-H
               scale = scale*(2._dp*xab*EXP(-aab*rija*rija))
            ELSEIF (sepi%z == 6 .AND. sepj%z == 6) THEN
               ! Special Case C-C
               scale = scale*(2._dp*xab*EXP(-aab*(rija+0.0003_dp*rija**6))+9.28_dp*EXP(-5.98_dp*rija))
            ELSEIF ((sepi%z == 8 .AND. sepj%z == 14) .OR. &
                    (sepj%z == 8 .AND. sepi%z == 14)) THEN
               ! Special Case Si-O
               scale = scale*(2._dp*xab*EXP(-aab*(rija+0.0003_dp*rija**6))-0.0007_dp*EXP(-(rija-2.9_dp)**2))
            ELSE
               ! General Case
               ! Factor of 2 found by experiment
               scale = scale*(2._dp*xab*EXP(-aab*(rija+0.0003_dp*rija**6)))
            END IF
            ! General correction term a*exp(-b*(rij-c)^2)
            qcorr = (sepi%a*EXP(-sepi%b*(rij-sepi%c)**2))*sepi%zeff*sepj%zeff/rij+ &
                    (sepj%a*EXP(-sepj%b*(rij-sepj%c)**2))*sepi%zeff*sepj%zeff/rij
            ! Hard core repulsion
            tmp = (REAL(sepi%z, dp)**(1._dp/3._dp)+REAL(sepj%z, dp)**(1._dp/3._dp))
            qcorr = qcorr+1.e-8_dp/evolt*(tmp/rija)**12
         END IF
         enuc = enuc+scale+qcorr
      END IF
   END SUBROUTINE corecore_num

! **************************************************************************************************
!> \brief Computes the electrostatic core-core interactions only.
!> \param sepi Atomic parameters of first atom
!> \param sepj Atomic parameters of second atom
!> \param rijv Coordinate vector i -> j
!> \param enuc nuclear-nuclear repulsion term.
!> \param itype ...
!> \param se_int_control input parameters that control the calculation of SE
!>                           integrals (shortrange, R3 residual, screening type)
!> \param se_taper ...
!> \author Teodoro Laino [tlaino] - 05.2009
! **************************************************************************************************
   SUBROUTINE corecore_el_num(sepi, sepj, rijv, enuc, itype, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: rijv
      REAL(dp), INTENT(OUT)                              :: enuc
      INTEGER, INTENT(IN)                                :: itype
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      REAL(dp)                                           :: rij, ssss, ssss_sr, zz
      TYPE(se_int_control_type)                          :: se_int_control_off

      rij = DOT_PRODUCT(rijv, rijv)
      enuc = 0.0_dp
      IF (rij > rij_threshold) THEN
         rij = SQRT(rij)
         CALL setup_se_int_control_type(se_int_control_off, shortrange=.FALSE., do_ewald_r3=.FALSE., &
                                        do_ewald_gks=.FALSE., integral_screening=se_int_control%integral_screening, &
                                        max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.)
         CALL ssss_nucint_num(sepi, sepj, rij, ssss=ssss, itype=itype, se_taper=se_taper, &
                              se_int_control=se_int_control_off)
         ! In case let's compute the short-range part of the (ss|ss) integral
         IF (se_int_control%shortrange .OR. se_int_control%pc_coulomb_int) THEN
            CALL ssss_nucint_num(sepi, sepj, rij, ssss=ssss_sr, itype=itype, se_taper=se_taper, &
                                 se_int_control=se_int_control)
         ELSE
            ssss_sr = ssss
         END IF
         zz = sepi%zeff*sepj%zeff
         ! Nuclear-Nuclear electrostatic contribution
         enuc = zz*ssss_sr
      END IF
   END SUBROUTINE corecore_el_num

! **************************************************************************************************
!> \brief Calculates the SSSS integrals (main driver)
!> \param sepi paramters of atom i
!> \param sepj paramters of atom j
!> \param rij interatomic distance
!> \param ssss derivative of (ssss) integral
!>                          derivatives are intended w.r.t. rij
!> \param itype type of semi_empirical model
!>                          extension to the original routine to compute qm/mm integrals
!> \param se_taper ...
!> \param se_int_control input parameters that control the calculation of SE
!>                          integrals (shortrange, R3 residual, screening type)
!> \par History
!>      03.2008 created [tlaino]
!> \author Teodoro Laino - Zurich University
! **************************************************************************************************
   SUBROUTINE ssss_nucint_num(sepi, sepj, rij, ssss, itype, se_taper, se_int_control)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), INTENT(IN)                               :: rij
      REAL(dp), INTENT(OUT)                              :: ssss
      INTEGER, INTENT(IN)                                :: itype
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control

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

      REAL(KIND=dp)                                      :: ft
      TYPE(se_int_screen_type)                           :: se_int_screen

! Computing Tapering function

      ft = 1.0_dp
      IF (itype /= do_method_pchg) THEN
         ft = taper_eval(se_taper%taper, rij)
      END IF

      ! In case of dumped integrals compute an additional taper term
      IF (se_int_control%integral_screening == do_se_IS_kdso_d) THEN
         se_int_screen%ft = 1.0_dp
         IF (itype /= do_method_pchg) THEN
            se_int_screen%ft = taper_eval(se_taper%taper_add, rij)
         END IF
      END IF

      ! Contribution from the sp shells
      CALL nucint_sp_num(sepi, sepj, rij, ssss=ssss, itype=itype, &
                         se_int_control=se_int_control, se_int_screen=se_int_screen)

      ! Tapering the integrals
      ssss = ft*ssss

   END SUBROUTINE ssss_nucint_num

! **************************************************************************************************
!> \brief Calculates the nuclear attraction integrals CORE (main driver)
!> \param sepi paramters of atom i
!> \param sepj paramters of atom j
!> \param rij interatomic distance
!> \param core derivative of 4 X 2 array of electron-core attraction integrals
!>                          derivatives are intended w.r.t. rij
!> \param itype type of semi_empirical model
!>                          extension to the original routine to compute qm/mm integrals
!> \param se_taper ...
!> \param se_int_control input parameters that control the calculation of SE
!>                          integrals (shortrange, R3 residual, screening type)
!> \par History
!>      03.2008 created [tlaino]
!> \author Teodoro Laino - Zurich University
! **************************************************************************************************
   SUBROUTINE core_nucint_num(sepi, sepj, rij, core, itype, se_taper, se_int_control)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), INTENT(IN)                               :: rij
      REAL(dp), DIMENSION(10, 2), INTENT(OUT)            :: core
      INTEGER, INTENT(IN)                                :: itype
      TYPE(se_taper_type), POINTER                       :: se_taper
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control

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

      INTEGER                                            :: i
      REAL(KIND=dp)                                      :: ft
      TYPE(se_int_screen_type)                           :: se_int_screen

! Computing the Tapering function

      ft = 1.0_dp
      IF (itype /= do_method_pchg) THEN
         ft = taper_eval(se_taper%taper, rij)
      END IF

      ! In case of dumped integrals compute an additional taper term
      IF (se_int_control%integral_screening == do_se_IS_kdso_d) THEN
         se_int_screen%ft = 1.0_dp
         IF (itype /= do_method_pchg) THEN
            se_int_screen%ft = taper_eval(se_taper%taper_add, rij)
         END IF
      END IF

      ! Contribution from the sp shells
      CALL nucint_sp_num(sepi, sepj, rij, core=core, itype=itype, &
                         se_int_control=se_int_control, se_int_screen=se_int_screen)

      IF (sepi%dorb .OR. sepj%dorb) THEN
         ! Compute the contribution from d shells
         CALL nucint_d_num(sepi, sepj, rij, core, itype, se_int_control, &
                           se_int_screen)
      END IF

      ! Tapering the integrals
      DO i = 1, sepi%core_size
         core(i, 1) = ft*core(i, 1)
      END DO
      DO i = 1, sepj%core_size
         core(i, 2) = ft*core(i, 2)
      END DO

   END SUBROUTINE core_nucint_num

! **************************************************************************************************
!> \brief ...
!> \param sepi ...
!> \param sepj ...
!> \param rij ...
!> \param ssss ...
!> \param core ...
!> \param itype ...
!> \param se_int_control ...
!> \param se_int_screen ...
!> \par History
!>      Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver
!>                    for computing integrals
!>      Teodoro Laino (04.2008) [tlaino] - Totally rewritten: nothing to do with
!>                    the old version
! **************************************************************************************************

   SUBROUTINE nucint_sp_num(sepi, sepj, rij, ssss, core, itype, se_int_control, &
                            se_int_screen)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), INTENT(IN)                               :: rij
      REAL(dp), INTENT(INOUT), OPTIONAL                  :: ssss
      REAL(dp), DIMENSION(10, 2), INTENT(INOUT), &
         OPTIONAL                                        :: core
      INTEGER, INTENT(IN)                                :: itype
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_int_screen_type), INTENT(IN)               :: se_int_screen

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

      INTEGER                                            :: ij, kl
      LOGICAL                                            :: l_core, l_ssss, si, sj

      l_core = PRESENT(core)
      l_ssss = PRESENT(ssss)
      IF (.NOT. (l_core .OR. l_ssss)) RETURN
      si = (sepi%natorb > 1)
      sj = (sepj%natorb > 1)

      ij = indexa(1, 1)
      IF (l_ssss) THEN
         ! Store the value for <S  S  | S  S  > (Used for computing the core-core interactions)
         ssss = ijkl_sp(sepi, sepj, ij, ij, 0, 0, 0, 0, -1, rij, CPPint_args)
      END IF

      IF (l_core) THEN
         !     <S  S  | S  S  >
         kl = indexa(1, 1)
         core(1, 1) = ijkl_sp(sepi, sepj, kl, ij, 0, 0, 0, 0, 2, rij, CPPint_args)*sepj%zeff
         IF (si) THEN
            !  <S  P  | S  S  >
            kl = indexa(2, 1)
            core(2, 1) = ijkl_sp(sepi, sepj, kl, ij, 0, 1, 0, 0, 2, rij, CPPint_args)*sepj%zeff
            !  <P  P  | S  S  >
            kl = indexa(2, 2)
            core(3, 1) = ijkl_sp(sepi, sepj, kl, ij, 1, 1, 0, 0, 2, rij, CPPint_args)*sepj%zeff
            !  <P+ P+ | S  S  >
            kl = indexa(3, 3)
            core(4, 1) = ijkl_sp(sepi, sepj, kl, ij, 1, 1, 0, 0, 2, rij, CPPint_args)*sepj%zeff
         END IF

         !     <S  S  | S  S  >
         kl = indexa(1, 1)
         core(1, 2) = ijkl_sp(sepi, sepj, ij, kl, 0, 0, 0, 0, 1, rij, CPPint_args)*sepi%zeff
         IF (sj) THEN
            !  <S  S  | S  P  >
            kl = indexa(2, 1)
            core(2, 2) = ijkl_sp(sepi, sepj, ij, kl, 0, 0, 0, 1, 1, rij, CPPint_args)*sepi%zeff
            !  <S  S  | P  P  >
            kl = indexa(2, 2)
            core(3, 2) = ijkl_sp(sepi, sepj, ij, kl, 0, 0, 1, 1, 1, rij, CPPint_args)*sepi%zeff
            !  <S  S  | P+ P+ >
            kl = indexa(3, 3)
            core(4, 2) = ijkl_sp(sepi, sepj, ij, kl, 0, 0, 1, 1, 1, rij, CPPint_args)*sepi%zeff
         END IF
      END IF

   END SUBROUTINE nucint_sp_num

! **************************************************************************************************
!> \brief Calculates the nuclear attraction integrals involving d orbitals
!> \param sepi paramters of atom i
!> \param sepj paramters of atom j
!> \param rij interatomic distance
!> \param core 4 X 2 array of electron-core attraction integrals
!>
!>         The storage of the nuclear attraction integrals  core(kl/ij) iS
!>         (SS/)=1,   (SP/)=2,   (PP/)=3,   (P+P+/)=4,   (SD/)=5,
!>         (DP/)=6,   (DD/)=7,   (D+P+)=8,  (D+D+/)=9,   (D#D#)=10
!>
!>         where ij=1 if the orbitals centred on atom i,  =2 if on atom j.
!> \param itype type of semi_empirical model
!>                         extension to the original routine to compute qm/mm integrals
!> \param se_int_control input parameters that control the calculation of SE
!>                         integrals (shortrange, R3 residual, screening type)
!> \param se_int_screen contains information for computing the screened
!>                         integrals KDSO-D
!> \author
!>      Teodoro Laino (03.2008) [tlaino] - University of Zurich
! **************************************************************************************************
   SUBROUTINE nucint_d_num(sepi, sepj, rij, core, itype, se_int_control, &
                           se_int_screen)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), INTENT(IN)                               :: rij
      REAL(dp), DIMENSION(10, 2), INTENT(INOUT)          :: core
      INTEGER, INTENT(IN)                                :: itype
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_int_screen_type), INTENT(IN)               :: se_int_screen

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

      INTEGER                                            :: ij, kl

! Check if d-orbitals are present

      IF (sepi%dorb .OR. sepj%dorb) THEN
         ij = indexa(1, 1)
         IF (sepj%dorb) THEN
            !  <S S | D S>
            kl = indexa(5, 1)
            core(5, 2) = ijkl_d(sepi, sepj, ij, kl, 0, 0, 2, 0, 1, rij, CPPint_args)*sepi%zeff
            !  <S S | D P >
            kl = indexa(5, 2)
            core(6, 2) = ijkl_d(sepi, sepj, ij, kl, 0, 0, 2, 1, 1, rij, CPPint_args)*sepi%zeff
            !  <S S | D D >
            kl = indexa(5, 5)
            core(7, 2) = ijkl_d(sepi, sepj, ij, kl, 0, 0, 2, 2, 1, rij, CPPint_args)*sepi%zeff
            !  <S S | D+P+>
            kl = indexa(6, 3)
            core(8, 2) = ijkl_d(sepi, sepj, ij, kl, 0, 0, 2, 1, 1, rij, CPPint_args)*sepi%zeff
            !  <S S | D+D+>
            kl = indexa(6, 6)
            core(9, 2) = ijkl_d(sepi, sepj, ij, kl, 0, 0, 2, 2, 1, rij, CPPint_args)*sepi%zeff
            !  <S S | D#D#>
            kl = indexa(8, 8)
            core(10, 2) = ijkl_d(sepi, sepj, ij, kl, 0, 0, 2, 2, 1, rij, CPPint_args)*sepi%zeff
         END IF
         IF (sepi%dorb) THEN
            !  <D S | S S>
            kl = indexa(5, 1)
            core(5, 1) = ijkl_d(sepi, sepj, kl, ij, 2, 0, 0, 0, 2, rij, CPPint_args)*sepj%zeff
            !  <D P | S S >
            kl = indexa(5, 2)
            core(6, 1) = ijkl_d(sepi, sepj, kl, ij, 2, 1, 0, 0, 2, rij, CPPint_args)*sepj%zeff
            !  <D D | S S >
            kl = indexa(5, 5)
            core(7, 1) = ijkl_d(sepi, sepj, kl, ij, 2, 2, 0, 0, 2, rij, CPPint_args)*sepj%zeff
            !  <D+P+| S S >
            kl = indexa(6, 3)
            core(8, 1) = ijkl_d(sepi, sepj, kl, ij, 2, 1, 0, 0, 2, rij, CPPint_args)*sepj%zeff
            !  <D+D+| S S >
            kl = indexa(6, 6)
            core(9, 1) = ijkl_d(sepi, sepj, kl, ij, 2, 2, 0, 0, 2, rij, CPPint_args)*sepj%zeff
            !  <D#D#| S S >
            kl = indexa(8, 8)
            core(10, 1) = ijkl_d(sepi, sepj, kl, ij, 2, 2, 0, 0, 2, rij, CPPint_args)*sepj%zeff
         END IF

      END IF
   END SUBROUTINE nucint_d_num

! **************************************************************************************************
!> \brief Numerical Derivatives for rotint
!> \param sepi ...
!> \param sepj ...
!> \param r ...
!> \param dw ...
!> \param delta ...
!> \param se_int_control ...
!> \param se_taper ...
! **************************************************************************************************
   SUBROUTINE drotint_num(sepi, sepj, r, dw, delta, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: r
      REAL(dp), DIMENSION(3, 2025), INTENT(OUT)          :: dw
      REAL(dp), INTENT(IN)                               :: delta
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      INTEGER                                            :: i, j, nsize
      REAL(dp)                                           :: od
      REAL(dp), DIMENSION(2025)                          :: wm, wp
      REAL(dp), DIMENSION(3)                             :: rr

      od = 0.5_dp/delta
      nsize = sepi%atm_int_size*sepj%atm_int_size
      DO i = 1, 3
         rr = r
         rr(i) = rr(i)+delta
         CALL rotint_num(sepi, sepj, rr, wp, se_int_control, se_taper=se_taper)
         rr(i) = rr(i)-2._dp*delta
         CALL rotint_num(sepi, sepj, rr, wm, se_int_control, se_taper=se_taper)
         DO j = 1, nsize
            dw(i, j) = od*(wp(j)-wm(j))
         END DO
      END DO

   END SUBROUTINE drotint_num

! **************************************************************************************************
!> \brief Numerical Derivatives for rotnuc
!> \param sepi ...
!> \param sepj ...
!> \param r ...
!> \param de1b ...
!> \param de2a ...
!> \param itype ...
!> \param delta ...
!> \param se_int_control ...
!> \param se_taper ...
! **************************************************************************************************
   SUBROUTINE drotnuc_num(sepi, sepj, r, de1b, de2a, itype, delta, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: r
      REAL(dp), DIMENSION(3, 45), INTENT(OUT), OPTIONAL  :: de1b, de2a
      INTEGER, INTENT(IN)                                :: itype
      REAL(dp), INTENT(IN)                               :: delta
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      INTEGER                                            :: i, j
      LOGICAL                                            :: l_de1b, l_de2a
      REAL(dp)                                           :: od
      REAL(dp), DIMENSION(3)                             :: rr
      REAL(dp), DIMENSION(45)                            :: e1m, e1p, e2m, e2p

      l_de1b = PRESENT(de1b)
      l_de2a = PRESENT(de2a)
      IF (.NOT. (l_de1b .OR. l_de2a)) RETURN
      od = 0.5_dp/delta
      DO i = 1, 3
         rr = r
         rr(i) = rr(i)+delta
         CALL rotnuc_num(sepi, sepj, rr, e1p, e2p, itype, se_int_control, se_taper=se_taper)
         rr(i) = rr(i)-2._dp*delta
         CALL rotnuc_num(sepi, sepj, rr, e1m, e2m, itype, se_int_control, se_taper=se_taper)
         IF (l_de1b) THEN
            DO j = 1, sepi%atm_int_size
               de1b(i, j) = od*(e1p(j)-e1m(j))
            END DO
         END IF
         IF (l_de2a) THEN
            DO j = 1, sepj%atm_int_size
               de2a(i, j) = od*(e2p(j)-e2m(j))
            END DO
         END IF
      END DO
   END SUBROUTINE drotnuc_num

! **************************************************************************************************
!> \brief Numerical Derivatives for corecore
!> \param sepi ...
!> \param sepj ...
!> \param r ...
!> \param denuc ...
!> \param itype ...
!> \param delta ...
!> \param se_int_control ...
!> \param se_taper ...
! **************************************************************************************************
   SUBROUTINE dcorecore_num(sepi, sepj, r, denuc, itype, delta, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: r
      REAL(dp), DIMENSION(3), INTENT(OUT)                :: denuc
      INTEGER, INTENT(IN)                                :: itype
      REAL(dp), INTENT(IN)                               :: delta
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      INTEGER                                            :: i
      REAL(dp)                                           :: enucm, enucp, od
      REAL(dp), DIMENSION(3)                             :: rr

      od = 0.5_dp/delta
      DO i = 1, 3
         rr = r
         rr(i) = rr(i)+delta
         CALL corecore_num(sepi, sepj, rr, enucp, itype, se_int_control, se_taper=se_taper)
         rr(i) = rr(i)-2._dp*delta
         CALL corecore_num(sepi, sepj, rr, enucm, itype, se_int_control, se_taper=se_taper)
         denuc(i) = od*(enucp-enucm)
      END DO
   END SUBROUTINE dcorecore_num

! **************************************************************************************************
!> \brief Numerical Derivatives for corecore
!> \param sepi ...
!> \param sepj ...
!> \param r ...
!> \param denuc ...
!> \param itype ...
!> \param delta ...
!> \param se_int_control ...
!> \param se_taper ...
! **************************************************************************************************
   SUBROUTINE dcorecore_el_num(sepi, sepj, r, denuc, itype, delta, se_int_control, se_taper)
      TYPE(semi_empirical_type), POINTER                 :: sepi, sepj
      REAL(dp), DIMENSION(3), INTENT(IN)                 :: r
      REAL(dp), DIMENSION(3), INTENT(OUT)                :: denuc
      INTEGER, INTENT(IN)                                :: itype
      REAL(dp), INTENT(IN)                               :: delta
      TYPE(se_int_control_type), INTENT(IN)              :: se_int_control
      TYPE(se_taper_type), POINTER                       :: se_taper

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

      INTEGER                                            :: i
      REAL(dp)                                           :: enucm, enucp, od
      REAL(dp), DIMENSION(3)                             :: rr

      od = 0.5_dp/delta
      DO i = 1, 3
         rr = r
         rr(i) = rr(i)+delta
         CALL corecore_el_num(sepi, sepj, rr, enucp, itype, se_int_control, se_taper=se_taper)
         rr(i) = rr(i)-2._dp*delta
         CALL corecore_el_num(sepi, sepj, rr, enucm, itype, se_int_control, se_taper=se_taper)
         denuc(i) = od*(enucp-enucm)
      END DO
   END SUBROUTINE dcorecore_el_num

END MODULE semi_empirical_int_num
