Potential bug in MPI_TESTSOME in Fortran: Invalid indices returned in completed_indices

[shizawarist]

Description
Dear developers,
I have encountered a potential issue where MPI_TESTSOME in Fortran returns invalid values in the indices (the 4th argument) array when using this library.

Environment:
Library version: sst-dumpi-13.1.0_Final
MPI implementation: FUJITSU MPI
Compiler: mpifrtpx (mpifrtpx --version: frtpx (FRT) 4.12.2 20251113) on supercomputer Fugaku

Actual Behavior:
In a Fortran environment, MPI_TESTSOME is expected to return indices in the range of 1 to incount (the 1st argument). However, when hooked by this library, it returns values outside this valid range (e.g., values less than 1).

Expected Behavior:
The returned completed_indices should always be within the range of 1 to incount, consistent with the Fortran MPI standard.

Steps to Reproduce:
I have attached a minimal reproduction code below (sample_testsome.F90). This program performs point-to-point communication where Rank 0 receives data from other ranks using MPI_IRECV and checks the results via MPI_TESTSOME.

!-----> reproduction code, sample_testsome.F90, begins

program main
  use mpi
  implicit none
  integer :: ierr, my_rank, nprocs, i, j
  integer :: incount, outcount
  integer, allocatable :: completed_indices(:)
  integer, allocatable :: statuses(:, :)
  integer :: st(MPI_STATUS_SIZE)
  integer :: abort_ierr
  double precision :: send_buf
  double precision, allocatable :: recv_bufs(:)
  integer, allocatable :: send_reqs(:), recv_reqs(:)
  integer :: k
  double precision :: dummy_val
  call MPI_INIT(ierr)
  call MPI_COMM_RANK(MPI_COMM_WORLD, my_rank, ierr)
  call MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
  if (nprocs < 2) then
    if (my_rank == 0) print *, "** ERROR **: 1: This program requires at least 2 processes."
    call MPI_ABORT(MPI_COMM_WORLD, 1, abort_ierr)
  end if
  if (my_rank == 0) then ! rank 0: receive from ranks 1 ... nprocs-1
    incount = nprocs - 1
    allocate(recv_bufs(incount))
    allocate(recv_reqs(incount))
    allocate(completed_indices(incount))
    allocate(statuses(MPI_STATUS_SIZE, incount))
    do i = 1, incount
      call MPI_IRECV(recv_bufs(i), 1, MPI_DOUBLE_PRECISION, i, i, &
        MPI_COMM_WORLD, recv_reqs(i), ierr)
    end do
    ! main recieve loop
    do while (.true.)
      call MPI_TESTSOME(incount, recv_reqs, outcount, completed_indices, statuses, ierr)
      if (outcount == MPI_UNDEFINED) then
        print *, "Rank 0: All requests are NULL (finished)."
        exit
      end if
      if (outcount > 0) then
        do j = 1, outcount
          i = completed_indices(j)
          ! According to the MPI specification, the index array should be in the range 0 to incount-1 for C and 1 to incount for Fortran.
          if (i >= 1 .and. i <= incount) then
            print *, "Rank 0: Received from Rank", i, " value:", recv_bufs(i)
          else
            print *, "** ERROR **: 901: checking index renge, i >= 1 .and. i <= incount, fails: i = ",i, " incount = ", incount
            call MPI_ABORT(MPI_COMM_WORLD, 901, abort_ierr)
          end if
        end do
      else
        ! dummy calculation
        dummy_val = 0.0d0
        do k = 1, 1000000
          dummy_val = dummy_val + sqrt(dble(k))
        end do
        ! dummy output to prevent loop elimination by optimization
        if (dummy_val < 0.0d0) print *, "This should not happen"
      end if
    end do
    call MPI_WAITALL(incount, recv_reqs, statuses, ierr)
  else ! ranks 1 ... nprocs-1: send to rank 0
    allocate(send_reqs(1))
    send_buf = dble(my_rank) * 1.1d0
    call MPI_ISEND(send_buf, 1, MPI_DOUBLE_PRECISION, 0, my_rank, &
      MPI_COMM_WORLD, send_reqs(1), ierr)
    call MPI_WAIT(send_reqs(1), st, ierr)
  end if
  if (allocated(recv_bufs)) deallocate(recv_bufs)
  if (allocated(recv_reqs)) deallocate(recv_reqs)
  if (allocated(completed_indices)) deallocate(completed_indices)
  if (allocated(statuses)) deallocate(statuses)
  if (allocated(send_reqs)) deallocate(send_reqs)
  if (my_rank == 0) print *, "NORMAL END"
  call MPI_FINALIZE(ierr)
