Merge branch 'devel/gfortran-test' of git+ssh://gcc.gnu.org/git/gcc into devel/gfortran-test

gcc/fortran/check.cc

@@ -1865,7 +1865,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team)
       || !positive_check (0, image))
     return false;
 
-  return !team || (scalar_check (team, 0) && team_type_check (team, 0));
+  return !team || (scalar_check (team, 1) && team_type_check (team, 1));
 }
 
 
@@ -1908,13 +1908,8 @@ gfc_check_f_c_string (gfc_expr *string, gfc_expr *asis)
 bool
 gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
 {
-  if (team)
+  if (team && (!scalar_check (team, 0) || !team_type_check (team, 0)))
-    {
+    return false;
-      gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
-		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
-		 &team->where);
-      return false;
-    }
 
   if (kind)
     {

gcc/fortran/invoke.texi

@@ -104,6 +104,7 @@ one is not the default.
 * Interoperability Options::  Options for interoperability with other
                               languages.
 * Environment Variables:: Environment variables that affect @command{gfortran}.
+* Shared Memory Coarrays:: Multi process shared memory coarray support.
 @end menu
 
 @node Option Summary
@@ -2294,3 +2295,65 @@ variables.
 @xref{Runtime}, for environment variables that affect the
 run-time behavior of programs compiled with GNU Fortran.
 @c man end
+
+@node Shared Memory Coarrays
+@section Shared Memory Coarrays
+
+@c man begin SHARED MEMORY COARRAYS
+
+@command{gfortran} supplies a runtime library for running coarray enabled
+programs using a shared memory multi process approach.  The library is supplied
+as a static link library with the @command{libgfortran} library and is fully
+compatible with the ABI enabled when @command{gfortran} is called with
+@code{-fcoarray=lib}.  The shared memory coarray library then just needs to be
+linked to the executable produced by @command{gfortran} using
+@code{-lcaf_shmem}.
+
+The library @code{caf_shmem} can only be used on architectures that allow
+multiple processes to use the same memory at the same virtual memory address in
+each process' memory space.  This is the case on most Unix and Windows based
+systems.
+
+The resulting executable can be started without any driver and does not provide
+any additional command line options.  Limited control is possible by
+environment variables:
+
+@env{GFORTRAN_NUM_IMAGES}: The number of images to spawn when running the
+executable.  Note, there will always be one additional supervisor process, which
+does not participate in the computation, but is only responsible for starting
+the images and catching any (ab-)normal termination.  When the environment
+variable is not set, then the number of hardware threads reported by the OS will
+be taken. Over-provisioning is possible.  The number of images is limited only
+by the OS and the size of an integer variable on the architecture the program is
+to be run on.
+
+@env{GFORTRAN_SHARED_MEMORY_SIZE}: The size of the shared memory segment made
+available to all images is fixed and needs to be set at program start.  It can
+not grow or shrink.  The size can be given in bytes (no suffix), kilobytes
+(@code{k} or @code{K} suffix), megabytes (@code{m} or @code{M}) or gigabytes
+(@code{g} or @code{G}).  If the variable is not set, or not parseable, then on
+32-bit architectures 2^28 bytes and on 64-bit 2^34 bytes are choosen.  Note,
+although the size is set, most modern systems do not allocate the memory at
+program start.  This allows to choose a shared memory size larger than available
+memory.
+
+Warning: Choosing a large shared memory size may produce large coredumps!
+
+@env{GFORTRAN_IMAGE_RESTARTS_LIMIT}: On certain platforms, esp. MacOS, the
+shared memory segment needs to be placed on the same (virtual) address in every
+image or synchronisation primitives do not work as expected.  Unfortunately are
+some OSes somewhat arbitrary on when they can do this.  When the OS is not able
+to fullfill the request, then the image aborts itsself and is restarted by the
+supervisor untill the OS complies.  This environment variable limits the total
+number of restarts of all images having an issue with shared memory segment
+placement.  The default value is 4000.
+
+The shared memory coarray library internally uses some additional environment
+variables, which will be overwritten without notice or may result in failure to
+start.  These are: @code{GFORTRAN_IMAGE_NUM}, @code{GFORTRAN_SHMEM_PID} and
+@code{GFORTRAN_SHMEM_BASE}.  It is strongly discouraged to use these variables.
+Special care needs to be taken, when one coarray program starts another coarray
+program as a child process.  In this case it is the spawning process'
+responsibility to remove above variables from the environment.
+
+@c man end

gcc/fortran/trans-expr.cc

@@ -90,6 +90,8 @@ static tree
 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
 {
   enum gfc_array_kind akind;
+  tree *lbound = NULL, *ubound = NULL;
+  int codim = 0;
 
   if (attr.pointer)
     akind = GFC_ARRAY_POINTER_CONT;
@@ -100,8 +102,16 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
 
   if (POINTER_TYPE_P (TREE_TYPE (scalar)))
     scalar = TREE_TYPE (scalar);
-  return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+  if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
-				    akind, !(attr.pointer || attr.target));
+    {
+      struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
+      codim = lang_specific->corank;
+      lbound = lang_specific->lbound;
+      ubound = lang_specific->ubound;
+    }
+  return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
+				    ubound, 1, akind,
+				    !(attr.pointer || attr.target));
 }
 
 tree
@@ -781,11 +791,43 @@ gfc_get_vptr_from_expr (tree expr)
   return NULL_TREE;
 }
 
+static void
+copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
+{
+  tree src_type = TREE_TYPE (src);
+  if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
+    {
+      struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
+      for (int c = 0; c < lang_specific->corank; ++c)
+	{
+	  int dim = lang_specific->rank + c;
+	  tree codim = gfc_rank_cst[dim];
+
+	  if (lang_specific->lbound[dim])
+	    gfc_conv_descriptor_lbound_set (block, dest, codim,
+					    lang_specific->lbound[dim]);
+	  else
+	    gfc_conv_descriptor_lbound_set (
+	      block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
+	  if (dim + 1 < lang_specific->corank)
+	    {
+	      if (lang_specific->ubound[dim])
+		gfc_conv_descriptor_ubound_set (block, dest, codim,
+						lang_specific->ubound[dim]);
+	      else
+		gfc_conv_descriptor_ubound_set (
+		  block, dest, codim,
+		  gfc_conv_descriptor_ubound_get (src, codim));
+	    }
+	}
+    }
+}
+
 void
 gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
 			     bool lhs_type)
 {
-  tree tmp, tmp2, type;
+  tree lhs_dim, rhs_dim, type;
 
   gfc_conv_descriptor_data_set (block, lhs_desc,
 				gfc_conv_descriptor_data_get (rhs_desc));
@@ -796,15 +838,18 @@ gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
 		  gfc_conv_descriptor_dtype (rhs_desc));
 
   /* Assign the dimension as range-ref.  */
-  tmp = gfc_get_descriptor_dimension (lhs_desc);
+  lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
-  tmp2 = gfc_get_descriptor_dimension (rhs_desc);
+  rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
 
-  type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
+  type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
-  tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
+  lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
-		    gfc_index_zero_node, NULL_TREE, NULL_TREE);
+			gfc_index_zero_node, NULL_TREE, NULL_TREE);
-  tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
+  rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
-		     gfc_index_zero_node, NULL_TREE, NULL_TREE);
+			gfc_index_zero_node, NULL_TREE, NULL_TREE);
-  gfc_add_modify (block, tmp, tmp2);
+  gfc_add_modify (block, lhs_dim, rhs_dim);
+
+  /* The corank dimensions are not copied by the ARRAY_RANGE_REF.  */
+  copy_coarray_desc_part (block, lhs_desc, rhs_desc);
 }
 
 /* Takes a derived type expression and returns the address of a temporary
@@ -920,6 +965,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
 						    gfc_expr_attr (e));
 	      gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
 			      gfc_get_dtype (type));
+	      copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
 	      if (optional)
 		parmse->expr = build3_loc (input_location, COND_EXPR,
 					   TREE_TYPE (parmse->expr),

gcc/fortran/trans-intrinsic.cc

@@ -2073,9 +2073,13 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
 					    GFC_STAT_STOPPED_IMAGE));
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB)
+    /* The team is optional and therefore needs to be a pointer to the opaque
+       pointer.  */
     tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
 			       args[0],
-			       num_args < 2 ? null_pointer_node : args[1]);
+			       num_args < 2
+				 ? null_pointer_node
+				 : gfc_build_addr_expr (NULL_TREE, args[1]));
   else
     gcc_unreachable ();
 

gcc/fortran/trans-stmt.cc

@@ -1362,7 +1362,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
     {
       gfc_init_se (&argse, NULL);
       gfc_conv_expr_val (&argse, code->expr1);
-      images = argse.expr;
+      images = gfc_trans_force_lval (&argse.pre, argse.expr);
+      gfc_add_block_to_block (&se.pre, &argse.pre);
     }
 
   if (code->expr2)
@@ -1372,6 +1373,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
       gfc_init_se (&argse, NULL);
       gfc_conv_expr_val (&argse, code->expr2);
       stat = argse.expr;
+      gfc_add_block_to_block (&se.pre, &argse.pre);
     }
   else
     stat = null_pointer_node;
@@ -1384,8 +1386,9 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
       argse.want_pointer = 1;
       gfc_conv_expr (&argse, code->expr3);
       gfc_conv_string_parameter (&argse);
-      errmsg = gfc_build_addr_expr (NULL, argse.expr);
+      errmsg = argse.expr;
       errmsglen = fold_convert (size_type_node, argse.string_length);
+      gfc_add_block_to_block (&se.pre, &argse.pre);
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB)
     {

gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90

@@ -11,11 +11,19 @@ program main
   end type
 
   type(mytype), save :: object[*]
-  integer :: me
+  integer :: me, other
 
   me=this_image()
-  allocate(object%indices(me))
+  other = me + 1
-  object%indices = 42
+  if (other .GT. num_images()) other = 1
+  if (me == num_images()) then
+     allocate(object%indices(me/2))
+  else
+    allocate(object%indices(me))
+  end if
+  object%indices = 42 * me
 
-  if ( any( object[me]%indices(:) /= 42 ) ) STOP 1
+  sync all
+  if ( any( object[other]%indices(:) /= 42 * other ) ) STOP 1
+  sync all
 end program

gcc/testsuite/gfortran.dg/coarray/atomic_2.f90

@@ -61,7 +61,7 @@ end do
 sync all
 
 call atomic_ref(var, caf[num_images()], stat=stat)
-if (stat /= 0 .or. var /= num_images() + this_image()) STOP 12
+if (stat /= 0 .or. var /= num_images() * 2) STOP 12
 do i = 1, num_images()
   call atomic_ref(var, caf[i], stat=stat)
   if (stat /= 0 .or. var /= num_images() + i) STOP 13
@@ -328,7 +328,7 @@ end do
 sync all
 
 call atomic_ref(var, caf[num_images()], stat=stat)
-if (stat /= 0 .or. var /= num_images() + this_image()) STOP 45
+if (stat /= 0 .or. var /= num_images() * 2) STOP 45
 do i = 1, num_images()
   call atomic_ref(var, caf[i], stat=stat)
   if (stat /= 0 .or. var /= num_images() + i) STOP 46
@@ -403,7 +403,7 @@ if (this_image() < storage_size(caf)-2) then
   do i = this_image(), min(num_images(), storage_size(caf)-2)
     var = -99
     call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat)
-    if (stat /= 0 .or. var <= 0) STOP 53
+    if (stat /= 0) STOP 53
   end do
 end if
 sync all
@@ -544,7 +544,7 @@ if (this_image() < storage_size(caf)-2) then
   do i = this_image(), min(num_images(), storage_size(caf)-2)
     var = -99
     call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat)
-    if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 68
+    if (stat /= 0) STOP 68
   end do
 end if
 sync all
@@ -628,26 +628,27 @@ sync all
 
 if (this_image() == 1) then
   call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat)
-  if (stat /= 0 .or. var2 .neqv. .true.) STOP 82
+  if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 82
   call atomic_ref(var2, caf_log[num_images()], stat=stat)
-  if (stat /= 0 .or. var2 .neqv. .true.) STOP 83
+  if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 83
 end if
 sync all
 
-if (this_image() == num_images() .and. caf_log .neqv. .true.) STOP 84
+if (this_image() == num_images() .and. (caf_log .neqv. .true.)) STOP 84
 call atomic_ref(var2, caf_log[num_images()], stat=stat)
-if (stat /= 0 .or. var2 .neqv. .true.) STOP 85
+if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 85
 sync all
 
 if (this_image() == 1) then
   call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat)
-  if (stat /= 0 .or. var2 .neqv. .true.) STOP 86
+  if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 86
   call atomic_ref(var2, caf_log[num_images()], stat=stat)
-  if (stat /= 0 .or. var2 .neqv. .false.) STOP 87
+  if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 87
 end if
 sync all
 
-if (this_image() == num_images() .and. caf_log .neqv. .false.) STOP 88
+if (this_image() == num_images() .and. (caf_log .neqv. .false.)) STOP 88
 call atomic_ref(var2, caf_log[num_images()], stat=stat)
-if (stat /= 0 .or. var2 .neqv. .false.) STOP 89
+if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 89
+sync all
 end

gcc/testsuite/gfortran.dg/coarray/caf.exp

@@ -70,6 +70,12 @@ proc dg-compile-aux-modules { args } {
     }
 }
 
+if { [getenv GFORTRAN_NUM_IMAGES] == "" } {
+  # Some caf_shmem tests need at least 8 images.  This is also to limit the
+  # number of images on big machines preventing overload w/o any benefit.
+  setenv GFORTRAN_NUM_IMAGES 8
+}
+
 # Main loop.
 foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] {
     # If we're only testing specific files and this isn't one of them, skip it.
@@ -103,6 +109,13 @@ foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]]
 	dg-test $test "-fcoarray=lib $flags -lcaf_single" {}
 	cleanup-modules ""
     }
+
+    foreach flags $option_list {
+        verbose "Testing $nshort (libcaf_shmem), $flags" 1
+        set gfortran_aux_module_flags "-fcoarray=lib $flags -lcaf_shmem"
+        dg-test $test "-fcoarray=lib $flags -lcaf_shmem" {}
+        cleanup-modules ""
+    }
 }
 torture-finish
 dg-finish

gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90

@@ -0,0 +1,94 @@
+!{ dg-do run }
+
+! Check that co_reduce for strings works.
+! This test is motivated by OpenCoarray's co_reduce_string test.
+
+program co_reduce_strings
+ 
+  implicit none
+
+  integer, parameter :: numstrings = 10, strlen = 8, base_len = 4
+  character(len=strlen), dimension(numstrings) :: fixarr
+  character(len=strlen), dimension(:), allocatable :: allocarr
+  character(len=:), allocatable :: defarr(:)
+  character(len=strlen) :: expect
+  integer :: i
+
+  ! Construct the strings by postfixing foo by a number.
+  associate (me => this_image(), np => num_images())
+    if (np > 999) error stop "Too many images; increase format string modifiers and sizes!"
+    
+    allocate(allocarr(numstrings))
+    do i = 1, numstrings
+      write(fixarr(i), "('foo',I04)") i * me
+      write(allocarr(i), "('foo',I04)") i * me
+    end do
+    ! Collectively reduce the maximum string.
+    call co_reduce(fixarr, fixmax)
+    call check(fixarr, 1)
+
+    call co_reduce(allocarr, strmax)
+    call check(allocarr, 2)
+  end associate
+
+  ! Construct the strings by postfixing foo by a number.
+  associate (me => this_image(), np => num_images())
+    allocate(character(len=base_len + 4)::defarr(numstrings))
+    do i = 1, numstrings
+      write(defarr(i), "('foo',I04)") i * me
+    end do
+    call sub_red(defarr)
+  end associate
+  sync all
+
+contains
+
+  pure function fixmax(lhs, rhs) result(m)
+    character(len=strlen), intent(in) :: lhs, rhs
+    character(len=strlen) :: m
+
+    if (lhs > rhs) then
+      m = lhs
+    else
+      m = rhs
+    end if
+  end function
+
+  pure function strmax(lhs, rhs) result(maxstr)
+    character(len=strlen), intent(in) :: lhs, rhs
+    character(len=strlen) :: maxstr
+
+    if (lhs > rhs) then
+      maxstr = lhs 
+    else 
+      maxstr = rhs
+    end if
+  end function
+
+  subroutine sub_red(str)
+    character(len=:), allocatable :: str(:)
+
+    call co_reduce(str, strmax)
+    call check(str, 3)
+  end subroutine
+
+  subroutine check(curr, stop_code)
+    character(len=*), intent(in) :: curr(:)
+    character(len=strlen) :: expect
+    integer, intent(in) :: stop_code
+    integer :: i
+
+    associate(np => num_images())
+      do i = 1, numstrings
+        write (expect, "('foo',I04)") i * np
+        if (curr(i) /= expect) then
+          ! On error print what we got and what we expected.
+          print *, this_image(), ": Got: ", curr(i), ", expected: ", expect, ", for i=", i
+          stop stop_code
+        end if
+      end do
+    end associate
+  end subroutine
+
+end program co_reduce_strings
+

gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90

@@ -19,7 +19,7 @@ program p
   ! For this reason, -fcoarray=single and -fcoarray=lib give the
   ! same result
   if (allocated (a[1])) stop 3
-  if (allocated (c%x[1,2,3])) stop 4
+  if (allocated (c%x[1,1,1])) stop 4
 
   ! Allocate collectively
   allocate(a[*])
@@ -28,16 +28,17 @@ program p
   if (.not. allocated (a)) stop 5
   if (.not. allocated (c%x)) stop 6
   if (.not. allocated (a[1])) stop 7
-  if (.not. allocated (c%x[1,2,3])) stop 8
+  if (.not. allocated (c%x[1,1,1])) stop 8
 
-  ! Deallocate collectively
+  sync all
+  ! Dellocate collectively
   deallocate(a)
   deallocate(c%x)
 
   if (allocated (a)) stop 9
   if (allocated (c%x)) stop 10
   if (allocated (a[1])) stop 11
-  if (allocated (c%x[1,2,3])) stop 12
+  if (allocated (c%x[1,1,1])) stop 12
 end
 
 ! Expected: always local access and never a call to _gfortran_caf_get

gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90

@@ -21,6 +21,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str1a = 1_"abc"
   str2a = 1_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     str2a[1] = str1a
   end if
@@ -37,6 +38,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr1a = 4_"abc"
   ustr2a = 4_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     ustr2a[1] = ustr1a
   end if
@@ -53,6 +55,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str2a = 1_"abcde"
   str1a = 1_"XXX"
+  sync all
   if (this_image() == num_images()) then
     str1a[1] = str2a
   end if
@@ -69,6 +72,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr2a = 4_"abcde"
   ustr1a = 4_"XXX"
+  sync all
   if (this_image() == num_images()) then
     ustr1a[1] = ustr2a
   end if
@@ -91,6 +95,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = str1b
   end if
@@ -113,6 +118,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = ustr1b
   end if
@@ -135,6 +141,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = str2b
   end if
@@ -157,6 +164,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = ustr2b
   end if
@@ -179,6 +187,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = str1a
   end if
@@ -199,6 +208,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = ustr1a
   end if
@@ -219,6 +229,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = str2a
   end if
@@ -239,6 +250,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = ustr2a
   end if
@@ -261,6 +273,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str1a = 1_"abc"
   str2a = 1_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     str2a = str1a[1]
   end if
@@ -277,6 +290,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr1a = 4_"abc"
   ustr2a = 4_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     ustr2a = ustr1a[1]
   end if
@@ -293,6 +307,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str2a = 1_"abcde"
   str1a = 1_"XXX"
+  sync all
   if (this_image() == num_images()) then
     str1a = str2a[1]
   end if
@@ -309,6 +324,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr2a = 4_"abcde"
   ustr1a = 4_"XXX"
+  sync all
   if (this_image() == num_images()) then
     ustr1a = ustr2a[1]
   end if
@@ -331,6 +347,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b = str1b(:)[1]
   end if
@@ -353,6 +370,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b = ustr1b(:)[1]
   end if
@@ -375,6 +393,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b = str2b(:)[1]
   end if
@@ -397,6 +416,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b = ustr2b(:)[1]
   end if
@@ -419,6 +439,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b = str1a[1]
   end if
@@ -439,6 +460,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b = ustr1a[1]
   end if
@@ -459,6 +481,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b = str2a[1]
   end if
@@ -479,6 +502,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b = ustr2a[1]
   end if
@@ -502,6 +526,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str1a = 1_"abc"
   str2a = 1_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     str2a[1] = str1a[mod(1, num_images())+1]
   end if
@@ -518,6 +543,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr1a = 4_"abc"
   ustr2a = 4_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     ustr2a[1] = ustr1a[mod(1, num_images())+1]
   end if
@@ -534,6 +560,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str2a = 1_"abcde"
   str1a = 1_"XXX"
+  sync all
   if (this_image() == num_images()) then
     str1a[1] = str2a[mod(1, num_images())+1]
   end if
@@ -550,6 +577,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr2a = 4_"abcde"
   ustr1a = 4_"XXX"
+  sync all
   if (this_image() == num_images()) then
     ustr1a[1] = ustr2a[mod(1, num_images())+1]
   end if
@@ -572,6 +600,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = str1b(:)[mod(1, num_images())+1]
   end if
@@ -594,6 +623,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
   end if
@@ -616,6 +646,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = str2b(:)[mod(1, num_images())+1]
   end if
@@ -638,6 +669,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
   end if
@@ -660,6 +692,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = str1a[mod(1, num_images())+1]
   end if
@@ -680,6 +713,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = ustr1a[mod(1, num_images())+1]
   end if
@@ -700,6 +734,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = str2a[mod(1, num_images())+1]
   end if
@@ -720,6 +755,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = ustr2a[mod(1, num_images())+1]
   end if
@@ -743,7 +779,8 @@ subroutine char_test()
   str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr1a = 4_"abc"
-  str1a = 1_"XXXXXXX"
+  str2a = 1_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     str2a[1] = ustr1a
   end if
