************************************************************************
* 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 MxMltp 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)
      Implicit Real*8 (a-h,o-z)

#include "warnings.fh"

      Parameter (MxMltp=2,MxK=(MxMltp*(MxMltp**2+6*MxMltp+11)+6)/6)

      Dimension Coord(3,nCentA),Dist(nCentA),DInv(nCentA)
      Dimension FactorA(4,nCentA),ExpoA(2,nCentA)
      Dimension SlPA(nCentA),ExpoB(MxMltp+1)

      Dimension EintSl(MxK),Colle(3)
      Dimension TMPA((MxMltp+1)*(MxMltp+2)/2)
      Dimension Rotte(3,3),v(3),TR(6,6)

      Logical lDiffA,lDiffB,lTooSmall,lAtom


*-- Some zeros.
      Do ijhr=1,MxK
        EintSl(ijhr)=0.0d0
      End do
      EintSl_Nuc=0.0d0

*
*-- Loop over all centers in molecule A.
*
      Do iCA=1,nCentA
        v(1)=Coord(1,iCA)
        v(2)=Coord(2,iCA)
        v(3)=Coord(3,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
*          armonics 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.gt.-1.0d0
          nS=iLA*(iLA+1)*(iLA+2)/6
          nT=(iLA+1)*(iLA+2)*(iLA+3)/6
          kaunt=0
          Do kComp=nS+1,nT
            kaunt=kaunt+1
            TMPA(kaunt)=FactorA(kComp,iCA)
          Enddo
*
*------ Rotate and go over to spherical representation.
*
          Sigge=-1.0d0
          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.gt.-1.0d0
*
*-------- There is not rotation of Multipoles in B since we do not use them.
*

*
*---- ELECTRON--ELECTRON.
*
*
*------ Both diffuse.
*
            EAp=0.5d0*EA
            EBp=0.5d0*EB
            If(lDiffA.and.lDiffB) then
              Call TKP(Tau,dKappa,Rho,RhoA,RhoB,EAp,EBp,R
     &                ,dNeigh,lTooSmall)
              Call ABBoth(iLA,iLB,TMPA
     &                   ,Tau,dKappa,Rho,RhoA,RhoB
     &                   ,Rinv,lTooSmall,Colle)
              If(iLB.eq.0) then
                  EintSl(1)=EintSl(1)+Colle(1)
              Else             ! if iLB not 0 then it is 1
                If(iLA.eq.0) then
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &                          +Colle(1)*Rotte(3,ijhr)
                  End do
                Else          ! if iLA is not 0 is 1
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &              +Colle(1)*Rotte(3,ijhr)+Colle(2)*Rotte(1,ijhr)
     &              +Colle(3)*Rotte(2,ijhr)
                  End do
                Endif
              Endif
*
*------ One diffuse, one not diffuse.
*
            ElseIf(lDiffA.and..not.lDiffB) then
              Call ABOne(iLA,iLB,TMPA
     &                  ,EAp,R,Rinv,Colle,lDiffA)
              If(iLB.eq.0) then
                EintSl(1)=EintSl(1)+Colle(1)
              ElseIf(iLB.eq.1) then
                If(iLA.eq.0) then
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &                          +Colle(1)*Rotte(3,ijhr)
                  End do
                Else       ! if iLA not 0 then it is 1
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &              +Colle(1)*Rotte(3,ijhr)
     &              +Colle(2)*Rotte(1,ijhr)
     &              +Colle(3)*Rotte(2,ijhr)
                  End do
                Endif
              ElseIf(iLB.eq.2) then
                If(iLA.eq.0) then
                  Do ijhr=1,6            ! Remember Qsigma=z2-0.5(x2+y2)
                    EintSl(ijhr+4)=EintSl(ijhr+4)
     &                   +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr)
     &                   +TR(4,ijhr)))
                  End do
                Else              ! if iLA not 0 then it is 1
                  Do ijhr=1,6            ! Remember Qsigma=z2-0.5(x2+y2)
                                         ! QPi1=sqrt(3)*xz
                                         ! QPi2=sqrt(3)*yz
                    EintSl(ijhr+4)=EintSl(ijhr+4)
     &                +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr)
     &                +TR(4,ijhr)))
     &                +Colle(2)*sqrt(3.0d0)*TR(3,ijhr)
     &                +Colle(3)*sqrt(3.0d0)*TR(5,ijhr)
                  End do
                Endif
              Endif

            ElseIf(.not.lDiffA.and.lDiffB) then
              Call ABOne(iLB,iLA,TMPA
     &                  ,EBp,R,Rinv,Colle,lDiffA)

              If(iLB.eq.0) then
                EintSl(1)=EintSl(1)+Colle(1)
              Else            ! if iLB not 0 then it is 1
                If(iLA.eq.0) then
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &                          +Colle(1)*Rotte(3,ijhr)
                  End do
                Else      ! is the same for iLA 1 and 2
                          ! because both have sigma pi1 and pi2
                          ! components regarding to B
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &              +Colle(1)*Rotte(3,ijhr)
     &              +Colle(2)*Rotte(1,ijhr)
     &              +Colle(3)*Rotte(2,ijhr)
                  End do
                Endif
              Endif
