subroutine PrintROFCIDUMP_RDM(filename)
! This prints out a new FCIDUMP file in the same format as the old one.
use IntegralsData, only: umat
use LoggingData, only: tBrokenSymNOs
use OneEInts, only: TMAT2D
use rdm_data, only: tRotatedNOs
use SystemData, only: nel, G1, tFixLz, tStoreSpinOrbs, lms, ARR, ecore
use UMatCache, only: UMatInd
use util_mod, only: get_free_unit
integer :: i, j, k, l, iunit, orb, a, b, g, d
character(len=9) :: filename
! PrintROFCIDUMP_Time%timer_name='PrintROFCIDUMP'
! call set_timer(PrintROFCIDUMP_Time,30)
iunit = get_free_unit()
open(iunit, file=filename, status='unknown') !'ROFCIDUMP',status='unknown')
write(iunit, '(2A6,I3,A7,I3,A5,I2,A)') '&FCI ', 'NORB=', NoOrbs, ',NELEC=', NEl, ',MS2=', LMS, ','
write(iunit, '(A9)', advance='no') 'ORBSYM='
do i = 1, NoOrbs
if (tOpenShell) then
write(iunit, '(I1,A1)', advance='no') int(G1(i)%sym%S) + 1, ','
else
if (tRotatedNOs .and. tBrokenSymNOs) then
write(iunit, '(I1,A1)', advance='no') 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,A12)') 'ISYM=', 1, ' UHF=.FALSE.'
end if
if (tFixLz) then
write(iunit, '(A7)', advance='no') 'SYML='
do i = 1, NoOrbs
if (i == NoOrbs) then
write(iunit, '(I3,A1)') - 20, ','
else
write(iunit, '(I3,A1)', advance='no') - 20, ','
end if
end do
write(iunit, '(A8)', advance='no') 'SYMLZ='
do i = 1, NoOrbs
orb = i
if (.not. tOpenShell) orb = 2 * orb
write(iunit, '(i3,",")', advance='no') int(g1(orb)%ml)
end do
write(iunit, *)
end if
write(iunit, '(A5)') '&end'
do i = 1, NoOrbs
do j = 1, NoOrbs
do l = 1, 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 k = 1, i
! UMatInd is in physical notation <ij|kl>, but the indices
! printed in the FCIDUMP are in chemical notation (ik|jl).
if (tOpenSpatialOrbs) then
a = gtID(i)
b = gtID(j)
g = gtID(k)
d = gtID(l)
else
a = i
b = j
g = k
d = l
end if
if (.not. near_zero(real(UMat(UMatInd(a, b, g, d)), dp))) &
write(iunit, '(F21.12,4I5)') &
real(UMat(UMatInd(a, b, g, d)), dp), a, g, b, d
end do
end do
end do
end do
! TMAT2D stored as spin orbitals.
do i = 1, NoOrbs
! Symmetry?
do k = 1, NoOrbs
if (tStoreSpinOrbs) then
if (.not. near_zero(real(TMAT2D(i, k), dp))) then
write(iunit, '(F21.12,4I5)') real(TMAT2D(i, k), dp), i, k, 0, 0
end if
else
if (tOpenSpatialOrbs) then
a = gtID(i)
b = gtID(k)
else
a = i
b = k
end if
if (.not. near_zero(real(TMAT2D(2 * a, 2 * b), dp))) then
write(iunit, '(F21.12,4I5)') real(TMAT2D(2 * a, 2 * b), dp), a, b, 0, 0
end if
if (.not. near_zero(real(TMAT2D(2 * a, 2 * b), dp))) then
write(iunit, '(F21.12,4I5)') real(TMAT2D(2 * a, 2 * b), dp), a, b, 0, 0
end if
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.
do k = 1, NoOrbs
if (tStoreSpinOrbs) then
write(iunit, '(F21.12,4I5)') Arr(k, 2), k, 0, 0, 0
else
if (tOpenSpatialOrbs) then
a = gtID(k)
else
a = k
end if
write(iunit, '(F21.12,4I5)') Arr(2 * a, 2), a, 0, 0, 0
end if
end do
write(iunit, '(F21.12,4I5)') ECore, 0, 0, 0, 0
call neci_flush(iunit)
close(iunit)
! call halt_timer(PrintROFCIDUMP_Time)
end subroutine PrintROFCIDUMP_RDM