@@ -760,6 +797,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str1a = 4_"abc"
   ustr2a = 1_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     ustr2a[1] = str1a
   end if
@@ -776,6 +814,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr2a = 4_"abcde"
   str1a = 1_"XXX"
+  sync all
   if (this_image() == num_images()) then
     str1a[1] = ustr2a
   end if
@@ -792,6 +831,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str2a = 4_"abcde"
   ustr1a = 1_"XXX"
+  sync all
   if (this_image() == num_images()) then
     ustr1a[1] = str2a
   end if
@@ -814,6 +854,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = ustr1b
   end if
@@ -836,6 +877,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = str1b
   end if
@@ -858,6 +900,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = ustr2b
   end if
@@ -880,6 +923,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = str2b
   end if
@@ -902,6 +946,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = ustr1a
   end if
@@ -922,6 +967,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = str1a
   end if
@@ -942,6 +988,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = ustr2a
   end if
@@ -962,6 +1009,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = str2a
   end if
@@ -984,6 +1032,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr1a = 4_"abc"
   str2a = 1_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     str2a = ustr1a[1]
   end if
@@ -1000,6 +1049,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str1a = 1_"abc"
   ustr2a = 4_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     ustr2a = str1a[1]
   end if
@@ -1016,6 +1066,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr2a = 4_"abcde"
   str1a = 1_"XXX"
+  sync all
   if (this_image() == num_images()) then
     str1a = ustr2a[1]
   end if
@@ -1032,6 +1083,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str2a = 1_"abcde"
   ustr1a = 4_"XXX"
+  sync all
   if (this_image() == num_images()) then
     ustr1a = str2a[1]
   end if
@@ -1054,6 +1106,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b = ustr1b(:)[1]
   end if
@@ -1076,6 +1129,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b = str1b(:)[1]
   end if
@@ -1098,6 +1152,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b = ustr2b(:)[1]
   end if
@@ -1120,6 +1175,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b = str2b(:)[1]
   end if
@@ -1142,6 +1198,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b = ustr1a[1]
   end if
@@ -1162,6 +1219,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b = str1a[1]
   end if
@@ -1182,6 +1240,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b = ustr2a[1]
   end if
@@ -1202,6 +1261,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b = str2a[1]
   end if
@@ -1225,6 +1285,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr1a = 4_"abc"
   str2a = 1_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     str2a[1] = ustr1a[mod(1, num_images())+1]
   end if
@@ -1241,6 +1302,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str1a = 1_"abc"
   ustr2a = 4_"XXXXXXX"
+  sync all
   if (this_image() == num_images()) then
     ustr2a[1] = str1a[mod(1, num_images())+1]
   end if
@@ -1257,6 +1319,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   ustr2a = 4_"abcde"
   str1a = 1_"XXX"
+  sync all
   if (this_image() == num_images()) then
     str1a[1] = ustr2a[mod(1, num_images())+1]
   end if
@@ -1273,6 +1336,7 @@ subroutine char_test()
   ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
   str2a = 1_"abcde"
   ustr1a = 4_"XXX"
+  sync all
   if (this_image() == num_images()) then
     ustr1a[1] = str2a[mod(1, num_images())+1]
   end if
@@ -1295,6 +1359,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
   end if
@@ -1317,6 +1382,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = str1b(:)[mod(1, num_images())+1]
   end if
@@ -1339,6 +1405,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
   end if
@@ -1361,6 +1428,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = str2b(:)[mod(1, num_images())+1]
   end if
@@ -1383,6 +1451,7 @@ subroutine char_test()
   str2b(1) = 1_"XXXXXXX"
   str2b(2) = 1_"YYYYYYY"
   str2b(3) = 1_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     str2b(:)[1] = ustr1a[mod(1, num_images())+1]
   end if
@@ -1403,6 +1472,7 @@ subroutine char_test()
   ustr2b(1) = 4_"XXXXXXX"
   ustr2b(2) = 4_"YYYYYYY"
   ustr2b(3) = 4_"ZZZZZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr2b(:)[1] = str1a[mod(1, num_images())+1]
   end if
@@ -1423,6 +1493,7 @@ subroutine char_test()
   str1b(1) = 1_"XXX"
   str1b(2) = 1_"YYY"
   str1b(3) = 1_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     str1b(:)[1] = ustr2a[mod(1, num_images())+1]
   end if
@@ -1443,6 +1514,7 @@ subroutine char_test()
   ustr1b(1) = 4_"XXX"
   ustr1b(2) = 4_"YYY"
   ustr1b(3) = 4_"ZZZ"
+  sync all
   if (this_image() == num_images()) then
     ustr1b(:)[1] = str2a[mod(1, num_images())+1]
   end if

gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08

@@ -15,8 +15,8 @@ program pr98903
   a = 42
   s = 42
 
-  ! Checking against single image only.  Therefore team statements are
+  sync all
-  ! not viable nor are they (yet) supported by GFortran.
+  
   if (a[1, team_number=-1, stat=s] /= 42) stop 1
   if (s /= 0) stop 2
 

gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90

@@ -13,68 +13,72 @@ program coindexed_5
   parentteam = get_team()
 
   caf = [23, 32]
-  form team(t_num, team, new_index=1)
+  form team(t_num, team) !, new_index=num_images() - this_image() + 1)
   form team(t_num, formed_team)
 
   change team(team, cell[*] => caf(2))
-    ! for get_from_remote
+    associate(me => this_image())
-    ! Checking against caf_single is very limitted.
+      ! for get_from_remote
-    if (cell[1, team_number=t_num] /= 32) stop 1
+      ! Checking against caf_single is very limitted.
-    if (cell[1, team_number=st_num] /= 32) stop 2
+      if (cell[me, team_number=t_num] /= 32) stop 1
-    if (cell[1, team=parentteam] /= 32) stop 3
+      if (cell[me, team_number=st_num] /= 32) stop 2
+      if (cell[me, team=parentteam] /= 32) stop 3
 
-    ! Check that team_number is validated
+      ! Check that team_number is validated
-    lhs = cell[1, team_number=5, stat=stat]
+      lhs = cell[me, team_number=5, stat=stat]
-    if (stat /= 1) stop 4
+      if (stat /= 1) stop 4
 
-    ! Check that only access to active teams is valid
+      ! Check that only access to active teams is valid
-    stat = 42
+      stat = 42
-    lhs = cell[1, team=formed_team, stat=stat]
+      lhs = cell[me, team=formed_team, stat=stat]
-    if (stat /= 1) stop 5
+      if (stat /= 1) stop 5
 
-    ! for send_to_remote
+      ! for send_to_remote
-    ! Checking against caf_single is very limitted.
+      ! Checking against caf_single is very limitted.
-    cell[1, team_number=t_num] = 45
+      cell[me, team_number=t_num] = 45
-    if (cell /= 45) stop 11
+      if (cell /= 45) stop 11
-    cell[1, team_number=st_num] = 46
+      cell[me, team_number=st_num] = 46
-    if (cell /= 46) stop 12
+      if (cell /= 46) stop 12
-    cell[1, team=parentteam] = 47
+      cell[me, team=parentteam] = 47
-    if (cell /= 47) stop 13
+      if (cell /= 47) stop 13
 
-    ! Check that team_number is validated
+      ! Check that team_number is validated
-    stat = -1
+      stat = -1
-    cell[1, team_number=5, stat=stat] = 0
+      cell[me, team_number=5, stat=stat] = 0
-    if (stat /= 1) stop 14
+      if (stat /= 1) stop 14
 
-    ! Check that only access to active teams is valid
+      ! Check that only access to active teams is valid
-    stat = 42
+      stat = 42
-    cell[1, team=formed_team, stat=stat] = -1
+      cell[me, team=formed_team, stat=stat] = -1
-    if (stat /= 1) stop 15
+      if (stat /= 1) stop 15
 
-    ! for transfer_between_remotes
+      ! for transfer_between_remotes
-    ! Checking against caf_single is very limitted.
+      ! Checking against caf_single is very limitted.
-    cell[1, team_number=t_num] = caf(1)[1, team_number=-1]
+      cell[me, team_number=t_num] = caf(1)[me, team_number=-1]
-    if (cell /= 23) stop 21
+      if (cell /= 23) stop 21
-    cell[1, team_number=st_num] = caf(2)[1, team_number=-1]
+      cell[me, team_number=st_num] = caf(2)[me, team_number=-1]
-    ! cell is an alias for caf(2) and has been overwritten by caf(1)!
+      ! cell is an alias for caf(2) and has been overwritten by caf(1)!
-    if (cell /= 23) stop 22
+      if (cell /= 23) stop 22
-    cell[1, team=parentteam] = caf(1)[1, team= team]
+      cell[me, team=parentteam] = caf(1)[me, team= team]
-    if (cell /= 23) stop 23
+      if (cell /= 23) stop 23
 
-    ! Check that team_number is validated
+      ! Check that team_number is validated
-    stat = -1
+      stat = -1
-    cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1]
+      cell[me, team_number=5, stat=stat] = caf(1)[me, team_number= -1]
-    if (stat /= 1) stop 24
+      if (stat /= 1) stop 24
-    stat = -1
+      stat = -1
-    cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat]
+      cell[me, team_number=t_num] = caf(1)[me, team_number= -2, stat=stat]
-    if (stat /= 1) stop 25
+      if (stat /= 1) stop 25
 
-    ! Check that only access to active teams is valid
+      ! Check that only access to active teams is valid
-    stat = 42
+      stat = 42
-    cell[1, team=formed_team, stat=stat] = caf(1)[1]
+      cell[me, team=formed_team, stat=stat] = caf(1)[me]
-    if (stat /= 1) stop 26
+      if (stat /= 1) stop 26
-    stat = 42
+      stat = 42
-    cell[1] = caf(1)[1, team=formed_team, stat=stat]
+      cell[me] = caf(1)[me, team=formed_team, stat=stat]
-    if (stat /= 1) stop 27
+      if (stat /= 1) stop 27
+
+      sync all
+    end associate
   end team
 end program coindexed_5

gcc/testsuite/gfortran.dg/coarray/dummy_3.f90

@@ -15,6 +15,7 @@ program pr77871
    p%i = 42
    allocate (p2(5)[*])
    p2(:)%i = (/(i, i=0, 4)/)
+   sync all
    call s(p, 1)
    call s2(p2, 1)
 contains

gcc/testsuite/gfortran.dg/coarray/event_1.f90

@@ -5,47 +5,54 @@
 use iso_fortran_env, only: event_type
 implicit none
 
-type(event_type), save :: var[*]
+type(event_type), save, allocatable, dimension(:) :: events[:]
 integer :: count, stat
 
-count = -42
+associate (me => this_image(), np => num_images())
-call event_query (var, count)
+  allocate(events(np)[*])
-if (count /= 0) STOP 1
 
-stat = 99
+  associate(var => events(me))
-event post (var, stat=stat)
+    count = -42
-if (stat /= 0) STOP 2
+    call event_query (var, count)
-call event_query(var, count, stat=stat)
+    if (count /= 0) STOP 1
-if (count /= 1 .or. stat /= 0) STOP 3
 
-stat = 99
+    stat = 99
-event post (var[this_image()])
+    event post (var, stat=stat)
-call event_query(var, count)
+    if (stat /= 0) STOP 2
-if (count /= 2) STOP 4
+    call event_query(var, count, stat=stat)
+    if (count /= 1 .or. stat /= 0) STOP 3
 
-stat = 99
+    count = 99
-event wait (var)
+    event post (var[this_image()])
-call event_query(var, count)
+    call event_query(var, count)
-if (count /= 1) STOP 5
+    if (count /= 2) STOP 4
 
-stat = 99
+    count = 99
-event post (var)
+    event wait (var)
-call event_query(var, count)
+    call event_query(var, count)
-if (count /= 2) STOP 6
+    if (count /= 1) STOP 5
 
-stat = 99
+    count = 99
-event post (var)
+    event post (var)
-call event_query(var, count)
+    call event_query(var, count)
-if (count /= 3) STOP 7
+    if (count /= 2) STOP 6
 
-stat = 99
+    count = 99
-event wait (var, until_count=2)
+    event post (var)
-call event_query(var, count)
+    call event_query(var, count)
-if (count /= 1) STOP 8
+    if (count /= 3) STOP 7
 
-stat = 99
+    count = 99
-event wait (var, stat=stat, until_count=1)
+    event wait (var, until_count=2)
-if (stat /= 0) STOP 9
+    call event_query(var, count)
-call event_query(event=var, stat=stat, count=count)
+    if (count /= 1) STOP 8
-if (count /= 0 .or. stat /= 0) STOP 10
+   
+    stat = 99
+    event wait (var, stat=stat, until_count=1)
+    if (stat /= 0) STOP 9
+    count = 99
+    call event_query(event=var, stat=stat, count=count)
+    if (count /= 0 .or. stat /= 0) STOP 10
+  end associate
+end associate
 end

gcc/testsuite/gfortran.dg/coarray/event_3.f08

@@ -11,8 +11,8 @@ program global_event
   contains
     subroutine exchange
       integer :: cnt
-      event post(x[1])
+      event post(x[this_image()])
-      event post(x[1])
+      event post(x[this_image()])
       call event_query(x, cnt)
       if (cnt /= 2) error stop 1
       event wait(x, until_count=2)

gcc/testsuite/gfortran.dg/coarray/event_4.f08

@@ -8,5 +8,6 @@ program event_4
   type(event_type) done[*]
   nc(1) = 1
   event post(done[1])
-  event wait(done,until_count=nc(1))
+  if (this_image() == 1) event wait(done,until_count=nc(1))
+  sync all
 end

gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08

@@ -8,7 +8,7 @@ program test_failed_images_1
   integer :: i
 
   fi = failed_images()         ! OK
-  fi = failed_images(TEAM=1)   ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" }
+  fi = failed_images(TEAM=1)   ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" }
   fi = failed_images(KIND=1)   ! OK
   fi = failed_images(KIND=4)   ! OK
   fi = failed_images(KIND=0)   ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" }

gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08

@@ -1,17 +1,44 @@
 ! { dg-do run }
 
 program test_failed_images_2
+  use iso_fortran_env
   implicit none
 
+  type(team_type) :: t
   integer, allocatable :: fi(:)
   integer(kind=1), allocatable :: sfi(:)
+  integer, allocatable :: rem_images(:)
+  integer :: i, st
 
-  fi = failed_images()
+  associate(np => num_images())
-  if (size(fi) > 0) error stop "failed_images result shall be empty array"
+    form team (1, t)
-  sfi = failed_images(KIND=1)
+    fi = failed_images()
-  if (size(sfi) > 0) error stop "failed_images result shall be empty array"
+    if (size(fi) > 0) stop 1
-  sfi = failed_images(KIND=8)
+    sfi = failed_images(KIND=1)
-  if (size(sfi) > 0) error stop "failed_images result shall be empty array"
+    if (size(sfi) > 0) stop 2
+    sfi = failed_images(KIND=8)
+    if (size(sfi) > 0) stop 3
+    
+    fi = failed_images(t)
+    if (size(fi) > 0) stop 4
   
+    if (num_images() > 1) then
+      sync all
+      if (this_image() == 2) fail image
+      rem_images = (/ 1, ( i, i = 3, np )/)
+      ! Can't synchronize well on a failed image.  Try with a sleep.
+      do i = 0, 10
+        if (size(failed_images()) == 0) then
+          call sleep(1)
+        else
+          exit
+        end if
+      end do
+      if (i == 10 .AND. size(failed_images()) == 0) stop 5
+      sync images (rem_images, stat=st)
+      if (any(failed_images() /= [2])) stop 6
+      if (any(failed_images(t, 8) /= [2])) stop 7
+    end if
+  end associate
 end program test_failed_images_2
 

gcc/testsuite/gfortran.dg/coarray/image_status_1.f08

@@ -18,7 +18,7 @@ program test_image_status_1
   isv = image_status(k2) ! Ok
   isv = image_status(k4) ! Ok
   isv = image_status(k8) ! Ok
-  isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" }
+  isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) shall be of type 'team_type'" }
   isv = image_status()          ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
   isv = image_status(team=1)    ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
 

gcc/testsuite/gfortran.dg/coarray/image_status_2.f08

@@ -1,12 +1,38 @@
 ! { dg-do run }
 
 program test_image_status_2
-  use iso_fortran_env , only : STAT_STOPPED_IMAGE
+  use iso_fortran_env
   implicit none
 
+  type(team_type) :: t
+  integer :: i, st
+  integer, allocatable :: rem_images(:)
+
+  form team (1, t)
+
   if (image_status(1) /= 0) error stop "Image 1 should report OK."
-  if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped."
+  if (image_status(num_images() + 1) /= STAT_STOPPED_IMAGE) error stop "Image should be stopped."
-  if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped."
+
+  if (image_status(1, t) /= 0) error stop "Image 1 in team t should report OK."
+
+  if (num_images() > 1) then
+    associate (np => num_images())
+      sync all
+      if (this_image() == 2) fail image 
+      rem_images = (/ 1, ( i, i = 3, np )/)
+      ! Can't synchronize well on failed image.  Try with a sleep.
+      do i = 0, 10
+        if (image_status(2) /= STAT_FAILED_IMAGE) then
+          call sleep(1)
+        else
+          exit
+        end if
+      end do
+      sync images (rem_images, stat=st)
+      if (image_status(2) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
+      if (image_status(2, t) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
+    end associate
+  end if
 
 end program test_image_status_2
 

gcc/testsuite/gfortran.dg/coarray/lock_2.f90

@@ -58,6 +58,8 @@ if (stat /= 0) STOP 9
 UNLOCK(lock3(4), stat=stat)
 if (stat /= 0) STOP 10
 
+! Ensure all other (/=1) images have released the locks.
+sync all
 if (this_image() == 1) then
   acquired = .false.
   LOCK (lock1[this_image()], acquired_lock=acquired)

gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90

@@ -12,28 +12,28 @@ allocate(a(1)[*])
 if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
   STOP 1
 if (any (lcobound(a) /= 1)) STOP 2
-if (any (ucobound(a) /= this_image())) STOP 3
+if (any (ucobound(a) /= num_images())) STOP 3
 deallocate(a)
 
 allocate(b[*])
 if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) &
   STOP 4
 if (any (lcobound(b) /= 1)) STOP 5
-if (any (ucobound(b) /= this_image())) STOP 6
+if (any (ucobound(b) /= num_images())) STOP 6
 deallocate(b)
 
 allocate(a(1)[-10:*])
 if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
   STOP 7
 if (any (lcobound(a) /= -10)) STOP 8
-if (any (ucobound(a) /= -11+this_image())) STOP 9
+if (any (ucobound(a) /= -11 + num_images())) STOP 9
 deallocate(a)
 
 allocate(d[23:*])
 if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) &
   STOP 10
 if (any (lcobound(d) /= 23)) STOP 11
-if (any (ucobound(d) /= 22+this_image())) STOP 12
+if (any (ucobound(d) /= 22 + num_images())) STOP 12
 deallocate(d)
 
 end

gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90

@@ -19,7 +19,7 @@ if (lcobound(a, dim=1) /= 1 .or. ucobound(a,dim=1) /= num_images()) &
 deallocate(a)
 
 allocate(a[4:*])
-a[this_image ()] = 8 - 2*this_image ()
+a[this_image () + 3] = 8 - 2*this_image ()
 
 if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) &
   STOP 4
@@ -30,6 +30,7 @@ n3 = 3
 allocate (B[n1:n2, n3:*])
 if (any (lcobound(b) /= [-1, 3]) .or. lcobound(B, dim=2) /= n3) &
   STOP 5
+sync all
 call sub(A, B)
 
 if (allocated (a)) STOP 6
@@ -47,7 +48,8 @@ contains
       STOP 8
     if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) &
       STOP 9
-    if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3
+    if (x[this_image () + 3] /= 8 - 2*this_image ()) STOP 10
+    sync all
     deallocate(x)
   end subroutine sub
 
@@ -56,12 +58,13 @@ contains
     integer, allocatable, SAVE :: a[:]
 
     if (init) then
-      if (allocated(a)) STOP 10
+      if (allocated(a)) STOP 11
       allocate(a[*])
       a = 45
    else
-      if (.not. allocated(a)) STOP 11
+      if (.not. allocated(a)) STOP 12
-      if (a /= 45) STOP 12
+      if (a /= 45) STOP 13
+      sync all
       deallocate(a)
     end if
   end subroutine two

gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08

@@ -8,7 +8,7 @@ program test_stopped_images_1
   integer :: i
 
   gi = stopped_images()         ! OK
-  gi = stopped_images(TEAM=1)   ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" }
+  gi = stopped_images(TEAM=1)   ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" }
   gi = stopped_images(KIND=1)   ! OK
   gi = stopped_images(KIND=4)   ! OK
   gi = stopped_images(KIND=0)   ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" }

gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08

@@ -1,17 +1,44 @@
 ! { dg-do run }
 
 program test_stopped_images_2
+  use iso_fortran_env
   implicit none
 
+  type(team_type) :: t
   integer, allocatable :: si(:)
   integer(kind=1), allocatable :: ssi(:)
+  integer, allocatable :: rem_images(:)
+  integer :: i, st
 
-  si = stopped_images()
+  associate(np => num_images())
-  if (size(si) > 0) error stop "stopped_images result shall be empty array"
+    form team (1, t)
-  ssi = stopped_images(KIND=1)
+    si = stopped_images()
-  if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
+    if (size(si) > 0) stop 1
-  ssi = stopped_images(KIND=8)
+    ssi = stopped_images(KIND=1)
-  if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
+    if (size(ssi) > 0) stop 2
+    ssi = stopped_images(KIND=8)
+    if (size(ssi) > 0) stop 3
+    
+    si = stopped_images(t)  
+    if (size(si) > 0) stop 4
   
+    if (num_images() > 1) then
+      sync all
+      if (this_image() == 2) stop
+      rem_images = (/ 1, ( i, i = 3, np )/)
+      ! Can't synchronize well on a stopped image.  Try with a sleep.
+      do i = 0, 10
+        if (size(stopped_images()) == 0) then
+          call sleep(1)
+        else
+          exit
+        end if
+      end do
+      if (i == 10 .AND. size(stopped_images()) == 0) stop 5
+      sync images (rem_images, stat=st)
+      if (any(stopped_images() /= [2])) stop 6
+      if (any(stopped_images(t, 8) /= [2])) stop 7
+    end if
+  end associate
 end program test_stopped_images_2
 