*
*------ Neither diffuse.
*
            ElseIf(.not.lDiffA.and..not.lDiffB) then
              Call ABNone(iLA,iLB,TMPA,Rinv,Colle)

              If(iLB.eq.0) then
                EintSl(1)=EintSl(1)+Colle(1)
              ElseIf(iLB.eq.1) then
                If(iLA.eq.0) then
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &                          +Colle(1)*Rotte(3,ijhr)
                  End do
                Else      ! is the same for iLA 1 or 2
                  Do ijhr=1,3
                    EintSl(ijhr+1)=EintSl(ijhr+1)
     &              +Colle(1)*Rotte(3,ijhr)
     &              +Colle(2)*Rotte(1,ijhr)
     &              +Colle(3)*Rotte(2,ijhr)
                  End do
                Endif
              ElseIf(iLB.eq.2) then
                If(iLA.eq.0) then
                  Do ijhr=1,6            ! Remember Qsigma=z2-0.5(x2+y2)
                    EintSl(ijhr+4)=EintSl(ijhr+4)
     &                   +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr)
     &                   +TR(4,ijhr)))
                  End do
                ElseIf(iLA.eq.1) then
                  Do ijhr=1,6            ! Remember Qsigma=z2-0.5(x2+y2)
                                         ! QPi1=sqrt(3)*xz
                                         ! QPi2=sqrt(3)*yz
                    EintSl(ijhr+4)=EintSl(ijhr+4)
     &                +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr)
     &                +TR(4,ijhr)))
     &                +Colle(2)*sqrt(3.d0)*TR(3,ijhr)
     &                +Colle(3)*sqrt(3.0d0)*TR(5,ijhr)
                  End do

*------------------Jose. This will be for a d-d interaction
C                  ElseIf(iLA.eq.2) then
C                    Do ijhr=1,6         ! Remember Qsigma=z2-0.5(x2+y2)
C                                        ! QPi1=sqrt(3)*xz
C                                        ! QPi2=sqrt(3)*yz
C                                        ! Del1=sqrt(3)*xy
C                                        ! Del2=0.5*sqrt(3)*(x2-y2)
C                      EintSl(ijhr+4)=EintSl(ijhr+4)
C     &                  +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr)
C     &                  +TR(4,ijhr)))+Colle(2)*sqrt(3.d0)*TR(3,ijhr)
C     &                  +Colle(3)*sqrt(3.0d0)*TR(5,ijhr)
C     &                  +Colle(4)*sqrt(3.0d0)*TR(2,ijhr)
C     &                  +Colle(5)*0.5d0*sqrt(3.0d0)*(TR(1,ijhr)
C     &                  -TR(4,ijhr))
C                    End do
*------------------
                Endif
              Endif

            Endif
          Enddo

*
*---- 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)
            Endif
          Endif

*

        Enddo

*---- ELECTRON--POINT.
*
*------ Point on centre A.
* Jose. Potential, Field and Field Gradient of nuclear
* charge in A on the B sites
*
        If(SlPA(iCA).gt.1.0d-8)then
          Do iLB=0,lMaxB
            EB=ExpoB(iLB+1)
            lDiffB=EB.gt.-1.0d0
            EBp=0.5d0*EB

            If(lDiffB) then
              Call ABOne(iLB,0,SlPA(iCA)
     &                  ,EBp,R,Rinv,Colle,.false.)
            Else
              Call ABNone(0,iLB,SlPA(iCA)
     &                     ,Rinv,Colle)
            Endif
            If(iLB.eq.0) then
              EintSl(1)=EintSl(1)+Colle(1)
            ElseIf(iLB.eq.1) then
              Do ijhr=1,3
                EintSl(ijhr+1)=EintSl(ijhr+1)
     &                      +Colle(1)*Rotte(3,ijhr)
              End do
            ElseIf(iLB.eq.2) then
              Do ijhr=1,6               ! Remember Qsigma=z2-0.5(x2+y2)
                EintSl(ijhr+4)=EintSl(ijhr+4)
     &               +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr)
     &               +TR(4,ijhr)))
              End do
            Endif
          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)
          Endif
        Endif

      Enddo

      Return
      End


*
*-- Construct rotation matrix.
*
      Subroutine Revolution(v,Rinv,Rotte)
      Implicit Real*8 (a-h,o-z)

      Dimension v(3),Rotte(3,3)
      Dimension u(3),w(3),t(3)

