!***********************************************************************
! This file is part of OpenMolcas.                                     *
!                                                                      *
! OpenMolcas is free software; you can redistribute it and/or modify   *
! it under the terms of the GNU Lesser General Public License, v. 2.1. *
! OpenMolcas is distributed in the hope that it will be useful, but it *
! is provided "as is" and without any express or implied warranties.   *
! For more details see the full text of the license in the file        *
! LICENSE or in <http://www.gnu.org/licenses/>.                        *
!***********************************************************************
!  Sl_Grad
!
!> @brief
!>   This subroutine is taken from the Anders program called Diffsph that calculates
!>   the Coulombic interaction between two Slater-type densities
!> @author A. Ohrn
!> @modified_by Jose
!>
!> @details
!> The subroutine (originally called ``Coulomb``) is taken and simplified
!> to QmStat purposes. Molecule A is going to be always the Solvent
!> Molecule and Molecule B the Quantum system. The subroutine is
!> writen for one center in the QM system, so it is called for each
!> center of the QM, and gives the Potential, Field and Field gradient
!> generated by all centers of the classical molecule in this center of the
!> QM molecule but considering the penetration. The original subroutine is for
!> classical molecules with as S (charge) slater distribution and a P
!> (dipole) distribution and it is not ready for Qmstat purposes.
!> Quantum molecule is represented up to \f$ L = 2 \f$. Interaction with
!> Multipole distributed Quadrupoles can be treated using an S
!> distribution in the clasical molecules. However a ``Logical``
!> variable is introduced to avoid the evaluation of this
!> iteraction and perform (in QmStat) less cumbersome calculations
!> using point charges in the classical molecule.
!>
!> This subroutine works with the Molcas order for the quadrupoles
!> \f$ xx=1 \f$, \f$ xy=2 \f$, \f$ xz=3 \f$, \f$ yy=4 \f$, \f$ yz=5 \f$ and \f$ zz=6 \f$
!> So the \p EintSl have to be changed outside the subroutine
!> to be adapted to the QmStat order
!> \f$ xx=1 \f$, \f$ xy=2 \f$, \f$ yy=3 \f$, \f$ xz=4 \f$, \f$ yz=5 \f$ and \f$ zz=6 \f$
!> The subroutine has the parameter \c _MxM_ that should be
!> changed if higher multipoles are included.
!***********************************************************************

subroutine Sl_Grad(nCentA,lMaxA,Coord,Dist,DInv,ExpoA,FactorA,SlPA,lMaxB,ExpoB,dNeigh,EintSl,EintSl_Nuc,lAtom)

use Index_Functions, only: nTri_Elem1, nTri3_Elem, nTri3_Elem1
use Constants, only: Zero, One, Three, Half
use Definitions, only: wp, iwp

! Maximum multipole implemented
#define _MxM_ 2

implicit none
integer(kind=iwp), intent(in) :: nCentA, lMaxA, lMaxB
real(kind=wp), intent(in) :: Coord(3,nCentA), Dist(nCentA), DInv(nCentA), ExpoA(2,nCentA), FactorA(4,nCentA), SlPA(nCentA), &
                             ExpoB(_MxM_+1), dNeigh
real(kind=wp), intent(out) :: EintSl(nTri3_Elem1(_MxM_)), EintSl_Nuc
logical(kind=iwp), intent(in) :: lAtom
integer(kind=iwp) :: iCA, iLA, iLB, kaunt, kComp, nS, nT
real(kind=wp) :: Colle(3), dKappa, EA, EAp, EB, EBp, R, Rho, RhoA, RhoB, Rinv, Rotte(3,3), Sigge, Tau, TMPA(nTri_Elem1(_MxM_)), &
                 TR(6,6), v(3)
logical(kind=iwp) :: lDiffA, lDiffB, lTooSmall

! Some zeros.
EintSl(:) = Zero
EintSl_Nuc = Zero

! Loop over all centers in molecule A.

