PrintRepeatROFCIDUMP Subroutine

    subroutine PrintRepeatROFCIDUMP()

        ! This prints out a new FCIDUMP file in the same format as the old one.

        integer :: i, j, k, l, ierr, a, b, g, d, iunit
        character(len=5) :: Label
        character(len=20) :: LabelFull
        character(len=*), parameter :: this_routine = 'PrintRepeatROFCIDUMP'

        PrintROFCIDUMP_Time%timer_name = 'PrintROFCIDUMP'
        call set_timer(PrintROFCIDUMP_Time, 30)

        Label = ''
        LabelFull = ''
        write(Label, '(I5)') NoFrozenVirt
        LabelFull = 'ROFCIDUMP-'//adjustl(Label)

        iunit = get_free_unit()
        open(iunit, file=LabelFull, status='unknown')

        write(iunit, '(2A6, I3, A7, I3, A5, I2, A)') '&FCI ', 'NORB = ', (NoOrbs - (NoFrozenVirt)), ', NELEC = ', NEl, ', MS2 = ', LMS, ','
        write(iunit, '(A9)', advance='no') 'ORBSYM = '
        do i = 1, (NoOrbs - (NoFrozenVirt))
            if ((tUseMP2VarDenMat .or. tFindCINatOrbs) .and. (.not. lNoSymmetry) .and. tTruncRODump) then
                write(iunit, '(I1, A1)', advance='no') (SymOrbs_rot(i) + 1), ','
            else
                if (tStoreSpinOrbs) then
                    write(iunit, '(I1, A1)', advance='no') (int(G1(i)%sym%S) + 1), ','
                else
                    write(iunit, '(I1, A1)', advance='no') (int(G1(i * 2)%sym%S) + 1), ','
                end if
            end if
        end do
        write(iunit, *) ''
        if (tStoreSpinOrbs) then
            write(iunit, '(A7, I1, A11)') 'ISYM = ', 1, ' UHF = .TRUE.'
        else
            write(iunit, '(A7, I1)') 'ISYM = ', 1
        end if
        write(iunit, '(A5)') '&end'

        allocate(SymLabelList3_rotInv(NoOrbs), stat=ierr)
        call LogMemAlloc('SymLabelList3_rotInv', NoOrbs, 4, this_routine, SymLabelList3_rotInvTag, ierr)
        SymLabelList3_rotInv(:) = 0

        do i = 1, NoOrbs
            SymLabelList3_rotInv(SymLabelList3_rot(i)) = i
        end do

        do i = 1, (NoOrbs - (NoFrozenVirt))
            a = SymLabelList3_rotInv(i)
            do k = 1, i
                g = SymLabelList3_rotInv(k)
                do j = 1, (NoOrbs - (NoFrozenVirt))
                    b = SymLabelList3_rotInv(j)
                    ! Potential to put symmetry in here, have currently taken
                    ! it out, because when we're only printing non-zero values,
                    ! it is kind of unnecessary - although it may be used to
                    ! speed things up.
                    do l = 1, j
                        d = SymLabelList3_rotInv(l)
                        if (.not. near_zero(FourIndInts(a, g, b, d))) then
                            write(iunit, '(F21.12, 4I3)') FourIndInts(a, g, b, d), i, k, j, l
                        end if
                    end do
                end do
            end do
        end do

        deallocate(SymLabelList3_rotInv)
        call LogMemDeAlloc(this_routine, SymLabelList3_rotInvTag)

        ! TMAT2D stored as spin orbitals.
        do k = 1, (NoOrbs - (NoFrozenVirt))
            ! Symmetry?
            do i = k, (NoOrbs - (NoFrozenVirt))
                if (tStoreSpinOrbs) then
                    if (.not. near_zero(TMAT2DNew(i, k))) write(iunit, '(F21.12, 4I3)') TMAT2DNew(i, k), i, k, 0, 0
                else
                    if (.not. near_zero(TMAT2DNew(2 * i, 2 * k))) write(iunit, '(F21.12, 4I3)') TMAT2DNew(2 * i, 2 * k), i, k, 0, 0
                end if
            end do
        end do

        ! ARR has the energies of the orbitals (eigenvalues). ARR(:,2) has
        ! ordering we want. ARR is stored as spin orbitals.

        if (tUseMP2VarDenMat .or. tFindCINatOrbs .or. tUseHFOrbs) then
            if (tStoreSpinOrbs) then
                do k = 1, (NoOrbs - (NoFrozenVirt))
                    write(iunit, '(F21.12, 4I3)') ArrDiagNew(k), k, 0, 0, 0
                end do
            else

                do k = 1, (NoOrbs - (NoFrozenVirt))

                    write(iunit, '(F21.12, 4I3)') ArrDiagNew(k), k, 0, 0, 0
                end do
            end if
        else
            if (tStoreSpinOrbs) then
                do k = 1, (NoOrbs - (NoFrozenVirt))
                    write(iunit, '(F21.12, 4I3)') ArrNew(k, k), k, 0, 0, 0
                end do
            else
                do k = 1, (NoOrbs - (NoFrozenVirt))
                    write(iunit, '(F21.12, 4I3)') ArrNew(k, k), k, 0, 0, 0
                end do
            end if
        end if

        write(iunit, '(F21.12, 4I3)') ECore, 0, 0, 0, 0

        call neci_flush(iunit)

        close(iunit)

        call halt_timer(PrintROFCIDUMP_Time)

    end subroutine PrintRepeatROFCIDUMP