*
*-- Obtain base-vectors for the plane to which v in the normal vector.
*
      Call PlaneVectors(u,w,v,Rinv)

*
*-- Normalize v.
*
      t(1)=Rinv*v(1)
      t(2)=Rinv*v(2)
      t(3)=Rinv*v(3)

*
*-- Assemble rotation matrix
*
      Rotte(1,1)=u(1)
      Rotte(1,2)=u(2)
      Rotte(1,3)=u(3)
      Rotte(2,1)=w(1)
      Rotte(2,2)=w(2)
      Rotte(2,3)=w(3)
      Rotte(3,1)=t(1)
      Rotte(3,2)=t(2)
      Rotte(3,3)=t(3)

      Return
      End


*
*-- Rotate multipole.
*
      Subroutine Rotation_qmstat(iL,dMul,Rotte,Sigge)
      Implicit Real*8 (a-h,o-z)

      Parameter (MxMltp=2)

      Dimension dMul((MxMltp+1)*(MxMltp+2)/2),Rotte(3,3)
      Dimension dMTrans(6),TD(6,6)

*
*-- Charge, trivial to rotate.
*
      If(iL.eq.0) then
        dMul(1)=dMul(1)
*
*-- Dipole, transforms as a vector. Sigge controls that if the
*   multipole is located not in origin, but at the other end,
*   i.e. molecule A, then any odd occurrence of z should be
*   mirrored. Applies for the quadrupole as well, see below.
*
      ElseIf(iL.eq.1) then
        d1=dMul(1)
        d2=dMul(2)
        d3=dMul(3)
        dMul(1)=Rotte(1,1)*d1+Rotte(1,2)*d2+Rotte(1,3)*d3
        dMul(2)=Rotte(2,1)*d1+Rotte(2,2)*d2+Rotte(2,3)*d3
        dMul(3)=Rotte(3,1)*d1+Rotte(3,2)*d2+Rotte(3,3)*d3
        dMul(1)=dMul(1)
        dMul(2)=dMul(2)
        dMul(3)=Sigge*dMul(3)
*
*-- Quadrupole, transforms as a quadratic form. Also, transform
*   to spherical representation.
*
      ElseIf(iL.eq.2) then
*
*---- Compute the transformation matrix for second-moments.
*
        Call M2Trans(Rotte,TD)
*
*---- Transform. Sigge is explained above.
*
        Do i=1,6
          dMTrans(i)=0.0d0
          Do j=1,6
            dMTrans(i)=dMTrans(i)+TD(i,j)*dMul(j)
          Enddo
        Enddo
        Do i=1,6
          Sig=1.0d0
          If(i.eq.3.or.i.eq.5)Sig=Sigge
          dMul(i)=dMTrans(i)*Sig
        Enddo
*
*---- Go to spherical representation.
*
        Call Spherical(dMul)
      Else
        Write(6,*)'Nope!, Error in sl_grad'
        Call Quit(_RC_IO_ERROR_READ_)
      Endif

      Return
      End


*
*-- Routine for the case where both centres are diffuse. Since these
*   formulas are pretty nasty and apparently with little general
*   structure, each type of interaction is hard-coded.
*
      Subroutine ABBoth(iLA,iLB,dMulA
     &                 ,Tau,dKappa,Rho,RhoA,RhoB
     &                 ,Rinv,lTooSmall,Colle)
      Implicit Real*8 (a-h,o-z)

      Parameter (MxMltp=2)

      Dimension dMulA((MxMltp+1)*(MxMltp+2)/2),Colle(3)

      Logical lTooSmall

*-- To calculate the interaction Sigma is the product of both multipoles
*   in A and in B but since we need potential, field and field gradient
*   for the QM system whe do not multiply for multipoles in B, but we
*   have to take into account to move the result for the original
*   coordinate system in QmStat.
*
      Do i=1,3
        Colle(i)=0.0d0
      End do
*
*-- s-s interaction. There is only sigma-components, hence simple.
*
      If(iLA.eq.0.and.iLB.eq.0) then
        Sigma=dMulA(1)
        If(lTooSmall) then
          Ex=Exp((-2.0d0)*Rho)
          Colle(1)=Sigma*CoulT0_1(Rho,Rinv,Ex)
        Else
          ExA=Exp((-2.0d0)*RhoA)
          ExB=Exp((-2.0d0)*RhoB)
          Colle(1)=Sigma*CoulTN_1(RhoA,RhoB,dKappa,Rinv,ExA,ExB)
        Endif