gcc/testsuite/gfortran.dg/coarray/sync_1.f90

@@ -26,7 +26,6 @@ n = 5
 sync all (stat=n,errmsg=str)
 if (n /= 0) STOP 2
 
-
 !
 ! Test SYNC MEMORY
 !
@@ -42,17 +41,21 @@ n = 5
 sync memory (errmsg=str,stat=n)
 if (n /= 0) STOP 4
 
-
 !
 ! Test SYNC IMAGES
 !
 sync images (*)
+
 if (this_image() == 1) then
     sync images (1)
     sync images (1, errmsg=str)
     sync images ([1])
 end if
 
+! Need to sync all here, because otherwise sync image 1 may overlap with the
+! sync images(*, stat=n) below and that may hang for num_images() > 1.
+sync all
+
 n = 5
 sync images (*, stat=n)
 if (n /= 0) STOP 5
@@ -61,4 +64,5 @@ n = 5
 sync images (*,errmsg=str,stat=n)
 if (n /= 0) STOP 6
 
+sync all
 end

gcc/testsuite/gfortran.dg/coarray/sync_3.f90

@@ -9,8 +9,9 @@
 ! PR fortran/18918
 
 implicit none
-integer :: n
+integer :: n, st
-character(len=30) :: str
+integer,allocatable :: others(:)
+character(len=40) :: str
 critical
 end critical
 myCr: critical
@@ -58,17 +59,32 @@ if (this_image() == 1) then
     sync images ([1])
 end if
 
+! Need to sync all here, because otherwise sync image 1 may overlap with the
+! sync images(*, stat=n) below and that may hang for num_images() > 1.
+sync all
+
 n = 5
 sync images (*, stat=n)
 if (n /= 0) STOP 5
 
 n = 5
-sync images (*,errmsg=str,stat=n)
+sync images (*, errmsg=str, stat=n)
 if (n /= 0) STOP 6
 
+if (this_image() == num_images()) then
+  others = (/( n, n=1, (num_images() - 1)) /)
+  sync images(others)
+else
+  sync images ( num_images() )
+end if 
+
 n = -1
-sync images ( num_images() )
+st = 0
-sync images (n) ! Invalid: "-1"
+sync images (n, errmsg=str, stat=st)
+if (st /= 1 .OR. str /= "Invalid image number -1 in SYNC IMAGES") STOP 7
+
+! Do this only on image 1, or output of error messages will clutter
+if (this_image() == 1) sync images (n) ! Invalid: "-1"
 
 end
 

gcc/testsuite/gfortran.dg/coarray/sync_team.f90

@@ -0,0 +1,33 @@
+!{ dg-do run }
+
+program main
+  use, intrinsic :: iso_fortran_env, only: team_type
+  implicit none
+  integer, parameter :: PARENT_TEAM = 1, CURRENT_TEAM = 2, CHILD_TEAM = 3
+  type(team_type) :: team(3)
+
+  if (num_images() > 7) then
+
+    form team (1, team(PARENT_TEAM))
+    change team (team(PARENT_TEAM))
+      form team (mod(this_image(),2) + 1, team(CURRENT_TEAM))
+      change team (team(CURRENT_TEAM))
+        form team(mod(this_image(),2) + 1, team(CHILD_TEAM))
+        sync team(team(PARENT_TEAM))
+        ! change order / number of syncs between teams to try to expose deadlocks
+        if (team_number() == 1) then
+           sync team(team(CURRENT_TEAM))
+           sync team(team(CHILD_TEAM))
+        else
+           sync team(team(CHILD_TEAM))
+           sync team(team(CURRENT_TEAM))
+           sync team(team(CHILD_TEAM))
+           sync team(team(CURRENT_TEAM))
+        end if
+      end team
+    end team
+
+    sync all
+  end if
+
+end program

gcc/testsuite/gfortran.dg/coarray_sync_memory.f90

@@ -14,5 +14,5 @@ end
 
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, 0B, 0\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, &&msg, 42\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, &msg, 42\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, &&msg, 42\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, &msg, 42\\);" 1 "original" } }

libgfortran/Makefile.am

@@ -58,13 +58,30 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version`
 	$(version_arg) -Wc,-shared-libgcc
 libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP)
 
-cafexeclib_LTLIBRARIES = libcaf_single.la
+libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h
+libcaf_shared_SRCS = caf/caf_error.c
+
+cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la
 cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
-libcaf_single_la_SOURCES = caf/single.c
+libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
 libcaf_single_la_LDFLAGS = -static
-libcaf_single_la_DEPENDENCIES = caf/libcaf.h
+libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
 libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
 
+libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \
+	caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \
+	caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \
+	caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \
+	caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c
+
+libcaf_shmem_la_LDFLAGS = -static
+libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \
+	caf/shmem/allocator.h caf/shmem/collective_subroutine.h \
+	caf/shmem/counter_barrier.h caf/shmem/hashmap.h \
+	caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \
+	caf/shmem/teams_mgmt.h caf/shmem/thread_support.h
+libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS)
+
 if IEEE_SUPPORT
 fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
 nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod

libgfortran/Makefile.in

@@ -219,21 +219,31 @@ am__installdirs = "$(DESTDIR)$(cafexeclibdir)" \
 	"$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" \
 	"$(DESTDIR)$(gfor_cdir)" "$(DESTDIR)$(fincludedir)"
 LTLIBRARIES = $(cafexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES)
-libcaf_single_la_LIBADD =
+libcaf_shmem_la_LIBADD =
 am__dirstamp = $(am__leading_dot)dirstamp
-am_libcaf_single_la_OBJECTS = caf/single.lo
+am__objects_1 = caf/caf_error.lo
+am_libcaf_shmem_la_OBJECTS = $(am__objects_1) caf/shmem.lo \
+	caf/shmem/alloc.lo caf/shmem/allocator.lo \
+	caf/shmem/collective_subroutine.lo \
+	caf/shmem/counter_barrier.lo caf/shmem/hashmap.lo \
+	caf/shmem/shared_memory.lo caf/shmem/supervisor.lo \
+	caf/shmem/sync.lo caf/shmem/teams_mgmt.lo \
+	caf/shmem/thread_support.lo
+libcaf_shmem_la_OBJECTS = $(am_libcaf_shmem_la_OBJECTS)
+libcaf_single_la_LIBADD =
+am_libcaf_single_la_OBJECTS = caf/single.lo $(am__objects_1)
 libcaf_single_la_OBJECTS = $(am_libcaf_single_la_OBJECTS)
 libgfortran_la_LIBADD =
-@LIBGFOR_MINIMAL_TRUE@am__objects_1 = runtime/minimal.lo
+@LIBGFOR_MINIMAL_TRUE@am__objects_2 = runtime/minimal.lo
-@LIBGFOR_MINIMAL_FALSE@am__objects_2 = runtime/backtrace.lo \
+@LIBGFOR_MINIMAL_FALSE@am__objects_3 = runtime/backtrace.lo \
 @LIBGFOR_MINIMAL_FALSE@	runtime/convert_char.lo \
 @LIBGFOR_MINIMAL_FALSE@	runtime/environ.lo runtime/error.lo \
 @LIBGFOR_MINIMAL_FALSE@	runtime/fpu.lo runtime/main.lo \
 @LIBGFOR_MINIMAL_FALSE@	runtime/pause.lo runtime/stop.lo
-am__objects_3 = runtime/bounds.lo runtime/compile_options.lo \
+am__objects_4 = runtime/bounds.lo runtime/compile_options.lo \
 	runtime/deep_copy.lo runtime/memory.lo runtime/string.lo \
-	runtime/select.lo $(am__objects_1) $(am__objects_2)
+	runtime/select.lo $(am__objects_2) $(am__objects_3)
-am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \
+am__objects_5 = generated/matmul_i1.lo generated/matmul_i2.lo \
 	generated/matmul_i4.lo generated/matmul_i8.lo \
 	generated/matmul_i16.lo generated/matmul_r4.lo \
 	generated/matmul_r8.lo generated/matmul_r10.lo \
@@ -241,9 +251,9 @@ am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \
 	generated/matmul_c4.lo generated/matmul_c8.lo \
 	generated/matmul_c10.lo generated/matmul_c16.lo \
 	generated/matmul_c17.lo
-am__objects_5 = generated/matmul_l4.lo generated/matmul_l8.lo \
+am__objects_6 = generated/matmul_l4.lo generated/matmul_l8.lo \
 	generated/matmul_l16.lo
-am__objects_6 = generated/matmulavx128_i1.lo \
+am__objects_7 = generated/matmulavx128_i1.lo \
 	generated/matmulavx128_i2.lo generated/matmulavx128_i4.lo \
 	generated/matmulavx128_i8.lo generated/matmulavx128_i16.lo \
 	generated/matmulavx128_r4.lo generated/matmulavx128_r8.lo \
@@ -251,7 +261,7 @@ am__objects_6 = generated/matmulavx128_i1.lo \
 	generated/matmulavx128_r17.lo generated/matmulavx128_c4.lo \
 	generated/matmulavx128_c8.lo generated/matmulavx128_c10.lo \
 	generated/matmulavx128_c16.lo generated/matmulavx128_c17.lo
-am__objects_7 = generated/all_l1.lo generated/all_l2.lo \
+am__objects_8 = generated/all_l1.lo generated/all_l2.lo \
 	generated/all_l4.lo generated/all_l8.lo generated/all_l16.lo \
 	generated/any_l1.lo generated/any_l2.lo generated/any_l4.lo \
 	generated/any_l8.lo generated/any_l16.lo \
@@ -540,17 +550,17 @@ am__objects_7 = generated/all_l1.lo generated/all_l2.lo \
 	generated/pow_m8_m16.lo generated/pow_m16_m1.lo \
 	generated/pow_m16_m2.lo generated/pow_m16_m4.lo \
 	generated/pow_m16_m8.lo generated/pow_m16_m16.lo \
-	$(am__objects_4) $(am__objects_5) $(am__objects_6) \
+	$(am__objects_5) $(am__objects_6) $(am__objects_7) \
 	runtime/ISO_Fortran_binding.lo
-@LIBGFOR_MINIMAL_FALSE@am__objects_8 = io/close.lo io/file_pos.lo \
+@LIBGFOR_MINIMAL_FALSE@am__objects_9 = io/close.lo io/file_pos.lo \
 @LIBGFOR_MINIMAL_FALSE@	io/format.lo io/inquire.lo \
 @LIBGFOR_MINIMAL_FALSE@	io/intrinsics.lo io/list_read.lo \
 @LIBGFOR_MINIMAL_FALSE@	io/lock.lo io/open.lo io/read.lo \
 @LIBGFOR_MINIMAL_FALSE@	io/transfer.lo io/transfer128.lo \
 @LIBGFOR_MINIMAL_FALSE@	io/unit.lo io/unix.lo io/write.lo \
 @LIBGFOR_MINIMAL_FALSE@	io/fbuf.lo io/async.lo
-am__objects_9 = io/size_from_kind.lo $(am__objects_8)
+am__objects_10 = io/size_from_kind.lo $(am__objects_9)
-@LIBGFOR_MINIMAL_FALSE@am__objects_10 = intrinsics/access.lo \
+@LIBGFOR_MINIMAL_FALSE@am__objects_11 = intrinsics/access.lo \
 @LIBGFOR_MINIMAL_FALSE@	intrinsics/c99_functions.lo \
 @LIBGFOR_MINIMAL_FALSE@	intrinsics/chdir.lo intrinsics/chmod.lo \
 @LIBGFOR_MINIMAL_FALSE@	intrinsics/clock.lo \
@@ -574,8 +584,8 @@ am__objects_9 = io/size_from_kind.lo $(am__objects_8)
 @LIBGFOR_MINIMAL_FALSE@	intrinsics/system_clock.lo \
 @LIBGFOR_MINIMAL_FALSE@	intrinsics/time.lo intrinsics/umask.lo \
 @LIBGFOR_MINIMAL_FALSE@	intrinsics/unlink.lo
-@IEEE_SUPPORT_TRUE@am__objects_11 = ieee/ieee_helper.lo
+@IEEE_SUPPORT_TRUE@am__objects_12 = ieee/ieee_helper.lo
-am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \
+am__objects_13 = intrinsics/associated.lo intrinsics/abort.lo \
 	intrinsics/args.lo intrinsics/cshift0.lo \
 	intrinsics/eoshift0.lo intrinsics/eoshift2.lo \
 	intrinsics/erfc_scaled.lo intrinsics/extends_type_of.lo \
@@ -590,12 +600,12 @@ am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \
 	intrinsics/selected_real_kind.lo intrinsics/trigd.lo \
 	intrinsics/unpack_generic.lo runtime/in_pack_generic.lo \
 	runtime/in_unpack_generic.lo runtime/in_pack_class.lo \
-	runtime/in_unpack_class.lo $(am__objects_10) $(am__objects_11)
+	runtime/in_unpack_class.lo $(am__objects_11) $(am__objects_12)
-@IEEE_SUPPORT_TRUE@am__objects_13 = ieee/ieee_arithmetic.lo \
+@IEEE_SUPPORT_TRUE@am__objects_14 = ieee/ieee_arithmetic.lo \
 @IEEE_SUPPORT_TRUE@	ieee/ieee_exceptions.lo \
 @IEEE_SUPPORT_TRUE@	ieee/ieee_features.lo
-am__objects_14 =
+am__objects_15 =
-am__objects_15 = generated/_abs_c4.lo generated/_abs_c8.lo \
+am__objects_16 = generated/_abs_c4.lo generated/_abs_c8.lo \
 	generated/_abs_c10.lo generated/_abs_c16.lo \
 	generated/_abs_c17.lo generated/_abs_i4.lo \
 	generated/_abs_i8.lo generated/_abs_i16.lo \
@@ -681,9 +691,9 @@ am__objects_15 = generated/_abs_c4.lo generated/_abs_c8.lo \
 	generated/_mod_r17.lo generated/misc_specifics.lo \
 	intrinsics/dprod_r8.lo intrinsics/f2c_specifics.lo \
 	intrinsics/random_init.lo
-am_libgfortran_la_OBJECTS = $(am__objects_3) $(am__objects_7) \
+am_libgfortran_la_OBJECTS = $(am__objects_4) $(am__objects_8) \
-	$(am__objects_9) $(am__objects_12) $(am__objects_13) \
+	$(am__objects_10) $(am__objects_13) $(am__objects_14) \
-	$(am__objects_14) $(am__objects_15)
+	$(am__objects_15) $(am__objects_16)
 libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
 AM_V_P = $(am__v_P_@AM_V@)
 am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
@@ -748,7 +758,8 @@ AM_V_FC = $(am__v_FC_@AM_V@)
 am__v_FC_ = $(am__v_FC_@AM_DEFAULT_V@)
 am__v_FC_0 = @echo "  FC      " $@;
 am__v_FC_1 = 
-SOURCES = $(libcaf_single_la_SOURCES) $(libgfortran_la_SOURCES)
+SOURCES = $(libcaf_shmem_la_SOURCES) $(libcaf_single_la_SOURCES) \
+	$(libgfortran_la_SOURCES)
 am__can_run_installinfo = \
   case $$AM_UPDATE_INFO_DIR in \
     n|no|NO) false;; \
@@ -965,12 +976,28 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version`
 	$(version_arg) -Wc,-shared-libgcc
 
 libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP)
-cafexeclib_LTLIBRARIES = libcaf_single.la
+libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h
+libcaf_shared_SRCS = caf/caf_error.c
+cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la
 cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
-libcaf_single_la_SOURCES = caf/single.c
+libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
 libcaf_single_la_LDFLAGS = -static
-libcaf_single_la_DEPENDENCIES = caf/libcaf.h
+libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
 libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
+libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \
+	caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \
+	caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \
+	caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \
+	caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c
+
+libcaf_shmem_la_LDFLAGS = -static
+libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \
+	caf/shmem/allocator.h caf/shmem/collective_subroutine.h \
+	caf/shmem/counter_barrier.h caf/shmem/hashmap.h \
+	caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \
+	caf/shmem/teams_mgmt.h caf/shmem/thread_support.h
+
+libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS)
 @IEEE_SUPPORT_TRUE@fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
 @IEEE_SUPPORT_TRUE@nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod
 AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
@@ -1967,6 +1994,37 @@ caf/$(am__dirstamp):
 caf/$(DEPDIR)/$(am__dirstamp):
 	@$(MKDIR_P) caf/$(DEPDIR)
 	@: > caf/$(DEPDIR)/$(am__dirstamp)
+caf/caf_error.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp)
+caf/shmem.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/$(am__dirstamp):
+	@$(MKDIR_P) caf/shmem
+	@: > caf/shmem/$(am__dirstamp)
+caf/shmem/$(DEPDIR)/$(am__dirstamp):
+	@$(MKDIR_P) caf/shmem/$(DEPDIR)
+	@: > caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/alloc.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/allocator.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/collective_subroutine.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/counter_barrier.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/hashmap.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/shared_memory.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/supervisor.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/sync.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/teams_mgmt.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/thread_support.lo: caf/shmem/$(am__dirstamp) \
+	caf/shmem/$(DEPDIR)/$(am__dirstamp)
+
+libcaf_shmem.la: $(libcaf_shmem_la_OBJECTS) $(libcaf_shmem_la_DEPENDENCIES) $(EXTRA_libcaf_shmem_la_DEPENDENCIES) 
+	$(AM_V_GEN)$(libcaf_shmem_la_LINK) -rpath $(cafexeclibdir) $(libcaf_shmem_la_OBJECTS) $(libcaf_shmem_la_LIBADD) $(LIBS)
 caf/single.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp)
 
 libcaf_single.la: $(libcaf_single_la_OBJECTS) $(libcaf_single_la_DEPENDENCIES) $(EXTRA_libcaf_single_la_DEPENDENCIES) 
@@ -3776,6 +3834,8 @@ mostlyclean-compile:
 	-rm -f *.$(OBJEXT)
 	-rm -f caf/*.$(OBJEXT)
 	-rm -f caf/*.lo
+	-rm -f caf/shmem/*.$(OBJEXT)
+	-rm -f caf/shmem/*.lo
 	-rm -f generated/*.$(OBJEXT)
 	-rm -f generated/*.lo
 	-rm -f ieee/*.$(OBJEXT)
@@ -3790,7 +3850,19 @@ mostlyclean-compile:
 distclean-compile:
 	-rm -f *.tab.c
 
+@AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/caf_error.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/shmem.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/single.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/alloc.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/allocator.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/collective_subroutine.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/counter_barrier.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/hashmap.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/shared_memory.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/supervisor.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/sync.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/teams_mgmt.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/thread_support.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l1.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l16.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l2.Plo@am__quote@
@@ -4556,6 +4628,7 @@ mostlyclean-libtool:
 clean-libtool:
 	-rm -rf .libs _libs
 	-rm -rf caf/.libs caf/_libs
+	-rm -rf caf/shmem/.libs caf/shmem/_libs
 	-rm -rf generated/.libs generated/_libs
 	-rm -rf ieee/.libs ieee/_libs
 	-rm -rf intrinsics/.libs intrinsics/_libs
@@ -4723,6 +4796,8 @@ distclean-generic:
 	-test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
 	-rm -f caf/$(DEPDIR)/$(am__dirstamp)
 	-rm -f caf/$(am__dirstamp)
+	-rm -f caf/shmem/$(DEPDIR)/$(am__dirstamp)
+	-rm -f caf/shmem/$(am__dirstamp)
 	-rm -f generated/$(DEPDIR)/$(am__dirstamp)
 	-rm -f generated/$(am__dirstamp)
 	-rm -f ieee/$(DEPDIR)/$(am__dirstamp)
@@ -4745,7 +4820,7 @@ clean-am: clean-cafexeclibLTLIBRARIES clean-generic clean-libtool \
 
 distclean: distclean-am
 	-rm -f $(am__CONFIG_DISTCLEAN_FILES)
-	-rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
+	-rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
 	-rm -f Makefile
 distclean-am: clean-am distclean-compile distclean-generic \
 	distclean-hdr distclean-libtool distclean-local distclean-tags
@@ -4794,7 +4869,7 @@ installcheck-am:
 maintainer-clean: maintainer-clean-am
 	-rm -f $(am__CONFIG_DISTCLEAN_FILES)
 	-rm -rf $(top_srcdir)/autom4te.cache
-	-rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
+	-rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
 	-rm -f Makefile
 maintainer-clean-am: distclean-am maintainer-clean-generic \
 	maintainer-clean-local

libgfortran/acinclude.m4

@@ -578,3 +578,15 @@ main ()
                        [Define to 1 if you have the `$1' function.])
   fi
 ])
+
+AC_DEFUN([LIBGFOR_CHECK_SANE_BUILTIN_CLZL], [
+  AC_RUN_IFELSE([AC_LANG_PROGRAM([[
+      int main()
+      {
+	return __builtin_clzl(256) != 8;
+      }]], [[]])],
+    AC_DEFINE(HAVE_SANE_BUILTIN_CLZL, 1,
+      [Define if __builtin_clzl behaves as expected.])
+    AM_CONDITIONAL([HAVE_SANE_BUILTIN_CLZL],true),
+    [AM_CONDITIONAL([HAVE_SANE_BUILTIN_CLZL],false)])
+])

libgfortran/caf/caf_error.c

@@ -0,0 +1,71 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "caf_error.h"
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+static void
+internal_caf_runtime_error (const char *format, va_list args)
+{
+  fprintf (stderr, "Fortran runtime error: ");
+  vfprintf (stderr, format, args);
+  fprintf (stderr, "\n");
+
+  exit (EXIT_FAILURE);
+}
+
+void
+caf_runtime_error (const char *format, ...)
+{
+  va_list ap;
+  va_start (ap, format);
+  internal_caf_runtime_error (format, ap);
+}
+
+void
+caf_internal_error (const char *format, int *stat, char *errmsg,
+		    size_t errmsg_len, ...)
+{
+  va_list args;
+  va_start (args, errmsg_len);
+  if (stat)
+    {
+      *stat = 1;
+      if (errmsg_len > 0)
+	{
+	  int len = vsnprintf (errmsg, errmsg_len, format, args);
+	  if (len >= 0 && errmsg_len > (size_t) len)
+	    memset (&errmsg[len], ' ', errmsg_len - len);
+	}
+      va_end (args);
+      return;
+    }
+  else
+    internal_caf_runtime_error (format, args);
+  va_end (args);
+}

libgfortran/caf/caf_error.h

@@ -0,0 +1,44 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef CAF_ERROR_H
+#define CAF_ERROR_H
+
+#include <stddef.h>
+
+/* Emit a printf style error message and exit with EXIT_FAILURE.  */
+
+void caf_runtime_error (const char *format, ...);
+
+/* If `stat` is given, it will be set to 1 and procedure returns to the caller.
+   If additionally `errmsg` is non-NULL, then printf-style `format` will by
+   printed to `errmsg`.  If the resulting message is longer then `errmsg_len`,
+   it will be truncated, else filled with spaces.
+   If `stat` is not given, then the printf-formated message will be emited to
+   stderr and the program terminates with EXIT_FAILURE.  */
+
+void caf_internal_error (const char *format, int *stat, char *errmsg,
+			 size_t errmsg_len, ...);
+
+#endif

