SUBROUTINE ORDERBASIS(NBASIS, ARR, BRR, ORBORDER, NBASISMAX, G1)
INTEGER NBASIS, BRR(NBASIS), ORBORDER(8, 2), nBasisMax(5, *)
INTEGER BRR2(NBASIS)
TYPE(BASISFN) G1(NBASIS)
real(dp) ARR(NBASIS, 2), ARR2(NBASIS, 2)
INTEGER IDONE, I, J, IBFN, ITOT, ITYPE, ISPIN
real(dp) OEN
character(*), parameter :: this_routine = 'ORDERBASIS'
IDONE = 0
ITOT = 0
!.. copy the default ordered energies.
CALL DCOPY(NBASIS, ARR(1, 1), 1, ARR(1, 2), 1)
CALL DCOPY(NBASIS, ARR(1, 1), 1, ARR2(1, 2), 1)
write(stdout, *) ''
write(stdout, "(A,8I4)") "Ordering Basis (Closed): ", (ORBORDER(I, 1), I=1, 8)
write(stdout, "(A,8I4)") "Ordering Basis (Open ): ", (ORBORDER(I, 2), I=1, 8)
IF (NBASISMAX(3, 3) == 1) THEN
!.. we use the symmetries of the spatial orbitals
! actually this is never really used below here it seems.. since orborder
! is only zeros, according to output. check that!
! and that is independent of the GUGA implementation TODO: check orborder!
DO ITYPE = 1, 2
IBFN = 1
DO I = 1, 8
! 8 probably because at most D2h symmetry giovanni told me about.
DO J = 1, ORBORDER(I, ITYPE)
DO WHILE (IBFN <= NBASIS .AND. (G1(IBFN)%SYM%s < I - 1 .OR. BRR(IBFN) == 0))
IBFN = IBFN + 1
end do
IF (IBFN > NBASIS) THEN
call stop_all(this_routine, "Cannot find enough basis fns of correct symmetry")
end if
IDONE = IDONE + 1
BRR2(IDONE) = IBFN
BRR(IBFN) = 0
ARR2(IDONE, 1) = ARR(IBFN, 1)
IBFN = IBFN + 1
end do
end do
! Beta sort
call sort(arr2(itot + 1:idone, 1), brr2(itot + 1:idone), nskip=2)
! Alpha sort
call sort(arr2(itot + 2:idone, 1), brr2(itot + 2:idone), nskip=2)
ITOT = IDONE
end do
DO I = 1, NBASIS
IF (BRR(I) /= 0) THEN
ITOT = ITOT + 1
BRR2(ITOT) = BRR(I)
ARR2(ITOT, 1) = ARR(I, 1)
end if
end do
! what are those doing?
! ok those are copying the newly obtained arr2 and brr2 into arr and brr
CALL NECI_ICOPY(NBASIS, BRR2, 1, BRR, 1)
CALL DCOPY(NBASIS, ARR2(1, 1), 1, ARR(1, 1), 1)
end if
! i think this is the only reached point: and this means i can make it
! similar to the Hubbard implementation to not reorder!
! beta sort
call sort(arr(idone + 1:nbasis, 1), brr(idone + 1:nbasis), nskip=2)
! alpha sort
call sort(arr(idone + 2:nbasis, 1), brr(idone + 2:nbasis), nskip=2)
!.. We need to now go through each set of degenerate orbitals, and make
!.. the correct ones are paired together in BRR otherwise bad things
!.. happen in FREEZEBASIS
!.. We do this by ensuring that within a degenerate set, the BRR are in
!.. ascending order
! IF(NBASISMAX(3,3).EQ.1) G1(3,BRR(1))=J
DO ISPIN = 0, 1
OEN = ARR(1 + ISPIN, 1)
J = 1 + ISPIN
ITOT = 2
DO I = 3 + ISPIN, NBASIS, 2
IF (ABS(ARR(I, 1) - OEN) > 1.0e-4_dp) THEN
!.. We don't have degenerate orbitals
!.. First deal with the last set of degenerate orbitals
!.. We sort them into order of BRR
call sort(brr(i - itot:i - 1), arr(i - itot:i - 1, 1), nskip=2)
!.. now setup the new degenerate set.
J = J + 2
ITOT = 2
ELSE
ITOT = ITOT + 2
end if
OEN = ARR(I, 1)
IF (NBASISMAX(3, 3) == 1) THEN
!.. If we've got a generic spatial sym or hf we mark degeneracies
! G(3,BRR(I))=J
end if
end do
! i is now nBasis+2
call sort(brr(i - itot:i - 2), arr(i - itot:i - 2, 1), nskip=2)
end do
! if (t_guga_noreorder) then
! ! this probably does not work so easy:
! allocate(temp_sym(nBasis))
! do i = 1, nBasis
! temp_sym(i) = G1(i)
! end do
! do i = 1, nBasis
! G1(i) = temp_sym(brr(i))
! brr(i) = i
! end do
! ! could i just do a new molpsymtable here??
! ! but only do it if symmetry is not turned off explicetyl!
! if (.not. lNoSymmetry) CALL GENMOLPSYMTABLE(NBASISMAX(5,2)+1,G1,NBASIS)
! end if
END subroutine ORDERBASIS