!***********************************************************************
! 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) 2021, Stefano Battaglia                                *
!***********************************************************************

#include "compiler_features.h"
#ifdef _DMRG_

subroutine mkfg3qcm(mkF,nLev,G1,F1,G2,F2,G3,F3,idxG3,nG3)

use, intrinsic :: iso_c_binding, only: c_bool
use Symmetry_Info, only: Mul
use qcmaquis_interface, only: qcmaquis_interface_get_1rdm_full, qcmaquis_interface_get_2rdm_full, &
                              qcmaquis_interface_get_3rdm_full, qcmaquis_interface_get_fock_contracted_4rdm_full, &
                              qcmaquis_interface_read_fock_contracted_4rdm
use printLevel, only: verbose
use sguga, only: SGS
use caspt2_global, only: iPrGlb
use caspt2_module, only: EPSA, jState
use stdalloc, only: mma_allocate, mma_deallocate
use Constants, only: Zero
use Definitions, only: wp, iwp, u6, byte

implicit none
logical(kind=iwp), intent(in) :: mkF
integer(kind=iwp), intent(in) :: nLev, nG3
real(kind=wp), intent(out) :: G1(nLev,nLev), F1(nLev,nLev), G2(nLev,nLev,nLev,nLev), F2(nLev,nLev,nLev,nLev), G3(nG3), F3(nG3)
integer(kind=byte), intent(in) :: idxG3(6,nG3)
integer(kind=iwp) :: i, t, u, v, w, x, y, z
real(kind=wp), allocatable :: G3tmp(:,:,:,:,:,:), TG3tmp(:,:,:,:,:,:)

! This might be memory hungry
call mma_allocate(G3tmp,nLev,nLev,nLev,nLev,nLev,nLev,Label='G3Tmp')
call mma_allocate(TG3tmp,nLev,nLev,nLev,nLev,nLev,nLev,Label='TG3Tmp')
!call mma_allocate(G4,n4,nLev,nLev,nLev,nLev,Label='G4')

if (iPrGlb >= verbose) write(u6,*) '>QCMaquis: Computing RDMs for STATE: ',JSTATE-1

! Remeasure RDM from rotated MPS
call qcmaquis_interface_get_1rdm_full(G1)
call qcmaquis_interface_get_2rdm_full(G2)
call qcmaquis_interface_get_3rdm_full(G3tmp)

! Fetch rotated RDM from unrotated MPS
!call qcmaquis_interface_read_rdm_full(int(JSTATE-1,kind=c_int),int(JSTATE-1,kind=c_int),G1,int(1,kind=c_int))
!call qcmaquis_interface_read_rdm_full(int(JSTATE-1,kind=c_int),int(JSTATE-1,kind=c_int),G2,int(2,kind=c_int))
! call qcmaquis_interface_read_rdm_full(int(JSTATE-1,kind=c_int),int(JSTATE-1,kind=c_int),G3tmp,int(3,kind=c_int))

! TODO: This should be removed in the future
TG3tmp = Zero  ! Initialize TG3tmp to zero
call qcmaquis_interface_get_fock_contracted_4rdm_full(EPSA,0)
call qcmaquis_interface_read_fock_contracted_4rdm(TG3tmp,logical(.false.,c_bool))

! call qcmaquis_interface_get_fock_contracted_4rdm_full(TG3tmp, epsa, CompressMPS)

! number of elements in the contracted 4-index of the 4-RDM
! n4 = nTri4_Elem(nLev)
! call mma_allocate(G4,n4,nLev,nLev,nLev,nLev,Label='G4')
! call qcmaquis_interface_get_4rdm_full(G4)

if (mkF) then
  do t=1,nLev
    do u=1,t
      if (Mul(SGS%ism(t),SGS%ism(u)) == 1) then
        do w=1,nLev
          F1(t,u) = F1(t,u)+G2(t,u,w,w)*epsa(w)
        end do
        F1(u,t) = F1(t,u)
      end if
    end do
  end do
end if

if (mkF) then
  do t=1,nLev
    do u=1,nLev
      do v=1,nLev
        do x=1,nLev
          if (Mul(SGS%ism(x),Mul(SGS%ism(v),Mul(SGS%ism(u),SGS%ism(t)))) == 1) then
            do w=1,nLev
              F2(t,u,v,x) = F2(t,u,v,x)+G3tmp(t,v,w,u,x,w)*epsa(w)
            end do
          end if
        end do
      end do
    end do
  end do
end if

do i=1,ng3
  t = idxG3(1,i)
  u = idxG3(2,i)
  v = idxG3(3,i)
  x = idxG3(4,i)
  y = idxG3(5,i)
  z = idxG3(6,i)

  G3(i) = G3tmp(t,v,y,u,x,z)
  ! F_tvyuxz = <| e_{tv,yu,xz} E_ww f_ww |> - <| e_{tv,yu,xz} |> (f_uu + f_xx + f_zz)
  ! Compute first term using transition RDM between <| and |'> = E_ww f_ww |>: <| e_{tv,yu,xz} |'>
  if (mkF) F3(i) = TG3tmp(t,v,y,u,x,z)-G3(i)*(epsa(u)+epsa(x)+epsa(z))

  !do w=1,nLev
  !  val = get_p4_element(G4,w,t,v,y,w,u,x,z,nLev)
  !  F3(i) = F3(i)+val*epsa(w)
  !end do
end do

call mma_deallocate(G3tmp)
call mma_deallocate(TG3tmp)
! call mma_deallocate(G4)
end subroutine mkfg3qcm

#elif ! defined (EMPTY_FILES)

! Some compilers do not like empty files
#include "macros.fh"
dummy_empty_procedure(mkfg3qcm)

#endif
