Re: GCC/gfortran: asking for permission to merge devel/gfortran-test into master, adding a shared memory implementation of coarrays.

From 5e1a6420dbc56230ed5b6a1df3abd17f4e8b01fd Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Fri, 5 Sep 2025 14:40:24 +0200
Subject: [PATCH 9/9] Fortran: Fix creating shared memory on macOS.

On MacOS mmap() very often does not respect the provided base address
for the shared memory segment.  On the other hand the mutexes have to be
on the same (virtual) address for each process to function properly.
Therefore try a configurable number of times to get the same address for
the shared memory segment on MacOS.  If that fails the user is notified
and the program terminates.

gcc/fortran/ChangeLog:

	* invoke.texi: Document new environment variable GFORTRAN_IMAGE_
	RESTARTS_LIMIT.

libgfortran/ChangeLog:

	* caf/shmem.c (_gfortran_caf_finalize): Ensure all memory is
	freeed.
	* caf/shmem/allocator.c (allocator_shared_malloc): Just assert
	that an index is within its bounds.
	* caf/shmem/shared_memory.c (shared_memory_init): When shared
	memory can not be placed at desired address, exit the image with
	a certain code to let the supervisor restart the image.
	(shared_memory_cleanup): Only the supervisor must unlink the shm
	object.
	* caf/shmem/supervisor.c (GFORTRAN_ENV_IMAGE_RESTARTS_LIMITS):
	New environment variable.
	(get_image_restarts_limit): Get the limit on image restarts
	(accumulates over all) form the environment variable or default
	to 4000.
	(ensure_shmem_initialization): Add error handling.
	(startWorker): Start a single worker/image.
	(kill_all_images): Kill all images.
	(supervisor_main_loop): When a worker/image reports a shared
	memory issue just try to restart it.
	* caf/shmem/thread_support.c (initialize_shared_mutex): Mark
	mutex robust on plattforms that support it.
	(initialize_shared_errorcheck_mutex): Same.
---
 gcc/fortran/invoke.texi                |   9 ++
 libgfortran/caf/shmem.c                |   1 +
 libgfortran/caf/shmem/allocator.c      |   2 +
 libgfortran/caf/shmem/shared_memory.c  |  30 +++--
 libgfortran/caf/shmem/supervisor.c     | 175 ++++++++++++++++++-------
 libgfortran/caf/shmem/thread_support.c |   8 +-
 6 files changed, 166 insertions(+), 59 deletions(-)

diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index b3be2453627..d0c03f0f583 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -2339,6 +2339,15 @@ 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
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index 266feab3e45..446e5f54483 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -152,6 +152,7 @@ _gfortran_caf_finalize (void)
   free_team_list (caf_teams_formed);
   caf_teams_formed = NULL;
 
+  shared_memory_cleanup (&local->sm);
   free (local);
 
   thread_support_cleanup ();
diff --git a/libgfortran/caf/shmem/allocator.c b/libgfortran/caf/shmem/allocator.c
index 2a22abb2a80..bd88f33e200 100644
--- a/libgfortran/caf/shmem/allocator.c
+++ b/libgfortran/caf/shmem/allocator.c
@@ -101,6 +101,8 @@ allocator_shared_malloc (allocator *a, size_t size)
   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);
diff --git a/libgfortran/caf/shmem/shared_memory.c b/libgfortran/caf/shmem/shared_memory.c
index d0789a4bac6..0659e6ba023 100644
--- a/libgfortran/caf/shmem/shared_memory.c
+++ b/libgfortran/caf/shmem/shared_memory.c
@@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include "libgfortran.h"
 #include "allocator.h"
 #include "shared_memory.h"
+#include "supervisor.h"
 
 #include <assert.h>
 #include <fcntl.h>
@@ -194,7 +195,7 @@ shared_memory_init (shared_memory_act *mem, size_t size)
   else
     {
 #ifdef HAVE_MMAP
-      mem->shm_fd = shm_open (shm_name, O_RDWR, 0);
+      mem->shm_fd = shm_open (shm_name, O_RDWR, 0600);
       if (mem->shm_fd == -1)
 	{
 	  perror ("opening shared memory segment failed.");
@@ -212,7 +213,14 @@ shared_memory_init (shared_memory_act *mem, size_t size)
 #ifdef HAVE_MMAP
   mem->glbl.base
     = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, mem->shm_fd, 0);
-  if (mem->glbl.base == MAP_FAILED)
+  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);
@@ -249,9 +257,6 @@ shared_memory_init (shared_memory_act *mem, size_t size)
 void
 shared_memory_cleanup (shared_memory_act *mem)
 {
-  char shm_name[NAME_MAX];
-
-  snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ());
 #ifdef HAVE_MMAP
   int res = munmap (mem->glbl.base, mem->size);
   if (res)
@@ -263,11 +268,18 @@ shared_memory_cleanup (shared_memory_act *mem)
     {
       perror ("closing shm file handle failed. Trying to continue...");
     }
-  res = shm_unlink (shm_name);
-  if (res == -1)
+  if (this_image.image_num == -1)
     {
-      perror ("shm_unlink failed");
-      exit (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))
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index c39ffc6715c..780ab4a45c0 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -43,6 +43,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #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;
 
@@ -68,6 +69,21 @@ get_image_num_from_envvar (void)
   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
@@ -157,6 +173,11 @@ ensure_shmem_initialization (void)
     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)
@@ -234,6 +255,54 @@ ensure_shmem_initialization (void)
 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
@@ -254,40 +323,19 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
   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 ());
-  m = this_image.supervisor;
+  im.supervisor = m = this_image.supervisor;
 
   for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++)
     {
 #ifdef HAVE_FORK
-      caf_shmem_pid new_pid;
-      if ((new_pid = fork ()))
-	{
-	  if (new_pid == -1)
-	    caf_runtime_error ("error spawning child\n");
-	  m->images[im.image_num] = (image_tracker) {new_pid, IMAGE_OK};
-	}
-      else
-	{
-	  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;
-	  execve ((*argv)[0], *argv, new_env);
-	  return 1;
-	}
+      if (startWorker (&im, argv))
+	return 1;
 #elif defined(WIN32)
       LPTCH new_env;
       size_t n = 0, es;
@@ -345,6 +393,14 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
 #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;
@@ -365,35 +421,56 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
 	       j < local->total_num_images && m->images[j].pid != finished_pid;
 	       j++)
 	    ;
-	  dprintf (2, "ERROR: Image %d(pid: %d) failed with %d.\n", j + 1,
-		   finished_pid, WTERMSIG (chstatus));
-	  if (j == local->total_num_images)
+	  if (WEXITSTATUS (chstatus) == 210)
 	    {
-	      if (finished_pid == getpid ())
+	      --i;
+	      im.image_num = j;
+	      ++restarts;
+	      if (restarts > restarts_limit)
 		{
-		  dprintf (2,
-			   "WARNING: Supervisor process got signal %d. Killing "
-			   "childs and exiting.\n",
-			   WTERMSIG (chstatus));
-		  for (j = 0; j < local->total_num_images; j++)
-		    {
-		      if (m->images[j].status == IMAGE_OK)
-			kill (m->images[j].pid, SIGKILL);
-		    }
+		  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);
 		}
-	      dprintf (2,
-		       "WARNING: Got signal %d for unknown process %d. "
-		       "Ignoring and trying to continue.\n",
-		       WTERMSIG (chstatus), finished_pid);
+	      if (startWorker (&im, argv))
+		return 1;
 	      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;
+	  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++)
diff --git a/libgfortran/caf/shmem/thread_support.c b/libgfortran/caf/shmem/thread_support.c
index e2c53627c2f..dcd8b00b788 100755
--- a/libgfortran/caf/shmem/thread_support.c
+++ b/libgfortran/caf/shmem/thread_support.c
@@ -50,6 +50,9 @@ 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));
 }
@@ -61,6 +64,9 @@ initialize_shared_errorcheck_mutex (caf_shmem_mutex *mutex)
   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));
 }
@@ -248,7 +254,7 @@ bm_set_mask (volatile unsigned long mask[], const int size)
     mask[i] = ~0UL >> (ULONGBITS - rem);
 }
 
