From 2ed3924e90343fdd1a2fb44bad167202670e0a67 Mon Sep 17 00:00:00 2001 From: Thomas Robitaille Date: Fri, 24 Jul 2026 06:46:57 +0000 Subject: [PATCH 1/2] Give the mp_n_photons send buffer the save attribute and free the fire-and-forget send requests so the buffer outlives pending mpi_isend operations --- src/mpi/mpi_routines.f90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/mpi/mpi_routines.f90 b/src/mpi/mpi_routines.f90 index 92fdbb94..e51ad956 100644 --- a/src/mpi/mpi_routines.f90 +++ b/src/mpi/mpi_routines.f90 @@ -73,7 +73,7 @@ subroutine mp_n_photons(n_photons_tot, n_photons_curr, n_photons_stats, n_photon integer(idp),intent(out) :: n_photons ! Number of photons used for MPI transfer - integer(idp),volatile,allocatable :: n_photons_send(:) + integer(idp),volatile,allocatable,save :: n_photons_send(:) ! Loop variable and dummy variable integer :: ir @@ -153,8 +153,12 @@ subroutine mp_n_photons(n_photons_tot, n_photons_curr, n_photons_stats, n_photon n_photons_curr = n_photons_curr + n_photons_send(ir) - ! Send number of photons and initialize receive for status check + ! Send number of photons and initialize receive for status check. + ! The send buffer has the save attribute and each slot is only + ! reused once the acknowledgement from the worker has been + ! received, so the request can be freed straight away. call mpi_isend(n_photons_send(ir), 1, mpi_integer8, ir, tag1, mpi_comm_world, request_dum, ierr) + call mpi_request_free(request_dum, ierr) call mpi_irecv(dtime(ir), 1, mpi_real8, ir, tag2, mpi_comm_world, request(ir), ierr) if(first) started(ir) = .true. @@ -186,6 +190,7 @@ subroutine mp_n_photons(n_photons_tot, n_photons_curr, n_photons_stats, n_photon if(flag) then n_photons_send(ir) = 0_idp call mpi_isend(n_photons_send(ir), 1, mpi_integer8, ir, tag1, mpi_comm_world, request_dum, ierr) + call mpi_request_free(request_dum, ierr) call mpi_irecv(dum_dp, 1, mpi_real8, ir, tag2, mpi_comm_world, request(ir), ierr) stopped(ir) = .true. if(debug) write(*,'("[mpi_routines] send abort signal to rank ",I0)') ir @@ -196,6 +201,7 @@ subroutine mp_n_photons(n_photons_tot, n_photons_curr, n_photons_stats, n_photon else if(.not.started(ir)) then n_photons_send(ir) = 0_idp call mpi_isend(n_photons_send(ir), 1, mpi_integer8, ir, tag1, mpi_comm_world, request_dum, ierr) + call mpi_request_free(request_dum, ierr) call mpi_irecv(dum_dp, 1, mpi_real8, ir, tag2, mpi_comm_world, request(ir), ierr) started(ir) = .true. stopped(ir) = .true. From cbe07e5c84d04f86cd3dde93980d311c6e62403d Mon Sep 17 00:00:00 2001 From: Thomas Robitaille Date: Fri, 24 Jul 2026 06:47:02 +0000 Subject: [PATCH 2/2] Compute broadcast size inside the main-process block in mp_table_read_column_auto_1d to avoid referencing an unallocated array on other ranks --- src/mpi/mpi_io.f90 | 32 +++++++++++++++++++++----------- src/mpi/mpi_io_template.f90 | 12 ++++++++---- 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/src/mpi/mpi_io.f90 b/src/mpi/mpi_io.f90 index f5226285..38cb87e7 100644 --- a/src/mpi/mpi_io.f90 +++ b/src/mpi/mpi_io.f90 @@ -1,4 +1,4 @@ -! MD5 of template: 744398b07cde70659e77bf8ee3986c3f +! MD5 of template: 9b916a2ee87489dd7e583277a1e87b9e module mpi_hdf5_io use core_lib @@ -365,8 +365,10 @@ subroutine mp_table_read_column_auto_1d_mpi_character(handle, path, name, array) character(len=*),intent(in) :: path, name character(len=*),allocatable,intent(out) :: array(:) integer :: n1 - if(main_process()) call hdf5_table_read_column_auto(handle, path, name, array) - n1 = size(array) + if(main_process()) then + call hdf5_table_read_column_auto(handle, path, name, array) + n1 = size(array) + end if call mpi_bcast(n1, 1, mpi_integer4, rank_main, mpi_comm_world, ierr) if(.not. main_process()) allocate(array(n1)) call mpi_bcast(array, n1 * len(array), mpi_character, rank_main, mpi_comm_world, ierr) @@ -438,8 +440,10 @@ subroutine mp_table_read_column_auto_1d_mpi_integer8(handle, path, name, array) character(len=*),intent(in) :: path, name integer(idp),allocatable,intent(out) :: array(:) integer :: n1 - if(main_process()) call hdf5_table_read_column_auto(handle, path, name, array) - n1 = size(array) + if(main_process()) then + call hdf5_table_read_column_auto(handle, path, name, array) + n1 = size(array) + end if call mpi_bcast(n1, 1, mpi_integer4, rank_main, mpi_comm_world, ierr) if(.not. main_process()) allocate(array(n1)) call mpi_bcast(array, n1, mpi_integer8, rank_main, mpi_comm_world, ierr) @@ -758,8 +762,10 @@ subroutine mp_table_read_column_auto_1d_mpi_integer4(handle, path, name, array) character(len=*),intent(in) :: path, name integer,allocatable,intent(out) :: array(:) integer :: n1 - if(main_process()) call hdf5_table_read_column_auto(handle, path, name, array) - n1 = size(array) + if(main_process()) then + call hdf5_table_read_column_auto(handle, path, name, array) + n1 = size(array) + end if call mpi_bcast(n1, 1, mpi_integer4, rank_main, mpi_comm_world, ierr) if(.not. main_process()) allocate(array(n1)) call mpi_bcast(array, n1, mpi_integer4, rank_main, mpi_comm_world, ierr) @@ -1078,8 +1084,10 @@ subroutine mp_table_read_column_auto_1d_mpi_real8(handle, path, name, array) character(len=*),intent(in) :: path, name real(dp),allocatable,intent(out) :: array(:) integer :: n1 - if(main_process()) call hdf5_table_read_column_auto(handle, path, name, array) - n1 = size(array) + if(main_process()) then + call hdf5_table_read_column_auto(handle, path, name, array) + n1 = size(array) + end if call mpi_bcast(n1, 1, mpi_integer4, rank_main, mpi_comm_world, ierr) if(.not. main_process()) allocate(array(n1)) call mpi_bcast(array, n1, mpi_real8, rank_main, mpi_comm_world, ierr) @@ -1398,8 +1406,10 @@ subroutine mp_table_read_column_auto_1d_mpi_real4(handle, path, name, array) character(len=*),intent(in) :: path, name real(sp),allocatable,intent(out) :: array(:) integer :: n1 - if(main_process()) call hdf5_table_read_column_auto(handle, path, name, array) - n1 = size(array) + if(main_process()) then + call hdf5_table_read_column_auto(handle, path, name, array) + n1 = size(array) + end if call mpi_bcast(n1, 1, mpi_integer4, rank_main, mpi_comm_world, ierr) if(.not. main_process()) allocate(array(n1)) call mpi_bcast(array, n1, mpi_real4, rank_main, mpi_comm_world, ierr) diff --git a/src/mpi/mpi_io_template.f90 b/src/mpi/mpi_io_template.f90 index 2dd83dac..fc176588 100644 --- a/src/mpi/mpi_io_template.f90 +++ b/src/mpi/mpi_io_template.f90 @@ -364,8 +364,10 @@ subroutine mp_table_read_column_auto_1d_mpi_character(handle, path, name, array) character(len=*),intent(in) :: path, name character(len=*),allocatable,intent(out) :: array(:) integer :: n1 - if(main_process()) call hdf5_table_read_column_auto(handle, path, name, array) - n1 = size(array) + if(main_process()) then + call hdf5_table_read_column_auto(handle, path, name, array) + n1 = size(array) + end if call mpi_bcast(n1, 1, mpi_integer4, rank_main, mpi_comm_world, ierr) if(.not. main_process()) allocate(array(n1)) call mpi_bcast(array, n1 * len(array), mpi_character, rank_main, mpi_comm_world, ierr) @@ -438,8 +440,10 @@ subroutine mp_table_read_column_auto_1d_(handle, path, name, array) character(len=*),intent(in) :: path, name @T,allocatable,intent(out) :: array(:) integer :: n1 - if(main_process()) call hdf5_table_read_column_auto(handle, path, name, array) - n1 = size(array) + if(main_process()) then + call hdf5_table_read_column_auto(handle, path, name, array) + n1 = size(array) + end if call mpi_bcast(n1, 1, mpi_integer4, rank_main, mpi_comm_world, ierr) if(.not. main_process()) allocate(array(n1)) call mpi_bcast(array, n1, , rank_main, mpi_comm_world, ierr)