libgfortran/caf/libcaf.h

@@ -26,9 +26,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #ifndef LIBCAF_H
 #define LIBCAF_H
 
-#include <stdbool.h>
-#include <stddef.h>	/* For size_t.  */
-
 #include "libgfortran.h"
 
 /* Definitions of the Fortran 2008 standard; need to kept in sync with
@@ -175,12 +172,9 @@ void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, size_t);
 void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, size_t);
 void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
 
-void _gfortran_caf_failed_images (gfc_descriptor_t *,
+void _gfortran_caf_failed_images (gfc_descriptor_t *, caf_team_t *, int *);
-				  caf_team_t * __attribute__ ((unused)), int *);
+int _gfortran_caf_image_status (int, caf_team_t *);
-int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused)));
+void _gfortran_caf_stopped_images (gfc_descriptor_t *, caf_team_t *, int *);
-void _gfortran_caf_stopped_images (gfc_descriptor_t *,
-				   caf_team_t * __attribute__ ((unused)),
-				   int *);
 
 void _gfortran_caf_random_init (bool, bool);
 

libgfortran/caf/shmem/alloc.c

@@ -0,0 +1,168 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+/* This provides the coarray-specific features (like IDs etc) for
+   allocator.c, in turn calling routines from shared_memory.c.
+*/
+
+#include "alloc.h"
+#include "../caf_error.h"
+#include "supervisor.h"
+#include "shared_memory.h"
+#include "thread_support.h"
+
+#include <assert.h>
+#include <string.h>
+
+/* Worker's part to initialize the alloc interface.  */
+
+void
+alloc_init (alloc *iface, shared_memory mem)
+{
+  iface->as = &this_image.supervisor->alloc_shared;
+  iface->mem = mem;
+  allocator_init (&iface->alloc, &iface->as->allocator_s, mem);
+  hashmap_init (&iface->hm, &this_image.supervisor->hms, &iface->alloc);
+}
+
+/* Allocate the shared memory interface.  This is called before we have
+   multiple images.  Called only by supervisor.  */
+
+void
+alloc_init_supervisor (alloc *iface, shared_memory mem)
+{
+  iface->as = &this_image.supervisor->alloc_shared;
+  iface->mem = mem;
+  allocator_init_supervisor (&iface->alloc, &iface->as->allocator_s, mem);
+  hashmap_init_supervisor (&iface->hm, &this_image.supervisor->hms,
+			   &iface->alloc);
+}
+
+/* Return a local pointer into a shared memory object identified by
+   id.  If the object is already found, it has been allocated before,
+   so just increase the reference counter.
+
+   The pointers returned by this function remain valid even if the
+   size of the memory allocation changes (see shared_memory.c).  */
+
+static void *
+get_memory_by_id_internal (alloc *iface, size_t size, memid id, bool *created)
+{
+  hashmap_search_result res;
+  shared_mem_ptr shared_ptr;
+  void *ret;
+
+  shared_memory_prepare (iface->mem);
+
+  res = hashmap_get (&iface->hm, id);
+
+  if (hm_search_result_contains (&res))
+    {
+      size_t found_size;
+      found_size = hm_search_result_size (&res);
+      if (found_size < size)
+	{
+	  allocator_unlock (&iface->alloc);
+	  caf_runtime_error (
+	    "Size mismatch for coarray allocation id %zd: found = %lu "
+	    "< size = %lu\n",
+	    id, found_size, size);
+	  return NULL; // The runtime_error exit()s, so this is never reached.
+	}
+      shared_ptr = hm_search_result_ptr (&res);
+      hashmap_inc (&iface->hm, id, &res);
+
+      if (created)
+	*created = false;
+      ret = SHMPTR_AS (void *, shared_ptr, iface->mem);
+    }
+  else
+    {
+      shared_ptr = allocator_shared_malloc (&iface->alloc, size);
+      hashmap_set (&iface->hm, id, NULL, shared_ptr, size);
+
+      if (created)
+	*created = true;
+
+      ret = SHMPTR_AS (void *, shared_ptr, iface->mem);
+    }
+
+  return ret;
+}
+
+void *
+alloc_get_memory_by_id (alloc *iface, size_t size, memid id)
+{
+  allocator_lock (&iface->alloc);
+  void *ret = get_memory_by_id_internal (iface, size, id, NULL);
+  allocator_unlock (&iface->alloc);
+  return ret;
+}
+
+void *
+alloc_get_memory_by_id_created (alloc *iface, size_t size, memid id,
+				bool *created)
+{
+  return get_memory_by_id_internal (iface, size, id, created);
+}
+
+
+/* Free memory with id.  Free it if this is the last image which
+   holds that memory segment, decrease the reference count otherwise.  */
+
+void
+alloc_free_memory_with_id (alloc *iface, memid id)
+{
+  hashmap_search_result res;
+  int entries_left;
+
+  allocator_lock (&iface->alloc);
+  shared_memory_prepare (iface->mem);
+
+  res = hashmap_get (&iface->hm, id);
+  if (!hm_search_result_contains (&res))
+    {
+      allocator_unlock (&iface->alloc);
+      caf_runtime_error ("Error in free_memory_with_id: %zd not found.\n", id);
+      return;
+    }
+
+  entries_left = hashmap_dec (&iface->hm, id, &res);
+  assert (entries_left >= 0);
+
+  if (entries_left == 0)
+    {
+      allocator_shared_free (&iface->alloc, hm_search_result_ptr (&res),
+			     hm_search_result_size (&res));
+    }
+
+  allocator_unlock (&iface->alloc);
+  return;
+}
+
+allocator *
+alloc_get_allocator (alloc *iface)
+{
+  return &iface->alloc;
+}

libgfortran/caf/shmem/alloc.h

@@ -0,0 +1,80 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef ALLOC_H
+#define ALLOC_H
+
+#include "allocator.h"
+#include "hashmap.h"
+
+/* High-level interface for shared memory allocation.
+   Handle allocation and freeing of blocks in the shared memory for coarrays.
+   While allocator keeps track of allocated and freeed portions, this "class"
+   allows allocation of coarrays identified by a memid and associate them
+   across images.
+ */
+
+/* The part of the alloc interface being shared with all other images.  There
+   must be only one of these objects!  */
+typedef struct alloc_shared
+{
+  allocator_shared allocator_s;
+} alloc_shared;
+
+/* This is the image's local part of the alloc interface.  */
+
+typedef struct alloc
+{
+  alloc_shared *as;
+  shared_memory mem;
+  allocator alloc;
+  hashmap hm;
+} alloc;
+
+/* Initialize the local instance of the alloc interface.  This routine is to be
+   called by every worker image and NOT by the supervisor.  */
+void alloc_init (alloc *, shared_memory);
+
+/* The routine MUST ONLY called by the supervisor process.
+   Initialize the shared part of the alloc interface.  The local one is only
+   initialized to be able to pass it to the other components needing it.  */
+void alloc_init_supervisor (alloc *, shared_memory);
+
+/* Get a shared memory block identified by id, or a new one, when the id
+   is not known yet.  This routine locks the allocator lock itself.  */
+void *alloc_get_memory_by_id (alloc *, size_t, memid);
+
+/* Same as alloc_get_memory_by_id, but it does not lock the allocator lock and
+   returns an additional bool, that is true, when the memory has been allocated
+   freshly.  */
+void *alloc_get_memory_by_id_created (alloc *, size_t, memid, bool *);
+
+/* Mark the memory identified by id as free.  This reduces the use counter on
+   the memory and sets is free, when the count goes to zero.  */
+void alloc_free_memory_with_id (alloc *, memid);
+
+/* Get the allocator for reuse in other interfaces.  */
+allocator *alloc_get_allocator (alloc *);
+
+#endif

libgfortran/caf/shmem/allocator.c

@@ -0,0 +1,145 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+/* Main allocation routine, works like malloc.  Round up allocations
+   to the next power of two and keep free lists in buckets.  */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include "libgfortran.h"
+
+#include "allocator.h"
+#include "supervisor.h"
+#include "thread_support.h"
+
+#include <assert.h>
+
+typedef struct
+{
+  shared_mem_ptr next;
+} bucket;
+
+size_t
+alignto (size_t size, size_t align)
+{
+  return align * ((size + align - 1) / align);
+}
+
+size_t pagesize;
+
+size_t
+round_to_pagesize (size_t s)
+{
+  return alignto (s, pagesize);
+}
+
+/* Initialize the allocator.  */
+
+void
+allocator_init (allocator *a, allocator_shared *s, shared_memory sm)
+{
+  *a = (allocator) {s, sm};
+}
+
+void
+allocator_init_supervisor (allocator *a, allocator_shared *s, shared_memory sm)
+{
+  *a = (allocator) {s, sm};
+  initialize_shared_mutex (&s->lock);
+  for (size_t i = 0; i < VOIDP_BITS; i++)
+    s->free_bucket_head[i] = SHMPTR_NULL;
+}
+
+#define MAX_ALIGN 16
+
+static size_t
+next_power_of_two (size_t size)
+{
+#ifdef HAVE_SANE_BUILTIN_CLZL
+  assert (size);
+#if (__INTPTR_WIDTH__ == 64)
+  return 1 << (VOIDP_BITS - __builtin_clzl (size - 1));
+#else
+  return 1 << (VOIDP_BITS - __builtin_clz (size - 1));
+#endif
+#else
+  return 1 << (int)ceil(log2(size));
+#endif
+}
+
+shared_mem_ptr
+allocator_shared_malloc (allocator *a, size_t size)
+{
+  shared_mem_ptr ret;
+  size_t sz;
+  size_t act_size;
+  int bucket_list_index;
+
+  sz = next_power_of_two (size);
+  act_size = sz > sizeof (bucket) ? sz : sizeof (bucket);
+  bucket_list_index = __builtin_clzl (act_size);
+  assert (bucket_list_index
+	  < (int) (sizeof (a->s->free_bucket_head) / sizeof (shared_mem_ptr)));
+
+  if (SHMPTR_IS_NULL (a->s->free_bucket_head[bucket_list_index]))
+    return shared_memory_get_mem_with_alignment (a->shm, act_size, MAX_ALIGN);
+
+  ret = a->s->free_bucket_head[bucket_list_index];
+  a->s->free_bucket_head[bucket_list_index]
+      = (SHMPTR_AS (bucket *, ret, a->shm)->next);
+  return ret;
+}
+
+/* Free memory.  */
+
+void
+allocator_shared_free (allocator *a, shared_mem_ptr p, size_t size)
+{
+  bucket *b;
+  size_t sz;
+  int bucket_list_index;
+  size_t act_size;
+
+  sz = next_power_of_two (size);
+  act_size = sz > sizeof (bucket) ? sz : sizeof (bucket);
+  bucket_list_index = __builtin_clzl (act_size);
+
+  b = SHMPTR_AS (bucket *, p, a->shm);
+  b->next = a->s->free_bucket_head[bucket_list_index];
+  a->s->free_bucket_head[bucket_list_index] = p;
+}
+
+void
+allocator_lock (allocator *a)
+{
+  caf_shmem_mutex_lock (&a->s->lock);
+}
+
+void
+allocator_unlock (allocator *a)
+{
+  caf_shmem_mutex_unlock (&a->s->lock);
+}

libgfortran/caf/shmem/allocator.h

@@ -0,0 +1,88 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+/* A malloc() - and free() - like interface, but for shared memory
+   pointers, except that we pass the size to free as well.  */
+
+#ifndef ALLOCATOR_HDR
+#define ALLOCATOR_HDR
+
+#include "shared_memory.h"
+#include "thread_support.h"
+
+#include <stddef.h>
+
+/* The number of bits a void pointer has.  */
+#define VOIDP_BITS (__CHAR_BIT__ * sizeof (void *))
+
+/* The shared memory part of the allocator.  */
+typedef struct {
+  caf_shmem_mutex lock;
+  shared_mem_ptr free_bucket_head[VOIDP_BITS];
+} allocator_shared;
+
+/* The image local part of the allocator.  */
+typedef struct {
+  allocator_shared *s;
+  shared_memory shm;
+} allocator;
+
+/* The size of a page on this architecture.  */
+extern size_t pagesize;
+
+/* Helper routine to align a size to a given boundary.  */
+size_t alignto (size_t, size_t);
+
+/* Helper routine to round a size to multiple of the architecture's pagesize.
+ */
+size_t round_to_pagesize (size_t);
+
+/* Link the worker's allocator with the part in the shared memory.  */
+void allocator_init (allocator *, allocator_shared *, shared_memory);
+
+/* Initialize the allocator.  This MUST be called ONLY be the supervisor and
+   only once!  */
+void allocator_init_supervisor (allocator *, allocator_shared *, shared_memory);
+
+/* Request a block of shared memory.  The memory is not linked with the other
+   images.  The shared_mem_ptr returned is only local to the calling image.
+   When requiring a memory block shared between all images, call
+   alloc_get_memory_by_id...().  */
+shared_mem_ptr allocator_shared_malloc (allocator *, size_t size);
+
+/* Free the given piece of memory.  This routine just inserts the memory chunk
+   into the bucket list of free memory.  It does not join adjacent blocks of
+   memory (not implemented yet).  */
+void allocator_shared_free (allocator *, shared_mem_ptr, size_t size);
+
+/* Lock the allocator lock preventing any image from modifying memory management
+   structures.  Do not forget to unlock.  This interface is exposed to be able
+   to do more then just get the memory without having to introduce a second lock
+   and the problems with having to get both.  */
+void allocator_lock (allocator *);
+
+/* Unlock the allocator lock.  */
+void allocator_unlock (allocator *);
+
+#endif

libgfortran/caf/shmem/collective_subroutine.c

@@ -0,0 +1,434 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "collective_subroutine.h"
+#include "supervisor.h"
+#include "teams_mgmt.h"
+#include "thread_support.h"
+
+#include <string.h>
+
+/* Usage:
+     pack_info pi;
+     packed = pack_array_prepare (&pi, source);
+
+ // Awesome allocation of destptr using pi.num_elem
+ if (packed)
+   memcpy (...);
+ else
+   pack_array_finish (&pi, source, destptr);
+
+This could also be used in in_pack_generic.c.  Additionally, since
+pack_array_prepare is the same for all type sizes, we would only have to
+specialize pack_array_finish, saving on code size.  */
+
+typedef struct
+{
+  index_type num_elem;
+  index_type extent[GFC_MAX_DIMENSIONS];
+  index_type stride[GFC_MAX_DIMENSIONS]; /* Stride is byte-based.  */
+} pack_info;
+
+static bool
+pack_array_prepare (pack_info *pi, const gfc_descriptor_t *source)
+{
+  index_type dim;
+  bool packed;
+  index_type span;
+  index_type type_size;
+  index_type ssize;
+
+  dim = GFC_DESCRIPTOR_RANK (source);
+  type_size = GFC_DESCRIPTOR_SIZE (source);
+  ssize = type_size;
+
+  pi->num_elem = 1;
+  packed = true;
+  span = source->span != 0 ? source->span : type_size;
+  for (index_type n = 0; n < dim; n++)
+    {
+      pi->stride[n] = GFC_DESCRIPTOR_STRIDE (source, n) * span;
+      pi->extent[n] = GFC_DESCRIPTOR_EXTENT (source, n);
+      if (pi->extent[n] <= 0)
+	{
+	  /* Do nothing.  */
+	  packed = true;
+	  pi->num_elem = 0;
+	  break;
+	}
+
+      if (ssize != pi->stride[n])
+	packed = false;
+
+      pi->num_elem *= pi->extent[n];
+      ssize *= pi->extent[n];
+    }
+
+  return packed;
+}
+
+static void
+pack_array_finish (const pack_info *pi, const gfc_descriptor_t *source,
+		   char *dest)
+{
+  index_type dim;
+  const char *restrict src;
+
+  index_type size;
+  index_type stride0;
+  index_type count[GFC_MAX_DIMENSIONS];
+
+  dim = GFC_DESCRIPTOR_RANK (source);
+  src = source->base_addr;
+  stride0 = pi->stride[0];
+  size = GFC_DESCRIPTOR_SIZE (source);
+  memset (count, '\0', sizeof (index_type) * dim);
+  while (src)
+    {
+      /* Copy the data.  */
+      memcpy (dest, src, size);
+      /* Advance to the next element.  */
+      dest += size;
+      src += stride0;
+      count[0]++;
+      /* Advance to the next source element.  */
+      index_type n = 0;
+      while (count[n] == pi->extent[n])
+	{
+	  /* When we get to the end of a dimension, reset it and increment
+	     the next dimension.  */
+	  count[n] = 0;
+	  /* We could precalculate these products, but this is a less
+	     frequently used path so probably not worth it.  */
+	  src -= pi->stride[n] * pi->extent[n];
+	  n++;
+	  if (n == dim)
+	    {
+	      src = NULL;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      src += pi->stride[n];
+	    }
+	}
+    }
+}
+
+static void
+unpack_array_finish (const pack_info *pi, const gfc_descriptor_t *d,
+		     const void *src)
+{
+  index_type stride0;
+  char *restrict dest;
+  index_type size;
+  index_type count[GFC_MAX_DIMENSIONS];
+  index_type dim;
+
+  size = GFC_DESCRIPTOR_SIZE (d);
+  stride0 = pi->stride[0];
+  dest = d->base_addr;
+  dim = GFC_DESCRIPTOR_RANK (d);
+
+  memset (count, '\0', sizeof (index_type) * dim);
+  while (dest)
+    {
+      memcpy (dest, src, size);
+      src += size;
+      dest += stride0;
+      count[0]++;
+      index_type n = 0;
+      while (count[n] == pi->extent[n])
+	{
+	  count[n] = 0;
+	  dest -= pi->stride[n] * pi->extent[n];
+	  n++;
+	  if (n == dim)
+	    {
+	      dest = NULL;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      dest += pi->stride[n];
+	    }
+	}
+    }
+}
+
+void
+collsub_init_supervisor (collsub_shared *cis, allocator *al,
+			 const int init_num_images)
+{
+  /* Choose an arbitrary large buffer.  It can grow later if needed.  */
+  const size_t init_size = 1U << 10;
+
+  cis->curr_size = init_size;
+  cis->collsub_buf = allocator_shared_malloc (al, init_size);
+
+  counter_barrier_init (&cis->barrier, init_num_images);
+  initialize_shared_mutex (&cis->mutex);
+}
+
+static void *
+get_collsub_buf (size_t size)
+{
+  void *ret;
+
+  caf_shmem_mutex_lock (&caf_current_team->u.image_info->collsub.mutex);
+  /* curr_size is always at least sizeof(double), so we don't need to worry
+     about size == 0.  */
+  if (size > caf_current_team->u.image_info->collsub.curr_size)
+    {
+      allocator_shared_free (
+	alloc_get_allocator (&local->ai),
+	caf_current_team->u.image_info->collsub.collsub_buf,
+	caf_current_team->u.image_info->collsub.curr_size);
+      caf_current_team->u.image_info->collsub.collsub_buf
+	= allocator_shared_malloc (alloc_get_allocator (&local->ai), size);
+      caf_current_team->u.image_info->collsub.curr_size = size;
+    }
+
+  ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf,
+		   &local->sm);
+  caf_shmem_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);
+  return ret;
+}
+
+/* This function syncs all images with one another.  It will only return once
+   all images have called it.  */
+
+static void
+collsub_sync (void)
+{
+  counter_barrier_wait (&caf_current_team->u.image_info->collsub.barrier);
+}
+
+typedef void *(*red_op) (void *, void *);
+typedef void (*ass_op) (red_op, void *, void *, size_t);
+
+#define GEN_FOR_BITS(BITS)                                                     \
+  static void assign_##BITS (void *op, uint##BITS##_t *lhs,                    \
+			     uint##BITS##_t *rhs, size_t)                      \
+  {                                                                            \
+    *lhs                                                                       \
+      = ((uint##BITS##_t (*) (uint##BITS##_t *, uint##BITS##_t *)) op) (lhs,   \
+									rhs);  \
+  }                                                                            \
+  static void assign_by_val_##BITS (void *op, uint##BITS##_t *lhs,             \
+				    uint##BITS##_t *rhs, size_t)               \
+  {                                                                            \
+    *lhs = ((uint##BITS##_t (*) (uint##BITS##_t, uint##BITS##_t)) op) (*lhs,   \
+								       *rhs);  \
+  }
+
+GEN_FOR_BITS (8)
+GEN_FOR_BITS (16)
+GEN_FOR_BITS (32)
+GEN_FOR_BITS (64)
+// GEN_FOR_BITS (128)
+
+static void
+assign_float (void *op, float *lhs, float *rhs, size_t)
+{
+  *lhs = ((float (*) (float *, float *)) op) (lhs, rhs);
+}
+
+static void
+assign_double (void *op, double *lhs, double *rhs, size_t)
+{
+  *lhs = ((double (*) (double *, double *)) op) (lhs, rhs);
+}
+
+static void
+assign_var (red_op op, void *lhs, void *rhs, size_t sz)
+{
+  memcpy (lhs, op (lhs, rhs), sz);
+}
+
+static void
+assign_char (void *op, void *lhs, void *rhs, size_t sz)
+{
+  ((void (*) (char *, size_t, char *, char *, size_t,
+	      size_t)) op) (lhs, sz, lhs, rhs, sz, sz);
+}
+
+static ass_op
+gen_reduction (const int type, const size_t sz, const int flags)
+{
+  const bool by_val = flags & GFC_CAF_ARG_VALUE;
+  switch (type)
+    {
+    case BT_CHARACTER:
+      return (ass_op) assign_char;
+    case BT_REAL:
+      switch (sz)
+	{
+	case 4:
+	  return (ass_op) assign_float;
+	case 8:
+	  return (ass_op) assign_double;
+	default:
+	  return assign_var;
+	}
+    default:
+      switch (sz)
+	{
+	case 1:
+	  return (ass_op) (by_val ? assign_by_val_8 : assign_8);
+	case 2:
+	  return (ass_op) (by_val ? assign_by_val_16 : assign_16);
+	case 4:
+	  return (ass_op) (by_val ? assign_by_val_32 : assign_32);
+	case 8:
+	  return (ass_op) (by_val ? assign_by_val_64 : assign_64);
+	// case 16:
+	//   return assign_128;
+	default:
+	  return assign_var;
+	}
+    }
+}
+
+/* Having result_image == -1 means allreduce.  */
+
+void
+collsub_reduce_array (gfc_descriptor_t *desc, int result_image,
+		      void *(*op) (void *, void *), int opr_flags,
+		      int str_len __attribute__ ((unused)))
+{
+  void *buffer;
+  pack_info pi;
+  bool packed;
+  int cbit = 0;
+  int imoffset;
+  index_type elem_size;
+  index_type this_image_size_bytes;
+  void *this_image_buf, *roll_iter, *src_iter;
+  ass_op assign;
+  const int this_img_id = caf_current_team->index;
+
+  packed = pack_array_prepare (&pi, desc);
+  if (pi.num_elem == 0)
+    return;
+
+  elem_size = GFC_DESCRIPTOR_SPAN (desc);
+  this_image_size_bytes = elem_size * pi.num_elem;
+
+  buffer = get_collsub_buf (
+    this_image_size_bytes * caf_current_team->u.image_info->image_count.count);
+  this_image_buf = buffer + this_image_size_bytes * this_img_id;
+
+  if (packed)
+    memcpy (this_image_buf, GFC_DESCRIPTOR_DATA (desc), this_image_size_bytes);
+  else
+    pack_array_finish (&pi, desc, this_image_buf);
+
+  assign = gen_reduction (GFC_DESCRIPTOR_TYPE (desc), elem_size, opr_flags);
+  collsub_sync ();
+
+  for (; ((this_img_id >> cbit) & 1) == 0
+	 && (caf_current_team->u.image_info->image_count.count >> cbit) != 0;
+       cbit++)
+    {
+      imoffset = 1 << cbit;
+      if (this_img_id + imoffset
+	  < caf_current_team->u.image_info->image_count.count)
+	{
+	  /* Reduce arrays elementwise.  */
+	  roll_iter = this_image_buf;
+	  src_iter = this_image_buf + this_image_size_bytes * imoffset;
+	  for (ssize_t i = 0; i < pi.num_elem;
+	       ++i, roll_iter += elem_size, src_iter += elem_size)
+	    assign (op, roll_iter, src_iter, elem_size);
+	}
+      collsub_sync ();
+    }
+  for (; (caf_current_team->u.image_info->image_count.count >> cbit) != 0;
+       cbit++)
+    collsub_sync ();
+
+  if (result_image < 0 || result_image == this_image.image_num)
+    {
+      if (packed)
+	memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, this_image_size_bytes);
+      else
+	unpack_array_finish (&pi, desc, buffer);
+    }
+
+  collsub_sync ();
+}
+
+/* Do not use sync_all(), because the program should deadlock in the case that
+ * some images are on a sync_all barrier while others are in a collective
+ * subroutine.  */
+
+void
+collsub_broadcast_array (gfc_descriptor_t *desc, int source_image)
+{
+  void *buffer;
+  pack_info pi;
+  bool packed;
+  index_type elem_size;
+  index_type size_bytes;
+
+  packed = pack_array_prepare (&pi, desc);
+  if (pi.num_elem == 0)
+    return;
+
+  if (GFC_DESCRIPTOR_TYPE (desc) == BT_CHARACTER)
+    {
+      if (GFC_DESCRIPTOR_SIZE (desc))
+	elem_size = GFC_DESCRIPTOR_SIZE (desc);
+      else
+	elem_size = strlen (desc->base_addr);
+    }
+  else
+    elem_size = GFC_DESCRIPTOR_SPAN (desc) != 0
+		  ? ((index_type) GFC_DESCRIPTOR_SPAN (desc))
+		  : ((index_type) GFC_DESCRIPTOR_SIZE (desc));
+  size_bytes = elem_size * pi.num_elem;
+  buffer = get_collsub_buf (size_bytes);
+
+  if (source_image == this_image.image_num)
+    {
+      if (packed)
+	memcpy (buffer, GFC_DESCRIPTOR_DATA (desc), size_bytes);
+      else
+	pack_array_finish (&pi, desc, buffer);
+      collsub_sync ();
+    }
+  else
+    {
+      collsub_sync ();
+      if (packed)
+	memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, size_bytes);
+      else
+	unpack_array_finish (&pi, desc, buffer);
+    }
+
+  collsub_sync ();
+}

