************************************************************************
* 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/>.                        *
************************************************************************
      SUBROUTINE RASSI(IRETURN)

      !> module dependencies
      use rassi_global_arrays, only: HAM, SFDYS, SODYSAMPS, EIGVEC,
     &                               SODYSAMPSR, SODYSAMPSI,
     &                               PROP, ESHFT, HDIAG, JBNUM, LROOT
      use rassi_aux, only: CMO1, CMO2, DMAB, ipglob, jDisk_TDM,
     &                     Job_Index, TocM
      use kVectors
      use frenkel_global_vars, only: doCoul, eNucB, vNucB, nh1, aux2,
     &                               doExcitonics
      use Symmetry_Info, only: nIrrep
      use Basis_Info, only: nBas
#ifdef _HDF5_
      use Dens2HDF5
      use mh5, only: mh5_put_dset
#endif
#ifdef _DMRG_
      use qcmaquis_interface_cfg
      use qcmaquis_interface, only: qcmaquis_interface_deinit
      use qcmaquis_info, only : qcmaquis_info_deinit
      use rasscf_data, only: doDMRG
#endif
      use Fock_util_global, only: Fake_CMO2
      use mspt2_eigenvectors, only : deinit_mspt2_eigenvectors
      use Data_Structures
      use cntrl_data, only: SONTOSTATES, SONATNSTATE
      use stdalloc, only: mma_allocate, mma_deallocate

      IMPLICIT REAL*8 (A-H,O-Z)
C Matrix elements over RAS wave functions.
C RAS state interaction.
#include "rasdim.fh"
#include "cntrl.fh"
#include "Files.fh"
#include "Morsel.fh"
#include "SysDef.fh"
#include "rassi.fh"
#include "jobin.fh"
#include "symmul.fh"
#include "rassiwfn.fh"
      Logical CLOSEONE
      INTEGER IRC
      Real*8, Allocatable:: USOR(:,:),
     &                      USOI(:,:), OVLP(:,:), DYSAMPS(:,:),
     &                      ENERGY(:), DMAT(:), TDMZZ(:),
     &                      VNAT(:),OCC(:), SOENE(:)
*                                                                      *
************************************************************************
*                                                                      *
*     Prologue
*
      IRETURN=20

      Call StatusLine('RASSI:','Starting calculation')

      CALL GETPRINTLEVEL()


C Greetings. Default settings. Initialize data sets.
      CALL INIT_RASSI()

      CLOSEONE=.FALSE.
      IRC=-1
      IOPT=0
      CALL OPNONE(IRC,IOPT,'ONEINT',LUONE)
      IF (IRC.NE.0) Then
         WRITE (6,*) 'RASSI: Error opening file'
         CALL ABEND()
      END IF
      CLOSEONE=.TRUE.

C Read and check keywords etc. from stdin. Print out.
      CALL INPCTL_RASSI()

CSVC: prepare HDF5 wavefunction file
      CALL CRE_RASSIWFN

C--------  RAS wave function section --------------------------
C First, in a double loop over the states, compute any matrix
C elements required for the input RASSCF state pairs.
C Needed generalized transition density matrices are computed by
C GTDMCTL. They are written on unit LUTDM.
C Needed matrix elements are computed by PROPER.
      Call mma_allocate(OVLP,NSTATE,NSTATE,Label='OVLP')
      Call mma_allocate(DYSAMPS,NSTATE,NSTATE,Label='DYSAMPS')
      Call mma_allocate(EigVec,nState,nState,Label='EigVec')
      Call mma_allocate(ENERGY,nState,Label='Energy')
      Call mma_allocate(TocM,NSTATE*(NSTATE+1)/2,Label='TocM')
      Call mma_allocate(PROP,NSTATE,NSTATE,NPROP,LABEL='Prop')
      Prop(:,:,:)=0.0D0
      DYSAMPS(:,:)=0.0D0
*                                                                      *
************************************************************************
*                                                                      *
C Number of basis functions
      NZ=0                      ! (NBAS is already used...)
      DO ISY=1,NSYM
         NZ=NZ+NBASF(ISY)
      END DO
      IF (DYSO) Call mma_allocate(SFDYS,nZ,nState,nState,Label='SFDYS')

      if (doCoul) then
        call mma_allocate(eNucB,mxroot*(mxroot+1)/2,Label='eNuc')
        eNucB(:) = 0.0D0
        NZcoul = 0  ! (NBAS is already used...)
        nh1 = 0
        inquire(file='AUXRFIL2', exist=aux2)
        if (aux2) then
          call NameRun('AUXRFIL2')
        else
          call NameRun('AUXRFIL1')
        end if
        call get_iArray('nBas', nBas, nIrrep)
        NZcoul = nBas(0)
        nh1 = NZcoul*(NZcoul+1)/2
        call mma_allocate(vNucB, nh1, Label='Attr PotB')
        call Get_dArray('Nuc Potential', vNucB, nh1)
        call NameRun('#Pop')    ! switch back to old RUNFILE
      end if

