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