-__attribute_used__ static bool
+__attribute__ ((used)) static bool
 bm_is_none (volatile unsigned long mask[], const int size)
 {
   const int entries = size / ULONGBITS;
-- 
2.51.0

From be782d3a78fd898d2ee1a009d4b1ce08baa6d6a2 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Wed, 6 Aug 2025 15:36:54 +0200
Subject: [PATCH 8/9] Fortran: Fix caf_shmem syncing on Windows.

Cygwin's libc's pthread implementation does not support setting
pshared on mutexes and condition variables.  Therefore Windows
synchronisation primitives needed to be used directly.
On MSYS2/UCRT64 fork and mmap are not available and Windows core
functionality needs to be used.

libgfortran/ChangeLog:

	* caf/shmem.c (_gfortran_caf_init): Cleanup thread helper after
	use.
	(_gfortran_caf_finalize): Same.
	(_gfortran_caf_register): Handle lock_t correctly on Windows.
	(GEN_OP): Prevent warnings on non-initialized.
	(_gfortran_caf_lock): Handle lock_t correctly on Windows.
	(_gfortran_caf_unlock): Same.
	(_gfortran_caf_random_init): Fix formatting.
	(_gfortran_caf_form_team): Add more images to counter_barrier.
	* caf/shmem/alloc.c: Use routines from thread_support.
	* caf/shmem/allocator.c (allocator_lock): Same.
	(allocator_unlock): Same.
	* caf/shmem/allocator.h: Same.
	* caf/shmem/collective_subroutine.c (get_collsub_buf): Same.
	* caf/shmem/collective_subroutine.h: Same.
	* caf/shmem/counter_barrier.c (lock_counter_barrier): Same.
	(unlock_counter_barrier): Same.
	(counter_barrier_init): Same.
	(counter_barrier_wait): Same.
	(change_internal_barrier_count): Same.
	(counter_barrier_add): Same.
	(counter_barrier_init_add): Only increase value w/o signaling.
	(counter_barrier_get_count): Use routines from thread_support.
	* caf/shmem/counter_barrier.h: Same.
	(counter_barrier_init_add): New routine.
	* caf/shmem/shared_memory.c: Use windows routines where
	applicable.
	(shared_memory_set_env): Same.
	(shared_memory_get_master): Same.
	(shared_memory_init): Same.
	(shared_memory_cleanup): Same.
	* caf/shmem/shared_memory.h: Use types from thread_support.
	* caf/shmem/supervisor.c: Use windows routines where applicable.
	(get_memory_size_from_envvar): Same.
	(ensure_shmem_initialization): Same.
	(supervisor_main_loop): Use windows process start on windows
	without fork().
	* caf/shmem/supervisor.h: Use types from thread_support.
	* caf/shmem/sync.c (lock_table): Use routines from thread_support.
	(unlock_table): Same.
	(sync_init): Same.
	(sync_init_supervisor): Same.
	(sync_table): Same.
	(lock_event): Same.
	(unlock_event): Same.
	(event_post): Same.
	(event_wait): Same.
	* caf/shmem/sync.h: Use types from thread_support.
	* caf/shmem/teams_mgmt.c (update_teams_images): Use routines from
	thread_support.
	* caf/shmem/thread_support.c: Add synchronisation primitives for
	windows.
	(smax): Windows only: Max for size_t.
	(get_handle): Windows only: Get the windows handle for a given
	id or create a new one, if it does not exist.
	(get_mutex): Windows only: Shortcut for getting a windows mutex
	handle.
	(get_condvar): Windows only: Same, but for condition variable.
	(thread_support_init_supervisor): Windows only: Clear tracker of
	allocated handle ids.
	(caf_shmem_mutex_lock): Windows only: Implememtation of lock,
	(caf_shmem_mutex_trylock): Windows only: trylock, and
	(caf_shmem_mutex_unlock): Windows only:  unlock for Windows.
	(bm_is_set): Windows only: Check a bit is set in a mask.
	(bm_clear_bit): Windows only: Clear a bit in a mask.
	(bm_set_mask): Windows only: Set all bits in a mask.
	(bm_is_none): Windows only: Check if all bits are cleared.
	(caf_shmem_cond_wait): Windows only: Condition variable
	implemenation fro wait,
	(caf_shmem_cond_broadcast): Windows only: broadcast, and
	(caf_shmem_cond_signal): Windows only: signal on Windows.
	(caf_shmem_cond_update_count): Windows only: Need to know the
	images participating in a condition variable.
	(thread_support_cleanup): Windows only: Clean up the handles on
	exit.
	* caf/shmem/thread_support.h: Conditionally compile the types
	as required for Windows and other OSes.
	* config.h.in: Regenerate.
	* configure: Regenerate.
	* configure.ac: Add test for mmap, setenv and sys/mman.h.
---
 libgfortran/caf/shmem.c                       |  79 +++--
 libgfortran/caf/shmem/alloc.c                 |   2 +-
 libgfortran/caf/shmem/allocator.c             |   4 +-
 libgfortran/caf/shmem/allocator.h             |   4 +-
 libgfortran/caf/shmem/collective_subroutine.c |   4 +-
 libgfortran/caf/shmem/collective_subroutine.h |   2 +-
 libgfortran/caf/shmem/counter_barrier.c       |  34 +-
 libgfortran/caf/shmem/counter_barrier.h       |  10 +-
 libgfortran/caf/shmem/shared_memory.c         | 114 ++++++-
 libgfortran/caf/shmem/shared_memory.h         |   3 +
 libgfortran/caf/shmem/supervisor.c            | 185 ++++++++++-
 libgfortran/caf/shmem/supervisor.h            |  11 +-
 libgfortran/caf/shmem/sync.c                  |  30 +-
 libgfortran/caf/shmem/sync.h                  |  12 +-
 libgfortran/caf/shmem/teams_mgmt.c            |   4 +-
 libgfortran/caf/shmem/thread_support.c        | 310 +++++++++++++++++-
 libgfortran/caf/shmem/thread_support.h        |  81 ++++-
 libgfortran/config.h.in                       |   9 +
 libgfortran/configure                         |  13 +-
 libgfortran/configure.ac                      |   4 +-
 20 files changed, 796 insertions(+), 119 deletions(-)
 mode change 100644 => 100755 libgfortran/caf/shmem/thread_support.c
 mode change 100644 => 100755 libgfortran/caf/shmem/thread_support.h

diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index b8d92d657f5..266feab3e45 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -94,6 +94,8 @@ _gfortran_caf_init (int *argc, char ***argv)
 
   if (supervisor_main_loop (argc, argv, &exit_code))
     return;
+
+  thread_support_cleanup ();
   shared_memory_cleanup (&local->sm);
 
   /* Free pseudo tokens and memory to allow main process to survive caf_init.
@@ -107,6 +109,7 @@ _gfortran_caf_init (int *argc, char ***argv)
       caf_static_list = tmp;
     }
   free (local);
+
   exit (exit_code);
 }
 
@@ -150,6 +153,8 @@ _gfortran_caf_finalize (void)
   caf_teams_formed = NULL;
 
   free (local);
+
+  thread_support_cleanup ();
 }
 
 int
@@ -267,19 +272,25 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
       {
 	lock_t *addr;
 	bool created;
+	size_t alloc_size;
 
 	allocator_lock (&local->ai.alloc);
-	/* Allocate enough space for the metadata infront of the lock
-	   array.  */
-	addr
-	  = alloc_get_memory_by_id_created (&local->ai, size * sizeof (lock_t),
-					    next_memid, &created);
+#if defined(WIN32) || defined(__CYGWIN__)
+	/* On Windows mutexes are not an object stored in the shmem but
+	   identified by an id.  */
+	alloc_size = size * caf_current_team->u.image_info->image_count.count;
+#else
+	alloc_size = size;
+#endif
+	addr = alloc_get_memory_by_id_created (&local->ai,
+					       alloc_size * sizeof (lock_t),
+					       next_memid, &created);
 
 	if (created)
 	  {
 	    /* Initialize the mutex only, when the memory was allocated for the
 	       first time.  */
-	    for (size_t c = 0; c < size; ++c)
+	    for (size_t c = 0; c < alloc_size; ++c)
 	      initialize_shared_errorcheck_mutex (&addr[c]);
 	  }
 	size *= sizeof (lock_t);
@@ -852,6 +863,7 @@ typedef void *opr_t;
 	default:                                                               \
 	  caf_runtime_error ("" #name                                          \
 			     " not available for type/kind combination");      \
+	  opr = NULL; /* Prevent false warnings.  */                           \
 	}                                                                      \
       break;                                                                   \
     }
@@ -873,10 +885,12 @@ typedef void *opr_t;
 	default:                                                               \
 	  caf_runtime_error ("" #name                                          \
 			     " not available for type/kind combination");      \
+	  opr = NULL; /* Prevent false warning.  */                            \
 	}                                                                      \
       break;                                                                   \
     default:                                                                   \
       caf_runtime_error ("" #name " not available for type/kind combination"); \
+      opr = NULL; /* Prevent false warning.  */                                \
     }
 
 void
@@ -1473,17 +1487,23 @@ _gfortran_caf_event_query (caf_token_t token, size_t index, int image_index,
 }
 
 void
