subroutine try_rdm_list_realloc(rdm_recv, new_nelements, recv_list)
! For cases where the receiving RDM array is not big enough for a
! communication, try and reallocate it to be big enough. This also
! requires a temporary array to be allocated, to store the current
! state of the receive list.
! recv_list should be input as true if reallocating an receiving RDM
! object. It should be false if reallocating the main array in the
! subroutine add_rdm_1_to_rdm_2. The only difference this makes is
! in the message output.
type(rdm_list_t), intent(inout) :: rdm_recv
integer, intent(in) :: new_nelements
logical, intent(in) :: recv_list
integer :: old_nelements, memory_old, memory_new, ierr
integer(int_rdm), allocatable :: temp_elements(:, :)
character(*), parameter :: t_r = 'try_rdm_list_realloc'
! The number of elements currently filled in the RDM array.
old_nelements = rdm_recv%nelements
if (recv_list) then
write (stdout, '("WARNING: There is not enough space in the current RDM array to receive all of the &
&communicated RDM elements. We will now try and reallocate this array to be large &
&enough. If there is not sufficient memory then the program may crash.")'); call neci_flush(stdout)
else
write (stdout, '("WARNING: There is not enough space in the current RDM array to add the received &
&RDM elements to the main RDM array. We will now try and reallocate this array to be 1.5 &
× larger. If there is not sufficient memory then the program may crash.")'); call neci_flush(stdout)
end if
! Memory of the old and new arrays, in bytes.
memory_old = rdm_recv%max_nelements * (rdm_recv%sign_length + 1) * size_int_rdm
memory_new = new_nelements * (rdm_recv%sign_length + 1) * size_int_rdm
write(stdout, '("Old RDM array had the following size (MB):", f14.6)') real(memory_old, dp) / 1048576.0_dp
write(stdout, '("Required new RDM array must have the following size (MB):", f14.6)') real(memory_new, dp) / 1048576.0_dp
if (old_nelements > 0) then
! Allocate a temporary array to copy the old RDM list to, while we
! reallocate that array.
allocate(temp_elements(0:rdm_recv%sign_length, old_nelements), stat=ierr)
if (ierr /= 0) call stop_all(t_r, "Error while allocating temporary array to hold existing &
&RDM receive array.")
temp_elements = rdm_recv%elements(:, 1:old_nelements)
end if
deallocate(rdm_recv%elements, stat=ierr)
if (ierr /= 0) call stop_all(t_r, "Error while deallocating existing RDM receive array.")
allocate(rdm_recv%elements(0:rdm_recv%sign_length, new_nelements), stat=ierr)
if (ierr /= 0) call stop_all(t_r, "Error while allocating RDM receive array to the new larger size.")
! Update the maximum number of elements for the rdm_recv object.
rdm_recv%max_nelements = new_nelements
if (old_nelements > 0) then
! Copy the existing elements back, and deallocate the temorary array.
rdm_recv%elements(:, 1:old_nelements) = temp_elements
deallocate(temp_elements, stat=ierr)
if (ierr /= 0) call stop_all(t_r, "Error while deallocating temporary RDM array.")
end if
end subroutine try_rdm_list_realloc