************************************************************************
* 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) 2019, Stefano Battaglia                                *
************************************************************************
      SUBROUTINE Backtransform(Heff,Ueff,U0)
      use definitions, only: wp
      use constants, only: Zero, One
      use stdalloc, only: mma_allocate, mma_deallocate
      use caspt2_module, only: Nstate, IFXMS, IFRMS
      IMPLICIT None
C Back-transform Heff and Ueff to the basis of the original
C CASSCF states.
      real(kind=wp), intent(inout) :: Heff(Nstate,Nstate),
     &                                Ueff(Nstate,Nstate)
      real(kind=wp), intent(in) :: U0(Nstate,Nstate)

      real(8),allocatable :: U0transpose(:,:),Utmp(:,:)


      if (IFXMS.or.IFRMS) then

* First we need to back-transform the effective Hamiltonian in the
* basis of original CASSCF states by U0 * Heff * U0^T
* Note that in the case of a normal MS-CASPT2 this and the next step
* do not have any effect on Heff and Ueff
        call mma_allocate(U0transpose,Nstate,Nstate,Label='U0transpose')
        call trnsps(Nstate,Nstate,U0,U0transpose)
        call transmat(Heff,U0transpose,Nstate)
        call mma_deallocate(U0transpose)

* Compute transformation matrix that diagonalizes the effective
* Hamiltonian expressed in the basis of original CASSCF states,
* i.e. simply combine the two transf matrices: Ueff = U0 * Ueff
        call mma_allocate(Utmp,Nstate,Nstate,Label='Utmp')
        call dgemm_('N','N',Nstate,Nstate,Nstate,
     &               One,U0,Nstate,Ueff,Nstate,
     &               Zero,Utmp,Nstate)
        Ueff=Utmp
        call mma_deallocate(Utmp)

      end if

      END SUBROUTINE Backtransform
