************************************************************************
* 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)
      Implicit Real*8 (a-h,o-z)
#include "stdalloc.fh"
#include "Molcas.fh"
#include "commgo.fh"
#include "gsswfn.fh"
      Real*8, Dimension(:), Allocatable :: Fck, CMO, Ovl,
     &                                     T1, T2, T3, Eps
*----------------------------------------------------------------------*
* Dummy arguments                                                      *
*----------------------------------------------------------------------*
      Integer iReturncode, nOrb(8)
      Logical StandAlone
*----------------------------------------------------------------------*
* Local variables                                                      *
*----------------------------------------------------------------------*
      Character*180 Line
      Logical Debug
      Logical Trace
      Character*80 Title
      Logical Verify
*----------------------------------------------------------------------*
      Integer IndType(7,8)
      Integer nTmp(8)
      Integer nBasTot
      Integer nBasMax
      Integer nTriTot
      Integer nSqrTot
      Integer iSym
      Integer iBas
      Integer jBas
      Integer kBas
*----------------------------------------------------------------------*
      Integer inFck
      Integer inCMO
      Integer inOvl
      Integer inEps
      Integer inT1
      Integer inT2
      Integer inT3
*----------------------------------------------------------------------*
      Integer Lu
      Integer irc
      Integer iSymlb
      Integer ij,ijS,ijT,ijL
      Integer nB
      Integer nC
      Integer nS
      Integer nD
      Integer nActEl
      Real*8  dActEl
      Integer nIsh(8)
      Integer nAsh(8)
#ifdef _HDF5_
      Character(1), Allocatable :: typestring(:)
      Integer nZero(MxSym)
#endif
*----------------------------------------------------------------------*
* Some setup                                                           *
*----------------------------------------------------------------------*
      If(StandAlone) Then
         Debug=.false.
         Trace=.false.
      Else
         Debug=.false.
         Trace=.false.
      End If
      If(Trace) Then
         Write(6,*) '>>> Entering fckbyint'
         Call xflush(6)
      End If
      iReturncode=0
      Call getenvf('MOLCAS_TEST',Line)
      Verify = LINE(1:5).EQ.'CHECK' .or. LINE(1:4).EQ.'GENE'
      Verify = .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
      Call RdOne(irc,6,'FckInt  ',1,Fck,iSymlb)
      If (iRc.ne.0) Then
         iReturncode=1
         Call mma_deallocate(Fck)
         Write(6,*) '***'
         Write(6,*) '*** WARNING:'
         Write(6,*) '*** Guessorb did not produce start orbitals!!!'
         Write(6,*) '***'
         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
      Call RdOne(irc,6,'Mltpl  0',1,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.gt.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,
     &                  1.0d0,T1,nB,
     &                        T2,nB,
     &                  0.0d0,T3,nB)
            Call MxMt(T2,nB,1,
     &                T3,1,nB,
     &                Fck(ijT), nB,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.gt.0) Then
            Call Square(Fck(ijT),T1,1,nB,nB)
            Call DGEMM_('N','N',
     &                  nB,nS,nB,
     &                  1.0d0,T1,nB,
     &                        CMO(ijS),nB,
     &                  0.0d0,T2,nB)
            Call MxMt(CMO(ijS),nB,1,
     &                T2,1,nB,
     &                T3, nS,nB)
            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,0)
            Call goPickup(T3,Eps(ijL),nS)
            Call goSort(Eps(ijL),CMO(ijS),nS,nB)
*
            Do i = 1, nS
               tmp = OrbPhase(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.                                      *
*----------------------------------------------------------------------*
      If(.false.) Goto 900
      iRc=-1
      iSymlb=1
      Call RdOne(irc,6,'Kinetic ',1,Fck,iSymlb)
      If (iRc.ne.0) Goto 900
      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).lt.-1.0d-3) nC=nC+1
         End Do
         nS=nB-nC-nD
         If(nS.gt.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 (Verify)
     &      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,
     &                  1.0d0,T1,nB,
     &                        CMO(ijS+nB*nC),nB,
     &                  0.0d0,T2,nB)

            Call MxMt(CMO(ijS+nB*nC),nB,1,
     &                T2,1,nB,
     &                T3, nS,nB)
            If(Debug) Then
               Call TriPrt('Virtual space','(12f12.6)',T3,nS)
            End If
            Call NIdiag(T3,CMO(ijS+nB*nC),nS,nB,0)
            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 = 0.0d0
               Do kBas = 1, nB
                  ik = ijS+ (iBas-1)*nB + kBas -1
                  tmp1 = tmp1 + Abs(CMO(ik)*DBLE(kBas))
               End Do
               Do jBas = iBas+1, nB-nD
                  ej = Eps(ijL+jBas-1)
                  If (Abs(ei-ej).lt.1.0D-12) Then
                     tmp2 = 0.0d0
                     Do kBas = 1, nB
                        jk = ijS+ (jBas-1)*nB + kBas -1
                        tmp2 = tmp2 + Abs(CMO(jk)*DBLE(kBas))
                     End Do
                     If (tmp2.gt.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
               tmp = OrbPhase(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)+3.0d0
            End Do
            Do iBas=nB-nD+1,nB
               Eps(ijL+iBas-1)=999.0d0
            End Do
            Do iBas=1,nB-nD
               If(Eps(ijL+iBas-1).gt.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(6,'(a,e10.3)')
     &         'Threshold for linear dependence due to S:',SThr
         Write(6,'(a,e10.3)')
     &         'Threshold for linear dependence due to T:',TThr
         Write(6,*)
         Write(6,'(a,8i5)')   'Total number of basis functions',
     &      (nBas(iSym),iSym=1,nSym)
         Write(6,'(a,8i5)')   'Deleted orbitals               ',
     &      (nDel(iSym),iSym=1,nSym)
         Write(6,*)
      End If
*----------------------------------------------------------------------*
* Present data.                                                        *
*----------------------------------------------------------------------*
900   Continue
      inT1=nBasTot
      inT2=nBasTot
      Call mma_allocate(T1,inT1)
      Call mma_allocate(T2,inT2)
      Do iBas=1,nBasTot
         T1(iBas)=0.0d0
      End Do
      Call GoPop(Eps,T1,T2,nBasTot,PrintEor,PrThr,GapThr)
      iBas=0
      dActEl=0.0d0
      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).gt.1.99d0) Then
               IndType(2,iSym)=IndType(2,iSym)+1
               IndType(6,iSym)=IndType(6,iSym)-1
            Else If(T1(iBas).gt.0.01d0) 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+0.5d0)
      If(PrintMOs) then
         Call PriMO('Start orbitals (virtuals shifted)',
     &              .true.,.true.,0.0d0,PrThr,
     &              nSym,nBas,nBas,Label,Eps,T1,
     &              CMO,iPrFmt)
         Call xflush(6)
      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=0.0d0
      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_
      nZero=0
      call mma_allocate(typestring, nBasTot)
      call orb2tpstr(nSym,nBas,
     &        IndType(1,:),IndType(2,:),
     &        IndType(3,:),IndType(4,:),IndType(5,:),
     &        IndType(6,:),IndType(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,
     &                    1.0d0,CMO(jOff),Max(1,nBas(iSym)),
     &                          CMO(jOff),Max(1,nBas(iSym)),
     &                    0.0d0,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_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(6,*) '<<< Exiting fckbyint'
         Call xflush(6)
      End If
      Return
      End
