!***********************************************************************
! 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) 2004, Per-Olof Widmark                                 *
!***********************************************************************
!***********************************************************************
!                                                                      *
! This routine creates start orbitals from model fock matrix elements  *
! generated by SEWARD.                                                 *
!                                                                      *
!----------------------------------------------------------------------*
!                                                                      *
! Author:  Per-Olof Widmark                                            *
!          Lund University                                             *
!          Sweden                                                      *
! Written: Oct 2004                                                    *
!                                                                      *
!***********************************************************************

subroutine FckByInt(iReturncode,StandAlone)

use GuessOrb_Global, only: GapThr, iPrFmt, Label, nBas, nDel, nSym, PrintEor, PrintMOs, PrintPop, PrThr, SThr, TThr
#ifdef _HDF5_
use GuessOrb_Global, only: wfn_energy, wfn_mocoef, wfn_occnum, wfn_orbene, wfn_tpidx
use mh5, only: mh5_put_dset
#endif
use OneDat, only: sNoNuc, sNoOri
use stdalloc, only: mma_allocate, mma_deallocate
use Constants, only: Zero, One, Three, Half
use Definitions, only: wp, iwp, u6

implicit none

!----------------------------------------------------------------------*
! Dummy arguments                                                      *
!----------------------------------------------------------------------*
integer(kind=iwp), intent(out) :: iReturncode
logical(kind=iwp), intent(in) :: StandAlone
!----------------------------------------------------------------------*
! Local variables                                                      *
!----------------------------------------------------------------------*
real(kind=wp), allocatable :: Fck(:), CMO(:), Ovl(:), T1(:), T2(:), T3(:), Eps(:)
character(len=180) :: Line
character(len=80) :: Title
character(len=8) :: Lbl
logical(kind=iwp) :: Debug, Trace, Vrify
integer(kind=iwp) :: IndType(7,8), nOrb(8), nTmp(8), nBasTot, nBasMax, nTriTot, nSqrTot, iSym, iBas, jBas, kBas
integer(kind=iwp) :: inFck, inCMO, inOvl, inEps, inT1, inT2, inT3
integer(kind=iwp) :: Lu, iOpt, irc, iSymlb, ij, ijS, ijT, ijL, nB, nC, nS, nD, nActEl, nIsh(8), nAsh(8)
integer(kind=iwp) :: i, i1, ik, iComp, iOff, ipCOk, ipEE, ipEE0, ipOk, ipOk0, ipOkk, ipT1, j1, jk, jOff, k, kOff, kSpin, nOkk
real(kind=wp) :: dActEl, ei, ej, Enr_go, tmp, tmp1, tmp2, xocc
#ifdef _HDF5_
integer(kind=iwp) :: IndTypeT(8,7)
character(len=1), allocatable :: typestring(:)
#endif

!----------------------------------------------------------------------*
! Some setup                                                           *
!----------------------------------------------------------------------*
if (StandAlone) then
  Debug = .false.
  Trace = .false.
else
  Debug = .false.
  Trace = .false.
end if
if (Trace) then
  write(u6,*) '>>> Entering fckbyint'
  call xflush(u6)
end if
iReturncode = 0
call getenvf('MOLCAS_TEST',Line)
Vrify = LINE(1:5) == 'CHECK' .or. LINE(1:4) == 'GENE'
Vrify = .true.
!----------------------------------------------------------------------*
! Do some counting                                                     *
!----------------------------------------------------------------------*
nBasTot = 0
nBasMax = 0
nTriTot = 0
nSqrTot = 0
do iSym=1,nSym
  nBasTot = nBasTot+nbas(iSym)
  nBasMax = max(nbasmax,nBas(iSym))
  nTriTot = nTriTot+nBas(iSym)*(nBas(iSym)+1)/2
  nSqrTot = nSqrTot+nBas(iSym)*nBas(iSym)
