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))) &
&write(iunit, '(F21.12, 4I3)') FourIndInts(a, g, b, d), i, k, j, l
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