-_gfortran_caf_lock (caf_token_t token, size_t index,
-		    int image_index __attribute__ ((unused)),
+_gfortran_caf_lock (caf_token_t token, size_t index, int image_index,
 		    int *acquired_lock, int *stat, char *errmsg,
 		    size_t errmsg_len)
 {
   const char *msg = "Already locked";
-  lock_t *lock = &((lock_t *) MEMTOK (token))[index];
+#if defined(WIN32) || defined(__CYGWIN__)
+  const size_t lock_index
+    = image_index * caf_current_team->u.image_info->image_count.count + index;
+#else
+  const size_t lock_index = index;
+  (void) image_index; // Prevent unused warnings.
+#endif
+  lock_t *lock = &((lock_t *) MEMTOK (token))[lock_index];
   int res;
 
-  res
-    = acquired_lock ? pthread_mutex_trylock (lock) : pthread_mutex_lock (lock);
+  res = acquired_lock ? caf_shmem_mutex_trylock (lock)
+		      : caf_shmem_mutex_lock (lock);
 
   if (stat)
     *stat = res == EBUSY ? GFC_STAT_LOCKED : 0;
@@ -1501,28 +1521,32 @@ _gfortran_caf_lock (caf_token_t token, size_t index,
     {
       if (errmsg_len > 0)
 	{
-	  size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
-						      : sizeof (msg);
+	  size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len : sizeof (msg);
 	  memcpy (errmsg, msg, len);
 	  if (errmsg_len > len)
-	    memset (&errmsg[len], ' ', errmsg_len-len);
+	    memset (&errmsg[len], ' ', errmsg_len - len);
 	}
       return;
     }
   _gfortran_caf_error_stop_str (msg, strlen (msg), false);
 }
 
-
 void
-_gfortran_caf_unlock (caf_token_t token, size_t index,
-		      int image_index __attribute__ ((unused)),
+_gfortran_caf_unlock (caf_token_t token, size_t index, int image_index,
 		      int *stat, char *errmsg, size_t errmsg_len)
 {
   const char *msg = "Variable is not locked";
-  lock_t *lock = &((lock_t *) MEMTOK (token))[index];
+#if defined(WIN32) || defined(__CYGWIN__)
+  const size_t lock_index
+    = image_index * caf_current_team->u.image_info->image_count.count + index;
+#else
+  const size_t lock_index = index;
+  (void) image_index; // Prevent unused warnings.
+#endif
+  lock_t *lock = &((lock_t *) MEMTOK (token))[lock_index];
   int res;
 
-  res = pthread_mutex_unlock (lock);
+  res = caf_shmem_mutex_unlock (lock);
 
   if (res == 0)
     {
@@ -1535,34 +1559,33 @@ _gfortran_caf_unlock (caf_token_t token, size_t index,
     {
       /* res == EPERM means that the lock is locked.  Now figure, if by us by
 	 trying to lock it or by other image, which fails.  */
-      res = pthread_mutex_trylock (lock);
+      res = caf_shmem_mutex_trylock (lock);
       if (res == EBUSY)
 	*stat = GFC_STAT_LOCKED_OTHER_IMAGE;
       else
 	{
 	  *stat = GFC_STAT_UNLOCKED;
-	  pthread_mutex_unlock (lock);
+	  caf_shmem_mutex_unlock (lock);
 	}
 
       if (errmsg_len > 0)
 	{
-	  size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
-	    : sizeof (msg);
+	  size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len : sizeof (msg);
 	  memcpy (errmsg, msg, len);
 	  if (errmsg_len > len)
-	    memset (&errmsg[len], ' ', errmsg_len-len);
+	    memset (&errmsg[len], ' ', errmsg_len - len);
 	}
       return;
     }
   _gfortran_caf_error_stop_str (msg, strlen (msg), false);
 }
 
-
 /* Reference the libraries implementation.  */
 extern void _gfortran_random_seed_i4 (int32_t *size, gfc_array_i4 *put,
 				      gfc_array_i4 *get);
 
-void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
+void
+_gfortran_caf_random_init (bool repeatable, bool image_distinct)
 {
   static struct
   {
@@ -1720,8 +1743,8 @@ _gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index,
 	   ++i)
 	t->u.image_info->image_map[i] = -1;
     }
-  counter_barrier_add (&t->u.image_info->image_count, 1);
-  counter_barrier_add (&t->u.image_info->collsub.barrier, 1);
+  counter_barrier_init_add (&t->u.image_info->image_count, 1);
+  counter_barrier_init_add (&t->u.image_info->collsub.barrier, 1);
   allocator_unlock (&local->ai.alloc);
 
   if (new_index)
diff --git a/libgfortran/caf/shmem/alloc.c b/libgfortran/caf/shmem/alloc.c
index fecf97c03ff..ea250ac6922 100644
--- a/libgfortran/caf/shmem/alloc.c
+++ b/libgfortran/caf/shmem/alloc.c
@@ -30,9 +30,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include "../caf_error.h"
 #include "supervisor.h"
 #include "shared_memory.h"
+#include "thread_support.h"
 
 #include <assert.h>
-#include <pthread.h>
 #include <string.h>
 
 /* Worker's part to initialize the alloc interface.  */
diff --git a/libgfortran/caf/shmem/allocator.c b/libgfortran/caf/shmem/allocator.c
index 3ea4d50e045..2a22abb2a80 100644
--- a/libgfortran/caf/shmem/allocator.c
+++ b/libgfortran/caf/shmem/allocator.c
@@ -133,11 +133,11 @@ allocator_shared_free (allocator *a, shared_mem_ptr p, size_t size)
 void
 allocator_lock (allocator *a)
 {
-  pthread_mutex_lock (&a->s->lock);
+  caf_shmem_mutex_lock (&a->s->lock);
 }
 
 void
 allocator_unlock (allocator *a)
 {
-  pthread_mutex_unlock (&a->s->lock);
+  caf_shmem_mutex_unlock (&a->s->lock);
 }
diff --git a/libgfortran/caf/shmem/allocator.h b/libgfortran/caf/shmem/allocator.h
index 53b6abeeba1..0cf31ea837a 100644
--- a/libgfortran/caf/shmem/allocator.h
+++ b/libgfortran/caf/shmem/allocator.h
@@ -29,16 +29,16 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #define ALLOCATOR_HDR
 
 #include "shared_memory.h"
+#include "thread_support.h"
 
 #include <stddef.h>
-#include <pthread.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 {
-  pthread_mutex_t lock;
+  caf_shmem_mutex lock;
   shared_mem_ptr free_bucket_head[VOIDP_BITS];
 } allocator_shared;
 
diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c
index 257a048d63d..d261b412a93 100644
--- a/libgfortran/caf/shmem/collective_subroutine.c
+++ b/libgfortran/caf/shmem/collective_subroutine.c
@@ -198,7 +198,7 @@ get_collsub_buf (size_t size)
 {
   void *ret;
 
-  pthread_mutex_lock (&caf_current_team->u.image_info->collsub.mutex);
+  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)
@@ -214,7 +214,7 @@ get_collsub_buf (size_t size)
 
   ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf,
 		   &local->sm);
-  pthread_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);
+  caf_shmem_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);
   return ret;
 }
 
diff --git a/libgfortran/caf/shmem/collective_subroutine.h b/libgfortran/caf/shmem/collective_subroutine.h
index 8c37186c867..bdddab07a93 100644
--- a/libgfortran/caf/shmem/collective_subroutine.h
+++ b/libgfortran/caf/shmem/collective_subroutine.h
@@ -36,7 +36,7 @@ typedef struct collsub_shared
   size_t curr_size;
   shared_mem_ptr collsub_buf;
   counter_barrier barrier;
-  pthread_mutex_t mutex;
+  caf_shmem_mutex mutex;
 } collsub_shared;
 
 void collsub_init_supervisor (collsub_shared *, allocator *,
diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c
index f78ba7fe852..2cda2afb2ed 100644
--- a/libgfortran/caf/shmem/counter_barrier.c
+++ b/libgfortran/caf/shmem/counter_barrier.c
@@ -34,7 +34,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 static inline void
 lock_counter_barrier (counter_barrier *b)
 {
-  pthread_mutex_lock (&b->mutex);
+  caf_shmem_mutex_lock (&b->mutex);
 }
 
 /* Unlock the associated counter of this barrier.  */
@@ -42,15 +42,15 @@ lock_counter_barrier (counter_barrier *b)
 static inline void
 unlock_counter_barrier (counter_barrier *b)
 {
-  pthread_mutex_unlock (&b->mutex);
+  caf_shmem_mutex_unlock (&b->mutex);
 }
 
 void
 counter_barrier_init (counter_barrier *b, int val)
 {
-  *b = (counter_barrier) {PTHREAD_MUTEX_INITIALIZER, PTHREAD_COND_INITIALIZER,
-			  val, 0, val};
-  initialize_shared_condition (&b->cond);
+  *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);
 }
 
@@ -60,15 +60,14 @@ 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)
-    pthread_cond_broadcast (&b->cond);
+    caf_shmem_cond_broadcast (&b->cond);
   else
     {
       while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
-	  pthread_cond_wait (&b->cond, &b->mutex);
+	caf_shmem_cond_wait (&b->cond, &b->mutex);
     }
 
   if (b->wait_count <= 0)
@@ -80,13 +79,12 @@ counter_barrier_wait (counter_barrier *b)
   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)