end do
!----------------------------------------------------------------------*
! Get model Fock matrix.                                               *
!----------------------------------------------------------------------*
inFck = nTriTot+6
call mma_allocate(Fck,inFck)
iRc = -1
iSymlb = 1
iOpt = ibset(ibset(0,sNoOri),sNoNuc)
Lbl = 'FckInt'
iComp = 1
call RdOne(irc,iOpt,Lbl,iComp,Fck,iSymlb)
if (iRc /= 0) then
  iReturncode = 1
  call mma_deallocate(Fck)
  write(u6,*) '***'
  write(u6,*) '*** WARNING:'
  write(u6,*) '*** Guessorb did not produce start orbitals!!!'
  write(u6,*) '***'
  return
end if
if (Debug) then
  ij = 1
  do iSym=1,nSym
    !call TriPrt('FckInt','(12f12.6)',Fck(ij),nBas(iSym))
    call NrmClc(Fck(ij),nBas(iSym)*(nBas(iSym)+1)/2,'FckbyInt','Fck(ij)')
    ij = ij+nBas(iSym)*(nBas(iSym)+1)/2
  end do
end if
!----------------------------------------------------------------------*
! Make symmetric orthonormal orbital basis.                            *
!----------------------------------------------------------------------*
inCMO = nSqrTot
call mma_allocate(CMO,inCMO)
call goLowdin(CMO)
if (Debug) then
  ij = 1
  do iSym=1,nSym
    nB = nBas(iSym)
    !call RecPrt('CMO','(12f12.6)',CMO(ij),nB,nB)
    call NrmClC(CMO(ij),nB**2,'FckbyInt','CMO(ij)')
    ij = ij+nB*nB
  end do
end if
!----------------------------------------------------------------------*
! Get overlap matrix                                                   *
!----------------------------------------------------------------------*
inOvl = nTriTot+6
call mma_allocate(Ovl,inOvl)
iSymlb = 1
Lbl = 'Mltpl  0'
call RdOne(irc,iOpt,Lbl,iComp,Ovl,iSymlb)
if (Debug) then
  ipT1 = 1
  do iSym=1,nSym
    !call TriPrt('Ovlp','(12f12.6)',Ovl(ipT1),nBas(iSym))
    call NrmClc(Ovl(ipT1),nBas(iSym)*(nBas(iSym)+1)/2,'FckbyInt','Ovl(ipT1)')
    ipT1 = ipT1+nBas(iSym)*(nBas(iSym)+1)/2
  end do
end if
!----------------------------------------------------------------------*
! Transform: F = S eps S                                               *
!----------------------------------------------------------------------*
inT1 = nBasMax*nBasMax
inT2 = nBasMax*nBasMax
inT3 = nBasMax*nBasMax
call mma_allocate(T1,inT1)
call mma_allocate(T2,inT2)
call mma_allocate(T3,inT3)
ijT = 1
ijS = 1
ijL = 1
do iSym=1,nSym
  nB = nBas(iSym)
  if (nB > 0) then
    call Square(Fck(ijT),T1,1,nB,nB)
    call Square(Ovl(ijT),T2,1,nB,nB)
    call DGEMM_('N','N',nB,nB,nB,One,T1,nB,T2,nB,Zero,T3,nB)
    call DGEMM_Tri('T','N',nB,nB,nB,One,T2,nB,T3,nB,Zero,Fck(ijT),nB)
    if (Debug) then
      !call TriPrt('Fock matrix with metric','(12f12.6)',Fck(ijT),nB)
      call NrmClc(Fck(ijT),nB*(nB+1)/2,'FckbyInt','Fck(ijT)')
    end if
  end if
  ijT = ijT+nB*(nB+1)/2
  ijS = ijS+nB*nB
  ijL = ijL+nB