*
*-- s-p interaction. Only the z-component of the dipole interacts
*   through a sigma-interaction with the s-distribution. Observe
*   that in the case that iLA.gt.iLB, then the formulas by Roothan
*   has to be reversed, i.e. RhoA and RhoB change place and
*   Tau and Kappa changes sign.
*
      ElseIf(iLA.eq.1.and.iLB.eq.0) then
        Sigma=dMulA(3)
        If(lTooSmall) then
          Ex=Exp((-2.0d0)*Rho)
          Colle(1)=Sigma*CoulT0_2(Rho,Rinv,Ex)
        Else
          ExA=Exp((-2.0d0)*RhoA)
          ExB=Exp((-2.0d0)*RhoB)
          Colle(1)=Sigma*CoulTN_2(Rho,-Tau,RhoB,RhoA,-dKappa,Rinv
     &             ,ExB,ExA)
        Endif
      ElseIf(iLA.eq.0.and.iLB.eq.1) then
        Sigma=dMulA(1)
        If(lTooSmall) then
          Ex=Exp((-2.0d0)*Rho)
          Colle(1)=Sigma*CoulT0_2(Rho,Rinv,Ex)
        Else
          ExA=Exp((-2.0d0)*RhoA)
          ExB=Exp((-2.0d0)*RhoB)
          Colle(1)=Sigma*CoulTN_2(Rho,Tau,RhoA,RhoB,dKappa,
     &             Rinv,ExA,ExB)
        Endif

*
*-- p-p interaction. The z-z combination gives a sigma-interaction,
*   and the x-x and y-y combinations give pi-interactions.
*
      ElseIf(iLA.eq.1.and.iLB.eq.1) then
*
*-- The sigma-component.
*
        Sigma=dMulA(3)
        If(lTooSmall) then
          Ex=Exp((-2.0d0)*Rho)
          Colle(1)=Sigma*CoulT0_4(Rho,Rinv,Ex)
        Else
          ExA=Exp((-2.0d0)*RhoA)
          ExB=Exp((-2.0d0)*RhoB)
          Colle(1)=Sigma*CoulTN_4(Rho,Tau,RhoA,RhoB,dKappa
     &             ,Rinv,ExA,ExB)
        Endif
*
*-- The two pi-components.
*
        Pi1=dMulA(1)
        Pi2=dMulA(2)
        If(lTooSmall) then
          Ex=Exp((-2.0d0)*Rho)
          Width=CoulT0_5(Rho,Rinv,Ex)
          Colle(2)=Pi1*Width
          Colle(3)=Pi2*Width
        Else
          ExA=Exp((-2.0d0)*RhoA)
          ExB=Exp((-2.0d0)*RhoB)
          Width=CoulTN_5(Rho,Tau,RhoA,RhoB,dKappa,Rinv,ExA,ExB)
          Colle(2)=Pi1*Width
          Colle(3)=Pi2*Width
        Endif

*
*-- Higher angular momentum interactions.
*
      Else
        Write(6,*)'Too high angular momentum'
        Write(6,*)'at least you start to implement.'
        Call Quit(_RC_IO_ERROR_READ_)
      Endif

      Return
      End

*
*-- One diffuse, the other not diffuse.
*
      Subroutine ABOne(iLdiff,iLpoi,dMul
     &                ,Ep,R,Rinv,Colle,lDiffA)
      Implicit Real*8 (a-h,o-z)

      Parameter (MxMltp=2)

      Dimension dMul((MxMltp+1)*(MxMltp+2)/2),Colle(3)
      Logical lDiffA

*
*-- The omnipresent exponential and distance-exponent product.
*
       er=Ep*R
       Ex=Exp((-2.0d0)*er)
       d3=sqrt(3.0d0)
       Do i=1,3
         Colle(i)=0.0d0
       End do

*
*-- s-s; see ABBoth for comments on sigma and similar below.
*
       If(iLdiff.eq.0.and.iLpoi.eq.0) then
         Sigma=dMul(1)
         DAMP=(1.0d0+er)*Ex
         Colle(1)=Sigma*Rinv*(1.0d0-DAMP)

*
*-- s-p
*
       ElseIf(iLdiff.eq.0.and.iLpoi.eq.1) then
         Sigma=dMul(3)
         If(lDiffA) then
          Sigma=dMul(1)
         End If
         DAMP=(1.0d0+2.0d0*er+2.0d0*er**2)*Ex
         Colle(1)=Sigma*Rinv**2*(1.0d0-DAMP)

*
*-- s-d
*
       ElseIf(iLdiff.eq.0.and.iLpoi.eq.2) then
         Sigma=dMul(3)
         If(lDiffA) then
          Sigma=dMul(1)
         End If
         DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+4.0d0*er**3/3.0d0)*Ex
         Colle(1)=Sigma*Rinv**3*(1.0d0-DAMP)

