!***********************************************************************
! 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) Francesco Aquilante                                    *
!***********************************************************************
!  CHO_GET_OED_cd
!
!> @brief
!>   Computes the Cholesky vectors of the 2nd-rank orbital energy denominators according to Eq. (7) of \cite Koc2000-JCP-113-508
!> @author F. Aquilante
!>
!> @details
!> Computes the Cholesky vectors of the 2nd-rank orbital energy denominators
!> according to Eq. (7) of \cite Koc2000-JCP-113-508
!>
!> @param[in]     incore Boolean for in or out of core decomposition
!> @param[in]     nOV    Number of (occ,vir) pairs matching a given compound symmetry
!> @param[in]     W      Array (\p nOV) of the orbital energy differences \p W(bj) = ``e(b)-e(j)``
!> @param[in]     NVec   Number of Cholesky vectors requested
!> @param[in]     ID_bj  Index array (\p NVec) of the decomposition pattern
!> @param[in]     JVec   Starting Cholesky vector
!> @param[in,out] Y      Matrix (\p nOV,\p NVec) of the Cholesky vectors for the decomposition of the orbital energy denominators
!> @param[in,out] R      Matrix (\p nOV) of the previous products, to be used for out of core decomposition.
!>                       Note: in case of out of core, in the first call this array *must* be initialized to ``1.0``.
!>                       For the in core case, it *must* also coincide with the first column of \p Y and *must* still be initialized in input.
!***********************************************************************

subroutine CHO_GET_OED_cd(incore,nOV,W,NVec,ID_bj,JVec,Y,R)

use Constants, only: Two
use Definitions, only: wp, iwp, u6

implicit none
logical(kind=iwp), intent(in) :: incore
integer(kind=iwp), intent(in) :: nOV, NVec, ID_bj(*), JVec
real(kind=wp), intent(in) :: W(*)
real(kind=wp), intent(inout) :: Y(*), R(*)
integer(kind=iwp) :: Jk, Jm, kp, np
real(kind=wp), parameter :: xtwo = sqrt(Two)

#include "warnings.h"

if (NVec < 1) then
  write(u6,*) 'Error in CHO_GET_OED_cd : in input NVec < 1 .'
  call quit(_RC_CHO_LOG_)
end if

! Compute  R(p,k) = R(p,k-1) * (W(p) - W(J[k-1]))/(W(p) + W(J[k-1]))
! ------------------------------------------------------------------
if (incore) then

  if (JVec /= 1) then
    write(u6,*) 'CHO_GET_OED_cd : JVec must be 1 if incore .'
    call quit(_RC_CHO_LOG_)
  end if
  do Jk=2,NVec
    kp = NOV*(Jk-1)
    np = kp-NOV
    Jm = ID_bj(Jk-1)
    Y(kp+1:kp+NOV) = Y(np+1:np+NOV)*(W(1:NOV)-W(Jm))/(W(1:NOV)+W(Jm))
  end do

else

  Jm = ID_bj(JVec-1)
  Y(1:NOV) = R(1:NOV)*(W(1:NOV)-W(Jm))/(W(1:NOV)+W(Jm))
  do Jk=2,NVec
    kp = NOV*(Jk-1)
    np = kp-NOV
    Jm = ID_bj(JVec+Jk-3)
    Y(kp+1:kp+NOV) = Y(np+1:np+NOV)*(W(1:NOV)-W(Jm))/(W(1:NOV)+W(Jm))
  end do
  R(1:NOV) = Y(NOV*(NVec-1)+1:NOV*NVec)

end if

! Compute  Y(p,k) = R(p,k) * sqrt(2*W(J[k]))/(W(p) + W(J[k]))
! -----------------------------------------------------------
do Jk=1,NVec
  kp = NOV*(Jk-1)
  Jm = ID_bj(JVec+Jk-1)
  Y(kp+1:kp+NOV) = Y(kp+1:kp+NOV)*xtwo*sqrt(W(Jm))/(W(1:NOV)+W(Jm))
end do

return

end subroutine CHO_GET_OED_cd