end do
call mma_deallocate(T3)
call mma_deallocate(T2)
call mma_deallocate(T1)
!----------------------------------------------------------------------*
! Diagonalize the model Fock matrix                                    *
!----------------------------------------------------------------------*
inEps = nBasTot
call mma_allocate(Eps,inEps)
inT1 = nBasMax*nBasMax
inT2 = nBasMax*nBasMax
inT3 = nBasMax*nBasMax
call mma_allocate(T1,inT1)
call mma_allocate(T2,inT2)
call mma_allocate(T3,inT3)
ijT = 1
ijS = 1
ijL = 1
do iSym=1,nSym
  nB = nBas(iSym)
  nS = nBas(iSym)-nDel(iSym)
  if (nB > 0) then
    call Square(Fck(ijT),T1,1,nB,nB)
    call DGEMM_('N','N',nB,nS,nB,One,T1,nB,CMO(ijS),nB,Zero,T2,nB)
    call DGEMM_Tri('T','N',nS,nS,nB,One,CMO(ijS),nB,T2,nB,Zero,T3,nS)
    if (Debug) then
      !call TriPrt('Transformed Fock matrix','(12f12.6)',T3,nB)
      call NrmClc(T3,nB*(nB+1)/2,'FckbyInt','Transformed Fck')
    end if
    call NIdiag(T3,CMO(ijS),nS,nB)
    call goPickup(T3,Eps(ijL),nS)
    call goSort(Eps(ijL),CMO(ijS),nS,nB)

    do i=1,nS
      call VecPhase(CMO(ijS+(i-1)*nB),nB)
    end do
  end if
  ijT = ijT+nB*(nB+1)/2
  ijS = ijS+nB*nB
  ijL = ijL+nB
end do
if (Debug) then
  ij = 1
  do iSym=1,nSym
    nB = nBas(iSym)
    !call RecPrt('CMO','(12f12.6)',CMO(ij),nB,nB)
    call NrmClC(CMO(ij),nB**2,'FckbyInt','CMO(ij)')
    ij = ij+nB*nB
  end do
end if
call mma_deallocate(T3)
call mma_deallocate(T2)
call mma_deallocate(T1)
!----------------------------------------------------------------------*
! Diagonalize T in virtual space.                                      *
!----------------------------------------------------------------------*
dummy: if (.true.) then
  iRc = -1
  iSymlb = 1
  Lbl = 'Kinetic'
  call RdOne(irc,iOpt,Lbl,iComp,Fck,iSymlb)
  ifrc: if (iRc == 0) then
    inT1 = nBasMax*nBasMax
    inT2 = nBasMax*nBasMax
    inT3 = nBasMax*nBasMax
    call mma_allocate(T1,inT1)
    call mma_allocate(T2,inT2)
    call mma_allocate(T3,inT3)
    ijT = 1
    ijS = 1
    ijL = 1
    do iSym=1,nSym
      nB = nBas(iSym)
      nD = nDel(iSym)
      nC = 0
      do iBas=1,nB-nD
        if (Eps(ijL+iBas-1) < -1.0e-3_wp) nC = nC+1
      end do
      nS = nB-nC-nD
      if (nS > 0) then

        ! Generate standardized virtual orbitals before we proceed.
        ! The virtual orbitals generated previously are not well
        ! defined and might differ substantially with different
        ! hardware/software and compiler options. To be able to
        ! compare we will need these standardized virtual orbitals.
        ! In real production calculations this step could for all
        ! practical purposes be skipped.

        if (Vrify) call Virt_Space(CMO(ijS),CMO(ijS+nB*nC),Ovl(ijT),nB,nC,nS)

        call Square(Fck(ijT),T1,1,nB,nB)
        call DGEMM_('N','N',nB,nS,nB,One,T1,nB,CMO(ijS+nB*nC),nB,Zero,T2,nB)

        call DGEMM_Tri('T','N',nS,nS,nB,One,CMO(ijS+nB*nC),nB,T2,nB,Zero,T3,nS)
        if (Debug) then
          call TriPrt('Virtual space','(12f12.6)',T3,nS)
        end if
        call NIdiag(T3,CMO(ijS+nB*nC),nS,nB)
        call goPickup(T3,Eps(ijL+nC),nS)
        call goSort(Eps(ijL+nC),CMO(ijS+nB*nC),nS,nB)
        if (Debug) then
          call RecPrt('Eps',' ',Eps(ijL+nC),nS,1)
          call RecPrt('Virtual Orbitals',' ',CMO(ijS+nB*nC),nB,nS)
        end if

        ! Now order degenerate orbitals. This is only important for
        ! verification runs.

        do iBas=nC+1,nB-nD-1
          ei = Eps(ijL+iBas-1)
          tmp1 = Zero
          do kBas=1,nB
            ik = ijS+(iBas-1)*nB+kBas-1
            tmp1 = tmp1+abs(CMO(ik)*real(kBas,kind=wp))
          end do
          do jBas=iBas+1,nB-nD
            ej = Eps(ijL+jBas-1)
            if (abs(ei-ej) < 1.0e-12_wp) then
              tmp2 = Zero
              do kBas=1,nB
                jk = ijS+(jBas-1)*nB+kBas-1
                tmp2 = tmp2+abs(CMO(jk)*real(kBas,kind=wp))
              end do
              if (tmp2 > tmp1) then
                tmp = tmp2
                tmp2 = tmp1
                tmp1 = tmp
                Eps(ijL+iBas-1) = ej
                Eps(ijL+jBas-1) = ei
                ei = ej
                i1 = ijS+(iBas-1)*nB
                j1 = ijS+(jBas-1)*nB
                call DSwap_(nB,CMO(i1),1,CMO(j1),1)
              end if
            end if

          end do
        end do

        ! Introduce "standard" phase.

        do iBas=1,nB
          call VecPhase(CMO(ijS+(iBas-1)*nB),nB)
        end do

        if (Debug) then
          call RecPrt('Eps',' ',Eps(ijL+nC),nS,1)
          call RecPrt('Virtual Orbitals',' ',CMO(ijS+nB*nC),nB,nS)
        end if
        do iBas=nC+1,nB-nD
          Eps(ijL+iBas-1) = Eps(ijL+iBas-1)+Three
        end do
        do iBas=nB-nD+1,nB
          Eps(ijL+iBas-1) = 999.0_wp
        end do
        do iBas=1,nB-nD
          if (Eps(ijL+iBas-1) > TThr) nDel(iSym) = nDel(iSym)+1
        end do
      end if
      ijT = ijT+nB*(nB+1)/2
      ijS = ijS+nB*nB
      ijL = ijL+nB
    end do
    call mma_deallocate(T3)
    call mma_deallocate(T2)
    call mma_deallocate(T1)
    !----------------------------------------------------------------------*
    ! Print orbital space data.                                            *
    !----------------------------------------------------------------------*
    if (StandAlone) then
      write(u6,'(a,es10.3)') 'Threshold for linear dependence due to S:',SThr
      write(u6,'(a,es10.3)') 'Threshold for linear dependence due to T:',TThr
      write(u6,*)
      write(u6,'(a,8i5)') 'Total number of basis functions',(nBas(iSym),iSym=1,nSym)
      write(u6,'(a,8i5)') 'Deleted orbitals               ',(nDel(iSym),iSym=1,nSym)
      write(u6,*)
    end if
  end if ifrc
