!***********************************************************************
! 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/>.                        *
!                                                                      *
! Copyright (C) 1993, Roland Lindh                                     *
!***********************************************************************

subroutine SroHss( &
#                 define _CALLING_
#                 include "hss_interface.fh"
                 )
!***********************************************************************
!                                                                      *
! Object: kernel routine for the computation of ECP integrals.         *
!                                                                      *
!***********************************************************************

use Index_Functions, only: nTri_Elem1
use Basis_Info, only: dbsc, nCnttp, Shells
use Center_Info, only: dc
use Symmetry_Info, only: iOper
use Constants, only: Zero, One
use Definitions, only: wp, iwp

implicit none
#include "hss_interface.fh"
integer(kind=iwp) :: iang, iDCRT(0:7), ip, ipfa1, ipfa2, ipfb1, ipfb2, ipfin, iptmp, ishll, iuvwx(4), JndGrd(3,4,0:7), &
                     jndhss(4,3,4,3,0:7), kcnt, kCnttp, kdc, kOp(4), ldcrt, lmbdt, mop(4), nDCRT, nExpi, nt
real(kind=wp) :: C(3), Coor(3,4), fact, g2(78), TC(3)
logical(kind=iwp) :: ifg(4), jfgrd(3,4), jfhss(4,3,4,3), tr(4)
integer(kind=iwp), external :: NrOpr
logical(kind=iwp), external :: EQ

#include "macros.fh"
unused_var(Zeta)
unused_var(ZInv)
unused_var(rKappa)
unused_var(P)
unused_var(rFinal)
unused_var(nHer)
unused_var(Ccoor)
unused_var(lOper)

iuvwx(1) = dc(mdc)%nStab
iuvwx(2) = dc(ndc)%nStab
mop(1:2) = nOp
kop(1) = ioper(nop(1))
kop(2) = ioper(nop(2))
coor(:,1) = A
coor(:,2) = RB

kdc = 0
do kCnttp=1,ncnttp
  if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr
  if (.not. dbsc(kcnttp)%ECP) cycle
  if (dbsc(kcnttp)%nSRO <= 0) cycle
  do kcnt=1,dbsc(kCnttp)%nCntr
    C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt)

    call dcr(lmbdt,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT)
    fact = real(nstabm,kind=wp)/real(LmbdT,kind=wp)

    iuvwx(3) = dc(kdc+kCnt)%nStab
    iuvwx(4) = dc(kdc+kCnt)%nStab

    do ldcrt=0,ndcRT-1

      kop(3) = idcrt(ldcrT)
      kop(4) = kop(3)
      mop(3) = nropr(kop(3))
      mop(4) = mop(3)

      call OA(iDCRT(lDCRT),C,TC)
      Coor(:,3) = TC

      if (eq(a,rb) .and. eq(A,TC)) cycle
      call nucind(coor,kdc+kCnt,ifgrd,ifhss,indgrd,indhss,jfgrd,jfhss,jndgrd,jndhss,tr,ifg)
      do iang=0,dbsc(kCnttp)%nSRO-1
        ishll = dbsc(kcnttp)%iSRO+iAng
        nExpi = Shells(iShll)%nExp
        if (nExpi == 0) cycle

        ip = 1
        ipfin = ip
        ip = ip+nzeta*nTri_Elem1(la)*nTri_Elem1(lb)*21
        ipfa1 = ip
        ip = ip+nalpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*4
        iptmp = ip
        ip = ip+nalpha*nExpi
        ipfa2 = ip
        ip = ip+nalpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*6
        ipfb1 = ip
        ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*4
        ipfb2 = ip
        ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*6

        Array(:) = Zero
        ! <a|c>, <a'|c>, <a",c>
        call Acore(iang,la,ishll,nordop,TC,A,Array(ip),narr-ip+1,Alpha,nalpha,Array(ipFA1),array(ipfa2),jfgrd(1,1),jfhss,2,.false.)
        ! Transform core orbital to spherical harmonics
        call LToSph(Array(ipFA1),nAlpha,ishll,la,iAng,4)
        call LToSph(Array(ipFA2),nAlpha,ishll,la,iAng,6)

        ! <c|b>,<c,b'>,<c|b">
        call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip),narr-ip+1,Beta,nbeta,Array(ipFB1),array(ipfb2),jfgrd(1,2),jfhss,2,.false.)
        ! Transform core orbital to spherical harmonics
        call RToSph(Array(ipFB1),nBeta,ishll,lb,iAng,4)
        call RToSph(Array(ipFB2),nBeta,ishll,lb,iAng,6)

        ! Construct complete derivatives (contracting core)
        call CmbnACB2(Array(ipFa1),Array(ipFa2),Array(ipFb1),Array(ipFb2),Array(ipFin),Fact,nalpha,nbeta,Shells(iShll)%Akl,nExpi, &
                      la,lb,iang,jfhss,Array(ipTmp),.true.)

        ! contract density
        nt = nZeta*nTri_Elem1(la)*nTri_Elem1(lb)
        g2(:) = Zero
        call dGeMV_('T',nT,21,One,Array(ipFin),nT,DAO,1,Zero,g2,1)

        ! distribute in hessian
        call Distg2(g2,Hess,nHess,JndGrd,JfHss,JndHss,iuvwx,kOp,mop,Tr,IfG)

      end do
    end do
  end do
end do

return

end subroutine SroHss