C Loop over jobiphs:
      IDISK=0  ! Initialize disk address for TDMs.
      DO JOB1=1,NJOB
        DO JOB2=1,JOB1

        Fake_CMO2 = JOB1.eq.JOB2  ! MOs1 = MOs2  ==> Fake_CMO2=.true.

C Compute generalized transition density matrices, as needed:
          CALL GTDMCTL(PROP,JOB1,JOB2,OVLP,DYSAMPS,NZ,IDISK)
        END DO
      END DO

#ifdef _HDF5_
      CALL mh5_put_dset(wfn_overlap,OVLP,[NSTATE,NSTATE],[0,0])
#endif
      Call Put_dArray('State Overlaps',OVLP,NSTATE*NSTATE)

      IF(TRACK) CALL TRACK_STATE(OVLP)
      IF(TRACK.OR.ONLY_OVERLAPS) THEN

C       Print the overlap matrix here, since MECTL is skipped
        IF(IPGLOB.GE.2) THEN
          WRITE(6,*)
          WRITE(6,*)'     OVERLAP MATRIX FOR THE ORIGINAL STATES:'
          WRITE(6,*)
          DO ISTATE=1,NSTATE
            WRITE(6,'(5(1X,F15.8))')(Ovlp(j,iState),j=1,istate)
          END DO
        END IF
        GOTO 100
      END IF

C Property matrix elements:
      Call StatusLine('RASSI:','Computing matrix elements.')
      CALL MECTL(PROP,OVLP,HAM,ESHFT)
*                                                                      *
************************************************************************
*                                                                      *
*     Spin-free section
*
C--------  SI wave function section --------------------------
C In a second section, if Hamiltonian elements were requested,
C then also a set of secular equations are solved. This gives
C a set of non-interacting, orthonormal wave functions expressed
C as linear combinations of the input wave functions. These
C results are written out, as well as the matrix elements  of
C the eigenstates, and if requested, their density matrices
C and perhaps GTDMs.

C Hamiltonian matrix elements, eigenvectors:
      IF(IFHAM) THEN
        Call StatusLine('RASSI:','Computing Hamiltonian.')
        CALL EIGCTL(PROP,OVLP,DYSAMPS,HAM,EIGVEC,ENERGY)
      END IF

! +++ J. Creutzberg, J. Norell - 2018
! Write the spin-free Dyson orbitals to .DysOrb and .molden
! files if requested
*----------------------------------------------------------------

      IF (DYSEXPORT) THEN

C Bruno Tenorio, 2020. It writes now the new Dyson norms
C See e.g. DYSNORM.f subroutine.
       CALL WRITEDYS(DYSAMPS,SFDYS,NZ,ENERGY)
      END IF
! +++

C Loop over states to compute Excitonic Couplings

      if (DoExcitonics) then
        call EXCCOUPL()
      end if

*---------------------------------------------------------------------*
C Natural orbitals, if requested:
      IF(NATO) THEN
C CALCULATE AND WRITE OUT NATURAL ORBITALS.
        Call mma_allocate(DMAT,nBSQ,Label='DMAT')
        Call mma_allocate(TDMZZ,nTDMZZ,Label='TDMZZ')
        Call mma_allocate(VNAT,nBSQ,Label='VNAT')
        Call mma_allocate(OCC,nBST,Label='OCC')
*
        CALL NATORB_RASSI(DMAT,TDMZZ,VNAT,OCC,EIGVEC)
        CALL NATSPIN_RASSI(DMAT,TDMZZ,VNAT,OCC,EIGVEC)
*
        Call mma_deallocate(DMAT)
        Call mma_deallocate(TDMZZ)
        Call mma_deallocate(VNAT)
        Call mma_deallocate(OCC)
      END IF
C Bi-natural orbitals, if requested:
      IF (BINA) CALL BINAT()
*
      IF(.NOT.IFHAM) GOTO 100

*                                                                      *
************************************************************************
*                                                                      *
*      Spin_Orbit section
*
C-------- Spin-Orbit calculations   --------------------------
C In this third section, if spin-orbit coupling parameters were
C computed by the previous sections, then additionally the
C spin-orbit eigenfunctions and levels are computed.

C Nr of spin states and division of loops:
      NSS=0
      DO ISTATE=1,NSTATE
         JOB=JBNUM(ISTATE)
         MPLET=MLTPLT(JOB)
         NSS=NSS+MPLET
      END DO

      Call mma_allocate(USOR,NSS,NSS,Label='USOR')
      USOR(:,:)=0.0D0
      For All (i=1:NSS) USOR(i,i)=1.0D0
      Call mma_allocate(USOI,NSS,NSS,Label='USOI')
      USOI(:,:)=0.0D0
      Call mma_allocate(SOENE,nSS,Label='SOENE')
      SOENE(:)=0.0D0

      IF(IFSO) THEN
        Call StatusLine('RASSI:','Computing SO Hamiltonian.')
        CALL SOEIG(PROP,USOR,USOI,SOENE,NSS,ENERGY)
      END IF

C Store TDMs in HDF5
#ifdef _HDF5_
      Call StoreDens(EigVec)
#endif