end if dummy
!----------------------------------------------------------------------*
! Present data.                                                        *
!----------------------------------------------------------------------*
inT1 = nBasTot
inT2 = nBasTot
call mma_allocate(T1,inT1)
call mma_allocate(T2,inT2)
do iBas=1,nBasTot
  T1(iBas) = Zero
end do
call GoPop(Eps,T1,T2,nBasTot,PrintEor,PrThr,GapThr)
iBas = 0
dActEl = Zero
do iSym=1,nSym
  IndType(1,iSym) = 0
  IndType(2,iSym) = 0
  IndType(3,iSym) = 0
  IndType(4,iSym) = 0
  IndType(5,iSym) = 0
  IndType(6,iSym) = nBas(iSym)-nDel(iSym)
  IndType(7,iSym) = nDel(iSym)
  do kBas=1,nBas(iSym)-nDel(iSym)
    iBas = iBas+1
    if (T1(iBas) > 1.99_wp) then
      IndType(2,iSym) = IndType(2,iSym)+1
      IndType(6,iSym) = IndType(6,iSym)-1
    else if (T1(iBas) > 0.01_wp) then
      IndType(4,iSym) = IndType(4,iSym)+1
      IndType(6,iSym) = IndType(6,iSym)-1
      dActEl = dActEl+T1(iBas)
    end if
  end do
end do
nActEl = int(dActEl+Half)
if (PrintMOs) then
  call PriMO('Start orbitals (virtuals shifted)',.true.,.true.,Zero,PrThr,nSym,nBas,nBas,Label,Eps,T1,CMO,iPrFmt)
  call xflush(u6)