*
*-- p-s
*
       ElseIf(iLdiff.eq.1.and.iLpoi.eq.0) then
         Sigma=dMul(1)
         If(lDiffA) then
          Sigma=dMul(3)
         End If
         DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+er**3)*Ex
         Colle(1)=Sigma*Rinv**2*(1.0d0-DAMP)

*
*-- p-p
*
       ElseIf(iLdiff.eq.1.and.iLpoi.eq.1) then
         Sigma=dMul(3)
         Pi1=dMul(1)
         Pi2=dMul(2)
         DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+3.0d0*er**3/2.0d0+er**4)*Ex
         Colle(1)=2.0d0*Sigma*Rinv**3*(1.0d0-DAMP)
         DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+er**3)*Ex
         Colle(2)=Pi1*Rinv**3*(1.0d0-DAMP)
         Colle(3)=Pi2*Rinv**3*(1.0d0-DAMP)

*
*-- p-d
*
       ElseIf(iLdiff.eq.1.and.iLpoi.eq.2) then
         Sigma=dMul(3)
         Pi1=dMul(2)
         Pi2=dMul(4)
         If(lDiffA) then
          Pi1=dMul(1)
          Pi2=dMul(2)
         End If
         DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+4.0d0*er**3/3.0d0
     &        +2.0d0*er**4/3.0d0+4.0d0*er**5/9.0d0)*Ex
         Colle(1)=3.0d0*Sigma*Rinv**4*(1.0d0-DAMP)
         DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+4.0d0*er**3/3.0d0
     &        +2.0d0*er**4/3.0d0)*Ex
         Colle(2)=d3*Pi1*Rinv**4*(1.0d0-DAMP)
         Colle(3)=d3*Pi2*Rinv**4*(1.0d0-DAMP)
c        Colle=Colle1+Colle2+Colle3

*
*-- Higher moments.
*
       Else
         Write(6,*)
         Write(6,*)'Too high momentum!'
         Call Quit(_RC_IO_ERROR_READ_)
       Endif

       Return
       End


*
*-- All points. A bunch of special cases, see ABOne and ABBoth for
*   more details.
*
      Subroutine ABNone(iLA,iLB,dMulA
     &                 ,Rinv,Colle)
      Implicit Real*8 (a-h,o-z)

      Parameter (MxMltp=2)

      Dimension dMulA((MxMltp+1)*(MxMltp+2)/2)
      Dimension Colle(3)

      Do i=1,3
        Colle(i)=0.0d0
      End do

      If(iLA.eq.0) then
        If(iLB.eq.0) then
          Sigma=dMulA(1)
          Colle(1)=Sigma*Rinv
        ElseIf(iLB.eq.1) then
          Sigma=dMulA(1)
          Colle(1)=Sigma*Rinv**2
        ElseIf(iLB.eq.2) then
          Sigma=dMulA(1)
          Colle(1)=Sigma*Rinv**3
        Endif
      ElseIf(iLA.eq.1) then
        If(iLB.eq.0) then
          Sigma=dMulA(3)
          Colle(1)=Sigma*Rinv**2
        ElseIf(iLB.eq.1) then
          Sigma=dMulA(3)
          Pi1=dMulA(1)
          Pi2=dMulA(2)
          Colle(1)=2.0d0*Sigma*(Rinv**3)
          Colle(2)=Pi1*(Rinv**3)
          Colle(3)=Pi2*(Rinv**3)
        ElseIf(iLB.eq.2) then
          d3=sqrt(3.0d0)
          Sigma=dMulA(3)
          Pi1=dMulA(1)
          Pi2=dMulA(2)
          Colle(1)=3.0d0*Sigma*(Rinv**4)
          Colle(2)=d3*Pi1*(Rinv**4)
          Colle(3)=d3*Pi2*(Rinv**4)
        Endif

C Jose* This is for Quadrupoles in Classical. We do not use in QmStat.
*--------------------------------------
C      ElseIf(iLA.eq.2) then
C        If(iLB.eq.0) then
C          Sigma=dMulA(3)
C          Colle(1)=Sigma*Rinv**3
C        ElseIf(iLB.eq.1) then
C          d3=sqrt(3.0d0)
C          Sigma=dMulA(3)
C          Pi1=dMulA(2)
C          Pi2=dMulA(4)
C          Colle(1)=3.0d0*Sigma*(Rinv**4)
C          Colle(2)=d3*Pi1*(Rinv**4)
C          Colle(3)=d3*Pi2*(Rinv**4)
C        ElseIf(iLB.eq.2) then
C          Sigma=dMulA(3)
C          Pi1=dMulA(2)
C          Pi2=dMulA(4)
C* Jose. Remember dMulB(1)=sqrt(3)*xy
C* and dMulB(5)=0.5*sqrt(3)*(x2-y2)
C          Del1=dMulA(1)
C          Del2=dMulA(5)
C          Colle(1)=6.0d0*Sigma*(Rinv**5)
C          Colle(2)=4.0d0*Pi1*(Rinv**5)
C          Colle(3)=4.0d0*Pi2*(Rinv**5)
C          Colle(4)=Del1*(Rinv**5)
C          Colle(5)=Del2*(Rinv**5)
C        Endif
*--------------------------------------
      Endif

      Return
      End


