[PATCH 14/22] Coarray caf_shmem final patch set

From 37ab61c272586857c3f40e9e9e2c0165e26bdb05 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Thu, 12 Feb 2026 11:13:25 +0100
Subject: [PATCH] Fortran: Fix form team in caf_shmem [PR124071]
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Form team w/o new_index= tried to compute the new_index assuming that
images are scattered onto to teams. I.e. the distribution is:

Image index: 1 2 3 4 5 6
New team no: 1 2 1 2 1 2 , i.e. scattered

But this algorithm failed, when the images were linearly distributed
into the new teams, like in:

Image index: 1 2 3 4 5 6
New team no: 1 1 1 2 2 2

The new approach is to look up a free index in the new team, when the
computed one is already taken.  Because F2018, 11.6.9, §4 states the
new index is processor dependent, it feels safe to do it this way.

	PR fortran/124071

libgfortran/ChangeLog:

	* caf/shmem.c (_gfortran_caf_form_team): Take free index, when
	computed one is already taken.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/form_team_1.f90: New test.
---
 .../gfortran.dg/coarray/form_team_1.f90       | 18 ++++++++
 libgfortran/caf/shmem.c                       | 45 ++++++++++++++-----
 2 files changed, 53 insertions(+), 10 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/coarray/form_team_1.f90

diff --git a/gcc/testsuite/gfortran.dg/coarray/form_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/form_team_1.f90
new file mode 100644
index 00000000000..e685efeb378
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/form_team_1.f90
@@ -0,0 +1,18 @@
+!{ dg-do run }
+
+program main
+  use, intrinsic :: iso_fortran_env, only: team_type
+  implicit none
+  type(team_type) :: team
+  integer :: slice_size, team_no
+
+  if (num_images() >= 3) then
+    slice_size = num_images() / 3
+    team_no = this_image() / slice_size + 1
+
+    form team (team_no, team)
+
+    sync all
+  end if
+
+end program
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index 1ef36cde1ac..9913db6d709 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -1768,26 +1768,51 @@ _gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index,
     }
   else
     {
-      int im;
-      int exp = -1;
+      int im, cnt;
+      int exp;
 
       __atomic_fetch_add (&t->u.image_info->image_map_size, 1,
 			  __ATOMIC_SEQ_CST);
       sync_team (caf_current_team);
 
-      im = caf_current_team->index * t->u.image_info->image_map_size
+      cnt = t->u.image_info->image_map_size;
+      /* Try to map the source team's images linearly into the domain of the
+	 new team.  This works for scattered teams distributions.  I.e. when a
+	 set of images is distritubed in this way:
+	 Image no: 1 2 3 4 5 6
+	 New team: 1 2 1 2 1 2
+	 but not for:
+	 Image no: 1 2 3 4 5 6
+	 New team: 1 1 1 2 2 2
+      */
+      im = caf_current_team->index * cnt
 	   / caf_current_team->u.image_info->image_count.count;
       /* Map our old index into the domain of the new team's size.  */
-      if (__atomic_compare_exchange_n (&t->u.image_info->image_map[im], &exp,
-				       this_image.image_num, false,
-				       __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST))
-	t->index = im;
-      else
+      do
 	{
-	  caf_internal_error (cannot_assign_index, stat, errmsg, errmsg_len);
-	  return;
+	  /* (Re-)set exp.  */
+	  exp = -1;
+	  if (__atomic_compare_exchange_n (&t->u.image_info->image_map[im],
+					   &exp, this_image.image_num, false,
+					   __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST))
+	    {
+	      t->index = im;
+	      goto form_team_finish;
+	    }
+	  /* Find a free new_index in the newly formed team for this image.
+	     There no longer is any order to the teams.  */
+	  ++im;
+	  if (im >= t->u.image_info->image_map_size)
+	    im = 0;
+	  --cnt;
 	}
+      while (cnt > 0);
+
+      caf_internal_error (cannot_assign_index, stat, errmsg, errmsg_len);
+      return;
     }
+
+form_team_finish:
   sync_team (caf_current_team);
 
   caf_teams_formed = t;
-- 
2.53.0