libgfortran/caf/shmem/collective_subroutine.h

@@ -0,0 +1,50 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef COLLECTIVE_SUBROUTINE_HDR
+#define COLLECTIVE_SUBROUTINE_HDR
+
+#include "alloc.h"
+#include "counter_barrier.h"
+#include "shared_memory.h"
+
+#include "caf/libcaf.h"
+
+typedef struct collsub_shared
+{
+  size_t curr_size;
+  shared_mem_ptr collsub_buf;
+  counter_barrier barrier;
+  caf_shmem_mutex mutex;
+} collsub_shared;
+
+void collsub_init_supervisor (collsub_shared *, allocator *,
+			      const int init_num_images);
+
+void collsub_broadcast_array (gfc_descriptor_t *, int);
+
+void collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *),
+			   int opr_flags, int str_len);
+
+#endif

libgfortran/caf/shmem/counter_barrier.c

@@ -0,0 +1,127 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+#include "counter_barrier.h"
+#include "supervisor.h"
+#include "thread_support.h"
+
+#include <assert.h>
+
+/* Lock the associated counter of this barrier.  */
+
+static inline void
+lock_counter_barrier (counter_barrier *b)
+{
+  caf_shmem_mutex_lock (&b->mutex);
+}
+
+/* Unlock the associated counter of this barrier.  */
+
+static inline void
+unlock_counter_barrier (counter_barrier *b)
+{
+  caf_shmem_mutex_unlock (&b->mutex);
+}
+
+void
+counter_barrier_init (counter_barrier *b, int val)
+{
+  *b = (counter_barrier) {CAF_SHMEM_MUTEX_INITIALIZER,
+			  CAF_SHMEM_COND_INITIALIZER, val, 0, val};
+  initialize_shared_condition (&b->cond, val);
+  initialize_shared_mutex (&b->mutex);
+}
+
+void
+counter_barrier_wait (counter_barrier *b)
+{
+  int wait_group_beginning;
+
+  lock_counter_barrier (b);
+  wait_group_beginning = b->curr_wait_group;
+
+  if ((--b->wait_count) <= 0)
+    caf_shmem_cond_broadcast (&b->cond);
+  else
+    {
+      while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
+	caf_shmem_cond_wait (&b->cond, &b->mutex);
+    }
+
+  if (b->wait_count <= 0)
+    {
+      b->curr_wait_group = !wait_group_beginning;
+      b->wait_count = b->count;
+    }
+
+  unlock_counter_barrier (b);
+}
+
+static inline void
+change_internal_barrier_count (counter_barrier *b, int val)
+{
+  b->wait_count += val;
+  if (b->wait_count <= 0)
+    caf_shmem_cond_broadcast (&b->cond);
+}
+
+int
+counter_barrier_add_locked (counter_barrier *c, int val)
+{
+  int ret;
+  ret = (c->count += val);
+  change_internal_barrier_count (c, val);
+
+  return ret;
+}
+
+int
+counter_barrier_add (counter_barrier *c, int val)
+{
+  int ret;
+  caf_shmem_mutex_lock (&c->mutex);
+  ret = counter_barrier_add_locked (c, val);
+
+  caf_shmem_mutex_unlock (&c->mutex);
+  return ret;
+}
+
+void
+counter_barrier_init_add (counter_barrier *b, int val)
+{
+  b->count += val;
+  b->wait_count += val;
+  caf_shmem_cond_update_count (&b->cond, val);
+}
+
+int
+counter_barrier_get_count (counter_barrier *c)
+{
+  int ret;
+  caf_shmem_mutex_lock (&c->mutex);
+  ret = c->count;
+  caf_shmem_mutex_unlock (&c->mutex);
+  return ret;
+}

libgfortran/caf/shmem/counter_barrier.h

@@ -0,0 +1,80 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef COUNTER_BARRIER_HDR
+#define COUNTER_BARRIER_HDR
+
+#include "thread_support.h"
+
+/* Usable as counter barrier and as waitable counter.
+   This "class" allows to sync all images acting as a barrier.  For this the
+   counter_barrier is to be initialized by the number of images and then later
+   calls to counter_barrier_wait() will sync the given number of images.  There
+   is no order in which the images will be woken up from their wait.
+   Furthermore may this "class" be used as a event queue counter.  To use it in
+   that way the counter barrier is to be initialized with zero.  Every "add" to
+   the queue then is to be made by incrementing the counter_barrier every take
+   by decrementing the queue.  If the queue does not satiesfy the needed number
+   of entries they can be waited for.
+ */
+
+typedef struct
+{
+  caf_shmem_mutex mutex;
+  caf_shmem_condvar cond;
+  volatile int wait_count;
+  volatile int curr_wait_group;
+  volatile int count;
+} counter_barrier;
+
+/* Initialize the counter barrier.  Only to be called once per counter barrier.
+   I.e. a counter barrier in shared memory must only be initialized by one
+   image.  */
+
+void counter_barrier_init (counter_barrier *, int);
+
+/* Add the given number to the counter barrier.  This signals waiting images
+   when the count drops below 0.  This routine is only to be called, when the
+   image has taken the counter barrier's lock by some other way.  */
+
+int counter_barrier_add_locked (counter_barrier *, int);
+
+/* Add the given number to the counter barrier.  This signals waiting images
+   when the count drops below 0.  */
+
+int counter_barrier_add (counter_barrier *, int);
+
+/* Add the given number to the counter barrier.  This version does not signal.
+   The mutex needs to be locked for this routine to be safe.  */
+void counter_barrier_init_add (counter_barrier *, int);
+
+/* Get the count of the barrier.  */
+
+int counter_barrier_get_count (counter_barrier *);
+
+/* Wait for the count in the barrier drop to or below 0.  */
+
+void counter_barrier_wait (counter_barrier *);
+
+#endif

libgfortran/caf/shmem/hashmap.c

@@ -0,0 +1,366 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+
+#include "hashmap.h"
+
+#include <string.h>
+
+#define INITIAL_BITNUM (5)
+#define INITIAL_SIZE (1 << INITIAL_BITNUM)
+#define CRITICAL_LOOKAHEAD (16)
+
+static ssize_t n_ent;
+
+typedef struct
+{
+  memid id;
+  shared_mem_ptr p; /* If p == SHMPTR_NULL, the entry is empty.  */
+  size_t s;
+  int max_lookahead;
+  int refcnt;
+} hashmap_entry;
+
+/* 64 bit to 64 bit hash function.  */
+
+static inline uint64_t
+hash (uint64_t key)
+{
+  key ^= (key >> 30);
+  key *= 0xbf58476d1ce4e5b9ul;
+  key ^= (key >> 27);
+  key *= 0x94d049bb133111ebul;
+  key ^= (key >> 31);
+
+  return key;
+}
+
+/* Gets a pointer to the current data in the hashmap.  */
+
+static inline hashmap_entry *
+get_data (hashmap *hm)
+{
+  return SHMPTR_AS (hashmap_entry *, hm->s->data, hm->sm);
+}
+
+/* Generate mask from current number of bits.  */
+
+static inline intptr_t
+gen_mask (hashmap *hm)
+{
+  return (1 << hm->s->bitnum) - 1;
+}
+
+/* Add with wrap-around at hashmap size.  */
+
+static inline size_t
+hmiadd (hashmap *hm, size_t s, ssize_t o)
+{
+  return (s + o) & gen_mask (hm);
+}
+
+/* Get the expected offset for entry id.  */
+
+static inline ssize_t
+get_expected_offset (hashmap *hm, memid id)
+{
+  return hash (id) >> (VOIDP_BITS - hm->s->bitnum);
+}
+
+/* Initialize the hashmap.  */
+
+void
+hashmap_init (hashmap *hm, hashmap_shared *hs, allocator *a)
+{
+  *hm = (hashmap) {hs, a->shm, a};
+}
+
+void
+hashmap_init_supervisor (hashmap *hm, hashmap_shared *hs, allocator *a)
+{
+  hashmap_entry *data;
+  *hm = (hashmap) {hs, a->shm, a};
+  hm->s->data
+    = allocator_shared_malloc (a, INITIAL_SIZE * sizeof (hashmap_entry));
+  data = get_data (hm);
+  memset (data, '\0', INITIAL_SIZE * sizeof (hashmap_entry));
+
+  hm->s->size = INITIAL_SIZE;
+  hm->s->bitnum = INITIAL_BITNUM;
+}
+
+/* This checks if the entry id exists in that range the range between
+   the expected position and the maximum lookahead.  */
+
+static ssize_t
+scan_inside_lookahead (hashmap *hm, ssize_t expected_off, memid id)
+{
+  ssize_t lookahead;
+  hashmap_entry *data;
+
+  data = get_data (hm);
+  lookahead = data[expected_off].max_lookahead;
+
+  for (int i = 0; i <= lookahead; i++) /* For performance, this could
+					 iterate backwards.  */
+    if (data[hmiadd (hm, expected_off, i)].id == id)
+      return hmiadd (hm, expected_off, i);
+
+  return -1;
+}
+
+/* Scan for the next empty slot we can use.  Returns offset relative
+   to the expected position.  */
+
+static ssize_t
+scan_empty (hashmap *hm, ssize_t expected_off)
+{
+  hashmap_entry *data;
+
+  data = get_data (hm);
+  for (int i = 0; i < CRITICAL_LOOKAHEAD; i++)
+    if (SHMPTR_IS_NULL (data[hmiadd (hm, expected_off, i)].p))
+      return i;
+
+  return -1;
+}
+
+/* Search the hashmap for id.  */
+
+hashmap_search_result
+hashmap_get (hashmap *hm, memid id)
+{
+  hashmap_search_result ret;
+  hashmap_entry *data;
+  size_t expected_offset;
+  ssize_t res;
+
+  data = get_data (hm);
+  expected_offset = get_expected_offset (hm, id);
+  res = scan_inside_lookahead (hm, expected_offset, id);
+
+  if (res != -1)
+    ret = ((hashmap_search_result){
+	.p = data[res].p, .size = data[res].s, .res_offset = res });
+  else
+    ret.p = SHMPTR_NULL;
+
+  return ret;
+}
+
+/* Return size of a hashmap search result.  */
+
+size_t
+hm_search_result_size (hashmap_search_result *res)
+{
+  return res->size;
+}
+
+/* Return pointer of a hashmap search result.  */
+
+shared_mem_ptr
+hm_search_result_ptr (hashmap_search_result *res)
+{
+  return res->p;
+}
+
+/* Return pointer of a hashmap search result.  */
+
+bool
+hm_search_result_contains (hashmap_search_result *res)
+{
+  return !SHMPTR_IS_NULL (res->p);
+}
+
+/* Enlarge hashmap memory.  */
+
+static void
+enlarge_hashmap_mem (hashmap *hm, hashmap_entry **data, bool f)
+{
+  shared_mem_ptr old_data_p;
+  size_t old_size;
+
+  old_data_p = hm->s->data;
+  old_size = hm->s->size;
+
+  hm->s->data = allocator_shared_malloc (hm->a, (hm->s->size *= 2)
+						  * sizeof (hashmap_entry));
+  hm->s->bitnum++;
+
+  *data = get_data (hm);
+  for (size_t i = 0; i < hm->s->size; i++)
+    (*data)[i] = ((hashmap_entry){
+	.id = 0, .p = SHMPTR_NULL, .s = 0, .max_lookahead = 0, .refcnt = 0 });
+
+  if (f)
+    allocator_shared_free (hm->a, old_data_p, old_size);
+}
+
+/* Resize hashmap.  */
+
+static void
+resize_hm (hashmap *hm, hashmap_entry **data)
+{
+  shared_mem_ptr old_data_p;
+  hashmap_entry *old_data, *new_data;
+  size_t old_size;
+  ssize_t new_offset, inital_index, new_index;
+  memid id;
+  ssize_t max_lookahead;
+
+  /* old_data points to the old block containing the hashmap.  We
+     redistribute the data from there into the new block.  */
+
+  old_data_p = hm->s->data;
+  old_data = *data;
+  old_size = hm->s->size;
+
+  enlarge_hashmap_mem (hm, &new_data, false);
+retry_resize:
+  for (size_t i = 0; i < old_size; i++)
+    {
+      if (SHMPTR_IS_NULL (old_data[i].p))
+	continue;
+
+      id = old_data[i].id;
+      inital_index = get_expected_offset (hm, id);
+      new_offset = scan_empty (hm, inital_index);
+
+      /* If we didn't find a free slot, just resize the hashmap
+	 again.  */
+      if (new_offset == -1)
+	{
+	  enlarge_hashmap_mem (hm, &new_data, true);
+	  goto retry_resize; /* Sue me.  */
+	}
+
+      new_index = hmiadd (hm, inital_index, new_offset);
+      max_lookahead = new_data[inital_index].max_lookahead;
+      new_data[inital_index].max_lookahead
+	  = new_offset > max_lookahead ? new_offset : max_lookahead;
+
+      new_data[new_index] = ((hashmap_entry){
+	  .id = id,
+	  .p = old_data[i].p,
+	  .s = old_data[i].s,
+	  .max_lookahead = new_data[new_index].max_lookahead,
+	  .refcnt = old_data[i].refcnt });
+    }
+  allocator_shared_free (hm->a, old_data_p, old_size);
+  *data = new_data;
+}
+
+/* Set an entry in the hashmap.  */
+
+void
+hashmap_set (hashmap *hm, memid id, hashmap_search_result *hsr,
+	     shared_mem_ptr p, size_t size)
+{
+  hashmap_entry *data;
+  ssize_t expected_offset, lookahead;
+  ssize_t empty_offset;
+  ssize_t delta;
+
+  data = get_data (hm);
+
+  if (hsr)
+    {
+      data[hsr->res_offset].s = size;
+      data[hsr->res_offset].p = p;
+      return;
+    }
+
+  expected_offset = get_expected_offset (hm, id);
+  while ((delta = scan_empty (hm, expected_offset)) == -1)
+    {
+      resize_hm (hm, &data);
+      expected_offset = get_expected_offset (hm, id);
+    }
+
+  empty_offset = hmiadd (hm, expected_offset, delta);
+  lookahead = data[expected_offset].max_lookahead;
+  data[expected_offset].max_lookahead = delta > lookahead ? delta : lookahead;
+  data[empty_offset]
+      = ((hashmap_entry){ .id = id,
+			  .p = p,
+			  .s = size,
+			  .max_lookahead = data[empty_offset].max_lookahead,
+			  .refcnt = 1 });
+
+  n_ent++;
+  /* TODO: Shouldn't reset refcnt, but this doesn't matter at the
+     moment because of the way the function is used.  */
+}
+
+/* Change the refcount of a hashmap entry.  */
+
+static int
+hashmap_change_refcnt (hashmap *hm, memid id, hashmap_search_result *res,
+		       int delta)
+{
+  hashmap_entry *data;
+  hashmap_search_result r;
+  hashmap_search_result *pr;
+  int ret;
+  hashmap_entry *entry;
+
+  data = get_data (hm);
+
+  if (res)
+    pr = res;
+  else
+    {
+      r = hashmap_get (hm, id);
+      pr = &r;
+    }
+
+  entry = &data[pr->res_offset];
+  ret = (entry->refcnt += delta);
+  if (ret == 0)
+    {
+      n_ent--;
+      entry->id = 0;
+      entry->p = SHMPTR_NULL;
+      entry->s = 0;
+    }
+
+  return ret;
+}
+
+/* Increase hashmap entry refcount.  */
+
+void
+hashmap_inc (hashmap *hm, memid id, hashmap_search_result *res)
+{
+  hashmap_change_refcnt (hm, id, res, 1);
+}
+
+/* Decrease hashmap entry refcount.  */
+
+int
+hashmap_dec (hashmap *hm, memid id, hashmap_search_result *res)
+{
+  return hashmap_change_refcnt (hm, id, res, -1);
+}

libgfortran/caf/shmem/hashmap.h