*
*-- s-s interaction, with too small exponent difference.
*
      Real*8 Function CoulT0_1(Rho,dSepInv,Expo)
      Implicit Real*8 (a-h,o-z)

      T1=1.0d0
      T2=(11.0d0/8.0d0)*Rho
      T3=(3.0d0/4.0d0)*Rho**2
      T4=(1.0d0/6.0d0)*Rho**3
      CoulT0_1=dSepInv*(1.0d0-(T1+T2+T3+T4)*Expo)

      Return
      End

*
*-- s-s interaction, normal case.
*
      Real*8 Function CoulTN_1(RA,RB,C,dSepInv,ExpA,ExpB)
      Implicit Real*8 (a-h,o-z)

      T1=0.25d0*(2.0d0+C)
      T2=0.25d0*RA
      TA=(1.0d0-C)**2*(T1+T2)*ExpA
      T1=0.25d0*(2.0d0-C)
      T2=0.25d0*RB
      TB=(1.0d0+C)**2*(T1+T2)*ExpB
      CoulTN_1=dSepInv*(1.0d0-TA-TB)

      Return
      End

*
*-- s-p interaction, with too small exponent difference.
*
      Real*8 Function CoulT0_2(Rho,dSepInv,Expo)
      Implicit Real*8 (a-h,o-z)

      T1=1.0d0
      T2=2.0d0*Rho
      T3=2.0d0*Rho**2
      T4=(59.0d0/48.0d0)*Rho**3
      T5=(11.0d0/24.0d0)*Rho**4
      T6=(1.0d0/12.0d0)*Rho**5
      CoulT0_2=dSepInv**2*(1.0d0-(T1+T2+T3+T4+T5+T6)*Expo)

      Return
      End

*
*-- s-p interaction, normal case.
*
      Real*8 Function CoulTN_2(R,T,RA,RB,C,dSepInv,ExpA,ExpB)
      Implicit Real*8 (a-h,o-z)

      T1=(1.0d0/16.0d0)*(5.0d0+3.0d0*C)*(1.0d0+2.0d0*RA)
      T2=0.25d0*RA**2
      TA=(1.0d0-C)**3*(T1+T2)*ExpA
      T1=(1.0d0/16.0d0)*(11.0d0-10.0d0*C+3.0d0*C**2)*(1.0d0+2.0d0*RB)
      T2=0.5d0*(2.0d0-C)*RB**2
      T3=0.25d0*RB**3
      TB=(1.0d0+C)**2*(T1+T2+T3)*ExpB
      CoulTN_2=dSepInv**2*(1.0d0-TA-TB)

      Return
c Avoid unused argument warnings
      If (.False.) Then
        Call Unused_real(R)
        Call Unused_real(T)
      End If
      End

*
*-- p-p (sigma), with too small exponent difference.
*
      Real*8 Function CoulT0_4(Rho,dSepInv,Expo)
      Implicit Real*8 (a-h,o-z)

      T1=1.0d0
      T2=2.0d0*Rho
      T3=2.0d0*Rho**2
      T4=(263.0d0/192.0d0)*Rho**3
      T5=(71.0d0/96.0d0)*Rho**4
      T6=(77.0d0/240.0d0)*Rho**5
      T7=(1.0d0/10.0d0)*Rho**6
      T8=(1.0d0/60.0d0)*Rho**7
      CoulT0_4=2.0d0*dSepInv**3*(1.0d0-(T1+T2+T3+T4+T5+T6+T7+T8)*Expo)

      Return
      End

*
*-- p-p (sigma), normal case.
*
      Real*8 Function CoulTN_4(R,T,RA,RB,C,dSepInv,ExpA,ExpB)
      Implicit Real*8 (a-h,o-z)

      T1=(1.0d0/16.0d0)*(8.0d0+9.0d0*C+3.0d0*C**2)
     &                 *(1.0d0+2.0d0*RA+2.0d0*RA**2)
      T2=(3.0d0/16.0d0)*(3.0d0+2.0d0*C)*RA**3
      T3=(1.0d0/8.0d0)*RA**4
      TA=(1.0d0-C)**3*(T1+T2+T3)*ExpA
      T1=(1.0d0/16.0d0)*(8.0d0-9.0d0*C+3.0d0*C**2)
     &                 *(1.0d0+2.0d0*RB+2.0d0*RB**2)
      T2=(3.0d0/16.0d0)*(3.0d0-2.0d0*C)*RB**3
      T3=(1.0d0/8.0d0)*RB**4
      TB=(1.0d0+C)**3*(T1+T2+T3)*ExpB
      CoulTN_4=2.0d0*dSepInv**3*(1.0d0-TA-TB)

      Return