-    pthread_cond_broadcast (&b->cond);
+    caf_shmem_cond_broadcast (&b->cond);
 }
 
 int
@@ -103,19 +101,27 @@ int
 counter_barrier_add (counter_barrier *c, int val)
 {
   int ret;
-  pthread_mutex_lock (&c->mutex);
+  caf_shmem_mutex_lock (&c->mutex);
   ret = counter_barrier_add_locked (c, val);
 
-  pthread_mutex_unlock (&c->mutex);
+  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;
-  pthread_mutex_lock (&c->mutex);
+  caf_shmem_mutex_lock (&c->mutex);
   ret = c->count;
-  pthread_mutex_unlock (&c->mutex);
+  caf_shmem_mutex_unlock (&c->mutex);
   return ret;
 }
diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h
index a28c58812a5..ab3d35ada74 100644
--- a/libgfortran/caf/shmem/counter_barrier.h
+++ b/libgfortran/caf/shmem/counter_barrier.h
@@ -25,7 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #ifndef COUNTER_BARRIER_HDR
 #define COUNTER_BARRIER_HDR
 
-#include <pthread.h>
+#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
@@ -41,8 +41,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 
 typedef struct
 {
-  pthread_mutex_t mutex;
-  pthread_cond_t cond;
+  caf_shmem_mutex mutex;
+  caf_shmem_condvar cond;
   volatile int wait_count;
   volatile int curr_wait_group;
   volatile int count;
@@ -65,6 +65,10 @@ int counter_barrier_add_locked (counter_barrier *, int);
 
 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 *);
diff --git a/libgfortran/caf/shmem/shared_memory.c b/libgfortran/caf/shmem/shared_memory.c
index 2b3666ddd3b..d0789a4bac6 100644
--- a/libgfortran/caf/shmem/shared_memory.c
+++ b/libgfortran/caf/shmem/shared_memory.c
@@ -22,6 +22,10 @@ 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"
@@ -30,7 +34,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #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
@@ -56,7 +65,11 @@ shared_memory_set_env (pid_t pid)
   char buffer[bufsize];
 
   snprintf (buffer, bufsize, "%d", pid);
+#ifdef HAVE_SETENV
   setenv (ENV_PPID, buffer, 1);
+#else
+  SetEnvironmentVariable (ENV_PPID, buffer);
+#endif
 #undef bufsize
 }
 
@@ -82,7 +95,7 @@ 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};
+    return (shared_mem_ptr) {mem->glbl.meta->master};
   else
     {
       ptrdiff_t loc = mem->glbl.meta->used;
@@ -112,7 +125,6 @@ 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 ();
-  int shm_fd, res;
   void *base_ptr;
 
   if (env_val)
@@ -131,70 +143,138 @@ shared_memory_init (shared_memory_act *mem, size_t size)
 
   if (!env_val)
     {
-      shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600);
-      if (shm_fd == -1)
+#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 (shm_fd, size);
+      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
     {
-      shm_fd = shm_open (shm_name, O_RDWR, 0);
-      if (shm_fd == -1)
+#ifdef HAVE_MMAP
+      mem->shm_fd = shm_open (shm_name, O_RDWR, 0);
+      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, shm_fd, 0);
-  res = close (shm_fd);
+    = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, mem->shm_fd, 0);
   if (mem->glbl.base == MAP_FAILED)
     {
       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
     }
-  if (res)
-    { // from close()
-      perror ("closing shm file handle failed. Trying to continue...");
-    }
   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 *)
+shared_memory_cleanup (shared_memory_act *mem)
 {
   char shm_name[NAME_MAX];
-  int res;
 
   snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ());
+#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...");
+    }
   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
diff --git a/libgfortran/caf/shmem/shared_memory.h b/libgfortran/caf/shmem/shared_memory.h
index 01ac2811e5d..3d031875ed2 100644
--- a/libgfortran/caf/shmem/shared_memory.h
+++ b/libgfortran/caf/shmem/shared_memory.h
@@ -25,6 +25,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #ifndef SHARED_MEMORY_H
 #define SHARED_MEMORY_H
 
+#include "thread_support.h"
+
 #include <stdlib.h>
 #include <stddef.h>
 #include <unistd.h>
@@ -47,6 +49,7 @@ typedef struct shared_memory_act
     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.  */
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index e4310b03e43..c39ffc6715c 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -22,8 +22,6 @@ 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 "config.h"
-
 #include "../caf_error.h"
 #include "supervisor.h"
 #include "teams_mgmt.h"
@@ -38,6 +36,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #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"
@@ -56,8 +57,13 @@ get_image_num_from_envvar (void)
   int nimages;
   num_images_char = getenv (GFORTRAN_ENV_NUM_IMAGES);
   if (!num_images_char)
-    return sysconf (_SC_NPROCESSORS_ONLN); /* TODO: Make portable.  */
-  /* TODO: Error checking.  */
+#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;
 }
@@ -105,7 +111,12 @@ get_memory_size_from_envvar (void)
       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;
 }
@@ -146,7 +157,19 @@ ensure_shmem_initialization (void)
     return;
 
   local = malloc (sizeof (image_local));
+#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);
@@ -199,6 +222,7 @@ ensure_shmem_initialization (void)
     {
       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);
@@ -206,16 +230,31 @@ ensure_shmem_initialization (void)
     }
 }
 
+#if !defined(environ)
 extern char **environ;
+#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,
-		      int *exit_code)
+supervisor_main_loop (int *argc __attribute__ ((unused)),
+		      char ***argv __attribute__ ((unused)), int *exit_code)
 {
   supervisor *m;
-  pid_t new_pid, finished_pid;
   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;
+#endif
 
   *exit_code = 0;
   shared_memory_set_env (getpid ());
@@ -223,6 +262,8 @@ supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
 
   for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++)
     {
+#ifdef HAVE_FORK
+      caf_shmem_pid new_pid;
       if ((new_pid = fork ()))
 	{
 	  if (new_pid == -1)
@@ -247,10 +288,63 @@ supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
 	  execve ((*argv)[0], *argv, new_env);
 	  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 j, i = 0; i < local->total_num_images; i++)
+  for (int i = 0; i < local->total_num_images; i++)
     {
-      finished_pid = wait (&chstatus);
+#ifdef HAVE_FORK
+      caf_shmem_pid finished_pid = wait (&chstatus);
+      int j;
       if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus))
 	{
 	  for (j = 0;
@@ -303,10 +397,77 @@ supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
 	}
       /* Trigger waiting sync images aka sync_table.  */
       for (j = 0; j < local->total_num_images; j++)
-	pthread_cond_signal (&SHMPTR_AS (pthread_cond_t *,
-					 m->sync_shared.sync_images_cond_vars,
-					 &local->sm)[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;
 }
diff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h
index 7afb8269674..7e5e19702e4 100644
--- a/libgfortran/caf/shmem/supervisor.h
+++ b/libgfortran/caf/shmem/supervisor.h
@@ -25,6 +25,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #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"
@@ -42,7 +46,7 @@ typedef enum
 
 typedef struct
 {
-  pid_t pid;
+  caf_shmem_pid pid;
   image_status status;
 } image_tracker;
 
@@ -56,7 +60,10 @@ typedef struct supervisor
   atomic_int failed_images;
   atomic_int finished_images;
   counter_barrier num_active_images;
-  pthread_mutex_t image_tracker_lock;
+  caf_shmem_mutex image_tracker_lock;
+#ifdef WIN32
+  size_t global_used_handles;
+#endif
   image_tracker images[];
 } supervisor;
 
diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c
index a456244629c..e1020a1e864 100644
--- a/libgfortran/caf/shmem/sync.c
+++ b/libgfortran/caf/shmem/sync.c
@@ -33,13 +33,13 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 static inline void
 lock_table (sync_t *si)
 {
-  pthread_mutex_lock (&si->cis->sync_images_table_lock);
+  caf_shmem_mutex_lock (&si->cis->sync_images_table_lock);
 }
 
 static inline void
 unlock_table (sync_t *si)
 {
-  pthread_mutex_unlock (&si->cis->sync_images_table_lock);
+  caf_shmem_mutex_unlock (&si->cis->sync_images_table_lock);
 }
 
 void
@@ -48,7 +48,7 @@ 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 (pthread_cond_t *,
+    SHMPTR_AS (caf_shmem_condvar *,
 	       this_image.supervisor->sync_shared.sync_images_cond_vars, sm)};
 }
 
@@ -61,7 +61,7 @@ sync_init_supervisor (sync_t *si, alloc *ai)
   si->cis = &this_image.supervisor->sync_shared;
 
   initialize_shared_mutex (&si->cis->event_lock);
-  initialize_shared_condition (&si->cis->event_cond);
+  initialize_shared_condition (&si->cis->event_cond, num_images);
 
   initialize_shared_mutex (&si->cis->sync_images_table_lock);
 
