! Molecular Orbital PACkage (MOPAC)
! Copyright (C) 2021, Virginia Polytechnic Institute and State University
!
! MOPAC is free software: you can redistribute it and/or modify it under
! the terms of the GNU Lesser General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! MOPAC is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public License
! along with this program.  If not, see <https://www.gnu.org/licenses/>.

      subroutine diag(fao, vector, nocc, eig, mdim, n)
      use molkst_C, only : norbs, mpack
      implicit none
      integer , intent(in) :: nocc
      integer , intent(in) :: mdim
      integer , intent(in) :: n
      double precision , intent(in) :: fao(mpack)
      double precision , intent(inout) :: vector(mdim,mdim)
      double precision , intent(in) :: eig(mdim)
!
      integer :: lumo, ij, i, kk, j, k, j1, k2, m
      double precision, dimension(norbs) :: ws
      double precision ::  bigeps = 1.5d-007, tiny, sum, a, b, c, d, e, alpha, beta
      double precision, allocatable :: fmo(:)
!***********************************************************************
!
!   "FAST" DIAGONALISATION PROCEDURE.
!
!    ON INPUT FAO CONTAINS THE LOWER HALF TRIANGLE OF THE MATRIX TO BE
!                         DIAGONALISED, PACKED.
!             VECTOR  CONTAINS THE OLD EIGENVECTORS ON INPUT, THE NEW
!             VECTORS ON EXITING.
!             NOCC = NUMBER OF OCCUPIED MOLECULAR ORBITALS.
!             EIG  = EIGENVALUES FROM AN EXACT DIAGONALISATION
!             MDIM = DECLARED SIZE OF MATRIX "C".
!             N = NUMBER OF ATOMIC ORBITALS IN BASIS SET
!
!  DIAG IS A PSEUDO-DIAGONALISATION PROCEDURE, IN THAT THE VECTORS THAT
!       ARE GENERATED BY IT ARE MORE NEARLY ABLE TO BLOCK-DIAGONALISE
!       THE FOCK MATRIX OVER MOLECULAR ORBITALS THAN THE STARTING
!       VECTORS. IT MUST BE CONSIDERED PSEUDO FOR SEVERAL REASONS:
!       (A) IT DOES NOT GENERATE EIGENVECTORS - THE SECULAR DETERMINANT
!           IS NOT DIAGONALISED, ONLY THE OCCUPIED-VIRTUAL INTERSECTION.
!       (B) MANY SMALL ELEMENTS IN THE SEC.DET. ARE IGNORED AS BEING TOO
!           SMALL COMPARED WITH THE LARGEST ELEMENT.
!       (C) WHEN ELEMENTS ARE ELIMINATED BY ROTATION, THE REST OF THE
!           SEC. DET. IS ASSUMED NOT TO CHANGE, I.E. ELEMENTS CREATED
!           ARE IGNORED.
!       (D) THE ROTATION REQUIRED TO ELIMINATE THOSE ELEMENTS CONSIDERED
!           SIGNIFICANT IS APPROXIMATED TO USING THE EIGENVALUES OF THE
!           EXACT DIAGONALISATION THROUGHOUT THE REST OF THE ITERATIVE
!           PROCEDURE.
!
!  (NOTE:- IN AN ITERATIVE PROCEDURE ALL THE APPROXIMATIONS PRESENT IN
!          DIAG BECOME VALID AT SELF-CONSISTENCY, SELF-CONSISTENCY IS
!          NOT SLOWED DOWN BY USE OF THESE APPROXIMATIONS)
!
!    REFERENCE:
!             "FAST SEMIEMPIRICAL CALCULATIONS",
!             STEWART. J.J.P., CSASZAR, P., PULAY, P., J. COMP. CHEM.,
!             3, 227, (1982)
!
!***********************************************************************
!
!  FIRST, CONSTRUCT THAT PART OF A SECULAR DETERMINANT OVER MOLECULAR
!  ORBITALS WHICH CONNECTS THE OCCUPIED AND VIRTUAL SETS.
!
!***********************************************************************
!


      allocate(fmo(mpack))
      tiny = 0.D0
      lumo = nocc + 1
      ij = 0
      do i = lumo, n
        kk = 0
        do j = 1, n
          sum = 0.D0
          do k = 1, j
            kk = kk + 1
            sum = sum + fao(kk)*vector(k,i)
          end do
          if (j /= n) then
            j1 = j + 1
            k2 = kk
            do k = j1, n
              k2 = k2 + k - 1
              sum = sum + fao(k2)*vector(k,i)
            end do
          end if
          ws(j) = sum
        end do
        do j = 1, nocc
          ij = ij + 1
          sum = 0.D0
          do k = 1, n
            sum = sum + ws(k)*vector(k,j)
          end do
          tiny = dmax1(abs(sum),tiny)
          fmo(ij) = sum
        end do
      end do
      tiny = 0.05D0*tiny



!***********************************************************************
!
!   NOW DO A CRUDE 2 BY 2 ROTATION TO "ELIMINATE" SIGNIFICANT ELEMENTS
!
!***********************************************************************
      ij = 0
!      k = 0

!
      do i = lumo, n
        do j = 1, nocc
          ij = ij + 1
          if (abs(fmo(ij)) < tiny) cycle
!
!      BEGIN 2 X 2 ROTATIONS
!
          a = eig(j)
          b = eig(i)
          c = fmo(ij)
          d = a - b
!
!    USE BIGEPS TO DETERMINE WHETHER TO DO A 2 BY 2 ROTATION
!
          if (abs(c/d) < bigeps) cycle
!
!  AT THIS POINT WE KNOW THAT
          e = sign(sqrt(4.D0*c*c + d*d),d)
          alpha = sqrt(0.5D0*(1.D0 + d/e))
          beta = -sign(sqrt(1.D0 - alpha*alpha),c)
!
!      ROTATION OF PSEUDO-EIGENVECTORS
!
! GBR test
!          k = k + 1
!
          do m = 1, n
            a = vector(m,j)
            b = vector(m,i)
            vector(m,j) = alpha*a + beta*b
            vector(m,i) = alpha*b - beta*a
          end do
          continue
        end do
      end do

! GBR test
!      write(iw,*) ' Number of Jacobi rotations in diag = ',k
!

      return
      end subroutine diag