c Avoid unused argument warnings
      If (.False.) Then
        Call Unused_real(R)
        Call Unused_real(T)
      End If
      End

*
*-- p-p (pi), with too small exponent difference.
*
      Real*8 Function CoulT0_5(Rho,dSepInv,Expo)
      Implicit Real*8 (a-h,o-z)

      T1=1.0d0
      T2=2.0d0*Rho
      T3=2.0d0*Rho**2
      T4=(121.0d0/96.0d0)*Rho**3
      T5=(25.0d0/48.0d0)*Rho**4
      T6=(2.0d0/15.0d0)*Rho**5
      T7=(1.0d0/60.0d0)*Rho**6
      CoulT0_5=dSepInv**3*(1.0d0-(T1+T2+T3+T4+T5+T6+T7)*Expo)

      Return
      End

*
*-- p-p (pi), normal case.
*
      Real*8 Function CoulTN_5(R,T,RA,RB,C,dSepInv,ExpA,ExpB)
      Implicit Real*8 (a-h,o-z)

      T1=(1.0d0/16.0d0)*(8.0d0+9.0d0*C+3.0d0*C**2)*(1.0d0+2.0d0*RA)
      T2=(1.0d0/8.0d0)*(5.0d0+3.0d0*C)*RA**2
      T3=(1.0d0/8.0d0)*RA**3
      TA=(1.0d0-C)**3*(T1+T2+T3)*ExpA
      T1=(1.0d0/16.0d0)*(8.0d0-9.0d0*C+3.0d0*C**2)*(1.0d0+2.0d0*RB)
      T2=(1.0d0/8.0d0)*(5.0d0-3.0d0*C)*RB**2
      T3=(1.0d0/8.0d0)*RB**3
      TB=(1.0d0+C)**3*(T1+T2+T3)*ExpB
      CoulTN_5=dSepInv**3*(1.0d0-TA-TB)

      Return
c Avoid unused argument warnings
      If (.False.) Then
        Call Unused_real(R)
        Call Unused_real(T)
      End If
      End


*
*-- Compute some auxiliary numbers.
*
      Subroutine TKP(Tau,dKappa,Rho,RhoA,RhoB,EA,EB,R
     &              ,dNeigh,lTooSmall)
      Implicit Real*8 (a-h,o-z)


      Logical lTooSmall

      Tau=(EA-EB)/(EA+EB)
      Rho=0.5d0*(EA+EB)*R
      RhoA=(1+Tau)*Rho
      RhoB=(1-Tau)*Rho
      If(abs(Tau).gt.dNeigh) then
        dKappa=0.5d0*(Tau+1.0d0/Tau)
        lTooSmall=.false.
      Else
        lTooSmall=.true.
      Endif

      Return
      End


*
*-- Routine to give base vectors of the plane with v as normal.
*
      Subroutine PlaneVectors(u,w,v,Rinv)
      Implicit Real*8 (a-h,o-z)

      Dimension u(3),w(3),v(3),p(3)

*
*-- Construct an arbitrary normalized vector orthogonal to the v-vector.
*
      const=0.0d0
      Shitx=1.0d0
      Shity=0.0d0
      Shitz=0.0d0
1001  Continue
        p(1)=Shitx+1.0d0*const
        p(2)=Shity+0.5d0*const
        p(3)=Shitz-1.0d0*const
        Scal=p(1)*v(1)+p(2)*v(2)+p(3)*v(3)
        u(1)=p(1)-Scal*Rinv**2*v(1)
        u(2)=p(2)-Scal*Rinv**2*v(2)
        u(3)=p(3)-Scal*Rinv**2*v(3)
        If(abs(u(1)).lt.1d-6.and.
     &     abs(u(2)).lt.1d-6.and.
     &     abs(u(3)).lt.1d-6) then
          const=const+1.0d0
          Go To 1001
        Else
          Go To 1002
        Endif
1002  Continue
      dLu=sqrt(u(1)**2+u(2)**2+u(3)**2)
      u(1)=u(1)/dLu
      u(2)=u(2)/dLu
      u(3)=u(3)/dLu
*
*-- Construct the final pi-vector, which is orthogonal to the v-vector
*   and the recently constructed pi-vector.
*
      w(1)=Rinv*(u(2)*v(3)-u(3)*v(2))
      w(2)=Rinv*(u(3)*v(1)-u(1)*v(3))
      w(3)=Rinv*(u(1)*v(2)-u(2)*v(1))

      Return
      End