@@ -69,14 +69,14 @@ sync_init_supervisor (sync_t *si, alloc *ai)
     = 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 (pthread_cond_t) * num_images);
+			       sizeof (caf_shmem_condvar) * num_images);
 
   si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem);
   si->triggers
-    = SHMPTR_AS (pthread_cond_t *, si->cis->sync_images_cond_vars, ai->mem);
+    = 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]);
+    initialize_shared_condition (&si->triggers[i], num_images);
 
   memset (si->table, 0, table_size_in_bytes);
 }
@@ -103,7 +103,7 @@ sync_table (sync_t *si, int *images, int size)
       for (i = 0; i < size; ++i)
 	{
 	  ++table[images[i] + img_c * this_image.image_num];
-	  pthread_cond_signal (&si->triggers[images[i]]);
+	  caf_shmem_cond_signal (&si->triggers[images[i]]);
 	}
       for (;;)
 	{
@@ -114,7 +114,7 @@ sync_table (sync_t *si, int *images, int size)
 	      break;
 	  if (i == size)
 	    break;
-	  pthread_cond_wait (&si->triggers[this_image.image_num],
+	  caf_shmem_cond_wait (&si->triggers[this_image.image_num],
 			     &si->cis->sync_images_table_lock);
 	}
     }
@@ -127,7 +127,7 @@ sync_table (sync_t *si, int *images, int size)
 	  if (this_image.supervisor->images[map[i]].status != IMAGE_OK)
 	    continue;
 	  ++table[map[i] + size * this_image.image_num];
-	  pthread_cond_signal (&si->triggers[map[i]]);
+	  caf_shmem_cond_signal (&si->triggers[map[i]]);
 	}
       for (;;)
 	{
@@ -138,7 +138,7 @@ sync_table (sync_t *si, int *images, int size)
 	      break;
 	  if (i == size)
 	    break;
-	  pthread_cond_wait (&si->triggers[this_image.image_num],
+	  caf_shmem_cond_wait (&si->triggers[this_image.image_num],
 			     &si->cis->sync_images_table_lock);
 	}
     }
@@ -160,23 +160,23 @@ sync_team (caf_shmem_team_t team)
 void
 lock_event (sync_t *si)
 {
-  pthread_mutex_lock (&si->cis->event_lock);
+  caf_shmem_mutex_lock (&si->cis->event_lock);
 }
 
 void
 unlock_event (sync_t *si)
 {
-  pthread_mutex_unlock (&si->cis->event_lock);
+  caf_shmem_mutex_unlock (&si->cis->event_lock);
 }
 
 void
 event_post (sync_t *si)
 {
-  pthread_cond_broadcast (&si->cis->event_cond);
+  caf_shmem_cond_broadcast (&si->cis->event_cond);
 }
 
 void
 event_wait (sync_t *si)
 {
-  pthread_cond_wait (&si->cis->event_cond, &si->cis->event_lock);
+  caf_shmem_cond_wait (&si->cis->event_cond, &si->cis->event_lock);
 }
diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h
index a3e586bca24..a6d20614b67 100644
--- a/libgfortran/caf/shmem/sync.h
+++ b/libgfortran/caf/shmem/sync.h
@@ -28,13 +28,11 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include "alloc.h"
 #include "counter_barrier.h"
 
-#include <pthread.h>
-
 typedef struct {
   /* Mutex and condition variable needed for signaling events.  */
-  pthread_mutex_t event_lock;
-  pthread_cond_t event_cond;
-  pthread_mutex_t sync_images_table_lock;
+  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;
@@ -42,10 +40,10 @@ typedef struct {
 typedef struct {
   sync_shared *cis;
   int *table; // we can cache the table and the trigger pointers here
-  pthread_cond_t *triggers;
+  caf_shmem_condvar *triggers;
 } sync_t;
 
-typedef pthread_mutex_t lock_t;
+typedef caf_shmem_mutex lock_t;
 
 typedef int event_t;
 
diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c
index 44a34d727c3..9bf8db2302c 100644
--- a/libgfortran/caf/shmem/teams_mgmt.c
+++ b/libgfortran/caf/shmem/teams_mgmt.c
@@ -31,7 +31,7 @@ caf_shmem_team_t caf_teams_formed = NULL;
 void
 update_teams_images (caf_shmem_team_t team)
 {
-  pthread_mutex_lock (&team->u.image_info->image_count.mutex);
+  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)
@@ -52,7 +52,7 @@ update_teams_images (caf_shmem_team_t team)
 				   old_num
 				     - team->u.image_info->num_term_images);
     }
-  pthread_mutex_unlock (&team->u.image_info->image_count.mutex);
+  caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex);
 }
 
 void
diff --git a/libgfortran/caf/shmem/thread_support.c b/libgfortran/caf/shmem/thread_support.c
old mode 100644
new mode 100755
index 572f39400b3..e2c53627c2f
--- a/libgfortran/caf/shmem/thread_support.c
+++ b/libgfortran/caf/shmem/thread_support.c
@@ -28,6 +28,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include <stdlib.h>
 #include <stdio.h>
 
+#if !defined(WIN32) && !defined(__CYGWIN__)
+#include <pthread.h>
+
 #define ERRCHECK(a)                                                            \
   do                                                                           \
     {                                                                          \
@@ -42,7 +45,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
   while (0)
 
 void
-initialize_shared_mutex (pthread_mutex_t *mutex)
+initialize_shared_mutex (caf_shmem_mutex *mutex)
 {
   pthread_mutexattr_t mattr;
   ERRCHECK (pthread_mutexattr_init (&mattr));
@@ -52,18 +55,18 @@ initialize_shared_mutex (pthread_mutex_t *mutex)
 }
 
 void
-initialize_shared_errorcheck_mutex (pthread_mutex_t *mutex)
+initialize_shared_errorcheck_mutex (caf_shmem_mutex *mutex)
 {
   pthread_mutexattr_t mattr;
   ERRCHECK (pthread_mutexattr_init (&mattr));
-  ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
   ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK));
+  ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
   ERRCHECK (pthread_mutex_init (mutex, &mattr));
   ERRCHECK (pthread_mutexattr_destroy (&mattr));
 }
 
 void
