DetPreFreezeInit_old Subroutine

public subroutine DetPreFreezeInit_old()

Arguments

None

Contents

Source Code


Source Code

    Subroutine DetPreFreezeInit_old()
        integer :: ierr, ms, iEl, flagAlpha, msTmp
        integer :: i, j, Lz, OrbOrder(8, 2), FDetTemp(NEl)
        type(BasisFn) s
        logical :: tGenFDet
        HElement_t(dp) :: OrbE
        character(25), parameter :: this_routine = 'DetPreFreezeInit_old'
        allocate (FDet(nEl), stat=ierr)
        LogAlloc(ierr, 'FDet', nEl, 4, tagFDet)
        IF (tDefineDet) THEN
            write (stdout, *) 'Defining FDet according to input'
            do i = 1, NEl
                FDet(i) = DefDet(i)
            end do
            call assignOccOrbs()

            ! A quick check that we have defined a reasonable det.
            ms = sum(get_spin_pn(fdet(1:nel)))
            if (abs(ms) /= abs(lms)) then
                write (stdout, *) 'LMS', lms
                write (stdout, *) 'Calculated Ms', ms
                call stop_all(this_routine, "Defined determinant has the &
                     &wrong Ms value. Change DEFINEDET or &
                     &SPIN-RESTRICT")
            end if

            if (tGUGA) then
                ms = abs(ms)
                if (ms < 0 .or. ms /= STOT) then
                    write (stdout, *) "S: ", STOT
                    write (stdout, *) "calculated S of inputted CSF: ", ms
                    call stop_all(this_routine, " Defined CSF has the &
                        &wrong total spin quantum number. Change DEFINEDET or &
                        &S quantum numnber!")
                end if
            end if

            tRef_Not_HF = .true.
        else
            if ((sum(nOccOrbs) + sum(nClosedOrbs)) == nel) then
                tGenFDet = .false.
                iEl = 1
                msTmp = -1 * lms
                do i = 1, nIrreps
                    ! doubly occupy the closed orbs
                    do j = 1, nClosedOrbs(i)
                        FDet(iEl) = irrepOrbOffset(i) + 2 * j - 1
                        iEl = iEl + 1
                        FDet(iEl) = irrepOrbOffset(i) + 2 * j
                        iEl = iEl + 1
                    end do
                    ! now distribute electrons to the open orbs
                    ! such that the total sz matches the requested
                    ! only consider occ orbs which are not closed
                    do j = nClosedOrbs(i) + 1, nOccOrbs(i)
                        if (msTmp < 0) then
                            flagAlpha = 0
                        else
                            flagAlpha = 1
                        end if
                        FDet(iEl) = irrepOrbOffset(i) + 2 * j - flagAlpha
                        iEl = iEl + 1
                        msTmp = msTmp + (1 - 2 * flagAlpha)
                    end do
                end do
                call sort(FDet)
            else
                CALL GENFDET(FDET)
                call assignOccOrbs()
                IF (tUEGSpecifyMomentum) THEN
                    write (stdout, *) 'Defining FDet according to a momentum input'
                    CALL ModifyMomentum(FDET)
                end if
                tRef_Not_HF = .false.
            end if
        end if
        write (stdout, "(A)", advance='no') " Fermi det (D0):"
        call write_det(stdout, FDET, .true.)
        Call GetSym(FDet, nEl, G1, nBasisMax, s)
        write (stdout, "(A)", advance='no') " Symmetry: "
        Call writesym(stdout, s%Sym, .true.)
        IF (tFixLz) THEN
            Call GetLz(FDet, nEl, Lz)
            write (stdout, "(A,I5)") "Lz of Fermi det:", Lz
        end if
        CALL NECI_ICOPY(NEL, FDET, 1, NUHFDET, 1)
        if (tMolpro) then
            !Orbitals are ordered by occupation number from MOLPRO, and not reordered in NECI
            !Therefore, we know HF determinant is first four occupied orbitals.
            write (stdout, "(A)") "NECI called from MOLPRO, so assuming orbitals ordered by occupation number."
            if (.not. tDefineDet) then
                FDetTemp(:) = FDet(:)
            else
                !We have defined our own reference determinant, but still use the first orbitals for the calculation
                !of 'orbital energies'
                CALL GENFDET(FDETTEMP)
            end if
            write (stdout, "(A)") "Calculating orbital energies..."
            do i = 1, nBasis
                OrbE = CalcFockOrbEnergy(i, FDetTemp)
                Arr(i, 1) = real(OrbE, dp)
                Brr(i) = i
            end do
            write (stdout, "(A)") "Reordering basis by orbital energies..."
            OrbOrder(:, :) = 0
            call ORDERBASIS(NBASIS, Arr, Brr, OrbOrder, nBasisMax, G1)
            !However, we reorder them here
            call writebasis(stdout, G1, nBasis, Arr, Brr)
        end if
        E0HFDET = ECORE
        DO I = 1, NEL
            E0HFDET = E0HFDET + ARR(NUHFDET(i), 2)
        end do
        write (stdout, *) "Fock operator energy:", E0HFDET

        ! Store the value of Ms for use in other areas
        calculated_ms = sum(get_spin_pn(fdet(1:nel)))

        if (tGUGA) then
            calculated_ms = abs(calculated_ms)
        end if

    contains

        subroutine assignOccOrbs
            integer :: k
            ! assign the occ/closed orbs
            nOccOrbs = 0
            nClosedOrbs = 0
            do k = 1, nel
                if (k > 1) then
                    if (is_alpha(FDet(k)) .and. FDet(k - 1) == FDet(k) - 1) then
                        ! we do not need to resolve the irrep anymore (not relevant
                        ! for further usage)
                        nClosedOrbs(1) = nClosedOrbs(1) + 1
                        cycle
                    end if
                end if
                nOccOrbs(1) = nOccOrbs(1) + 1
            end do
        end subroutine assignOccOrbs
    End Subroutine DetPreFreezeInit_old