end program main

!-----< reproduction code, sample_testsome.F90, ends

!-----> Makefile for sample_testsome.F90 on supercomputer Fugaku, begins

FC      = mpifrtpx
FLAGS   = -Kfast,openmp,simd -Koptmsg=2 -Nlst=t  -Nmaxserious=1
OBJGROUP = sample_testsome.F90
LIBS    =
sample_testsome.exe: $(OBJGROUP) FORCE
	rm -f $@  *.mod *.o *.lst
	$(FC) $(FLAGS) -o $@ $(OBJGROUP) $(LIBS)
FORCE:

!-----< Makefile for sample_testsome.F90 on supercomputer Fugaku, ends

!-----> reproduction job script on supercomputer Fugaku, job_with_SST_n1_p4.sh, begins

#!/bin/bash
#PJM -L "rscgrp=small-s1"
#PJM -L "node=1"
#PJM --mpi "proc=4"
#PJM --mpi "max-proc-per-node=4"
#PJM -L "elapse=0:30:00"
#PJM -S
#PJM -x PJM_LLIO_GFSCACHE=/vol0004
set -e
#------------------------------------ SST dumpi setup
libdumpid=/home/apps/oss/SST/sst-dumpi/lib/
export LD_PRELOAD=$libdumpid/libdumpi.so:$libdumpid/libdumpif77.so:$libdumpid/libdumpif90.so
#------------------------------------ SST dumpi setup end
EXEC_FILE=./sample_testsome.exe
mpiexec -n $PJM_MPI_PROC  ${EXEC_FILE}
#------------------------------------ SST dumpi to ascii
dumpi2ascii=/home/apps/oss/SST/sst-dumpi/bin/dumpi2ascii
sstbin=`echo *0000.bin | sed -e "s:0000\.bin::g"`
if [ ! -f sst_log/${sstbin}0000.bin.ascii ];then
    mkdir -p sst_log
    mpiexec -n $PJM_MPI_PROC sh -c 'p04=`printf %04d $PMIX_RANK`;
    sstbin=`echo *${p04}.bin`;
    '$dumpi2ascii' $sstbin  > ./sst_log/${sstbin}.ascii'
else
    echo sst_log/${sstbin}0000.bin.ascii exist!!
fi
#------------------------------------ SST dumpi to ascii end
exit

!-----< reproduction job script on supercomputer Fugaku, job_with_SST_n1_p4.sh, ends

Observation:
Without sst-dumpi: The program runs as expected, always following the path [A] (index range is valid).
With sst-dumpi (via LD_PRELOAD): The program unexpectedly follows path [B] (the else block), triggering MPI_ABORT because completed_indices contains values outside the range 1 to incount.

      if (i >= 1 .and. i <= incount) then
        ! [A] Should always be true (Behavior without SST DUMPI)
        print *, "Rank 0: Received from Rank", i, " value:", recv_bufs(i)
      else
        ! [B] Unexpectedly triggered when using SST DUMPI
        print *, "** ERROR **: 901: checking index range, i >= 1 .and. i <= incount, fails: i = ",i, " incount = ", incount
        call MPI_ABORT(MPI_COMM_WORLD, 901, abort_ierr)
      end if

When sst-dumpi is linked, the standard output for path [B] is as follows:

==> output.48358064/0/1/stdout.1.0 <==
 ** ERROR **: 901: checking index range, i >= 1 .and. i <= incount, fails: i = 0 incount = 3

As shown above, i = 0 was returned while incount = 3. This strongly suggests that the Fortran wrapping/hooking logic in sst-dumpi might be returning 0-based indices (C style) instead of the 1-based indices required by the Fortran MPI standard.

Could you please investigate if this is a bug in the hooking logic?
Best regards,