-initialize_shared_condition (pthread_cond_t *cond)
+initialize_shared_condition (caf_shmem_condvar *cond, const int)
 {
   pthread_condattr_t cattr;
   ERRCHECK (pthread_condattr_init (&cattr));
@@ -71,3 +74,302 @@ initialize_shared_condition (pthread_cond_t *cond)
   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
diff --git a/libgfortran/caf/shmem/thread_support.h b/libgfortran/caf/shmem/thread_support.h
old mode 100644
new mode 100755
index e70b4b83c7d..351cdbbb868
--- a/libgfortran/caf/shmem/thread_support.h
+++ b/libgfortran/caf/shmem/thread_support.h
@@ -25,14 +25,89 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #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 (pthread_mutex_t *);
+void initialize_shared_mutex (caf_shmem_mutex *);
 
-void initialize_shared_errorcheck_mutex (pthread_mutex_t *);
+void initialize_shared_errorcheck_mutex (caf_shmem_mutex *);
 
-void initialize_shared_condition (pthread_cond_t *);
+void initialize_shared_condition (caf_shmem_condvar *, const int size);
 
 #endif
-- 
2.51.0

From 02f8af26e3362a603b5f4f141d05e0244d3b6833 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Mon, 1 Sep 2025 14:11:27 +0200
Subject: [PATCH 7/9] Fortran: Detect working CLZL or use alternative.

libgfortran/ChangeLog:

	* Makefile.in: Regenerate.
	* acinclude.m4: Add check for sane clzl implemenation.
	* caf/shmem/allocator.c (next_power_of_two): Use sane clzl
	implementation or alternative.
	* config.h.in: Regenerate.
	* configure: Regenerate.
	* configure.ac: Call clzl check.
---
 libgfortran/Makefile.in           |  4 +-
 libgfortran/acinclude.m4          | 12 ++++++
 libgfortran/caf/shmem/allocator.c | 12 ++++++
 libgfortran/config.h.in           |  3 ++
 libgfortran/configure             | 65 ++++++++++++++++++++++++++++++-
 libgfortran/configure.ac          |  3 ++
 6 files changed, 95 insertions(+), 4 deletions(-)

diff --git a/libgfortran/caf/shmem/allocator.c b/libgfortran/caf/shmem/allocator.c
index d900167cfc2..3ea4d50e045 100644
--- a/libgfortran/caf/shmem/allocator.c
+++ b/libgfortran/caf/shmem/allocator.c
@@ -25,6 +25,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 /* 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"
@@ -74,8 +78,16 @@ allocator_init_supervisor (allocator *a, allocator_shared *s, shared_memory sm)
 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
 
-- 
2.51.0

From a87d27d1590054a54e3618b82ccb4d3c4cc7adfa Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Wed, 18 Jun 2025 09:26:22 +0200
Subject: [PATCH 6/9] Fortran: Enable coarray tests for multi image use
 [PR88076]

Change some of regression tests to run on single and multiple images.
Add some new tests.

	PR fortran/88076

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/alloc_comp_4.f90: Make multi image
	compatible.
	* gfortran.dg/coarray/atomic_2.f90: Same.
	* gfortran.dg/coarray/caf.exp: Also test caf_shmem and choose
	eight images as a default.
	* gfortran.dg/coarray/coarray_allocated.f90: Add multi image
	support.
	* gfortran.dg/coarray/coindexed_1.f90: Same.
	* gfortran.dg/coarray/coindexed_3.f08: Same.
	* gfortran.dg/coarray/coindexed_5.f90: Same.
	* gfortran.dg/coarray/dummy_3.f90: Same.
	* gfortran.dg/coarray/event_1.f90: Same.
	* gfortran.dg/coarray/event_3.f08: Same.
	* gfortran.dg/coarray/event_4.f08: Same.
	* gfortran.dg/coarray/failed_images_2.f08: Same.
	* gfortran.dg/coarray/image_status_1.f08: Same.
	* gfortran.dg/coarray/image_status_2.f08: Same.
	* gfortran.dg/coarray/lock_2.f90: Same.
	* gfortran.dg/coarray/poly_run_3.f90: Same.
	* gfortran.dg/coarray/scalar_alloc_1.f90: Same.
	* gfortran.dg/coarray/stopped_images_2.f08: Same.
	* gfortran.dg/coarray/sync_1.f90: Same.
	* gfortran.dg/coarray/sync_3.f90: Same.
	* gfortran.dg/coarray/co_reduce_string.f90: New test.
	* gfortran.dg/coarray/sync_team.f90: New test.
---
 .../gfortran.dg/coarray/alloc_comp_4.f90      |  16 ++-
 .../gfortran.dg/coarray/atomic_2.f90          |  25 ++--
 gcc/testsuite/gfortran.dg/coarray/caf.exp     |  13 +++
 .../gfortran.dg/coarray/co_reduce_string.f90  |  94 +++++++++++++++
 .../gfortran.dg/coarray/coarray_allocated.f90 |   9 +-
 .../gfortran.dg/coarray/coindexed_1.f90       |  74 +++++++++++-
 .../gfortran.dg/coarray/coindexed_3.f08       |   4 +-
 .../gfortran.dg/coarray/coindexed_5.f90       | 108 +++++++++---------
 gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 |   1 +
 gcc/testsuite/gfortran.dg/coarray/event_1.f90 |  89 ++++++++-------
 gcc/testsuite/gfortran.dg/coarray/event_3.f08 |   4 +-
 gcc/testsuite/gfortran.dg/coarray/event_4.f08 |   3 +-
 .../gfortran.dg/coarray/failed_images_2.f08   |  39 ++++++-
 .../gfortran.dg/coarray/image_status_1.f08    |   2 +-
 .../gfortran.dg/coarray/image_status_2.f08    |  32 +++++-
 gcc/testsuite/gfortran.dg/coarray/lock_2.f90  |   2 +
 .../gfortran.dg/coarray/poly_run_3.f90        |   8 +-
 .../gfortran.dg/coarray/scalar_alloc_1.f90    |  13 ++-
 .../gfortran.dg/coarray/stopped_images_2.f08  |  39 ++++++-
 gcc/testsuite/gfortran.dg/coarray/sync_1.f90  |   8 +-
 gcc/testsuite/gfortran.dg/coarray/sync_3.f90  |  26 ++++-
 .../gfortran.dg/coarray/sync_team.f90         |  33 ++++++
 22 files changed, 491 insertions(+), 151 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90
 create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_team.f90

diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90
index 2ee8ff0253d..50b4bab1603 100644
--- a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90
+++ b/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))
-  object%indices = 42
+  other = me + 1
+  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
diff --git a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90
index 5e1c4967248..7eccd7b578c 100644
--- a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/caf.exp b/gcc/testsuite/gfortran.dg/coarray/caf.exp
index c1e8e8ca2b0..1f002e08fa3 100644
--- a/gcc/testsuite/gfortran.dg/coarray/caf.exp
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 b/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90
new file mode 100644
index 00000000000..9b4c44f1ada
--- /dev/null
+++ b/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
+
diff --git a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 b/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90
index 27db0e8d8ce..ce7c6288a61 100644
--- a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90
index f90b65cb389..8f7a83a9c99 100644
--- a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
index 7fd20851e0a..145835d461b 100644
--- a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
+++ b/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
-  ! not viable nor are they (yet) supported by GFortran.
+  sync all
+  
   if (a[1, team_number=-1, stat=s] /= 42) stop 1
   if (s /= 0) stop 2
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90
index c35ec1093c1..8eb64669628 100644
--- a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90
+++ b/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
-    ! Checking against caf_single is very limitted.
-    if (cell[1, team_number=t_num] /= 32) stop 1
-    if (cell[1, team_number=st_num] /= 32) stop 2
-    if (cell[1, team=parentteam] /= 32) stop 3
+    associate(me => this_image())
+      ! for get_from_remote
+      ! Checking against caf_single is very limitted.
+      if (cell[me, team_number=t_num] /= 32) stop 1
+      if (cell[me, team_number=st_num] /= 32) stop 2
+      if (cell[me, team=parentteam] /= 32) stop 3
 
-    ! Check that team_number is validated
-    lhs = cell[1, team_number=5, stat=stat]
-    if (stat /= 1) stop 4
+      ! Check that team_number is validated
+      lhs = cell[me, team_number=5, stat=stat]
+      if (stat /= 1) stop 4
 
-    ! Check that only access to active teams is valid
-    stat = 42
-    lhs = cell[1, team=formed_team, stat=stat]
-    if (stat /= 1) stop 5
+      ! Check that only access to active teams is valid
+      stat = 42
+      lhs = cell[me, team=formed_team, stat=stat]
+      if (stat /= 1) stop 5
 
-    ! for send_to_remote
-    ! Checking against caf_single is very limitted.
-    cell[1, team_number=t_num] = 45
-    if (cell /= 45) stop 11
-    cell[1, team_number=st_num] = 46
-    if (cell /= 46) stop 12
-    cell[1, team=parentteam] = 47
-    if (cell /= 47) stop 13
+      ! for send_to_remote
+      ! Checking against caf_single is very limitted.
+      cell[me, team_number=t_num] = 45
+      if (cell /= 45) stop 11
+      cell[me, team_number=st_num] = 46
+      if (cell /= 46) stop 12
+      cell[me, team=parentteam] = 47
+      if (cell /= 47) stop 13
 
-    ! Check that team_number is validated
-    stat = -1
-    cell[1, team_number=5, stat=stat] = 0
-    if (stat /= 1) stop 14
+      ! Check that team_number is validated
+      stat = -1
+      cell[me, team_number=5, stat=stat] = 0
+      if (stat /= 1) stop 14
 
-    ! Check that only access to active teams is valid
-    stat = 42
-    cell[1, team=formed_team, stat=stat] = -1
-    if (stat /= 1) stop 15
+      ! Check that only access to active teams is valid
+      stat = 42
+      cell[me, team=formed_team, stat=stat] = -1
+      if (stat /= 1) stop 15
 
-    ! for transfer_between_remotes
-    ! Checking against caf_single is very limitted.
-    cell[1, team_number=t_num] = caf(1)[1, team_number=-1]
-    if (cell /= 23) stop 21
-    cell[1, team_number=st_num] = caf(2)[1, team_number=-1]
-    ! cell is an alias for caf(2) and has been overwritten by caf(1)!
-    if (cell /= 23) stop 22
-    cell[1, team=parentteam] = caf(1)[1, team= team]
-    if (cell /= 23) stop 23
+      ! for transfer_between_remotes
+      ! Checking against caf_single is very limitted.
+      cell[me, team_number=t_num] = caf(1)[me, team_number=-1]
+      if (cell /= 23) stop 21
+      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)!
+      if (cell /= 23) stop 22
+      cell[me, team=parentteam] = caf(1)[me, team= team]
+      if (cell /= 23) stop 23
 
-    ! Check that team_number is validated
-    stat = -1
-    cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1]
-    if (stat /= 1) stop 24
-    stat = -1
-    cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat]
-    if (stat /= 1) stop 25
+      ! Check that team_number is validated
+      stat = -1
+      cell[me, team_number=5, stat=stat] = caf(1)[me, team_number= -1]
+      if (stat /= 1) stop 24
+      stat = -1
+      cell[me, team_number=t_num] = caf(1)[me, team_number= -2, stat=stat]
+      if (stat /= 1) stop 25
 
-    ! Check that only access to active teams is valid
-    stat = 42
-    cell[1, team=formed_team, stat=stat] = caf(1)[1]
-    if (stat /= 1) stop 26
-    stat = 42
-    cell[1] = caf(1)[1, team=formed_team, stat=stat]
-    if (stat /= 1) stop 27
+      ! Check that only access to active teams is valid
+      stat = 42
+      cell[me, team=formed_team, stat=stat] = caf(1)[me]
+      if (stat /= 1) stop 26
+      stat = 42
+      cell[me] = caf(1)[me, team=formed_team, stat=stat]
+      if (stat /= 1) stop 27
+
+      sync all
+    end associate
   end team
 end program coindexed_5
diff --git a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90
index 4b45daab649..c569390e7c6 100644
--- a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 b/gcc/testsuite/gfortran.dg/coarray/event_1.f90
index 81dc90b7197..a9fecf93984 100644
--- a/gcc/testsuite/gfortran.dg/coarray/event_1.f90
+++ b/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
-call event_query (var, count)
-if (count /= 0) STOP 1
-
-stat = 99
-event post (var, stat=stat)
-if (stat /= 0) STOP 2
-call event_query(var, count, stat=stat)
-if (count /= 1 .or. stat /= 0) STOP 3
-
-stat = 99
-event post (var[this_image()])
-call event_query(var, count)
-if (count /= 2) STOP 4
-
-stat = 99
-event wait (var)
-call event_query(var, count)
-if (count /= 1) STOP 5
-
-stat = 99
-event post (var)
-call event_query(var, count)
-if (count /= 2) STOP 6
-
-stat = 99
-event post (var)
-call event_query(var, count)
-if (count /= 3) STOP 7
-
-stat = 99
-event wait (var, until_count=2)
-call event_query(var, count)
-if (count /= 1) STOP 8
-
-stat = 99
-event wait (var, stat=stat, until_count=1)
-if (stat /= 0) STOP 9
-call event_query(event=var, stat=stat, count=count)
-if (count /= 0 .or. stat /= 0) STOP 10
+associate (me => this_image(), np => num_images())
+  allocate(events(np)[*])
+
+  associate(var => events(me))
+    count = -42
+    call event_query (var, count)
+    if (count /= 0) STOP 1
+
+    stat = 99
+    event post (var, stat=stat)
+    if (stat /= 0) STOP 2
+    call event_query(var, count, stat=stat)
+    if (count /= 1 .or. stat /= 0) STOP 3
+
+    count = 99
+    event post (var[this_image()])
+    call event_query(var, count)
+    if (count /= 2) STOP 4
+
+    count = 99
+    event wait (var)
+    call event_query(var, count)
+    if (count /= 1) STOP 5
+
+    count = 99
+    event post (var)
+    call event_query(var, count)
+    if (count /= 2) STOP 6
+
+    count = 99
+    event post (var)
+    call event_query(var, count)
+    if (count /= 3) STOP 7
+
+    count = 99
+    event wait (var, until_count=2)
+    call event_query(var, count)
+    if (count /= 1) STOP 8
+   
+    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
diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08
index 60d3193f776..cedf636b79b 100644
--- a/gcc/testsuite/gfortran.dg/coarray/event_3.f08
+++ b/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[1])
+      event post(x[this_image()])
+      event post(x[this_image()])
       call event_query(x, cnt)
       if (cnt /= 2) error stop 1
       event wait(x, until_count=2)
diff --git a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 b/gcc/testsuite/gfortran.dg/coarray/event_4.f08
index de901c01aa4..26a1f59df03 100644
--- a/gcc/testsuite/gfortran.dg/coarray/event_4.f08
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08
index ca5fe4020d5..78d92daf071 100644
--- a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08
+++ b/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()
-  if (size(fi) > 0) error stop "failed_images result shall be empty array"
-  sfi = failed_images(KIND=1)
-  if (size(sfi) > 0) error stop "failed_images result shall be empty array"
-  sfi = failed_images(KIND=8)
-  if (size(sfi) > 0) error stop "failed_images result shall be empty array"
+  associate(np => num_images())
+    form team (1, t)
+    fi = failed_images()
+    if (size(fi) > 0) stop 1
+    sfi = failed_images(KIND=1)
+    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
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08
index b7ec5a6a9c9..f725f81d4aa 100644
--- a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08
+++ b/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\\)" }
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08
index fb49289cb78..8866f237481 100644
--- a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08
+++ b/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(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped."
+  if (image_status(num_images() + 1) /= STAT_STOPPED_IMAGE) error stop "Image 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
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90
index 8e96154996d..3d445b9b5e8 100644
--- a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90
+++ b/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)
diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90
index c284a566760..4da1b9569fe 100644
--- a/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90
index b0d27bdfb8f..8dd7df5d436 100644
--- a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90
+++ b/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 (a /= 45) STOP 12
+      if (.not. allocated(a)) STOP 12
+      if (a /= 45) STOP 13
+      sync all
       deallocate(a)
     end if
   end subroutine two
diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08
index 0bf4a81a7e2..dadd00ecda7 100644
--- a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08
+++ b/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()
-  if (size(si) > 0) error stop "stopped_images result shall be empty array"
-  ssi = stopped_images(KIND=1)
-  if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
-  ssi = stopped_images(KIND=8)
-  if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
+  associate(np => num_images())
+    form team (1, t)
+    si = stopped_images()
+    if (size(si) > 0) stop 1
+    ssi = stopped_images(KIND=1)
+    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
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90
index 8633c4aa527..4abe5a3b548 100644
--- a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90
index fe1e4c548c8..ceb4b19d517 100644
--- a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90
+++ b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90
@@ -9,8 +9,9 @@
 ! PR fortran/18918
 
 implicit none
-integer :: n
-character(len=30) :: str
+integer :: n, st
+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() )
-sync images (n) ! Invalid: "-1"
+st = 0
+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
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_team.f90
new file mode 100644
index 00000000000..a96884549a3
--- /dev/null
+++ b/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
-- 
2.51.0

From 7963b09b28031f2867d1854d3363d993d9a657a5 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Wed, 18 Jun 2025 09:23:32 +0200
Subject: [PATCH 4/9] Fortran: Fix signatures of coarray API and caf_single.

The teams argument to some functions was marked as unused in the header.
With upcoming caf_shmem this is incorrect, given the mark is repeated in
caf_single.

libgfortran/ChangeLog:

	* caf/libcaf.h (_gfortran_caf_failed_images): Team attribute is
	used now in some libs.
	(_gfortran_caf_image_status): Same.
	(_gfortran_caf_stopped_images): Same.
	* caf/single.c (caf_internal_error): Use correct printf function
	to handle va_list.
---
 libgfortran/caf/libcaf.h | 9 +++------
 libgfortran/caf/single.c | 2 +-
 2 files changed, 4 insertions(+), 7 deletions(-)

diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 7267bc76905..81549f9b980 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -175,12 +175,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 *,
-				  caf_team_t * __attribute__ ((unused)), int *);
-int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused)));
-void _gfortran_caf_stopped_images (gfc_descriptor_t *,
-				   caf_team_t * __attribute__ ((unused)),
-				   int *);
+void _gfortran_caf_failed_images (gfc_descriptor_t *, caf_team_t *, int *);
+int _gfortran_caf_image_status (int, caf_team_t *);
+void _gfortran_caf_stopped_images (gfc_descriptor_t *, caf_team_t *, int *);
 
 void _gfortran_caf_random_init (bool, bool);
 
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 97876fa9d8c..a6576f28260 100644
--- a/libgfortran/caf/single.c
+++ b/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);
 	}
-- 
2.51.0

From a2e97bba194aaa4a68dc5e40f105994a3dc22aee Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Wed, 18 Jun 2025 09:32:19 +0200
Subject: [PATCH 3/9] Fortran: Fix coarray generation for char arrays and
 derived types.

Fix the generation of a coarray, esp. its bounds, for char arrays.
When a scalar char array is used in a co_reduce the coarray part was
dropped.

Furthermore for class typed dummy arguments where derived types were
used as actual arguments the coarray generation is now done, too.

gcc/fortran/ChangeLog:

	* trans-expr.cc (get_scalar_to_descriptor_type): Fix coarray
	generation.
	(copy_coarray_desc_part): New function to copy coarray dimensions.
	(gfc_class_array_data_assign): Use the new function.
	(gfc_conv_derived_to_class): Same.
---
 gcc/fortran/trans-expr.cc | 68 ++++++++++++++++++++++++++++++++-------
 1 file changed, 57 insertions(+), 11 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 271d2633dfb..80b0842f35a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/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,
-				    akind, !(attr.pointer || attr.target));
+  if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
+    {
+      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);
-  tmp2 = gfc_get_descriptor_dimension (rhs_desc);
+  lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
+  rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
+
+  type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
+  lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
+			gfc_index_zero_node, NULL_TREE, NULL_TREE);
+  rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
+			gfc_index_zero_node, NULL_TREE, NULL_TREE);
+  gfc_add_modify (block, lhs_dim, rhs_dim);
 
-  type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
-  tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
-		    gfc_index_zero_node, NULL_TREE, NULL_TREE);
-  tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
-		     gfc_index_zero_node, NULL_TREE, NULL_TREE);
-  gfc_add_modify (block, tmp, tmp2);
+  /* 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),
-- 
2.51.0

From 1ceec92620113959a6e86bcdcf6101ff2096020a Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Wed, 18 Jun 2025 09:21:16 +0200
Subject: [PATCH 2/9] Fortran: Small fixes of coarray routines handling and
 code gen.

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_image_status): Fix argument index of team=
	argument for correct error message.
	* trans-intrinsic.cc (conv_intrinsic_image_status): Team=
	argument is optional and is a pointer to the team handle.
	* trans-stmt.cc (gfc_trans_sync): Make images argument also a
	dereferencable pointer.  But treat errmsg as a pointer to a
	char array like in all other functions.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray_sync_memory.f90: Adapt grep pattern for
	msg being only &msg.
---
 gcc/fortran/check.cc                              | 2 +-
 gcc/fortran/trans-intrinsic.cc                    | 6 +++++-
 gcc/fortran/trans-stmt.cc                         | 7 +++++--
 gcc/testsuite/gfortran.dg/coarray_sync_memory.f90 | 4 ++--
 4 files changed, 13 insertions(+), 6 deletions(-)

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index d63a554b29f..fae628bae40 100644
--- a/gcc/fortran/check.cc
+++ b/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));
 }
 
 
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index d1c2a80b277..46d90466f37 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/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 ();
 
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f25335d6bdb..4bfab4f20f8 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/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)
     {
diff --git a/gcc/testsuite/gfortran.dg/coarray_sync_memory.f90 b/gcc/testsuite/gfortran.dg/coarray_sync_memory.f90
index c4e660b8cf7..0030d91257d 100644
--- a/gcc/testsuite/gfortran.dg/coarray_sync_memory.f90
+++ b/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 \\(&stat, &&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" } }
-- 
2.51.0

From 4f179fa489e47641e8d67df9303b9308ad84e02e Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Fri, 25 Apr 2025 14:37:47 +0200
Subject: [PATCH 1/9] Fortran: Unify check of teams parameter in
 failed/stopped_images().

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_failed_or_stopped_images): Support teams
	argument and check for incorrect type.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/failed_images_1.f08: Adapt check of error
	message.
	* gfortran.dg/coarray/stopped_images_1.f08: Same.
---
 gcc/fortran/check.cc                                   | 9 ++-------
 gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08  | 2 +-
 gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 | 2 +-
 3 files changed, 4 insertions(+), 9 deletions(-)

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 1f170131ae1..d63a554b29f 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -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)
-    {
-      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 (team && (!scalar_check (team, 0) || !team_type_check (team, 0)))
+    return false;
 
   if (kind)
     {
diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08
index 4898dd8a7a2..34ae131d15f 100644
--- a/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08
+++ b/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" }
diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08
index 403de585b9a..7658e6bb6bb 100644
--- a/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08
+++ b/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" }
-- 
2.51.0

From 2fa2c3f6133fbb1579ce7db2d4318ee32eb31351 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Fri, 6 Feb 2026 15:01:52 +0100
Subject: [PATCH] Fortran: Ensure constant strings are send correctly to caf.

gcc/fortran/ChangeLog:

	* trans-intrinsic.cc (conv_caf_send_to_remote): Fix treating constant
	char arrays when used in coarray sends.
---
 gcc/fortran/trans-intrinsic.cc | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 41a65617b0cf..1a91f38fb0c2 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1486,7 +1486,8 @@ conv_caf_send_to_remote (gfc_code *code)
   gfc_init_se (&rhs_se, NULL);
   if (rhs_expr->rank == 0)
     {
-      rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER;
+      rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER
+			    && rhs_expr->expr_type != EXPR_CONSTANT;
       gfc_conv_expr (&rhs_se, rhs_expr);
       gfc_add_block_to_block (&block, &rhs_se.pre);
       opt_rhs_desc = null_pointer_node;
-- 
2.53.0

From 597ccd028d524c995639fb85af175d482ee01d17 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Wed, 4 Feb 2026 13:40:41 +0100
Subject: [PATCH] Fortran: Fix coarray assignment when rhs is complicated.

gcc/fortran/ChangeLog:

	* resolve.cc: Introduce temporary holding rhs when lhs is a
	coarray expresssion.
---
 gcc/fortran/resolve.cc | 29 ++++++++++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e5b36234d7e6..a7b31e14c56c 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -14247,10 +14247,33 @@ start:
 	      code->ext.actual = gfc_get_actual_arglist ();
 	      code->ext.actual->expr = code->expr1;
 	      code->ext.actual->next = gfc_get_actual_arglist ();
-	      code->ext.actual->next->expr = code->expr2;
+	      if (code->expr2->expr_type != EXPR_VARIABLE
+		  && code->expr2->expr_type != EXPR_CONSTANT)
+		{
+		  /* Convert assignments of expr1[...] = expr2 into
+			tvar = expr2
+			expr1[...] = tvar
+		     when expr2 is not trivial.  */
+		  gfc_expr *tvar = get_temp_from_expr (code->expr2, ns);
+		  gfc_code next_code = *code;
+		  gfc_code *rhs_code
+		    = build_assignment (EXEC_ASSIGN, tvar, code->expr2, NULL,
+					NULL, code->expr2->where);
+		  *code = *rhs_code;
+		  code->next = rhs_code;
+		  *rhs_code = next_code;
 
-	      code->expr1 = NULL;
-	      code->expr2 = NULL;
+		  rhs_code->ext.actual->next->expr = tvar;
+		  rhs_code->expr1 = NULL;
+		  rhs_code->expr2 = NULL;
+		}
+	      else
+		{
+		  code->ext.actual->next->expr = code->expr2;
+
+		  code->expr1 = NULL;
+		  code->expr2 = NULL;
+		}
 	      break;
 	    }
 