*
*-- Routine to generate the transformation for the second moments.
*
      Subroutine M2Trans(Rotte,TD)
      Implicit Real*8 (a-h,o-z)

      Dimension Rotte(3,3),TD(6,6)

*
*-- The transformation of x2.
*
      TD(1,1)=Rotte(1,1)*Rotte(1,1)
      TD(2,1)=Rotte(1,1)*Rotte(2,1)
      TD(3,1)=Rotte(1,1)*Rotte(3,1)
      TD(4,1)=Rotte(2,1)*Rotte(2,1)
      TD(5,1)=Rotte(2,1)*Rotte(3,1)
      TD(6,1)=Rotte(3,1)*Rotte(3,1)
*
*-- The transformation of xy.
*
      TD(1,2)=Rotte(1,1)*Rotte(1,2)+Rotte(1,2)*Rotte(1,1)
      TD(2,2)=Rotte(1,1)*Rotte(2,2)+Rotte(1,2)*Rotte(2,1)
      TD(3,2)=Rotte(1,1)*Rotte(3,2)+Rotte(1,2)*Rotte(3,1)
      TD(4,2)=Rotte(2,1)*Rotte(2,2)+Rotte(2,2)*Rotte(2,1)
      TD(5,2)=Rotte(2,1)*Rotte(3,2)+Rotte(2,2)*Rotte(3,1)
      TD(6,2)=Rotte(3,1)*Rotte(3,2)+Rotte(3,2)*Rotte(3,1)
*
*-- The transformation of xz.
*
      TD(1,3)=Rotte(1,1)*Rotte(1,3)+Rotte(1,3)*Rotte(1,1)
      TD(2,3)=Rotte(1,1)*Rotte(2,3)+Rotte(1,3)*Rotte(2,1)
      TD(3,3)=Rotte(1,1)*Rotte(3,3)+Rotte(1,3)*Rotte(3,1)
      TD(4,3)=Rotte(2,1)*Rotte(2,3)+Rotte(2,3)*Rotte(2,1)
      TD(5,3)=Rotte(2,1)*Rotte(3,3)+Rotte(2,3)*Rotte(3,1)
      TD(6,3)=Rotte(3,1)*Rotte(3,3)+Rotte(3,3)*Rotte(3,1)
*
*-- The transformation of y2.
*
      TD(1,4)=Rotte(1,2)*Rotte(1,2)
      TD(2,4)=Rotte(1,2)*Rotte(2,2)
      TD(3,4)=Rotte(1,2)*Rotte(3,2)
      TD(4,4)=Rotte(2,2)*Rotte(2,2)
      TD(5,4)=Rotte(2,2)*Rotte(3,2)
      TD(6,4)=Rotte(3,2)*Rotte(3,2)
*
*-- The transformation of yz.
*
      TD(1,5)=Rotte(1,2)*Rotte(1,3)+Rotte(1,3)*Rotte(1,2)
      TD(2,5)=Rotte(1,2)*Rotte(2,3)+Rotte(1,3)*Rotte(2,2)
      TD(3,5)=Rotte(1,2)*Rotte(3,3)+Rotte(1,3)*Rotte(3,2)
      TD(4,5)=Rotte(2,2)*Rotte(2,3)+Rotte(2,3)*Rotte(2,2)
      TD(5,5)=Rotte(2,2)*Rotte(3,3)+Rotte(2,3)*Rotte(3,2)
      TD(6,5)=Rotte(3,2)*Rotte(3,3)+Rotte(3,3)*Rotte(3,2)
*
*-- The transformation of z2.
*
      TD(1,6)=Rotte(1,3)*Rotte(1,3)
      TD(2,6)=Rotte(1,3)*Rotte(2,3)
      TD(3,6)=Rotte(1,3)*Rotte(3,3)
      TD(4,6)=Rotte(2,3)*Rotte(2,3)
      TD(5,6)=Rotte(2,3)*Rotte(3,3)
      TD(6,6)=Rotte(3,3)*Rotte(3,3)

      Return
      End

*
*-- Take higher multipole into spherical representation.
*
      Subroutine Spherical(dMul)
      Implicit Real*8 (a-h,o-z)

      Parameter (MxMltp=2)

      Dimension dMul((MxMltp+1)*(MxMltp+2)/2)

      d3=sqrt(3.0d0)
      x2=dMul(1)
      y2=dMul(4)
      z2=dMul(6)
      xy=dMul(2)
      xz=dMul(3)
      yz=dMul(5)
      dMul(1)=d3*xy
      dMul(2)=d3*xz
      dMul(3)=z2-0.5d0*(x2+y2)
      dMul(4)=d3*yz
      dMul(5)=0.5d0*d3*(x2-y2)

      Return
      End
