!***********************************************************************
! 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) 1990-1992, Roland Lindh                                *
!               1995, Anders Bernhardsson                              *
!***********************************************************************

subroutine Drvk2_mck(mdede,New_Fock)
!***********************************************************************
!                                                                      *
!  Object: to precompute all pair entites as zeta, kappa, P.           *
!                                                                      *
!     Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA  *
!             March '90                                                *
!                                                                      *
!             June '91, modified for k2 loop.                          *
!             January '92, modified to gradient calculations.          *
!             April '92, modified to use the Cauchy-Schwarz inequality *
!              to estimate the integral derivatives.                   *
!              Modified 1995 for 2nd derivatives by AB                 *
!***********************************************************************

use Index_Functions, only: iTri, nTri_Elem1
use k2_setup, only: Data_k2, Indk2, nk2
use k2_arrays, only: DoGrad_, DoHess_
use iSD_data, only: iSD
use Basis_Info, only: dbsc, Shells
use Symmetry_Info, only: iOper, nIrrep
use Sizes_of_Seward, only: S
use stdalloc, only: mma_allocate, mma_deallocate
use Definitions, only: wp, iwp, u6

implicit none
integer(kind=iwp), intent(out) :: mdede
logical(kind=iwp), intent(in) :: New_Fock
#include "ndarray.fh"
integer(kind=iwp) :: iAng, iAngV(4), iAO, iBas, iBasi, iBsInc, iCmp, iCmpV(4), iCnt, iCnttp, iDCRR(0:7), iDeSiz, ijCmp, ijShll, &
                     iShllV(2), ipM001, ipM002, ipM003, ipM004, iPrim, iPrimi, iPrInc, iS, iShell, iShll, iSmLbl, jAng, jAO, jBas, &
                     jBasj, jBsInc, jCmp, jCnt, jCnttp, jpk2, jPrim, jPrimj, jPrInc, jS, jShell, jShll, kBask, kBsInc, kPrimk, &
                     kPrInc, lBasl, lBsInc, lPriml, lPrInc, M001, M002, M003, M004, M00d, Maxk2, MaxMem, mdci, mdcj, MemPrm, &
                     MemTmp, mk2, nBasi, nBasj, nDCRR, nHrrab, nMemab, nSkal, nSO, nZeta
real(kind=wp) :: Coor(3,2), TCpu1, TCpu2, TWall1, TWall2
real(kind=wp), allocatable :: Con(:), Data_k2_local(:), Wrk(:)
integer(kind=iwp), external :: MemSO1

!                                                                      *
!***********************************************************************
!                                                                      *
call CWTime(TCpu1,TWall1)
call mma_MaxDBLE(Maxk2)
maxk2 = maxk2/2
call mma_allocate(Data_k2_local,Maxk2)
jpk2 = 1
nk2 = 0
mdede = 0
mk2 = 0

DoGrad_ = .false.
DoHess_ = .true.
!                                                                      *
!***********************************************************************
!                                                                      *
call Nr_Shells(nSkal)
!                                                                      *
!***********************************************************************
!                                                                      *
call mma_allocate(Con,S%m2Max,Label='Con')
!                                                                      *
!***********************************************************************
!                                                                      *
MemTmp = 0
do iAng=0,S%iAngMx
  MemTmp = max(MemTmp,(S%MaxPrm(iAng)*nTri_Elem1(iAng))**2)