@@ -0,0 +1,98 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef HASHMAP_H
+#define HASHMAP_H
+
+#include "allocator.h"
+
+#include <stdbool.h>
+#include <stddef.h>
+#include <stdint.h>
+
+/* Data structures and variables:
+
+   memid is a unique identifier for the coarray.  */
+
+typedef uint64_t memid;
+
+typedef struct {
+  shared_mem_ptr data;
+  size_t size;
+  int bitnum;
+} hashmap_shared;
+
+typedef struct hashmap
+{
+  hashmap_shared *s;
+  shared_memory sm;
+  allocator *a;
+} hashmap;
+
+typedef struct {
+  shared_mem_ptr p;
+  size_t size;
+  ssize_t res_offset;
+} hashmap_search_result;
+
+/* Initialize the hashmap on a worker image.  */
+
+void hashmap_init (hashmap *, hashmap_shared *, allocator *a);
+
+/* Initialize the hashmap on the supervisor.  This routine must be called only
+   on the supervisor.  */
+
+void hashmap_init_supervisor (hashmap *, hashmap_shared *, allocator *);
+
+/* Look up memid in the hashmap.  The result can be inspected via the
+   hm_search_result_* functions.  */
+
+hashmap_search_result hashmap_get (hashmap *, memid);
+
+/* Given a search result, returns the size.  */
+size_t hm_search_result_size (hashmap_search_result *);
+
+/* Given a search result, returns the pointer.  */
+shared_mem_ptr hm_search_result_ptr (hashmap_search_result *);
+
+/* Given a search result, returns whether something was found.  */
+bool hm_search_result_contains (hashmap_search_result *);
+
+/* Sets the hashmap entry for memid to shared_mem_ptr and
+   size_t.  Optionally, if a hashmap_search_result is supplied, it is
+   used to make the lookup faster.  */
+
+void hashmap_set (hashmap *, memid, hashmap_search_result *, shared_mem_ptr p,
+		  size_t);
+
+/* Increments the hashmap entry for memid.  Optionally, if a
+   hashmap_search_result is supplied, it is used to make the lookup
+   faster.  */
+
+void hashmap_inc (hashmap *, memid, hashmap_search_result *);
+
+/* Same, but decrement.  */
+int hashmap_dec (hashmap *, memid, hashmap_search_result *);
+
+#endif

libgfortran/caf/shmem/shared_memory.c

@@ -0,0 +1,292 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include "libgfortran.h"
+#include "allocator.h"
+#include "shared_memory.h"
+#include "supervisor.h"
+
+#include <assert.h>
+#include <fcntl.h>
+#include <stdlib.h>
+#include <string.h>
+#ifdef HAVE_SYS_MMAN_H
+#include <sys/mman.h>
+#elif defined(WIN32)
+#include <Windows.h>
+#include <Memoryapi.h>
+#endif
+#include <unistd.h>
+
+/* This implements shared memory based on POSIX mmap.  We start with
+   memory block of the size of the global shared memory data, rounded
+   up to one pagesize, and enlarge as needed.
+
+   We address the memory via a shared_memory_ptr, which is an offset into
+   the shared memory block.  The metadata is situated at offset 0.
+
+   In order to be able to resize the memory and to keep pointers
+   valid, we keep the old mapping around, so the memory is actually
+   visible several times to the process.  Thus, pointers returned by
+   shared_memory_get_mem_with_alignment remain valid even when
+   resizing.  */
+
+static const char *ENV_PPID = "GFORTRAN_SHMEM_PPID";
+static const char *ENV_BASE = "GFORTRAN_SHMEM_BASE";
+
+void
+shared_memory_set_env (pid_t pid)
+{
+#define bufsize 20
+  char buffer[bufsize];
+
+  snprintf (buffer, bufsize, "%d", pid);
+#ifdef HAVE_SETENV
+  setenv (ENV_PPID, buffer, 1);
+#else
+  SetEnvironmentVariable (ENV_PPID, buffer);
+#endif
+#undef bufsize
+}
+
+char *
+shared_memory_get_env (void)
+{
+  return getenv (ENV_PPID);
+}
+
+/* Get a pointer into the shared memory block with alignemnt
+   (works similar to sbrk).  */
+
+shared_mem_ptr
+shared_memory_get_mem_with_alignment (shared_memory_act *mem, size_t size,
+				      size_t align)
+{
+  size_t aligned_curr_size = alignto (mem->glbl.meta->used, align);
+  mem->glbl.meta->used = aligned_curr_size + size;
+  return (shared_mem_ptr) {aligned_curr_size};
+}
+
+shared_mem_ptr
+shared_memory_get_master (shared_memory_act *mem, size_t size, size_t align)
+{
+  if (mem->glbl.meta->master)
+    return (shared_mem_ptr) {mem->glbl.meta->master};
+  else
+    {
+      ptrdiff_t loc = mem->glbl.meta->used;
+      shared_mem_ptr p
+	= shared_memory_get_mem_with_alignment (mem, size, align);
+      mem->glbl.meta->master = loc;
+      return p;
+    }
+}
+
+/* If another image changed the size, update the size accordingly.  */
+
+void
+shared_memory_prepare (shared_memory_act *)
+{
+  asm volatile ("" ::: "memory");
+}
+
+#define NAME_MAX 255
+
+/* Initialize the memory with one page, the shared metadata of the
+   shared memory is stored at the beginning.  */
+
+void
+shared_memory_init (shared_memory_act *mem, size_t size)
+{
+  char shm_name[NAME_MAX];
+  const char *env_val = getenv (ENV_PPID), *base = getenv (ENV_BASE);
+  pid_t ppid = getpid ();
+  void *base_ptr;
+
+  if (env_val)
+    {
+      int n = sscanf (env_val, "%d", &ppid);
+      assert (n == 1);
+    }
+  snprintf (shm_name, NAME_MAX, "/gfor-shm-%d", ppid);
+  if (base)
+    {
+      int n = sscanf (base, "%p", &base_ptr);
+      assert (n == 1);
+    }
+  else
+    base_ptr = NULL;
+
+  if (!env_val)
+    {
+#ifdef HAVE_MMAP
+      int res;
+
+      mem->shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600);
+      if (mem->shm_fd == -1)
+	{
+	  perror ("creating shared memory segment failed.");
+	  exit (1);
+	}
+
+      res = ftruncate (mem->shm_fd, size);
+      if (res == -1)
+	{
+	  perror ("resizing shared memory segment failed.");
+	  exit (1);
+	}
+#elif defined(WIN32)
+      mem->shm_fd
+	= CreateFileMapping (INVALID_HANDLE_VALUE, NULL, PAGE_READWRITE,
+			     size >> (sizeof (DWORD) * 8),
+			     (DWORD) (size & ~((DWORD) 0)), shm_name);
+      if (mem->shm_fd == NULL)
+	{
+	  LPVOID lpMsgBuf;
+	  DWORD dw = GetLastError ();
+
+	  if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
+			       | FORMAT_MESSAGE_FROM_SYSTEM
+			       | FORMAT_MESSAGE_IGNORE_INSERTS,
+			     NULL, dw,
+			     MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
+			     (LPTSTR) &lpMsgBuf, 0, NULL)
+	      == 0)
+	    {
+	      fprintf (stderr, "formatting the error message failed.\n");
+	      ExitProcess (dw);
+	    }
+
+	  fprintf (stderr, "creating shared memory segment failed: %d, %s\n",
+		   dw, (LPCTSTR) lpMsgBuf);
+
+	  LocalFree (lpMsgBuf);
+	  exit (1);
+	}
+#else
+#error "no way to map shared memory."
+#endif
+    }
+  else
+    {
+#ifdef HAVE_MMAP
+      mem->shm_fd = shm_open (shm_name, O_RDWR, 0600);
+      if (mem->shm_fd == -1)
+	{
+	  perror ("opening shared memory segment failed.");
+	  exit (1);
+	}
+#elif defined(WIN32)
+      mem->shm_fd = OpenFileMapping (FILE_MAP_ALL_ACCESS, FALSE, shm_name);
+      if (mem->shm_fd == NULL)
+	{
+	  perror ("opening shared memory segment failed.");
+	  exit (1);
+	}
+#endif
+    }
+#ifdef HAVE_MMAP
+  mem->glbl.base
+    = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, mem->shm_fd, 0);
+  if (base_ptr && mem->glbl.base != base_ptr)
+    {
+      /* The supervisor will start us again.  */
+      close (mem->shm_fd);
+      free (local);
+      exit (210);
+    }
+  else if (!base_ptr && !mem->glbl.base)
+    {
+      perror ("mmap failed");
+      exit (1);
+    }
+#elif defined(WIN32)
+  mem->glbl.base
+    = (LPTSTR) MapViewOfFileExNuma (mem->shm_fd, FILE_MAP_ALL_ACCESS, 0, 0,
+				    size, base_ptr, NUMA_NO_PREFERRED_NODE);
+  if (mem->glbl.base == NULL)
+    {
+      perror ("MapViewOfFile failed");
+      exit (1);
+    }
+#endif
+  if (!base_ptr)
+    {
+#define bufsize 20
+      char buffer[bufsize];
+
+      snprintf (buffer, bufsize, "%p", mem->glbl.base);
+#ifdef HAVE_SETENV
+      setenv (ENV_BASE, buffer, 1);
+#else
+      SetEnvironmentVariable (ENV_BASE, buffer);
+#endif
+#undef bufsize
+    }
+  mem->size = size;
+  if (!env_val)
+    *mem->glbl.meta
+      = (global_shared_memory_meta) {sizeof (global_shared_memory_meta), 0};
+}
+
+void
+shared_memory_cleanup (shared_memory_act *mem)
+{
+#ifdef HAVE_MMAP
+  int res = munmap (mem->glbl.base, mem->size);
+  if (res)
+    {
+      perror ("unmapping shared memory segment failed");
+    }
+  res = close (mem->shm_fd);
+  if (res)
+    {
+      perror ("closing shm file handle failed. Trying to continue...");
+    }
+  if (this_image.image_num == -1)
+    {
+      char shm_name[NAME_MAX];
+
+      snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ());
+      /* Only the supervisor is to delete the shm-file.  */
+      res = shm_unlink (shm_name);
+      if (res == -1)
+	{
+	  perror ("shm_unlink failed");
+	  exit (1);
+	}
+    }
+#elif defined(WIN32)
+  if (!UnmapViewOfFile (mem->glbl.base))
+    {
+      perror ("unmapping shared memory segment failed");
+    }
+  CloseHandle (mem->shm_fd);
+#endif
+}
+#undef NAME_MAX

libgfortran/caf/shmem/shared_memory.h

@@ -0,0 +1,96 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef SHARED_MEMORY_H
+#define SHARED_MEMORY_H
+
+#include "thread_support.h"
+
+#include <stdlib.h>
+#include <stddef.h>
+#include <unistd.h>
+
+/* Global metadata for shared memory, always kept at offset 0.  */
+
+typedef struct
+{
+  size_t used;
+  ptrdiff_t master;
+} global_shared_memory_meta;
+
+/* Type realization for shared_memory.  */
+
+typedef struct shared_memory_act
+{
+  union
+  {
+    void *base;
+    global_shared_memory_meta *meta;
+  } glbl;
+  size_t size; // const
+  caf_shmem_fd shm_fd;
+} shared_memory_act;
+
+/* A struct to serve as shared memory object.  */
+
+typedef struct shared_memory_act * shared_memory;
+
+#define SHMPTR_NULL ((shared_mem_ptr) {.offset = 0})
+#define SHMPTR_IS_NULL(x) (x.offset == 0)
+
+#define SHMPTR_DEREF(x, s, sm) ((x) = *(__typeof (x) *) s.p)
+#define SHMPTR_AS(type, s, sm) ((type) (*((void **) sm) + s.offset))
+#define AS_SHMPTR(p, sm) ((shared_mem_ptr) {.offset = (p) - sm.glbl.base})
+
+#define SHARED_MEMORY_RAW_ALLOC(mem, t, n)                                     \
+  shared_memory_get_mem_with_alignment (mem, sizeof (t) * n, __alignof__ (t))
+
+#define SHARED_MEMORY_RAW_ALLOC_PTR(mem, t) \
+  SHMPTR_AS (t *, SHARED_MEMORY_RAW_ALLOC (mem, t, 1), mem)
+
+/* A shared-memory pointer is implemented as an offset into the shared
+   memory region.  */
+
+typedef struct shared_mem_ptr
+{
+  ptrdiff_t offset;
+} shared_mem_ptr;
+
+void shared_memory_init (shared_memory, size_t);
+
+void shared_memory_cleanup (shared_memory);
+
+void shared_memory_prepare (shared_memory);
+
+shared_mem_ptr shared_memory_get_mem_with_alignment (shared_memory mem,
+						     size_t size, size_t align);
+
+shared_mem_ptr shared_memory_get_master (shared_memory pmem, size_t size,
+					 size_t align);
+
+void shared_memory_set_env (pid_t pid);
+
+char *shared_memory_get_env (void);
+
+#endif

libgfortran/caf/shmem/supervisor.c

@@ -0,0 +1,550 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "../caf_error.h"
+#include "supervisor.h"
+#include "teams_mgmt.h"
+#include "thread_support.h"
+
+#include <assert.h>
+#include <signal.h>
+#include <string.h>
+#include <unistd.h>
+#ifdef HAVE_WAIT_H
+#include <wait.h>
+#elif HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+#if !defined(_SC_PAGE_SIZE) && defined(WIN32)
+#include <windows.h>
+#endif
+
+#define GFORTRAN_ENV_NUM_IMAGES "GFORTRAN_NUM_IMAGES"
+#define GFORTRAN_ENV_SHARED_MEMORY_SIZE "GFORTRAN_SHARED_MEMORY_SIZE"
+#define GFORTRAN_ENV_IMAGE_NUM "GFORTRAN_IMAGE_NUM"
+#define GFORTRAN_ENV_IMAGE_RESTARTS_LIMITS "GFORTRAN_IMAGE_RESTARTS_LIMIT"
+
+image_local *local = NULL;
+
+image this_image = {-1, NULL};
+
+/* Get image number from environment or sysconf.  */
+
+static int
+get_image_num_from_envvar (void)
+{
+  char *num_images_char;
+  int nimages;
+  num_images_char = getenv (GFORTRAN_ENV_NUM_IMAGES);
+  if (!num_images_char)
+#ifdef _SC_NPROCESSORS_ONLN
+    return sysconf (_SC_NPROCESSORS_ONLN);
+#elif defined(WIN32)
+    num_images_char = getenv ("NUMBER_OF_PROCESSORS");
+#else
+#error "Unsupported system: No known way to get number of cores!"
+#endif
+  nimages = atoi (num_images_char);
+  return nimages;
+}
+
+/* Get the number of restarts allowed when the shared memory could not be placed
+at the same location in each image.  This is mostly important for MacOS, because
+this OS acts somewhat arbitrary/indeterministic.  */
+
+static unsigned
+get_image_restarts_limit (void)
+{
+  char *limit_chars;
+  unsigned limit = 4000;
+  limit_chars = getenv (GFORTRAN_ENV_IMAGE_RESTARTS_LIMITS);
+  if (limit_chars)
+    limit = atoi (limit_chars);
+  return limit;
+}
+
+/* Get the amount of memory for the shared memory block.  This is picked from
+   an environment variable.  If that is not there, pick a reasonable default.
+   Note that on a 64-bit system which allows overcommit, there is no penalty in
+   reserving a large space and then not using it.  */
+
+static size_t
+get_memory_size_from_envvar (void)
+{
+  char *e;
+  size_t sz = 0;
+  e = getenv (GFORTRAN_ENV_SHARED_MEMORY_SIZE);
+  if (e)
+    {
+      char suffix[2];
+      int rv;
+      rv = sscanf (e, "%zu%1s", &sz, suffix);
+      if (rv == 2)
+	{
+	  switch (suffix[0])
+	    {
+	    case 'k':
+	    case 'K':
+	      sz *= ((size_t) 1) << 10;
+	      break;
+	    case 'm':
+	    case 'M':
+	      sz *= ((size_t) 1) << 20;
+	      break;
+	    case 'g':
+	    case 'G':
+	      sz *= ((size_t) 1) << 30;
+	      break;
+	    default:
+	      sz = 0;
+	    }
+	}
+    }
+  if (sz == 0)
+    {
+      /* Use 256 MB for 32-bit systems and 4 GB for 64-bit systems.  */
+      if (sizeof (size_t) == 4)
+	sz = ((size_t) 1) << 28;
+      else
+#ifndef WIN32
+	sz = ((size_t) 1) << 34;
+#else
+	/* Use 1GB on Windows.  */
+	sz = ((size_t) 1) << 30;
+#endif
+    }
+  return sz;
+}
+
+/* Get a supervisor.  */
+
+static supervisor *
+get_supervisor (void)
+{
+  supervisor *sv;
+  sv = SHMPTR_AS (supervisor *,
+		  shared_memory_get_master (&local->sm,
+					    sizeof (supervisor)
+					      + sizeof (image_tracker)
+						  * local->total_num_images,
+					    __alignof__ (supervisor)),
+		  &local->sm);
+  sv->failed_images = 0;
+  sv->finished_images = 0;
+  return sv;
+}
+
+/* Defined in shmem.c, but we need it here.  */
+
+extern memid next_memid;
+
+#define SUPERVISOR_MAGIC_NUM 0x12345678
+
+/* Ensure things are initialized.  */
+
+void
+ensure_shmem_initialization (void)
+{
+  size_t shmem_size;
+  char *image_num;
+
+  if (local)
+    return;
+
+  local = malloc (sizeof (image_local));
+  if (!local)
+    {
+      caf_runtime_error ("can not initialize memory for local cache");
+      exit (1);
+    }
+#if defined(_SC_PAGE_SIZE)
+  pagesize = sysconf (_SC_PAGE_SIZE);
+#elif defined(WIN32)
+  {
+    SYSTEM_INFO si;
+    GetNativeSystemInfo (&si);
+    pagesize = si.dwAllocationGranularity;
+  }
+#else
+#warning                                                                       \
+  "Unsupported system: No known way to get memory page size. Assuming 4k!"
+  pagesize = 4096;
+#endif
+  shmem_size = round_to_pagesize (get_memory_size_from_envvar ());
+  local->total_num_images = get_image_num_from_envvar ();
+  shared_memory_init (&local->sm, shmem_size);
+  shared_memory_prepare (&local->sm);
+
+  /* Shared memory needs to be present, before master can be initialized/linked
+     to.  */
+  image_num = getenv (GFORTRAN_ENV_IMAGE_NUM);
+  if (image_num)
+    {
+      bool created;
+      this_image = (image) {atoi (image_num), get_supervisor ()};
+      assert (this_image.supervisor->magic_number == SUPERVISOR_MAGIC_NUM);
+
+      alloc_init (&local->ai, &local->sm);
+
+      caf_initial_team = caf_current_team
+	= (caf_shmem_team_t) calloc (1, sizeof (struct caf_shmem_team));
+      allocator_lock (&local->ai.alloc);
+      *caf_initial_team = (struct caf_shmem_team) {
+	NULL,
+	-1,
+	this_image.image_num,
+	0,
+	NULL,
+	{alloc_get_memory_by_id_created (&local->ai,
+					 local->total_num_images * sizeof (int)
+					   + sizeof (struct shmem_image_info),
+					 next_memid++, &created)}};
+      if (created)
+	{
+	  counter_barrier_init (&caf_initial_team->u.image_info->image_count,
+				local->total_num_images);
+	  collsub_init_supervisor (&caf_initial_team->u.image_info->collsub,
+				   alloc_get_allocator (&local->ai),
+				   local->total_num_images);
+	  caf_initial_team->u.image_info->team_parent_id = 0;
+	  caf_initial_team->u.image_info->team_id = -1;
+	  caf_initial_team->u.image_info->image_map_size
+	    = local->total_num_images;
+	  caf_initial_team->u.image_info->num_term_images = 0;
+	  caf_initial_team->u.image_info->lastmemid = 0;
+	  for (int i = 0; i < local->total_num_images; ++i)
+	    caf_initial_team->u.image_info->image_map[i] = i;
+	}
+      allocator_unlock (&local->ai.alloc);
+      sync_init (&local->si, &local->sm);
+    }
+  else
+    {
+      this_image = (image) {-1, get_supervisor ()};
+      this_image.supervisor->magic_number = SUPERVISOR_MAGIC_NUM;
+      thread_support_init_supervisor ();
+      counter_barrier_init (&this_image.supervisor->num_active_images,
+			    local->total_num_images);
+      alloc_init_supervisor (&local->ai, &local->sm);
+      sync_init_supervisor (&local->si, &local->ai);
+    }
+}
+
+#if !defined(environ)
+extern char **environ;
+#endif
+
+static bool
+startWorker (image *im __attribute__ ((unused)),
+	     char ***argv __attribute__ ((unused)))
+{
+#ifdef HAVE_FORK
+  caf_shmem_pid new_pid;
+  if ((new_pid = fork ()))
+    {
+      im->supervisor->images[im->image_num]
+	= (image_tracker) {new_pid, IMAGE_OK};
+      return false;
+    }
+  else
+    {
+      if (new_pid == -1)
+	caf_runtime_error ("error spawning child\n");
+      static char **new_env;
+      static char num_image[32];
+      size_t n = 2; /* Add one env-var and one for the term NULL.  */
+
+      /* Count the number of entries in the current environment.  */
+      for (char **e = environ; *e; ++e, ++n)
+	;
+      new_env = (char **) malloc (sizeof (char *) * n);
+      memcpy (new_env, environ, sizeof (char *) * (n - 2));
+      snprintf (num_image, 32, "%s=%d", GFORTRAN_ENV_IMAGE_NUM, im->image_num);
+      new_env[n - 2] = num_image;
+      new_env[n - 1] = NULL;
+      if (execve ((*argv)[0], *argv, new_env) == -1)
+	{
+	  perror ("execve failed");
+	}
+      exit (255);
+    }
+#endif
+  return true;
+}
+
+#ifndef WIN32
+static void
+kill_all_images (supervisor *m)
+{
+  for (int j = 0; j < local->total_num_images; j++)
+    if (m->images[j].status == IMAGE_OK)
+      kill (m->images[j].pid, SIGKILL);
+}
+#endif
+
+/* argc and argv may not be used on certain OSes.  Flag them unused therefore.
+ */
+int
+supervisor_main_loop (int *argc __attribute__ ((unused)),
+		      char ***argv __attribute__ ((unused)), int *exit_code)
+{
+  supervisor *m;
+  image im;
+#if defined(WIN32) && !defined(HAVE_FORK)
+  HANDLE *process_handles = malloc (sizeof (HANDLE) * local->total_num_images),
+	 *thread_handles = malloc (sizeof (HANDLE) * local->total_num_images),
+	 *waiting_handles = malloc (sizeof (HANDLE) * local->total_num_images);
+  int count_waiting = local->total_num_images;
+  LPTCH *envs = malloc (sizeof (LPTCH) * local->total_num_images);
+  LPTSTR currentDir;
+  DWORD cdLen = GetCurrentDirectory (0, NULL);
+  currentDir = malloc (cdLen);
+  GetCurrentDirectory (cdLen, currentDir);
+#else
+  int chstatus;
+  unsigned restarts = 0, restarts_limit;
+  restarts_limit = get_image_restarts_limit ();
+#endif
+
+  *exit_code = 0;
+  shared_memory_set_env (getpid ());
+  im.supervisor = m = this_image.supervisor;
+
+  for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++)
+    {
+#ifdef HAVE_FORK
+      if (startWorker (&im, argv))
+	return 1;
+#elif defined(WIN32)
+      LPTCH new_env;
+      size_t n = 0, es;
+      STARTUPINFO si;
+      DWORD dwFlags = 0;
+      PROCESS_INFORMATION pi;
+      LPTCH env = GetEnvironmentStrings ();
+
+      ZeroMemory (&si, sizeof (si));
+      si.cb = sizeof (si);
+      ZeroMemory (&pi, sizeof (pi));
+
+      /* Count the number of characters in the current environment.  */
+      for (LPTSTR e = (LPTSTR) env; *e; es = lstrlen (e) + 1, e += es, n += es)
+	;
+      new_env = (LPCH) malloc (n + 32 * sizeof (TCHAR));
+      memcpy (new_env, env, n);
+      snprintf (&((TCHAR *) new_env)[n], 32, "%s=%d%c", GFORTRAN_ENV_IMAGE_NUM,
+		im.image_num, (char) 0);
+      if (!CreateProcessA (NULL, GetCommandLine (), NULL, NULL, FALSE, dwFlags,
+			   new_env, currentDir, &si, &pi))
+	{
+	  LPVOID lpMsgBuf;
+	  DWORD dw = GetLastError ();
+
+	  if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
+			       | FORMAT_MESSAGE_FROM_SYSTEM
+			       | FORMAT_MESSAGE_IGNORE_INSERTS,
+			     NULL, dw,
+			     MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
+			     (LPTSTR) &lpMsgBuf, 0, NULL)
+	      == 0)
+	    {
+	      fprintf (stderr, "formatting the error message failed.\n");
+	      ExitProcess (dw);
+	    }
+
+	  fprintf (stderr, "error spawning child: %ld, %s\n", dw,
+		   (LPCTSTR) lpMsgBuf);
+
+	  LocalFree (lpMsgBuf);
+	  exit (1);
+	}
+      m->images[im.image_num] = (image_tracker) {pi.hProcess, IMAGE_OK};
+      process_handles[im.image_num] = waiting_handles[im.image_num]
+	= pi.hProcess;
+      thread_handles[im.image_num] = pi.hThread;
+      envs[im.image_num] = new_env;
+#else
+#error "no way known to start child processes."
+#endif
+    }
+  for (int i = 0; i < local->total_num_images; i++)
+    {
+#ifdef HAVE_FORK
+      caf_shmem_pid finished_pid = wait (&chstatus);
+      int j;
+
+      if (finished_pid == -1)
+	{
+	  /* Skip wait having an issue.  */
+	  perror ("wait failed");
+	  --i;
+	  continue;
+	}
+      if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus))
+	{
+	  for (j = 0;
+	       j < local->total_num_images && m->images[j].pid != finished_pid;
+	       j++)
+	    ;
+	  /* Only set the status, when it has not been set by the (failing)
+	     image already.  */
+	  if (m->images[j].status == IMAGE_OK)
+	    {
+	      m->images[j].status = IMAGE_SUCCESS;
+	      atomic_fetch_add (&m->finished_images, 1);
+	    }
+	}
+      else if (!WIFEXITED (chstatus) || WEXITSTATUS (chstatus))
+	{
+	  for (j = 0;
+	       j < local->total_num_images && m->images[j].pid != finished_pid;
+	       j++)
+	    ;
+	  if (WEXITSTATUS (chstatus) == 210)
+	    {
+	      --i;
+	      im.image_num = j;
+	      ++restarts;
+	      if (restarts > restarts_limit)
+		{
+		  kill_all_images (m);
+		  caf_runtime_error (
+		    "After restarting images %d times, no common state on "
+		    "shared memory could be reached. Giving up...",
+		    restarts);
+		  exit (1);
+		}
+	      if (startWorker (&im, argv))
+		return 1;
+	      continue;
+	    }
+	  else
+	    {
+	      dprintf (2,
+		       "ERROR: Image %d(pid: %d) failed with signal %d, "
+		       "exitstatus %d.\n",
+		       j + 1, finished_pid, WTERMSIG (chstatus),
+		       WEXITSTATUS (chstatus));
+	      if (j == local->total_num_images)
+		{
+		  if (finished_pid == getpid ())
+		    {
+		      dprintf (
+			2,
+			"WARNING: Supervisor process got signal %d. Killing "
+			"childs and exiting.\n",
+			WTERMSIG (chstatus));
+		      kill_all_images (m);
+		      exit (1);
+		    }
+		  dprintf (2,
+			   "WARNING: Got signal %d for unknown process %d. "
+			   "Ignoring and trying to continue.\n",
+			   WTERMSIG (chstatus), finished_pid);
+		  continue;
+		}
+	      m->images[j].status = IMAGE_FAILED;
+	      atomic_fetch_add (&m->failed_images, 1);
+	      if (*exit_code < WTERMSIG (chstatus))
+		*exit_code = WTERMSIG (chstatus);
+	      else if (*exit_code == 0)
+		*exit_code = 1;
+	    }
+	}
+      /* Trigger waiting sync images aka sync_table.  */
+      for (j = 0; j < local->total_num_images; j++)
+	caf_shmem_cond_signal (&SHMPTR_AS (caf_shmem_condvar *,
+					   m->sync_shared.sync_images_cond_vars,
+					   &local->sm)[j]);
+      counter_barrier_add (&m->num_active_images, -1);
+#elif defined(WIN32)
+      DWORD res = WaitForMultipleObjects (count_waiting, waiting_handles, FALSE,
+					  INFINITE);
+      HANDLE cand;
+      bool progress = false;
+      DWORD process_exit_code;
+      if (res == WAIT_FAILED)
+	caf_runtime_error ("waiting for process termination failed.");
+      int index = res - WAIT_OBJECT_0, finished_process;
+      bool fail;
+
+      do
+	{
+	  cand = waiting_handles[index];
+	  for (finished_process = 0;
+	       finished_process < local->total_num_images
+	       && cand != process_handles[finished_process];
+	       ++finished_process)
+	    ;
+
+	  GetExitCodeProcess (cand, &process_exit_code);
+	  fail = process_exit_code != 0;
+	  fprintf (stderr, "terminating process %d with fail status %d (%ld)\n",
+		   finished_process, fail, process_exit_code);
+	  if (finished_process < local->total_num_images)
+	    {
+	      CloseHandle (process_handles[finished_process]);
+	      process_handles[finished_process] = NULL;
+	      CloseHandle (thread_handles[finished_process]);
+	      FreeEnvironmentStrings (envs[finished_process]);
+	      if (fail)
+		{
+		  m->images[finished_process].status = IMAGE_FAILED;
+		  atomic_fetch_add (&m->failed_images, 1);
+		  if (*exit_code < process_exit_code)
+		    *exit_code = process_exit_code;
+		}
+	      else
+		{
+		  m->images[finished_process].status = IMAGE_SUCCESS;
+		  atomic_fetch_add (&m->finished_images, 1);
+		}
+	    }
+	  memmove (&waiting_handles[index], &waiting_handles[index + 1],
+		   sizeof (HANDLE) * (count_waiting - index - 1));
+	  --count_waiting;
+	  counter_barrier_add (&m->num_active_images, -1);
+
+	  /* Check if more than one process has terminated already.  */
+	  progress = false;
+	  for (index = 0; index < count_waiting; ++index)
+	    if (WaitForSingleObject (waiting_handles[index], 0)
+		== WAIT_OBJECT_0)
+	      {
+		progress = true;
+		++i;
+		break;
+	      }
+	}
+      while (progress && count_waiting > 0);
+#endif
+    }
+
+#if defined(WIN32) && !defined(HAVE_FORK)
+  free (process_handles);
+  free (thread_handles);
+  free (envs);
+#endif
+  return 0;
+}

