DumpFCIDUMP Subroutine

    subroutine DumpFCIDUMP()
        use SystemData, only: G1, nBasis, nel
        integer :: i, j, k, l, iunit
        character(len=*), parameter :: this_routine = 'DumpFCIDUMP'
        character(*), parameter :: formatter = "(F21.12,6I3)"

        ASSERT(nBasis / 2 <= 999) ! Otherwise the formatters have to be adapted

        if(tStoreSpinOrbs) call stop_all(this_routine, 'Dumping FCIDUMP not currently working with tStoreSpinOrbs (non RHF)')
        if(tFixLz) call stop_all(this_routine, 'Dumping FCIDUMP not working with Lz')

        iunit = get_free_unit()
        open(iunit, file='FCIDUMP-NECI', status='unknown')
        write(iunit, '(2A6,I3,A7,I3,A5,I2,A)') '&FCI ', 'NORB=', nBasis / 2, ',NELEC=', NEl, ',MS2=', LMS, ','
        write(iunit, '(A9)', advance='no') 'ORBSYM='
        do i = 1, nBasis, 2
            write(iunit, '(I1,A1)', advance='no')(INT(G1(i)%sym%S) + 1), ','
        end do
        write(iunit, '(A)') ''
        write(iunit, '(A9)') 'ISYM= 1,'
        write(iunit, '(A5)') '&END'

        do i = 2, nBasis, 2
            do k = 2, i, 2
                do j = 2, nBasis, 2
                    do l = 2, j, 2
                        if((abs(real(umat(umatind(i / 2, j / 2, k / 2, l / 2)), dp))) > 1.0e-9_dp) then
                            write(iunit, formatter) REAL(UMat(UMatInd(i / 2, j / 2, k / 2, l / 2)), dp), i / 2, k / 2, j / 2, l / 2
                        end if
                    end do
                end do
            end do
        end do

        do i = 2, nBasis, 2
            do j = 2, i, 2
                if(abs(real(tmat2d(i, j), dp)) > 1.0e-9_dp) then
                    write(iunit, formatter) REAL(TMAT2D(i, j), dp), i / 2, j / 2, 0, 0
                end if
            end do
        end do

        write(iunit, formatter) ECore, 0, 0, 0, 0
        call neci_flush(iunit)
        close(iunit)

    end subroutine DumpFCIDUMP