-- 
2.52.0

From 5325ed280446ec72aed03606ad341cde269afcc2 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Thu, 20 Nov 2025 12:52:24 +0100
Subject: [PATCH] Fortran: Sync coarray images on exit.

libgfortran/ChangeLog:

	* caf/shmem.c (_gfortran_caf_finalize): Add a sync on the
	initial team on exit.
---
 libgfortran/caf/shmem.c | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index 446e5f54483..1ef36cde1ac 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -147,6 +147,8 @@ _gfortran_caf_finalize (void)
       caf_static_list = tmp;
     }
 
+  /* Make sure to wait for all images to finish.  */
+  sync_team (caf_initial_team);
   free_team_list (caf_current_team);
   caf_initial_team = caf_current_team = NULL;
   free_team_list (caf_teams_formed);
-- 
2.51.1

diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index 63c880cddcb..9272fa86741 100644
--- a/libgfortran/Makefile.in
+++ b/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_FALSE@am__objects_2 = runtime/backtrace.lo \
+@LIBGFOR_MINIMAL_TRUE@am__objects_2 = runtime/minimal.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)
-am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \
+	runtime/select.lo $(am__objects_2) $(am__objects_3)
+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)
-@LIBGFOR_MINIMAL_FALSE@am__objects_10 = intrinsics/access.lo \
+am__objects_10 = io/size_from_kind.lo $(am__objects_9)
+@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
-am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \
+@IEEE_SUPPORT_TRUE@am__objects_12 = ieee/ieee_helper.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)
-@IEEE_SUPPORT_TRUE@am__objects_13 = ieee/ieee_arithmetic.lo \
+	runtime/in_unpack_class.lo $(am__objects_11) $(am__objects_12)
+@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 = generated/_abs_c4.lo generated/_abs_c8.lo \
+am__objects_15 =
+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__objects_9) $(am__objects_12) $(am__objects_13) \
-	$(am__objects_14) $(am__objects_15)
+am_libgfortran_la_OBJECTS = $(am__objects_4) $(am__objects_8) \
+	$(am__objects_10) $(am__objects_13) $(am__objects_14) \
+	$(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
diff --git a/libgfortran/config.h.in b/libgfortran/config.h.in
index da2c44c1af1..1a66ee7e513 100644
--- a/libgfortran/config.h.in
+++ b/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
 
diff --git a/libgfortran/configure b/libgfortran/configure
index 38d6c3cf3a0..6227e5bee74 100755
--- a/libgfortran/configure
+++ b/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"
@@ -13236,7 +13241,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 13239 "configure"
+#line 13244 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -13342,7 +13347,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 13345 "configure"
+#line 13350 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -17127,6 +17132,8 @@ done
 
 
 
+
+
 
 
 
@@ -17728,6 +17735,10 @@ done
 
 
 
+
+
+
+
 
 
 
@@ -31827,6 +31838,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"
@@ -32118,6 +32180,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
diff --git a/libgfortran/configure.ac b/libgfortran/configure.ac
index cca1ea0ea97..b165dff1e05 100644
--- a/libgfortran/configure.ac
+++ b/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