end if
if (PrintPop) then
  call Charge(nSym,nBas,Label,CMO,T1,Ovl,2,.true.,.true.)
end if
call put_darray('Guessorb',CMO,nSqrTot)
call put_darray('Guessorb energies',Eps,nBasTot)
do iSym=1,nSym
  nOrb(iSym) = nBas(iSym)-nDel(iSym)
end do
call Put_iArray('nOrb',nOrb,nSym)
call Put_iArray('nDel_go',nDel,nSym)
call Put_iArray('nDel',nDel,nSym)
do iSym=1,nSym
  nTmp(iSym) = IndType(2,iSym)
  nIsh(iSym) = nTmp(iSym)
end do
call Put_iArray('nIsh',nTmp,nSym)
do iSym=1,nSym
  nTmp(iSym) = IndType(4,iSym)
  nAsh(iSym) = nTmp(iSym)
end do
call Put_iArray('nAsh',nTmp,nSym)
call Put_iScalar('nActel',nActEl)
kSpin = 1 ! always same alpha and beta orbs
call Put_iScalar('Multiplicity',kSpin)
Enr_go = Zero
ipEE0 = 1
ipOk0 = 1
do iSym=1,nSym
  do i=0,nIsh(iSym)+nAsh(iSym)-1
    ipEE = ipEE0+i
    ipOk = ipOk0+i
    Enr_go = Enr_go+T1(ipOk)*Eps(ipEE)
  end do
  ipEE0 = ipEE0+nBas(iSym)
  ipOk0 = ipOk0+nBas(iSym)
end do
call Put_dScalar('Last energy',Enr_go)
#ifdef _HDF5_
call mh5_put_dset(wfn_energy,Enr_go)
#endif
Lu = 20
Title = 'Guess orbitals'
call WrVec('GSSORB',Lu,'COEI',nSym,nBas,nBas,CMO,T1,Eps,IndType,Title)
#ifdef _HDF5_
IndTypeT(:,:) = transpose(IndType(:,:))
call mma_allocate(typestring,nBasTot)
call orb2tpstr(nSym,nBas,IndTypeT(:,1),IndTypeT(:,2),IndTypeT(:,3),IndTypeT(:,4),IndTypeT(:,5),IndTypeT(:,6),IndTypeT(:,7), &
               typestring)
call mh5_put_dset(wfn_tpidx,typestring)
call mma_deallocate(typestring)
call mh5_put_dset(wfn_mocoef,CMO)
call mh5_put_dset(wfn_occnum,T1)
call mh5_put_dset(wfn_orbene,Eps)
#endif

! Compute density matrix (re-use memory allocated in Ovl)
iOff = 1
jOff = 1
kOff = 1
do iSym=1,nSym
  ipOkk = iOff
  nOkk = nIsh(iSym)+nAsh(iSym)
  ipCOk = jOff
  do k=0,nOkk-1
    xocc = sqrt(T1(k+ipOkk))
    call dscal_(nBas(iSym),xocc,CMO(ipCOk),1)
    ipCOk = ipCOk+nBas(iSym)
  end do
  call DGEMM_Tri('N','T',nBas(iSym),nBas(iSym),nOkk,One,CMO(jOff),max(1,nBas(iSym)),CMO(jOff),max(1,nBas(iSym)),Zero,Ovl(kOff), &
                 max(1,nBas(iSym)))
  iOff = iOff+nBas(iSym)
  jOff = jOff+nBas(iSym)**2
  kOff = kOff+nBas(iSym)*(nBas(iSym)+1)/2
end do
call Fold_tMat(nSym,nBas,Ovl,Ovl)
call Put_dArray('D1ao',Ovl,nTriTot)

call mma_deallocate(T2)
call mma_deallocate(T1)
!----------------------------------------------------------------------*
! Done, deallocate the rest.                                           *
!----------------------------------------------------------------------*
call mma_deallocate(Eps)
call mma_deallocate(Ovl)
call mma_deallocate(CMO)
call mma_deallocate(Fck)
if (Trace) then
  write(u6,*) '<<< Exiting fckbyint'
  call xflush(u6)
end if

return

end subroutine FckByInt