libgfortran/caf/shmem/supervisor.h

@@ -0,0 +1,119 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef SUPERVISOR_H
+#define SUPERVISOR_H
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include "caf/libcaf.h"
+#include "alloc.h"
+#include "collective_subroutine.h"
+#include "sync.h"
+
+#include <stdatomic.h>
+
+typedef enum
+{
+  IMAGE_UNKNOWN = 0,
+  IMAGE_OK,
+  IMAGE_FAILED,
+  IMAGE_SUCCESS
+} image_status;
+
+typedef struct
+{
+  caf_shmem_pid pid;
+  image_status status;
+} image_tracker;
+
+typedef struct supervisor
+{
+  ptrdiff_t magic_number;
+  alloc_shared alloc_shared;
+  hashmap_shared hms;
+  collsub_shared collsub_shared;
+  sync_shared sync_shared;
+  atomic_int failed_images;
+  atomic_int finished_images;
+  counter_barrier num_active_images;
+  caf_shmem_mutex image_tracker_lock;
+#ifdef WIN32
+  size_t global_used_handles;
+#endif
+  image_tracker images[];
+} supervisor;
+
+typedef struct
+{
+  int image_num;
+  supervisor *supervisor;
+} image;
+
+extern image this_image;
+
+typedef struct
+{
+  int total_num_images;
+  struct shared_memory_act sm;
+  alloc ai;
+  sync_t si;
+} image_local;
+
+extern image_local *local;
+
+struct caf_shmem_token
+{
+  /* The pointer to the memory registered for the current image.  For arrays
+     this is the data member in the descriptor.  For components it's the pure
+     data pointer.  */
+  void *memptr;
+  /* The descriptor when this token is associated to an allocatable array.  */
+  gfc_descriptor_t *desc;
+  /* The base address this coarray's memory in the shared memory space.  The
+     base address of image I is computed by base + I * image_size.  */
+  void *base;
+  /* The size of memory in each image aligned on pointer borders, i.e. each
+     images memory starts on an address that is aligned to enable maximum speed
+     for the processor architecure used.  */
+  size_t image_size;
+  /* The id of this token.  */
+  memid token_id;
+  /* Set when the caf lib has allocated the memory in memptr and is responsible
+     for freeing it on deregister.  */
+  bool owning_memory;
+};
+typedef struct caf_shmem_token *caf_shmem_token_t;
+
+
+/* Ensure the shared memory environment is up and all support structures are
+   initialized and linked correctly.  */
+
+void ensure_shmem_initialization (void);
+
+int supervisor_main_loop (int *argc, char ***argv, int *exit_code);
+
+#endif

libgfortran/caf/shmem/sync.c

@@ -0,0 +1,182 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+#include "supervisor.h"
+#include "sync.h"
+#include "teams_mgmt.h"
+#include "thread_support.h"
+
+#include <string.h>
+
+static inline void
+lock_table (sync_t *si)
+{
+  caf_shmem_mutex_lock (&si->cis->sync_images_table_lock);
+}
+
+static inline void
+unlock_table (sync_t *si)
+{
+  caf_shmem_mutex_unlock (&si->cis->sync_images_table_lock);
+}
+
+void
+sync_init (sync_t *si, shared_memory sm)
+{
+  *si = (sync_t) {
+    &this_image.supervisor->sync_shared,
+    SHMPTR_AS (int *, this_image.supervisor->sync_shared.sync_images_table, sm),
+    SHMPTR_AS (caf_shmem_condvar *,
+	       this_image.supervisor->sync_shared.sync_images_cond_vars, sm)};
+}
+
+void
+sync_init_supervisor (sync_t *si, alloc *ai)
+{
+  const int num_images = local->total_num_images;
+  const size_t table_size_in_bytes = sizeof (int) * num_images * num_images;
+
+  si->cis = &this_image.supervisor->sync_shared;
+
+  initialize_shared_mutex (&si->cis->event_lock);
+  initialize_shared_condition (&si->cis->event_cond, num_images);
+
+  initialize_shared_mutex (&si->cis->sync_images_table_lock);
+
+  si->cis->sync_images_table
+    = allocator_shared_malloc (alloc_get_allocator (ai), table_size_in_bytes);
+  si->cis->sync_images_cond_vars
+    = allocator_shared_malloc (alloc_get_allocator (ai),
+			       sizeof (caf_shmem_condvar) * num_images);
+
+  si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem);
+  si->triggers
+    = SHMPTR_AS (caf_shmem_condvar *, si->cis->sync_images_cond_vars, ai->mem);
+
+  for (int i = 0; i < num_images; i++)
+    initialize_shared_condition (&si->triggers[i], num_images);
+
+  memset (si->table, 0, table_size_in_bytes);
+}
+
+void
+sync_table (sync_t *si, int *images, int size)
+{
+  /* The variable `table` is an N x N matrix, where N is the number of all
+     images.  The position (i, j) (where i and j are always the real images
+     index, i.e. after team de-mapping) tells whether image i has seen the same
+     number of synchronisation calls to sync_table like j.  When table(i,j) ==
+     table(j,i) then the sync for i with this image is completed (here j is the
+     real image index of the current image).  When this holds for all i in the
+     current set of images (or all images, if the set is empty), then sync table
+     command is completed.
+     */
+  volatile int *table = si->table;
+  int i;
+
+  lock_table (si);
+  if (size > 0)
+    {
+      const size_t img_c = caf_current_team->u.image_info->image_map_size;
+      for (i = 0; i < size; ++i)
+	{
+	  ++table[images[i] + img_c * this_image.image_num];
+	  caf_shmem_cond_signal (&si->triggers[images[i]]);
+	}
+      for (;;)
+	{
+	  for (i = 0; i < size; ++i)
+	    if (this_image.supervisor->images[images[i]].status == IMAGE_OK
+		&& table[images[i] + this_image.image_num * img_c]
+		     > table[this_image.image_num + images[i] * img_c])
+	      break;
+	  if (i == size)
+	    break;
+	  caf_shmem_cond_wait (&si->triggers[this_image.image_num],
+			     &si->cis->sync_images_table_lock);
+	}
+    }
+  else
+    {
+      int *map = caf_current_team->u.image_info->image_map;
+      size = caf_current_team->u.image_info->image_count.count;
+      for (i = 0; i < size; ++i)
+	{
+	  if (this_image.supervisor->images[map[i]].status != IMAGE_OK)
+	    continue;
+	  ++table[map[i] + size * this_image.image_num];
+	  caf_shmem_cond_signal (&si->triggers[map[i]]);
+	}
+      for (;;)
+	{
+	  for (i = 0; i < size; ++i)
+	    if (this_image.supervisor->images[map[i]].status == IMAGE_OK
+		&& table[map[i] + size * this_image.image_num]
+		     > table[this_image.image_num + map[i] * size])
+	      break;
+	  if (i == size)
+	    break;
+	  caf_shmem_cond_wait (&si->triggers[this_image.image_num],
+			     &si->cis->sync_images_table_lock);
+	}
+    }
+  unlock_table (si);
+}
+
+void
+sync_all (void)
+{
+  counter_barrier_wait (&caf_current_team->u.image_info->image_count);
+}
+
+void
+sync_team (caf_shmem_team_t team)
+{
+  counter_barrier_wait (&team->u.image_info->image_count);
+}
+
+void
+lock_event (sync_t *si)
+{
+  caf_shmem_mutex_lock (&si->cis->event_lock);
+}
+
+void
+unlock_event (sync_t *si)
+{
+  caf_shmem_mutex_unlock (&si->cis->event_lock);
+}
+
+void
+event_post (sync_t *si)
+{
+  caf_shmem_cond_broadcast (&si->cis->event_cond);
+}
+
+void
+event_wait (sync_t *si)
+{
+  caf_shmem_cond_wait (&si->cis->event_cond, &si->cis->event_lock);
+}

libgfortran/caf/shmem/sync.h

@@ -0,0 +1,77 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef SYNC_H
+#define SYNC_H
+
+#include "alloc.h"
+#include "counter_barrier.h"
+
+typedef struct {
+  /* Mutex and condition variable needed for signaling events.  */
+  caf_shmem_mutex event_lock;
+  caf_shmem_condvar event_cond;
+  caf_shmem_mutex sync_images_table_lock;
+  shared_mem_ptr sync_images_table;
+  shared_mem_ptr sync_images_cond_vars;
+} sync_shared;
+
+typedef struct {
+  sync_shared *cis;
+  int *table; // we can cache the table and the trigger pointers here
+  caf_shmem_condvar *triggers;
+} sync_t;
+
+typedef caf_shmem_mutex lock_t;
+
+typedef int event_t;
+
+void sync_init (sync_t *, shared_memory);
+
+void sync_init_supervisor (sync_t *, alloc *);
+
+void sync_all (void);
+
+/* Prototype for circular dependency break.  */
+
+struct caf_shmem_team;
+typedef struct caf_shmem_team *caf_shmem_team_t;
+
+void sync_team (caf_shmem_team_t team);
+
+void sync_table (sync_t *, int *, int);
+
+void lock_alloc_lock (sync_t *);
+
+void unlock_alloc_lock (sync_t *);
+
+void lock_event (sync_t *);
+
+void unlock_event (sync_t *);
+
+void event_post (sync_t *);
+
+void event_wait (sync_t *);
+
+#endif

libgfortran/caf/shmem/teams_mgmt.c

@@ -0,0 +1,83 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "teams_mgmt.h"
+#include "../caf_error.h"
+
+caf_shmem_team_t caf_current_team = NULL, caf_initial_team;
+caf_shmem_team_t caf_teams_formed = NULL;
+
+void
+update_teams_images (caf_shmem_team_t team)
+{
+  caf_shmem_mutex_lock (&team->u.image_info->image_count.mutex);
+  if (team->u.image_info->num_term_images
+      != this_image.supervisor->finished_images
+	   + this_image.supervisor->failed_images)
+    {
+      const int old_num = team->u.image_info->num_term_images;
+      const int sz = team->u.image_info->image_map_size;
+      int i, good = 0;
+
+      for (i = 0; i < sz; ++i)
+	if (this_image.supervisor->images[team->u.image_info->image_map[i]]
+	      .status
+	    == IMAGE_OK)
+	  ++good;
+
+      team->u.image_info->num_term_images = sz - good;
+
+      counter_barrier_add_locked (&team->u.image_info->image_count,
+				   old_num
+				     - team->u.image_info->num_term_images);
+    }
+  caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex);
+}
+
+void
+check_health (int *stat, char *errmsg, size_t errmsg_len)
+{
+  if (this_image.supervisor->finished_images
+      || this_image.supervisor->failed_images)
+    {
+      if (this_image.supervisor->finished_images)
+	{
+	  caf_internal_error ("Stopped images present (currently %d)", stat,
+			      errmsg, errmsg_len,
+			      this_image.supervisor->finished_images);
+	  if (stat)
+	    *stat = CAF_STAT_STOPPED_IMAGE;
+	}
+      else if (this_image.supervisor->failed_images)
+	{
+	  caf_internal_error ("Failed images present (currently %d)", stat,
+			      errmsg, errmsg_len,
+			      this_image.supervisor->failed_images);
+	  if (stat)
+	    *stat = CAF_STAT_FAILED_IMAGE;
+	}
+    }
+  else if (stat)
+    *stat = 0;
+}

libgfortran/caf/shmem/teams_mgmt.h

@@ -0,0 +1,93 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef TEAMS_MGMT_H
+#define TEAMS_MGMT_H
+
+#include "alloc.h"
+#include "collective_subroutine.h"
+#include "supervisor.h"
+
+struct caf_shmem_team
+{
+  struct caf_shmem_team *parent;
+  int team_no;
+  /* The index is the image's index minus one in this team.  I.e. if in Fortran
+     notion the current image is 3, then the value of index is 2.  This allows
+     access to the image_map without having to substract one each time (and
+     missing it).  Returning the image's index to the user is rarer, so adding
+     one there is cheaper.  */
+  int index;
+  /* The last memid the parent team used.  This is used to restore the memid
+     on an end team.  */
+  memid parent_teams_last_active_memid;
+  struct coarray_allocated
+  {
+    struct coarray_allocated *next;
+    caf_shmem_token_t token;
+  } *allocated;
+  union
+  {
+    void *shm;
+    struct shmem_image_info
+    {
+      counter_barrier image_count;
+      struct collsub_shared collsub;
+      int team_parent_id;
+      int team_id;
+      int image_map_size;
+      /* Store the last known number of terminated images (either stopped or
+	 failed) images.  On each access where all images need to be present
+	 this is checked against the global number and the image_count and
+	 image_map is updated.  */
+      int num_term_images;
+      memid lastmemid;
+      int image_map[];
+    } *image_info;
+  } u;
+};
+typedef struct caf_shmem_team *caf_shmem_team_t;
+
+/* The team currently active.  */
+extern caf_shmem_team_t caf_current_team;
+
+/* The initial team.  */
+extern caf_shmem_team_t caf_initial_team;
+
+/* Teams formed, but not in used currently.  */
+extern caf_shmem_team_t caf_teams_formed;
+
+#define CHECK_TEAM_INTEGRITY(team)                                             \
+  if (unlikely (team->u.image_info->num_term_images                            \
+		!= this_image.supervisor->failed_images                        \
+		     + this_image.supervisor->finished_images))                \
+  update_teams_images (team)
+
+void update_teams_images (caf_shmem_team_t);
+
+void check_health (int *, char *, size_t);
+
+#define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)
+
+#endif

libgfortran/caf/shmem/thread_support.c