do iCA=1,nCentA
  v(:) = Coord(:,iCA)
  R = Dist(iCA)
  Rinv = DInv(iCA)

  ! Obtain rotation matrix.

  call Revolution(v,Rinv,Rotte)

  ! Obtain the Matrix used to transform the Quadrupoles
  ! This 6x6 matrix is really 6 matrix of 3x3 in diagonal form
  ! Each element of each matrix gives the contribution from the
  ! old quadrupole to the new quadrupole (new coordinate system)
  ! Thus, if xx=1, xy=2, xz=3, yy=4, yz=5 and zz=6
  ! QNew(1)=Qold(1)*TD(1,1)+Qold(2)*TD(1,2)+Qold(3)+TD(1,3)+...
  ! So, to get field gradient for xx from the sigma interaction
  ! (see Anders paper) we have
  ! FG(xx)=FGSigma*(TD(6,1)-0.5(TD(1,1)*TD(4,1))). Remember that
  ! the Energy contribution in sigma is calculated using spherical
  ! harmonics so ESigma=FGSigma(Qnew(6)-0.5(Qnew(1)+Qnew(4)))

  call M2Trans(Rotte,TR)

  ! Loop over centres on A. Suck out exponents, factors and point-part. Rotate multipole.

  do iLA=0,lMaxA
    EA = ExpoA(iLA+1,iCA)
    lDiffA = EA > -One
    nS = nTri3_Elem(iLA)
    nT = nTri3_Elem((iLA+1))
    kaunt = 0
    do kComp=nS+1,nT
      kaunt = kaunt+1
      TMPA(kaunt) = FactorA(kComp,iCA)
    end do

    ! Rotate and go over to spherical representation.

    Sigge = -One
    call Rotation_qmstat(iLA,TMPA,Rotte,Sigge)

    ! Jose. Only one center in B so not loop over centres on B.
    !       Not Suck out Factors since we do not use them here.

    do iLB=0,lMaxB
      EB = ExpoB(iLB+1)
      lDiffB = EB > -One

      ! There is no rotation of Multipoles in B since we do not use them.

      ! ELECTRON--ELECTRON.

      EAp = Half*EA
      EBp = Half*EB
      if (lDiffA .and. lDiffB) then
        ! Both diffuse.

        call TKP(Tau,dKappa,Rho,RhoA,RhoB,EAp,EBp,R,dNeigh,lTooSmall)
        call ABBoth(iLA,iLB,TMPA,dKappa,Rho,RhoA,RhoB,Rinv,lTooSmall,Colle)
        if (iLB == 0) then
          EintSl(1) = EintSl(1)+Colle(1)
        else ! if iLB not 0 then it is 1
          if (iLA == 0) then
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)
          else ! if iLA is not 0 is 1
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:)
          end if
        end if

      else if (lDiffA .and. (.not. lDiffB)) then
        ! One diffuse, one not diffuse.

        call ABOne(iLA,iLB,TMPA,EAp,R,Rinv,Colle,lDiffA)
        if (iLB == 0) then
          EintSl(1) = EintSl(1)+Colle(1)
        else if (iLB == 1) then
          if (iLA == 0) then
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)
          else ! if iLA not 0 then it is 1
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:)
          end if
        else if (iLB == 2) then
          if (iLA == 0) then
            ! Remember Qsigma=z2-0.5(x2+y2)
            EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))
          else ! if iLA not 0 then it is 1
            ! Remember Qsigma=z2-0.5(x2+y2) QPi1=sqrt(3)*xz QPi2=sqrt(3)*yz
            EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))+ &
                           Colle(2)*sqrt(Three)*TR(3,:)+Colle(3)*sqrt(Three)*TR(5,:)
          end if
        end if

      else if ((.not. lDiffA) .and. lDiffB) then
        call ABOne(iLB,iLA,TMPA,EBp,R,Rinv,Colle,lDiffA)

        if (iLB == 0) then
          EintSl(1) = EintSl(1)+Colle(1)
        else ! if iLB not 0 then it is 1
          if (iLA == 0) then
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)
          else ! is the same for iLA 1 and 2 because both have sigma pi1 and pi2 components regarding to B
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:)
          end if
        end if
      else if ((.not. lDiffA) .and. (.not. lDiffB)) then
        ! Neither diffuse.

        call ABNone(iLA,iLB,TMPA,Rinv,Colle)

        if (iLB == 0) then
          EintSl(1) = EintSl(1)+Colle(1)
        else if (iLB == 1) then
          if (iLA == 0) then
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)
          else ! is the same for iLA 1 or 2
            EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:)
          end if
        else if (iLB == 2) then
          if (iLA == 0) then
            ! Remember Qsigma=z2-0.5(x2+y2)
            EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))
          else if (iLA == 1) then
            ! Remember Qsigma=z2-0.5(x2+y2) QPi1=sqrt(3)*xz QPi2=sqrt(3)*yz
            EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))+ &
                           Colle(2)*sqrt(Three)*TR(3,:)+Colle(3)*sqrt(Three)*TR(5,:)
          !Jose. This will be for a d-d interaction
          !else if (iLA == 2) then
          !  ! Remember Qsigma=z2-0.5(x2+y2) QPi1=sqrt(3)*xz QPi2=sqrt(3)*yz Del1=sqrt(3)*xy Del2=0.5*sqrt(3)*(x2-y2)
          !  EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))+ &
          !                 Colle(2)*sqrt(Three)*TR(3,:)+Colle(3)*sqrt(Three)*TR(5,:)+ &
          !                 Colle(4)*sqrt(Three)*TR(2,:)+Colle(5)*Half*sqrt(Three)*(TR(1,:)-TR(4,:))
          !  end do
          !--------
          end if
        end if

      end if
    end do

    ! ELECTRON--POINT.

    ! Point on centre B.
    ! Jose. Potential, Field and Field Gradient of Multipole
    ! distribution in A on B (to obtain nuclear interaction in B)

    if (lAtom) then
      if (lDiffA) then
        call ABOne(iLA,0,TMPA,EAp,R,Rinv,Colle,lDiffA)
        EintSl_Nuc = EintSl_Nuc+Colle(1)
      else
        call ABNone(iLA,0,TMPA,Rinv,Colle)
        EintSl_Nuc = EintSl_Nuc+Colle(1)
      end if
    end if

  end do

  ! ELECTRON--POINT.

  ! Point on centre A.
  ! Jose. Potential, Field and Field Gradient of nuclear
  ! charge in A on the B sites

  if (SlPA(iCA) > 1.0e-8_wp) then
    do iLB=0,lMaxB
      EB = ExpoB(iLB+1)
      lDiffB = EB > -One
      EBp = Half*EB

      if (lDiffB) then
        call ABOne(iLB,0,SlPA(iCA),EBp,R,Rinv,Colle,.false.)
      else
        call ABNone(0,iLB,SlPA(iCA),Rinv,Colle)
      end if
      if (iLB == 0) then
        EintSl(1) = EintSl(1)+Colle(1)
      else if (iLB == 1) then
        EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)
      else if (iLB == 2) then
        ! Remember Qsigma=z2-0.5(x2+y2)
        EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))
      end if
    end do

    ! POINT--POINT.
    ! Jose. Potential of nuclear charge in A on B
    ! (to obtain nuclear interaction in B)
    if (lAtom) then
      call ABNone(0,0,SlPA(iCA),Rinv,Colle)
      EintSl_Nuc = EintSl_Nuc+Colle(1)
    end if
  end if

end do

return

end subroutine Sl_Grad