! +++ J. Norell - 2018
C Make the SO Dyson orbitals and amplitudes from the SF ones

      IF (DYSO.AND.IFSO) THEN
         Call mma_allocate(SODYSAMPS,NSS,NSS,Label='SODYSAMPS')
         Call mma_allocate(SODYSAMPSR,NSS,NSS,Label='SODYSAMPSR')
         Call mma_allocate(SODYSAMPSI,NSS,NSS,Label='SODYSAMPSI')

         CALL SODYSORB(NSS,USOR,USOI,DYSAMPS,NZ,SOENE)
      END IF

      Call mma_deallocate(SFDYS,safe='*')
! +++

      CALL PRPROP(PROP,USOR,USOI,SOENE,NSS,OVLP,
     &            ENERGY,JBNUM,EigVec)


C Plot SO-Natural Orbitals if requested
C Will also handle mixing of states (sodiag.f)
      IF(SONATNSTATE.GT.0) CALL DO_SONATORB(NSS,USOR,USOI)
C Plot SO-Natural Transition Orbitals if requested
      IF(SONTOSTATES.GT.0) CALL DO_SONTO(NSS,USOR,USOI)

      Call mma_deallocate(USOR)
      Call mma_deallocate(USOI)
      Call mma_deallocate(SOENE)
      IF (DYSO.AND.IFSO) THEN
         Call mma_deallocate(SODYSAMPS)
         Call mma_deallocate(SODYSAMPSR)
         Call mma_deallocate(SODYSAMPSI)
      END IF
*                                                                      *
************************************************************************
*                                                                      *
*   Trajectory Surface Hopping                                         *
*                                                                      *
*   Turns on the procedure if the Keyword HOP was specified.           *
*                                                                      *
      IF (HOP) then
        Call StatusLine('RASSI:','Trajectory Surface Hopping')
        CALL TSHinit(ENERGY(:))
      END IF
*                                                                      *
************************************************************************
*                                                                      *
* CEH April 2015 DQV diabatization scheme
* This passes the PROP matrix into the DQV diabatization subroutine
* The subroutine will compute a transformation matrix, which is used
* to compute diabats.
*
* The user has to compute x, y, z, xx, yy, zz, 1/r in this order.

      IF (DQVD) then
        Call StatusLine('RASSI:', 'DQV Diabatization')
        CALL DQVDiabat(PROP,HAM)
      END IF
*                                                                      *
************************************************************************
*                                                                      *
*     EPILOGUE                                                         *
*                                                                      *
************************************************************************
*                                                                      *
 100  CONTINUE

      if (DoCoul) then
        if (.not. aux2) then
          call NameRun('AUXRFIL1')
          call Put_dArray('<rhoB|VnucA>', eNucB, mxroot*(mxroot+1)/2)
          call Cho_X_Final(irc)
          call NameRun('#Pop') ! switch back to old RUNFILE
          call mma_deallocate(VNucB)
          call mma_deallocate(eNucB)
        else
          call NameRun('AUXRFIL1')
          call Cho_X_Final(irc)
          call NameRun('#Pop')
          call mma_deallocate(VNucB)
          call mma_deallocate(eNucB)
        end if
      end if

      Call mma_deallocate(Ovlp)
      Call mma_deallocate(DYSAMPS)
      Call mma_deallocate(HAM)
      Call mma_deallocate(EigVec)
      Call mma_deallocate(Energy)
      Call mma_deallocate(ESHFT)
      Call mma_deallocate(HDIAG)
      Call mma_deallocate(jDisk_TDM)
      Call mma_deallocate(JBNUM)
      Call mma_deallocate(LROOT)
      Call mma_deallocate(TocM)
      Call mma_deallocate(Prop)

      If (Do_SK) Call mma_deallocate(k_Vector)

      IF (CLOSEONE) THEN
         IRC=-1
         CALL CLSONE(IRC,0)
         IF (IRC.NE.0) Then
            WRITE (6,*) 'RASSI: Error opening file'
            CALL ABEND()
         END IF
      END IF

#ifdef _DMRG_
!     !> finalize MPS-SI interface
      if (doDMRG)then
        call qcmaquis_interface_deinit
        call qcmaquis_info_deinit
      end if
#endif
!     > free memory (if allocated at all - currently only for QD-NEVPT2 as ref wfn)
      call deinit_mspt2_eigenvectors()
*                                                                      *
************************************************************************
*                                                                      *
*     Close dafiles.
*
      IF (SaveDens) Then
         Call DaClos(LuTDM)
         Call mma_deallocate(JOB_INDEX,safe='*')
         Call mma_deallocate(CMO1,safe='*')
         Call mma_deallocate(CMO2,safe='*')
         Call mma_deallocate(DMAB,safe='*')
      End If
      Call DaClos(LuExc)
*                                                                      *
************************************************************************
*                                                                      *
*     PRINT I/O STATISTICS:
      i=iPrintLevel(3)
      CALL FASTIO('STATUS')

      Call StatusLine('RASSI:','Finished.')
      IRETURN=0

      END SUBROUTINE RASSI