end do
!                                                                      *
!***********************************************************************
!                                                                      *
call mma_MaxDBLE(MaxMem)
call mma_allocate(Wrk,MaxMem,Label='Wrk')
ipM001 = 1
!                                                                      *
!***********************************************************************
!                                                                      *
do iS=1,nSkal
  iShll = iSD(0,iS)
  iAng = iSD(1,iS)
  iCmp = iSD(2,iS)
  iBas = iSD(3,iS)
  iPrim = iSD(5,iS)
  iAO = iSD(7,iS)
  mdci = iSD(10,iS)
  iShell = iSD(11,iS)
  iCnttp = iSD(13,iS)
  iCnt = iSD(14,iS)
  Coor(1:3,1) = dbsc(iCnttp)%Coor(1:3,iCnt)

  iAngV(1) = iAng
  iShllV(1) = iShll
  iCmpV(1) = nTri_Elem1(iAng)

  do jS=1,iS
    jShll = iSD(0,jS)
    jAng = iSD(1,jS)
    jCmp = iSD(2,jS)
    jBas = iSD(3,jS)
    jPrim = iSD(5,jS)
    jAO = iSD(7,jS)
    mdcj = iSD(10,jS)
    jShell = iSD(11,jS)
    jCnttp = iSD(13,jS)
    jCnt = iSD(14,jS)
    Coor(1:3,2) = dbsc(jCnttp)%Coor(1:3,jCnt)

    iAngV(2) = jAng
    iShllV(2) = jShll
    iCmpV(2) = nTri_Elem1(jAng)

    ! Compute FLOP's for the transfer equation.

    call mHrr(iAng,jAng,nHrrab,nMemab)
    ijCmp = nTri_Elem1(iAng)*nTri_Elem1(jAng)

    iPrimi = iPrim
    jPrimj = jPrim
    nBasi = Shells(iShllV(1))%nBasis
    nBasj = Shells(iShllV(2))%nBasis

    kPrimk = 1
    lPriml = 1
    iBasi = iPrimi
    jBasj = jPrimj
    kBask = 1
    lBasl = 1

    nZeta = iPrimi*jPrimj

    call ConMax(Con,iPrimi,jPrimj,Shells(iShll)%pCff,nBasi,Shells(jShll)%pCff,nBasj)

    iAngV(3:4) = iAngV(1:2)
    iCmpV(3:4) = iCmpV(1:2)

    ijShll = iTri(iShell,jShell)

    nSO = 1

    ! Compute memory request for the primitives, i.e. how much memory
    ! is needed up to the transfer equation.

    call MemRys(iAngV,MemPrm)

    ! Decide on the partioning of the shells based on
    ! the available memory and the requested memory.

    call PSOAO0_h(nSO,nMemab,nMemab,MemPrm,MaxMem,iAngV,iCmpV,iBasi,iBsInc,jBasj,jBsInc,kBask,kBsInc,lBasl,lBsInc,iPrimi,iPrInc, &
                  jPrimj,jPrInc,kPrimk,kPrInc,lPriml,lPrInc,ipM001,ipM002,ipM003,ipM004,M001,M002,M003,M004,M00d)
    if ((iBasi /= iBsInc) .or. (jBasj /= jBsInc)) then
      write(u6,*) 'Drvk2: (iBasi /= iBsInc) .or. (jBasj /= jBsInc)'
      write(u6,*) 'iBasi,iBsInc=',iBasi,iBsInc
      write(u6,*) 'jBasj,jBsInc=',jBasj,jBsInc
      call Abend()
    end if

    ! Find the Double Coset Representatives for center A and B.

    iDCRR(0:nIrrep-1) = iOper(0:nIrrep-1)
    nDCRR = nIrrep

    ! Compute all pair entities (zeta, kappa, Px, Py, Pz, ZInv, alpha,
    ! beta, [nm|nm] and derivative entity, a total of ten different
    ! entities) for all possible unique pairs of centers generated
    ! for the symmetry unique centers A and B.

    call k2Loop_mck(Coor,iAngV,iCmpV,iDCRR,nDCRR,Data_k2_local(jpk2),ijCmp,Shells(iShllV(1))%Exp,iPrimi,Shells(iShllV(2))%Exp, &
                    jPrimj,Shells(iShllV(1))%pCff,iBas,Shells(iShllV(2))%pCff,jBas,nMemab,Wrk(ipM002),M002,Wrk(ipM003),M003,mdci, &
                    mdcj)

    Indk2(1,ijShll) = jpk2
    Indk2(2,ijShll) = nDCRR
    nk2 = nk2+(nZeta*nDArray+nDScalar)*nDCRR
    mk2 = mk2+nDCRR

    if (New_Fock) then
      iDeSiz = 1+iPrim*jPrim+iCmp*jCmp
    else
      iDeSiz = 1+iPrim*jPrim+(iBas*jBas+1)*iCmp*jCmp
    end if
    iSmLbl = 1
    nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO)
    if (nSO > 0) mDeDe = mDeDe+iDeSiz*nDCRR

    jpk2 = 1+nk2

  end do
end do
!                                                                      *
!***********************************************************************
!                                                                      *
call mma_deallocate(Wrk)
call mma_deallocate(Con)
!                                                                      *
!***********************************************************************
!                                                                      *
! Resize the memory to the actual size

call move_alloc(Data_k2_local,Data_k2)
!                                                                      *
!***********************************************************************
!                                                                      *
#ifdef _DEBUGPRINT_
write(u6,*)
write(u6,'(20X,A)') ' *** The k2 entities have been precomputed ***'
write(u6,'(I7,A,I7,A)') mk2,' blocks of k2 data were computed and',nk2,' Word(*8) of memory is used for storage.'
write(u6,'(A)') ' The prescreening is based on the integral estimates.'
#endif

call CWTime(TCpu2,TWall2)
call SavTim(2,TCpu2-TCpu1,TWall2-TWall1)

return

end subroutine Drvk2_mck