@@ -0,0 +1,381 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "thread_support.h"
+
+#include <errno.h>
+#include <stdlib.h>
+#include <stdio.h>
+
+#if !defined(WIN32) && !defined(__CYGWIN__)
+#include <pthread.h>
+
+#define ERRCHECK(a)                                                            \
+  do                                                                           \
+    {                                                                          \
+      int rc = a;                                                              \
+      if (rc)                                                                  \
+	{                                                                      \
+	  errno = rc;                                                          \
+	  perror (#a " failed");                                               \
+	  exit (1);                                                            \
+	}                                                                      \
+    }                                                                          \
+  while (0)
+
+void
+initialize_shared_mutex (caf_shmem_mutex *mutex)
+{
+  pthread_mutexattr_t mattr;
+  ERRCHECK (pthread_mutexattr_init (&mattr));
+  ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
+#ifdef PTHREAD_MUTEX_ROBUST
+  ERRCHECK (pthread_mutexattr_setrobust (&mattr, PTHREAD_MUTEX_ROBUST));
+#endif
+  ERRCHECK (pthread_mutex_init (mutex, &mattr));
+  ERRCHECK (pthread_mutexattr_destroy (&mattr));
+}
+
+void
+initialize_shared_errorcheck_mutex (caf_shmem_mutex *mutex)
+{
+  pthread_mutexattr_t mattr;
+  ERRCHECK (pthread_mutexattr_init (&mattr));
+  ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK));
+  ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
+#ifdef PTHREAD_MUTEX_ROBUST
+  ERRCHECK (pthread_mutexattr_setrobust (&mattr, PTHREAD_MUTEX_ROBUST));
+#endif
+  ERRCHECK (pthread_mutex_init (mutex, &mattr));
+  ERRCHECK (pthread_mutexattr_destroy (&mattr));
+}
+
+void
+initialize_shared_condition (caf_shmem_condvar *cond, const int)
+{
+  pthread_condattr_t cattr;
+  ERRCHECK (pthread_condattr_init (&cattr));
+  ERRCHECK (pthread_condattr_setpshared (&cattr, PTHREAD_PROCESS_SHARED));
+  ERRCHECK (pthread_cond_init (cond, &cattr));
+  ERRCHECK (pthread_condattr_destroy (&cattr));
+}
+#else
+#include "../caf_error.h"
+#include "supervisor.h"
+#include "teams_mgmt.h"
+#include <windows.h>
+#include <assert.h>
+
+static HANDLE *handles = NULL;
+static size_t cap_handles = 0;
+
+static const int ULONGBITS = sizeof (unsigned long) << 3; // *8
+
+static size_t
+smax (size_t a, size_t b)
+{
+  return a < b ? b : a;
+}
+
+static HANDLE
+get_handle (const size_t id, const char t)
+{
+  const int add = t == 'c' ? 1 : 0;
+  while (id + add >= cap_handles)
+    {
+      cap_handles += 1024;
+      if (handles)
+	handles = realloc (handles, sizeof (HANDLE) * cap_handles);
+      else
+	handles = malloc (sizeof (HANDLE) * cap_handles);
+      if (!handles)
+	caf_runtime_error (
+	  "can not get buffer for synchronication objects, aborting");
+
+      memset (&handles[cap_handles - 1024], 0, sizeof (HANDLE) * 1024);
+    }
+  if (!handles[id])
+    {
+      static char *pid = NULL;
+      char name[MAX_PATH];
+
+      if (!pid)
+	pid = shared_memory_get_env ();
+      snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd", pid, t, id);
+      switch (t)
+	{
+	case 'm':
+	  handles[id] = CreateMutex (NULL, false, name);
+	  break;
+	case 'c':
+	  {
+	    handles[id] = CreateSemaphore (NULL, 0, __INT_MAX__, name);
+	    snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd_lock", pid, t,
+		      id);
+	    handles[id + 1] = CreateSemaphore (NULL, 1, 1, name);
+	    this_image.supervisor->global_used_handles
+	      = smax (this_image.supervisor->global_used_handles, id + 2);
+	    break;
+	  }
+	default:
+	  caf_runtime_error ("Unknown handle type %c", t);
+	  exit (1);
+	}
+      if (handles[id] == NULL)
+	{
+	  caf_runtime_error (
+	    "Could not create synchronisation object, error: %d",
+	    GetLastError ());
+	  return NULL;
+	}
+
+      this_image.supervisor->global_used_handles
+	= smax (this_image.supervisor->global_used_handles, id + 1);
+    }
+
+  return handles[id];
+}
+
+static HANDLE
+get_mutex (caf_shmem_mutex *m)
+{
+  return get_handle (m->id, 'm');
+}
+
+static HANDLE
+get_condvar (caf_shmem_condvar *cv)
+{
+  return get_handle (cv->id, 'c');
+}
+
+void
+thread_support_init_supervisor (void)
+{
+  if (local->total_num_images > ULONGBITS * MAX_NUM_SIGNALED)
+    caf_runtime_error ("Maximum number of supported images is %zd.",
+		       ULONGBITS * MAX_NUM_SIGNALED);
+  this_image.supervisor->global_used_handles = 0;
+}
+
+int
+caf_shmem_mutex_lock (caf_shmem_mutex *m)
+{
+  HANDLE mutex = get_mutex (m);
+  DWORD res = WaitForSingleObject (mutex, INFINITE);
+
+  /* Return zero on success.  */
+  return res != WAIT_OBJECT_0;
+}
+
+int
+caf_shmem_mutex_trylock (caf_shmem_mutex *m)
+{
+  HANDLE mutex = get_mutex (m);
+  DWORD res = WaitForSingleObject (mutex, 0);
+
+  return res == WAIT_OBJECT_0 ? 0 : EBUSY;
+}
+
+int
+caf_shmem_mutex_unlock (caf_shmem_mutex *m)
+{
+  HANDLE mutex = get_mutex (m);
+  BOOL res = ReleaseMutex (mutex);
+
+  if (!res)
+    {
+      LPVOID lpMsgBuf;
+      DWORD dw = GetLastError ();
+
+      if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
+			   | FORMAT_MESSAGE_FROM_SYSTEM
+			   | FORMAT_MESSAGE_IGNORE_INSERTS,
+			 NULL, dw, MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
+			 (LPTSTR) &lpMsgBuf, 0, NULL)
+	  == 0)
+	{
+	  fprintf (stderr, "%d: formatting the error message failed.\n",
+		   this_image.image_num);
+	  ExitProcess (dw);
+	}
+
+      fprintf (stderr, "%d: unlock mutex failed: %d, %s\n",
+	       this_image.image_num, dw, (LPCTSTR) lpMsgBuf);
+
+      LocalFree (lpMsgBuf);
+    }
+  return res ? 0 : EPERM;
+}
+
+static bool
+bm_is_set (volatile unsigned long mask[], const int b)
+{
+  return (mask[b / ULONGBITS] & (1UL << (b % ULONGBITS))) != 0;
+}
+
+static void
+bm_clear_bit (volatile unsigned long mask[], const int b)
+{
+  mask[b / ULONGBITS] &= ~(1UL << (b % ULONGBITS));
+}
+
+static void
+bm_set_mask (volatile unsigned long mask[], const int size)
+{
+  const int entries = size / ULONGBITS;
+  const int rem = size % ULONGBITS;
+  int i = 0;
+  assert (entries >= 0);
+
+  for (; i < entries; ++i)
+    mask[i] = ~0UL;
+  if (rem != 0)
+    mask[i] = ~0UL >> (ULONGBITS - rem);
+}
+
+__attribute__ ((used)) static bool
+bm_is_none (volatile unsigned long mask[], const int size)
+{
+  const int entries = size / ULONGBITS;
+  const int rem = size % ULONGBITS;
+  int i = 0;
+  for (; i < entries; ++i)
+    if (mask[i] != 0)
+      return false;
+
+  return rem == 0 || ((mask[i] & (~0UL >> (ULONGBITS - rem))) == 0);
+}
+
+void
+caf_shmem_cond_wait (caf_shmem_condvar *cv, caf_shmem_mutex *m)
+{
+  HANDLE mutex = get_mutex (m), condvar = get_condvar (cv),
+	 lock = get_handle (cv->id + 1, 'c');
+  HANDLE entry[3] = {mutex, condvar, lock};
+  int res;
+
+  WaitForSingleObject (lock, INFINITE);
+  for (;;)
+    {
+      if (bm_is_set (cv->signaled, this_image.image_num) || cv->any)
+	{
+	  break;
+	}
+      ReleaseMutex (mutex);
+      ReleaseSemaphore (lock, 1, NULL);
+      res = WaitForMultipleObjects (3, entry, true, INFINITE);
+      if (res != WAIT_OBJECT_0)
+	{
+	  fprintf (stderr, "%d: failed to get all wait for: %d\n",
+		   this_image.image_num, res);
+	  fflush (stderr);
+	}
+      ReleaseSemaphore (condvar, 1, NULL);
+    }
+  res = WaitForSingleObject (condvar, INFINITE);
+  if (res != WAIT_OBJECT_0)
+    {
+      fprintf (stderr, "%d: failed to get condvar: %d\n", this_image.image_num,
+	       res);
+      fflush (stderr);
+    }
+
+  bm_clear_bit (cv->signaled, this_image.image_num);
+  cv->any = 0;
+  ReleaseSemaphore (lock, 1, NULL);
+}
+
+void
+caf_shmem_cond_broadcast (caf_shmem_condvar *cv)
+{
+  HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c');
+
+  WaitForSingleObject (lock, INFINITE);
+  bm_set_mask (cv->signaled, cv->size);
+  bm_clear_bit (cv->signaled, this_image.image_num);
+
+  ReleaseSemaphore (condvar, cv->size, NULL);
+  ReleaseSemaphore (lock, 1, NULL);
+}
+
+void
+caf_shmem_cond_signal (caf_shmem_condvar *cv)
+{
+  HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c');
+
+  if (caf_current_team)
+    {
+      WaitForSingleObject (lock, INFINITE);
+    }
+  else
+    return;
+  /* The first image is zero, which wouldn't allow it to signal.  */
+  cv->any = this_image.image_num + 1;
+  ReleaseSemaphore (condvar, 1, NULL);
+  ReleaseSemaphore (lock, 1, NULL);
+}
+
+void
+caf_shmem_cond_update_count (caf_shmem_condvar *cv, int val)
+{
+  cv->size += val;
+}
+
+void
+initialize_shared_mutex (caf_shmem_mutex *m)
+{
+  *m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles};
+
+  get_mutex (m);
+}
+
+void
+initialize_shared_errorcheck_mutex (caf_shmem_mutex *m)
+{
+  *m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles};
+
+  get_mutex (m);
+}
+
+void
+initialize_shared_condition (caf_shmem_condvar *cv, const int size)
+{
+  *cv = (caf_shmem_condvar) {this_image.supervisor->global_used_handles,
+			     0,
+			     size,
+			     {}};
+
+  memset ((void *) cv->signaled, 0, sizeof (unsigned long) * MAX_NUM_SIGNALED);
+  get_condvar (cv);
+  assert (bm_is_none (cv->signaled, cv->size));
+}
+
+void
+thread_support_cleanup (void)
+{
+  for (size_t i = 0; i < this_image.supervisor->global_used_handles; ++i)
+    if (handles[i])
+      CloseHandle (handles[i]);
+}
+#endif

libgfortran/caf/shmem/thread_support.h

@@ -0,0 +1,113 @@
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+   Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef THREAD_SUPPORT_H
+#define THREAD_SUPPORT_H
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#ifndef WIN32
+#include <sys/types.h>
+
+typedef pid_t caf_shmem_pid;
+typedef int caf_shmem_fd;
+#else
+#include <handleapi.h>
+
+typedef HANDLE caf_shmem_pid;
+typedef HANDLE caf_shmem_fd;
+#endif
+
+#if !defined(WIN32) && !defined(__CYGWIN__)
+#include <pthread.h>
+
+typedef pthread_mutex_t caf_shmem_mutex;
+typedef pthread_cond_t caf_shmem_condvar;
+
+#define CAF_SHMEM_MUTEX_INITIALIZER PTHREAD_MUTEX_INITIALIZER
+#define CAF_SHMEM_COND_INITIALIZER PTHREAD_COND_INITIALIZER
+
+#define thread_support_init_supervisor() (void) 0
+
+#define caf_shmem_mutex_lock pthread_mutex_lock
+#define caf_shmem_mutex_trylock pthread_mutex_trylock
+#define caf_shmem_mutex_unlock pthread_mutex_unlock
+
+#define caf_shmem_cond_wait pthread_cond_wait
+#define caf_shmem_cond_broadcast pthread_cond_broadcast
+#define caf_shmem_cond_signal pthread_cond_signal
+#define caf_shmem_cond_update_count(c, v) (void) 0
+
+#define thread_support_cleanup() (void) 0
+#else
+#include <synchapi.h>
+#include <stddef.h>
+
+typedef struct caf_shmem_mutex
+{
+  size_t id;
+} caf_shmem_mutex;
+
+#define MAX_NUM_SIGNALED 8
+
+typedef struct caf_shmem_condvar
+{
+  size_t id;
+  volatile int any;
+  int size;
+  volatile unsigned long signaled[MAX_NUM_SIGNALED];
+} caf_shmem_condvar;
+
+#define CAF_SHMEM_MUTEX_INITIALIZER (caf_shmem_mutex){0}
+#define CAF_SHMEM_COND_INITIALIZER                                             \
+  (caf_shmem_condvar)                                                          \
+  {                                                                            \
+    0, 0, 0, {}                                                                \
+  }
+
+void thread_support_init_supervisor (void);
+
+int caf_shmem_mutex_lock (caf_shmem_mutex *);
+int caf_shmem_mutex_trylock (caf_shmem_mutex *);
+int caf_shmem_mutex_unlock (caf_shmem_mutex *);
+
+void caf_shmem_cond_wait (caf_shmem_condvar *, caf_shmem_mutex *);
+void caf_shmem_cond_broadcast (caf_shmem_condvar *);
+void caf_shmem_cond_signal (caf_shmem_condvar *);
+void caf_shmem_cond_update_count (caf_shmem_condvar *, int);
+
+void thread_support_cleanup (void);
+#endif
+
+/* Support routines to setup pthread structs in shared memory.  */
+
+void initialize_shared_mutex (caf_shmem_mutex *);
+
+void initialize_shared_errorcheck_mutex (caf_shmem_mutex *);
+
+void initialize_shared_condition (caf_shmem_condvar *, const int size);
+
+#endif

libgfortran/caf/single.c

@@ -129,7 +129,7 @@ caf_internal_error (const char *msg, int *stat, char *errmsg,
       *stat = 1;
       if (errmsg_len > 0)
 	{
-	  int len = snprintf (errmsg, errmsg_len, msg, args);
+	  int len = vsnprintf (errmsg, errmsg_len, msg, args);
 	  if (len >= 0 && errmsg_len > (size_t) len)
 	    memset (&errmsg[len], ' ', errmsg_len - len);
 	}

libgfortran/config.h.in

@@ -777,6 +777,9 @@
 /* Define to 1 if you have the `mkstemp' function. */
 #undef HAVE_MKSTEMP
 
+/* Define to 1 if you have the `mmap' function. */
+#undef HAVE_MMAP
+
 /* Define to 1 if you have the `newlocale' function. */
 #undef HAVE_NEWLOCALE
 
@@ -828,6 +831,9 @@
 /* Define to 1 if you have the `roundl' function. */
 #undef HAVE_ROUNDL
 
+/* Define if __builtin_clzl behaves as expected. */
+#undef HAVE_SANE_BUILTIN_CLZL
+
 /* Define to 1 if you have the `scalbn' function. */
 #undef HAVE_SCALBN
 
@@ -843,6 +849,9 @@
 /* Define to 1 if you have the `secure_getenv' function. */
 #undef HAVE_SECURE_GETENV
 
+/* Define to 1 if you have the `setenv' function. */
+#undef HAVE_SETENV
+
 /* Define to 1 if you have the `setmode' function. */
 #undef HAVE_SETMODE
 
@@ -945,6 +954,9 @@
 /* Define to 1 if you have the `symlink' function. */
 #undef HAVE_SYMLINK
 
+/* Define to 1 if you have the <sys/mman.h> header file. */
+#undef HAVE_SYS_MMAN_H
+
 /* Define to 1 if you have the <sys/random.h> header file. */
 #undef HAVE_SYS_RANDOM_H
 

libgfortran/configure

@@ -637,6 +637,8 @@ am__EXEEXT_TRUE
 LTLIBOBJS
 LIBOBJS
 get_gcc_base_ver
+HAVE_SANE_BUILTIN_CLZL_FALSE
+HAVE_SANE_BUILTIN_CLZL_TRUE
 HAVE_AVX128_FALSE
 HAVE_AVX128_TRUE
 tmake_file
@@ -2620,6 +2622,7 @@ as_fn_append ac_header_list " fpxcp.h"
 as_fn_append ac_header_list " pwd.h"
 as_fn_append ac_header_list " complex.h"
 as_fn_append ac_header_list " xlocale.h"
+as_fn_append ac_header_list " sys/mman.h"
 as_fn_append ac_func_list " getrusage"
 as_fn_append ac_func_list " times"
 as_fn_append ac_func_list " mkstemp"
@@ -2639,6 +2642,8 @@ as_fn_append ac_func_list " sleep"
 as_fn_append ac_func_list " ttyname"
 as_fn_append ac_func_list " sigaction"
 as_fn_append ac_func_list " waitpid"
+as_fn_append ac_func_list " mmap"
+as_fn_append ac_func_list " setenv"
 as_fn_append ac_func_list " alarm"
 as_fn_append ac_func_list " access"
 as_fn_append ac_func_list " fork"
@@ -13221,7 +13226,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 13224 "configure"
+#line 13229 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -13327,7 +13332,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 13330 "configure"
+#line 13335 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -17112,6 +17117,8 @@ done
 
 
 
+
+
 
 
 
@@ -17713,6 +17720,10 @@ done
 
 
 
+
+
+
+
 
 
 
@@ -31812,6 +31823,57 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
   CFLAGS="$ac_save_CFLAGS"
 
 
+# Check if __builtin_clzl behaves (it doesn't on Msys2/ucrt64).
+
+  if test "$cross_compiling" = yes; then :
+  { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot run test program while cross compiling
+See \`config.log' for more details" "$LINENO" 5; }
+else
+  cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h.  */
+
+      int main()
+      {
+	return __builtin_clzl(256) != 8;
+      }
+int
+main ()
+{
+
+  ;
+  return 0;
+}
+_ACEOF
+if ac_fn_c_try_run "$LINENO"; then :
+
+$as_echo "#define HAVE_SANE_BUILTIN_CLZL 1" >>confdefs.h
+
+     if true; then
+  HAVE_SANE_BUILTIN_CLZL_TRUE=
+  HAVE_SANE_BUILTIN_CLZL_FALSE='#'
+else
+  HAVE_SANE_BUILTIN_CLZL_TRUE='#'
+  HAVE_SANE_BUILTIN_CLZL_FALSE=
+fi
+
+else
+   if false; then
+  HAVE_SANE_BUILTIN_CLZL_TRUE=
+  HAVE_SANE_BUILTIN_CLZL_FALSE='#'
+else
+  HAVE_SANE_BUILTIN_CLZL_TRUE='#'
+  HAVE_SANE_BUILTIN_CLZL_FALSE=
+fi
+
+fi
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+  conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+
+
+
 # Determine what GCC version number to use in filesystem paths.
 
   get_gcc_base_ver="cat"
@@ -32103,6 +32165,14 @@ if test -z "${HAVE_AVX128_TRUE}" && test -z "${HAVE_AVX128_FALSE}"; then
   as_fn_error $? "conditional \"HAVE_AVX128\" was never defined.
 Usually this means the macro was only invoked conditionally." "$LINENO" 5
 fi
+if test -z "${HAVE_SANE_BUILTIN_CLZL_TRUE}" && test -z "${HAVE_SANE_BUILTIN_CLZL_FALSE}"; then
+  as_fn_error $? "conditional \"HAVE_SANE_BUILTIN_CLZL\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${HAVE_SANE_BUILTIN_CLZL_TRUE}" && test -z "${HAVE_SANE_BUILTIN_CLZL_FALSE}"; then
+  as_fn_error $? "conditional \"HAVE_SANE_BUILTIN_CLZL\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
 
 : "${CONFIG_STATUS=./config.status}"
 ac_write_fail=0

libgfortran/configure.ac

@@ -298,7 +298,7 @@ AC_CHECK_TYPES([ptrdiff_t])
 AC_CHECK_HEADERS_ONCE(unistd.h sys/random.h sys/time.h sys/times.h \
 sys/resource.h sys/types.h sys/stat.h sys/uio.h sys/wait.h \
 floatingpoint.h ieeefp.h fenv.h fptrap.h \
-fpxcp.h pwd.h complex.h xlocale.h)
+fpxcp.h pwd.h complex.h xlocale.h sys/mman.h)
 
 GCC_HEADER_STDINT(gstdint.h)
 
@@ -334,7 +334,7 @@ if test "${hardwire_newlib:-0}" -eq 1; then
 else
    AC_CHECK_FUNCS_ONCE(getrusage times mkstemp strtof strtold snprintf \
    ftruncate chsize chdir getentropy getlogin gethostname kill link symlink \
-   sleep ttyname sigaction waitpid \
+   sleep ttyname sigaction waitpid mmap setenv\
    alarm access fork posix_spawn setmode fcntl writev \
    gettimeofday stat fstat lstat getpwuid vsnprintf dup \
    getcwd localtime_r gmtime_r getpwuid_r ttyname_r clock_gettime \
@@ -789,6 +789,9 @@ LIBGFOR_CHECK_FMA4
 # Check if AVX128 works
 LIBGFOR_CHECK_AVX128
 
+# Check if __builtin_clzl behaves (it doesn't on Msys2/ucrt64).
+LIBGFOR_CHECK_SANE_BUILTIN_CLZL
+
 # Determine what GCC version number to use in filesystem paths.
 GCC_BASE_VER