gcc-7.3.0HEADgcc-7.3.0master

3 files changed, 3729 insertions, 0 deletions

diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
new file mode 100644
index 0000000000..24726462e8
--- /dev/null
+++ b/libgfortran/caf/libcaf.h
@@ -0,0 +1,263 @@
+/* Common declarations for all of GNU Fortran libcaf implementations.
+   Copyright (C) 2011-2017 Free Software Foundation, Inc.
+   Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
+
+Libcaf is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libcaf is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef LIBCAF_H
+#define LIBCAF_H
+
+#include <stdbool.h>
+#include <stddef.h>	/* For size_t.  */
+#include <stdint.h>	/* For int32_t.  */
+
+#include "libgfortran.h"
+
+#if 0
+#ifndef __GNUC__
+#define __attribute__(x)
+#define likely(x)       (x)
+#define unlikely(x)     (x)
+#else
+#define likely(x)       __builtin_expect(!!(x), 1)
+#define unlikely(x)     __builtin_expect(!!(x), 0)
+#endif
+#endif
+
+/* Definitions of the Fortran 2008 standard; need to kept in sync with
+   ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h.  */
+typedef enum
+{
+  CAF_STAT_UNLOCKED = 0,
+  CAF_STAT_LOCKED,
+  CAF_STAT_LOCKED_OTHER_IMAGE,
+  CAF_STAT_STOPPED_IMAGE = 6000,
+  CAF_STAT_FAILED_IMAGE  = 6001
+}
+caf_stat_codes_t;
+
+
+/* Describes what type of array we are registerring.  Keep in sync with
+   gcc/fortran/trans.h.  */
+typedef enum caf_register_t {
+  CAF_REGTYPE_COARRAY_STATIC,
+  CAF_REGTYPE_COARRAY_ALLOC,
+  CAF_REGTYPE_LOCK_STATIC,
+  CAF_REGTYPE_LOCK_ALLOC,
+  CAF_REGTYPE_CRITICAL,
+  CAF_REGTYPE_EVENT_STATIC,
+  CAF_REGTYPE_EVENT_ALLOC,
+  CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY,
+  CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
+}
+caf_register_t;
+
+/* Describes the action to take on _caf_deregister.  Keep in sync with
+   gcc/fortran/trans.h.  */
+typedef enum caf_deregister_t {
+  CAF_DEREGTYPE_COARRAY_DEREGISTER,
+  CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY
+}
+caf_deregister_t;
+
+typedef void* caf_token_t;
+typedef void * caf_team_t;
+typedef gfc_array_void gfc_descriptor_t;
+
+/* Linked list of static coarrays registered.  */
+typedef struct caf_static_t {
+  caf_token_t token;
+  struct caf_static_t *prev;
+}
+caf_static_t;
+
+/* When there is a vector subscript in this dimension, nvec == 0, otherwise,
+   lower_bound, upper_bound, stride contains the bounds relative to the declared
+   bounds; kind denotes the integer kind of the elements of vector[].  */
+typedef struct caf_vector_t {
+  size_t nvec;
+  union {
+    struct {
+      void *vector;
+      int kind;
+    } v;
+    struct {
+      ptrdiff_t lower_bound, upper_bound, stride;
+    } triplet;
+  } u;
+}
+caf_vector_t;
+
+typedef enum caf_ref_type_t {
+  /* Reference a component of a derived type, either regular one or an
+     allocatable or pointer type.  For regular ones idx in caf_reference_t is
+     set to -1.  */
+  CAF_REF_COMPONENT,
+  /* Reference an allocatable array.  */
+  CAF_REF_ARRAY,
+  /* Reference a non-allocatable/non-pointer array.  */
+  CAF_REF_STATIC_ARRAY
+} caf_ref_type_t;
+
+typedef enum caf_array_ref_t {
+  /* No array ref.  This terminates the array ref.  */
+  CAF_ARR_REF_NONE = 0,
+  /* Reference array elements given by a vector.  Only for this mode
+     caf_reference_t.u.a.dim[i].v is valid.  */
+  CAF_ARR_REF_VECTOR,
+  /* A full array ref (:).  */
+  CAF_ARR_REF_FULL,
+  /* Reference a range on elements given by start, end and stride.  */
+  CAF_ARR_REF_RANGE,
+  /* Only a single item is referenced given in the start member.  */
+  CAF_ARR_REF_SINGLE,
+  /* An array ref of the kind (i:), where i is an arbitrary valid index in the
+     array.  The index i is given in the start member.  */
+  CAF_ARR_REF_OPEN_END,
+  /* An array ref of the kind (:i), where the lower bound of the array ref
+     is given by the remote side.  The index i is given in the end member.  */
+  CAF_ARR_REF_OPEN_START
+} caf_array_ref_t;
+
+/* References to remote components of a derived type.  */
+typedef struct caf_reference_t {
+  /* A pointer to the next ref or NULL.  */
+  struct caf_reference_t *next;
+  /* The type of the reference.  */
+  /* caf_ref_type_t, replaced by int to allow specification in fortran FE.  */
+  int type;
+  /* The size of an item referenced in bytes.  I.e. in an array ref this is
+     the factor to advance the array pointer with to get to the next item.
+     For component refs this gives just the size of the element referenced.  */
+  size_t item_size;
+  union {
+    struct {
+      /* The offset (in bytes) of the component in the derived type.  */
+      ptrdiff_t offset;
+      /* The offset (in bytes) to the caf_token associated with this
+	 component.  NULL, when not allocatable/pointer ref.  */
+      ptrdiff_t caf_token_offset;
+    } c;
+    struct {
+      /* The mode of the array ref.  See CAF_ARR_REF_*.  */
+      /* caf_array_ref_t, replaced by unsigend char to allow specification in
+	 fortran FE.  */
+      unsigned char mode[GFC_MAX_DIMENSIONS];
+      /* The type of a static array.  Unset for array's with descriptors.  */
+      int static_array_type;
+      /* Subscript refs (s) or vector refs (v).  */
+      union {
+	struct {
+	  /* The start and end boundary of the ref and the stride.  */
+	  index_type start, end, stride;
+	} s;
+	struct {
+	  /* nvec entries of kind giving the elements to reference.  */
+	  void *vector;
+	  /* The number of entries in vector.  */
+	  size_t nvec;
+	  /* The integer kind used for the elements in vector.  */
+	  int kind;
+	} v;
+      } dim[GFC_MAX_DIMENSIONS];
+    } a;
+  } u;
+} caf_reference_t;
+
+void _gfortran_caf_init (int *, char ***);
+void _gfortran_caf_finalize (void);
+
+int _gfortran_caf_this_image (int);
+int _gfortran_caf_num_images (int, int);
+
+void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *,
+			     gfc_descriptor_t *, int *, char *, int);
+void _gfortran_caf_deregister (caf_token_t *, caf_deregister_t, int *, char *,
+			       int);
+
+void _gfortran_caf_sync_all (int *, char *, int);
+void _gfortran_caf_sync_memory (int *, char *, int);
+void _gfortran_caf_sync_images (int, int[], int *, char *, int);
+
+void _gfortran_caf_stop_numeric (int32_t)
+     __attribute__ ((noreturn));
+void _gfortran_caf_stop_str (const char *, int32_t)
+     __attribute__ ((noreturn));
+void _gfortran_caf_error_stop_str (const char *, int32_t)
+     __attribute__ ((noreturn));
+void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
+void _gfortran_caf_fail_image (void) __attribute__ ((noreturn));
+
+void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, int);
+void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, int);
+void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *, int, int);
+void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, int);
+void _gfortran_caf_co_reduce (gfc_descriptor_t *, void* (*) (void *, void*),
+			      int, int, int *, char *, int, int);
+
+void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *,
+			caf_vector_t *, gfc_descriptor_t *, int, int, bool,
+			int *);
+void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *,
+			 caf_vector_t *, gfc_descriptor_t *, int, int, bool,
+			 int *);
+void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *,
+			    caf_vector_t *, caf_token_t, size_t, int,
+			    gfc_descriptor_t *, caf_vector_t *, int, int, bool);
+
+void _gfortran_caf_get_by_ref (caf_token_t token, int image_idx,
+	gfc_descriptor_t *dst, caf_reference_t *refs, int dst_kind,
+	int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat);
+void _gfortran_caf_send_by_ref (caf_token_t token, int image_index,
+	gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind,
+	int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat);
+void _gfortran_caf_sendget_by_ref (
+	caf_token_t dst_token, int dst_image_index, caf_reference_t *dst_refs,
+	caf_token_t src_token, int src_image_index, caf_reference_t *src_refs,
+	int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat,
+	int *src_stat);
+
+void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *,
+				  int, int);
+void _gfortran_caf_atomic_ref (caf_token_t, size_t, int, void *, int *,
+			       int, int);
+void _gfortran_caf_atomic_cas (caf_token_t, size_t, int, void *, void *,
+			       void *, int *, int, int);
+void _gfortran_caf_atomic_op (int, caf_token_t, size_t, int, void *, void *,
+			      int *, int, int);
+
+void _gfortran_caf_lock (caf_token_t, size_t, int, int *, int *, char *, int);
+void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int);
+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 *);
+
+int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *);
+
+#endif  /* LIBCAF_H  */
diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c
new file mode 100644
index 0000000000..ec65725c4f
--- /dev/null
+++ b/libgfortran/caf/mpi.c
@@ -0,0 +1,379 @@
+/* MPI implementation of GNU Fortran Coarray Library
+   Copyright (C) 2011-2017 Free Software Foundation, Inc.
+   Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
+
+Libcaf is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libcaf is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libcaf.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>	/* For memcpy.  */
+#include <stdarg.h>	/* For variadic arguments.  */
+#include <mpi.h>
+
+
+/* Define GFC_CAF_CHECK to enable run-time checking.  */
+/* #define GFC_CAF_CHECK  1  */
+
+typedef void ** mpi_token_t;
+#define TOKEN(X) ((mpi_token_t) (X))
+
+static void error_stop (int error) __attribute__ ((noreturn));
+
+/* Global variables.  */
+static int caf_mpi_initialized;
+static int caf_this_image;
+static int caf_num_images;
+static int caf_is_finalized;
+
+caf_static_t *caf_static_list = NULL;
+
+
+/* Keep in sync with single.c.  */
+static void
+caf_runtime_error (const char *message, ...)
+{
+  va_list ap;
+  fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image);
+  va_start (ap, message);
+  vfprintf (stderr, message, ap);
+  va_end (ap);
+  fprintf (stderr, "\n");
+
+  /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
+  /* FIXME: Do some more effort than just MPI_ABORT.  */
+  MPI_Abort (MPI_COMM_WORLD, EXIT_FAILURE);
+
+  /* Should be unreachable, but to make sure also call exit.  */
+  exit (EXIT_FAILURE);
+}
+
+
+/* Initialize coarray program.  This routine assumes that no other
+   MPI initialization happened before; otherwise MPI_Initialized
+   had to be used.  As the MPI library might modify the command-line
+   arguments, the routine should be called before the run-time
+   libaray is initialized.  */
+
+void
+_gfortran_caf_init (int *argc, char ***argv)
+{
+  if (caf_num_images == 0)
+    {
+      /* caf_mpi_initialized is only true if the main program is
+       not written in Fortran.  */
+      MPI_Initialized (&caf_mpi_initialized);
+      if (!caf_mpi_initialized)
+	MPI_Init (argc, argv);
+
+      MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
+      MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
+      caf_this_image++;
+    }
+}
+
+
+/* Finalize coarray program.   */
+
+void
+_gfortran_caf_finalize (void)
+{
+  while (caf_static_list != NULL)
+    {
+      caf_static_t *tmp = caf_static_list->prev;
+
+      free (TOKEN (caf_static_list->token)[caf_this_image-1]);
+      free (TOKEN (caf_static_list->token));
+      free (caf_static_list);
+      caf_static_list = tmp;
+    }
+
+  if (!caf_mpi_initialized)
+    MPI_Finalize ();
+
+  caf_is_finalized = 1;
+}
+
+
+int
+_gfortran_caf_this_image (int distance __attribute__ ((unused)))
+{
+  return caf_this_image;
+}
+
+
+int
+_gfortran_caf_num_images (int distance __attribute__ ((unused)),
+			  int failed __attribute__ ((unused)))
+{
+  return caf_num_images;
+}
+
+
+void *
+_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
+			int *stat, char *errmsg, int errmsg_len,
+			int num_alloc_comps __attribute__ ((unused)))
+{
+  void *local;
+  int err;
+
+  if (unlikely (caf_is_finalized))
+    goto error;
+
+  /* Start MPI if not already started.  */
+  if (caf_num_images == 0)
+    _gfortran_caf_init (NULL, NULL);
+
+  /* Token contains only a list of pointers.  */
+  local = malloc (size);
+  *token = malloc (sizeof (mpi_token_t) * caf_num_images);
+
+  if (unlikely (local == NULL || *token == NULL))
+    goto error;
+
+  /* token[img-1] is the address of the token in image "img".  */
+  err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, TOKEN (*token),
+		       sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
+
+  if (unlikely (err))
+    {
+      free (local);
+      free (*token);
+      goto error;
+    }
+
+  if (type == CAF_REGTYPE_COARRAY_STATIC)
+    {
+      caf_static_t *tmp = malloc (sizeof (caf_static_t));
+      tmp->prev  = caf_static_list;
+      tmp->token = *token;
+      caf_static_list = tmp;
+    }
+
+  if (stat)
+    *stat = 0;
+
+  return local;
+
+error:
+  {
+    char *msg;
+
+    if (caf_is_finalized)
+      msg = "Failed to allocate coarray - there are stopped images";
+    else
+      msg = "Failed to allocate coarray";
+
+    if (stat)
+      {
+	*stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
+	if (errmsg_len > 0)
+	  {
+	    int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
+							: (int) strlen (msg);
+	    memcpy (errmsg, msg, len);
+	    if (errmsg_len > len)
+	      memset (&errmsg[len], ' ', errmsg_len-len);
+	  }
+      }
+    else
+      caf_runtime_error (msg);
+  }
+
+  return NULL;
+}
+
+
+void
+_gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, int errmsg_len)
+{
+  if (unlikely (caf_is_finalized))
+    {
+      const char msg[] = "Failed to deallocate coarray - "
+			  "there are stopped images";
+      if (stat)
+	{
+	  *stat = STAT_STOPPED_IMAGE;
+	
+	  if (errmsg_len > 0)
+	    {
+	      int len = ((int) sizeof (msg) - 1 > errmsg_len)
+			? errmsg_len : (int) sizeof (msg) - 1;
+	      memcpy (errmsg, msg, len);
+	      if (errmsg_len > len)
+		memset (&errmsg[len], ' ', errmsg_len-len);
+	    }
+	  return;
+	}
+      caf_runtime_error (msg);
+    }
+
+  _gfortran_caf_sync_all (NULL, NULL, 0);
+
+  if (stat)
+    *stat = 0;
+
+  free (TOKEN (*token)[caf_this_image-1]);
+  free (*token);
+}
+
+
+void
+_gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
+{
+  int ierr;
+
+  if (unlikely (caf_is_finalized))
+    ierr = STAT_STOPPED_IMAGE;
+  else
+    ierr = MPI_Barrier (MPI_COMM_WORLD);
+ 
+  if (stat)
+    *stat = ierr;
+
+  if (ierr)
+    {
+      char *msg;
+      if (caf_is_finalized)
+	msg = "SYNC ALL failed - there are stopped images";
+      else
+	msg = "SYNC ALL failed";
+
+      if (errmsg_len > 0)
+	{
+	  int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
+						      : (int) strlen (msg);
+	  memcpy (errmsg, msg, len);
+	  if (errmsg_len > len)
+	    memset (&errmsg[len], ' ', errmsg_len-len);
+	}
+      else
+	caf_runtime_error (msg);
+    }
+}
+
+
+/* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
+   SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
+   is not equivalent to SYNC ALL. */
+void
+_gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
+			   int errmsg_len)
+{
+  int ierr;
+  if (count == 0 || (count == 1 && images[0] == caf_this_image))
+    {
+      if (stat)
+	*stat = 0;
+      return;
+    }
+
+#ifdef GFC_CAF_CHECK
+  {
+    int i;
+
+    for (i = 0; i < count; i++)
+      if (images[i] < 1 || images[i] > caf_num_images)
+	{
+	  fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
+		   "IMAGES", images[i]);
+	  error_stop (1);
+	}
+  }
+#endif
+
+  /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
+     mapped to MPI communicators. Thus, exist early with an error message.  */
+  if (count > 0)
+    {
+      fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
+      error_stop (1);
+    }
+
+  /* Handle SYNC IMAGES(*).  */
+  if (unlikely (caf_is_finalized))
+    ierr = STAT_STOPPED_IMAGE;
+  else
+    ierr = MPI_Barrier (MPI_COMM_WORLD);
+
+  if (stat)
+    *stat = ierr;
+
+  if (ierr)
+    {
+      char *msg;
+      if (caf_is_finalized)
+	msg = "SYNC IMAGES failed - there are stopped images";
+      else
+	msg = "SYNC IMAGES failed";
+
+      if (errmsg_len > 0)
+	{
+	  int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
+						      : (int) strlen (msg);
+	  memcpy (errmsg, msg, len);
+	  if (errmsg_len > len)
+	    memset (&errmsg[len], ' ', errmsg_len-len);
+	}
+      else
+	caf_runtime_error (msg);
+    }
+}
+
+
+/* ERROR STOP the other images.  */
+
+static void
+error_stop (int error)
+{
+  /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
+  /* FIXME: Do some more effort than just MPI_ABORT.  */
+  MPI_Abort (MPI_COMM_WORLD, error);
+
+  /* Should be unreachable, but to make sure also call exit.  */
+  exit (error);
+}
+
+
+/* ERROR STOP function for string arguments.  */
+
+void
+_gfortran_caf_error_stop_str (const char *string, int32_t len)
+{
+  fputs ("ERROR STOP ", stderr);
+  while (len--)
+    fputc (*(string++), stderr);
+  fputs ("\n", stderr);
+
+  error_stop (1);
+}
+
+
+/* ERROR STOP function for numerical arguments.  */
+
+void
+_gfortran_caf_error_stop (int32_t error)
+{
+  fprintf (stderr, "ERROR STOP %d\n", error);
+  error_stop (error);
+}
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
new file mode 100644
index 0000000000..bf1a229975
--- /dev/null
+++ b/libgfortran/caf/single.c
@@ -0,0 +1,3087 @@
+/* Single-image implementation of GNU Fortran Coarray Library
+   Copyright (C) 2011-2017 Free Software Foundation, Inc.
+   Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
+
+Libcaf is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libcaf is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libcaf.h"
+#include <stdio.h>  /* For fputs and fprintf.  */
+#include <stdlib.h> /* For exit and malloc.  */
+#include <string.h> /* For memcpy and memset.  */
+#include <stdarg.h> /* For variadic arguments.  */
+#include <assert.h>
+
+/* Define GFC_CAF_CHECK to enable run-time checking.  */
+/* #define GFC_CAF_CHECK  1  */
+
+struct caf_single_token
+{
+  /* The pointer to the memory registered.  For arrays this is the data member
+     in the descriptor.  For components it's the pure data pointer.  */
+  void *memptr;
+  /* The descriptor when this token is associated to an allocatable array.  */
+  gfc_descriptor_t *desc;
+  /* Set when the caf lib has allocated the memory in memptr and is responsible
+     for freeing it on deregister.  */
+  bool owning_memory;
+};
+typedef struct caf_single_token *caf_single_token_t;
+
+#define TOKEN(X) ((caf_single_token_t) (X))
+#define MEMTOK(X) ((caf_single_token_t) (X))->memptr
+
+/* Single-image implementation of the CAF library.
+   Note: For performance reasons -fcoarry=single should be used
+   rather than this library.  */
+
+/* Global variables.  */
+caf_static_t *caf_static_list = NULL;
+
+/* Keep in sync with mpi.c.  */
+static void
+caf_runtime_error (const char *message, ...)
+{
+  va_list ap;
+  fprintf (stderr, "Fortran runtime error: ");
+  va_start (ap, message);
+  vfprintf (stderr, message, ap);
+  va_end (ap);
+  fprintf (stderr, "\n");
+
+  /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
+  exit (EXIT_FAILURE);
+}
+
+/* Error handling is similar everytime.  */
+static void
+caf_internal_error (const char *msg, int *stat, char *errmsg,
+		    int errmsg_len, ...)
+{
+  va_list args;
+  va_start (args, errmsg_len);
+  if (stat)
+    {
+      *stat = 1;
+      if (errmsg_len > 0)
+	{
+	  size_t len = snprintf (errmsg, errmsg_len, msg, args);
+	  if ((size_t)errmsg_len > len)
+	    memset (&errmsg[len], ' ', errmsg_len - len);
+	}
+      va_end (args);
+      return;
+    }
+  else
+    caf_runtime_error (msg, args);
+  va_end (args);
+}
+
+
+void
+_gfortran_caf_init (int *argc __attribute__ ((unused)),
+		    char ***argv __attribute__ ((unused)))
+{
+}
+
+
+void
+_gfortran_caf_finalize (void)
+{
+  while (caf_static_list != NULL)
+    {
+      caf_static_t *tmp = caf_static_list->prev;
+      free (caf_static_list->token);
+      free (caf_static_list);
+      caf_static_list = tmp;
+    }
+}
+
+
+int
+_gfortran_caf_this_image (int distance __attribute__ ((unused)))
+{
+  return 1;
+}
+
+
+int
+_gfortran_caf_num_images (int distance __attribute__ ((unused)),
+			  int failed __attribute__ ((unused)))
+{
+  return 1;
+}
+
+
+void
+_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
+			gfc_descriptor_t *data, int *stat, char *errmsg,
+			int errmsg_len)
+{
+  const char alloc_fail_msg[] = "Failed to allocate coarray";
+  void *local;
+  caf_single_token_t single_token;
+
+  if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
+      || type == CAF_REGTYPE_CRITICAL)
+    local = calloc (size, sizeof (bool));
+  else if (type == CAF_REGTYPE_EVENT_STATIC || type == CAF_REGTYPE_EVENT_ALLOC)
+    /* In the event_(wait|post) function the counter for events is a uint32,
+       so better allocate enough memory here.  */
+    local = calloc (size, sizeof (uint32_t));
+  else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
+    local = NULL;
+  else
+    local = malloc (size);
+
+  if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
+    *token = malloc (sizeof (struct caf_single_token));
+
+  if (unlikely (*token == NULL
+		|| (local == NULL
+		    && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
+    {
+      /* Freeing the memory conditionally seems pointless, but
+	 caf_internal_error () may return, when a stat is given and then the
+	 memory may be lost.  */
+      if (local)
+	free (local);
+      if (*token)
+	free (*token);
+      caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
+      return;
+    }
+
+  single_token = TOKEN (*token);
+  single_token->memptr = local;
+  single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
+  single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
+
+
+  if (stat)
+    *stat = 0;
+
+  if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
+      || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
+      || type == CAF_REGTYPE_EVENT_ALLOC)
+    {
+      caf_static_t *tmp = malloc (sizeof (caf_static_t));
+      tmp->prev  = caf_static_list;
+      tmp->token = *token;
+      caf_static_list = tmp;
+    }
+  GFC_DESCRIPTOR_DATA (data) = local;
+}
+
+
+void
+_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
+			  char *errmsg __attribute__ ((unused)),
+			  int errmsg_len __attribute__ ((unused)))
+{
+  caf_single_token_t single_token = TOKEN (*token);
+
+  if (single_token->owning_memory && single_token->memptr)
+    free (single_token->memptr);
+
+  if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+    {
+      free (TOKEN (*token));
+      *token = NULL;
+    }
+  else
+    {
+      single_token->memptr = NULL;
+      single_token->owning_memory = false;
+    }
+
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+_gfortran_caf_sync_all (int *stat,
+			char *errmsg __attribute__ ((unused)),
+			int errmsg_len __attribute__ ((unused)))
+{
+  __asm__ __volatile__ ("":::"memory");
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+_gfortran_caf_sync_memory (int *stat,
+			   char *errmsg __attribute__ ((unused)),
+			   int errmsg_len __attribute__ ((unused)))
+{
+  __asm__ __volatile__ ("":::"memory");
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+_gfortran_caf_sync_images (int count __attribute__ ((unused)),
+			   int images[] __attribute__ ((unused)),
+			   int *stat,
+			   char *errmsg __attribute__ ((unused)),
+			   int errmsg_len __attribute__ ((unused)))
+{
+#ifdef GFC_CAF_CHECK
+  int i;
+
+  for (i = 0; i < count; i++)
+    if (images[i] != 1)
+      {
+	fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
+		 "IMAGES", images[i]);
+	exit (EXIT_FAILURE);
+      }
+#endif
+
+  __asm__ __volatile__ ("":::"memory");
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+_gfortran_caf_stop_numeric(int32_t stop_code)
+{
+  fprintf (stderr, "STOP %d\n", stop_code);
+  exit (0);
+}
+
+
+void
+_gfortran_caf_stop_str(const char *string, int32_t len)
+{
+  fputs ("STOP ", stderr);
+  while (len--)
+    fputc (*(string++), stderr);
+  fputs ("\n", stderr);
+
+  exit (0);
+}
+
+
+void
+_gfortran_caf_error_stop_str (const char *string, int32_t len)
+{
+  fputs ("ERROR STOP ", stderr);
+  while (len--)
+    fputc (*(string++), stderr);
+  fputs ("\n", stderr);
+
+  exit (1);
+}
+
+
+/* Reported that the program terminated because of a fail image issued.
+   Because this is a single image library, nothing else than aborting the whole
+   program can be done.  */
+
+void _gfortran_caf_fail_image (void)
+{
+  fputs ("IMAGE FAILED!\n", stderr);
+  exit (0);
+}
+
+
+/* Get the status of image IMAGE.  Because being the single image library all
+   other images are reported to be stopped.  */
+
+int _gfortran_caf_image_status (int image,
+				caf_team_t * team __attribute__ ((unused)))
+{
+  if (image == 1)
+    return 0;
+  else
+    return CAF_STAT_STOPPED_IMAGE;
+}
+
+
+/* Single image library.  There can not be any failed images with only one
+   image.  */
+
+void
+_gfortran_caf_failed_images (gfc_descriptor_t *array,
+			     caf_team_t * team __attribute__ ((unused)),
+			     int * kind)
+{
+  int local_kind = kind != NULL ? *kind : 4;
+
+  array->base_addr = NULL;
+  array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
+		  | (local_kind << GFC_DTYPE_SIZE_SHIFT));
+   /* Setting lower_bound higher then upper_bound is what the compiler does to
+      indicate an empty array.  */
+  array->dim[0].lower_bound = 0;
+  array->dim[0]._ubound = -1;
+  array->dim[0]._stride = 1;
+  array->offset = 0;
+}
+
+
+/* With only one image available no other images can be stopped.  Therefore
+   return an empty array.  */
+
+void
+_gfortran_caf_stopped_images (gfc_descriptor_t *array,
+			      caf_team_t * team __attribute__ ((unused)),
+			      int * kind)
+{
+  int local_kind = kind != NULL ? *kind : 4;
+
+  array->base_addr = NULL;
+  array->dtype =  ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
+		   | (local_kind << GFC_DTYPE_SIZE_SHIFT));
+  /* Setting lower_bound higher then upper_bound is what the compiler does to
+     indicate an empty array.  */
+  array->dim[0].lower_bound = 0;
+  array->dim[0]._ubound = -1;
+  array->dim[0]._stride = 1;
+  array->offset = 0;
+}
+
+
+void
+_gfortran_caf_error_stop (int32_t error)
+{
+  fprintf (stderr, "ERROR STOP %d\n", error);
+  exit (error);
+}
+
+
+void
+_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
+			    int source_image __attribute__ ((unused)),
+			    int *stat, char *errmsg __attribute__ ((unused)),
+			    int errmsg_len __attribute__ ((unused)))
+{
+  if (stat)
+    *stat = 0;
+}
+
+void
+_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
+		      int result_image __attribute__ ((unused)),
+		      int *stat, char *errmsg __attribute__ ((unused)),
+		      int errmsg_len __attribute__ ((unused)))
+{
+  if (stat)
+    *stat = 0;
+}
+
+void
+_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
+		      int result_image __attribute__ ((unused)),
+		      int *stat, char *errmsg __attribute__ ((unused)),
+		      int a_len __attribute__ ((unused)),
+		      int errmsg_len __attribute__ ((unused)))
+{
+  if (stat)
+    *stat = 0;
+}
+
+void
+_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
+		      int result_image __attribute__ ((unused)),
+		      int *stat, char *errmsg __attribute__ ((unused)),
+		      int a_len __attribute__ ((unused)),
+		      int errmsg_len __attribute__ ((unused)))
+{
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+_gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
+                        void * (*opr) (void *, void *)
+                               __attribute__ ((unused)),
+                        int opr_flags __attribute__ ((unused)),
+                        int result_image __attribute__ ((unused)),
+                        int *stat, char *errmsg __attribute__ ((unused)),
+                        int a_len __attribute__ ((unused)),
+                        int errmsg_len __attribute__ ((unused)))
+ {
+   if (stat)
+     *stat = 0;
+ }
+
+
+static void
+assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
+			 unsigned char *src)
+{
+  size_t i, n;
+  n = dst_size/4 > src_size ? src_size : dst_size/4;
+  for (i = 0; i < n; ++i)
+    dst[i] = (int32_t) src[i];
+  for (; i < dst_size/4; ++i)
+    dst[i] = (int32_t) ' ';
+}
+
+
+static void
+assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
+			 uint32_t *src)
+{
+  size_t i, n;
+  n = dst_size > src_size/4 ? src_size/4 : dst_size;
+  for (i = 0; i < n; ++i)
+    dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
+  if (dst_size > n)
+    memset (&dst[n], ' ', dst_size - n);
+}
+
+
+static void
+convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
+	      int src_kind, int *stat)
+{
+#ifdef HAVE_GFC_INTEGER_16
+  typedef __int128 int128t;
+#else
+  typedef int64_t int128t;
+#endif
+
+#if defined(GFC_REAL_16_IS_LONG_DOUBLE)
+  typedef long double real128t;
+  typedef _Complex long double complex128t;
+#elif defined(HAVE_GFC_REAL_16)
+  typedef _Complex float __attribute__((mode(TC))) __complex128;
+  typedef __float128 real128t;
+  typedef __complex128 complex128t;
+#elif defined(HAVE_GFC_REAL_10)
+  typedef long double real128t;
+  typedef long double complex128t;
+#else
+  typedef double real128t;
+  typedef _Complex double complex128t;
+#endif
+
+  int128t int_val = 0;
+  real128t real_val = 0;
+  complex128t cmpx_val = 0;
+
+  switch (src_type)
+    {
+    case BT_INTEGER:
+      if (src_kind == 1)
+	int_val = *(int8_t*) src;
+      else if (src_kind == 2)
+	int_val = *(int16_t*) src;
+      else if (src_kind == 4)
+	int_val = *(int32_t*) src;
+      else if (src_kind == 8)
+	int_val = *(int64_t*) src;
+#ifdef HAVE_GFC_INTEGER_16
+      else if (src_kind == 16)
+	int_val = *(int128t*) src;
+#endif
+      else
+	goto error;
+      break;
+    case BT_REAL:
+      if (src_kind == 4)
+	real_val = *(float*) src;
+      else if (src_kind == 8)
+	real_val = *(double*) src;
+#ifdef HAVE_GFC_REAL_10
+      else if (src_kind == 10)
+	real_val = *(long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+      else if (src_kind == 16)
+	real_val = *(real128t*) src;
+#endif
+      else
+	goto error;
+      break;
+    case BT_COMPLEX:
+      if (src_kind == 4)
+	cmpx_val = *(_Complex float*) src;
+      else if (src_kind == 8)
+	cmpx_val = *(_Complex double*) src;
+#ifdef HAVE_GFC_REAL_10
+      else if (src_kind == 10)
+	cmpx_val = *(_Complex long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+      else if (src_kind == 16)
+	cmpx_val = *(complex128t*) src;
+#endif
+      else
+	goto error;
+      break;
+    default:
+      goto error;
+    }
+
+  switch (dst_type)
+    {
+    case BT_INTEGER:
+      if (src_type == BT_INTEGER)
+	{
+	  if (dst_kind == 1)
+	    *(int8_t*) dst = (int8_t) int_val;
+	  else if (dst_kind == 2)
+	    *(int16_t*) dst = (int16_t) int_val;
+	  else if (dst_kind == 4)
+	    *(int32_t*) dst = (int32_t) int_val;
+	  else if (dst_kind == 8)
+	    *(int64_t*) dst = (int64_t) int_val;
+#ifdef HAVE_GFC_INTEGER_16
+	  else if (dst_kind == 16)
+	    *(int128t*) dst = (int128t) int_val;
+#endif
+	  else
+	    goto error;
+	}
+      else if (src_type == BT_REAL)
+	{
+	  if (dst_kind == 1)
+	    *(int8_t*) dst = (int8_t) real_val;
+	  else if (dst_kind == 2)
+	    *(int16_t*) dst = (int16_t) real_val;
+	  else if (dst_kind == 4)
+	    *(int32_t*) dst = (int32_t) real_val;
+	  else if (dst_kind == 8)
+	    *(int64_t*) dst = (int64_t) real_val;
+#ifdef HAVE_GFC_INTEGER_16
+	  else if (dst_kind == 16)
+	    *(int128t*) dst = (int128t) real_val;
+#endif
+	  else
+	    goto error;
+	}
+      else if (src_type == BT_COMPLEX)
+	{
+	  if (dst_kind == 1)
+	    *(int8_t*) dst = (int8_t) cmpx_val;
+	  else if (dst_kind == 2)
+	    *(int16_t*) dst = (int16_t) cmpx_val;
+	  else if (dst_kind == 4)
+	    *(int32_t*) dst = (int32_t) cmpx_val;
+	  else if (dst_kind == 8)
+	    *(int64_t*) dst = (int64_t) cmpx_val;
+#ifdef HAVE_GFC_INTEGER_16
+	  else if (dst_kind == 16)
+	    *(int128t*) dst = (int128t) cmpx_val;
+#endif
+	  else
+	    goto error;
+	}
+      else
+	goto error;
+      return;
+    case BT_REAL:
+      if (src_type == BT_INTEGER)
+	{
+	  if (dst_kind == 4)
+	    *(float*) dst = (float) int_val;
+	  else if (dst_kind == 8)
+	    *(double*) dst = (double) int_val;
+#ifdef HAVE_GFC_REAL_10
+	  else if (dst_kind == 10)
+	    *(long double*) dst = (long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+	  else if (dst_kind == 16)
+	    *(real128t*) dst = (real128t) int_val;
+#endif
+	  else
+	    goto error;
+	}
+      else if (src_type == BT_REAL)
+	{
+	  if (dst_kind == 4)
+	    *(float*) dst = (float) real_val;
+	  else if (dst_kind == 8)
+	    *(double*) dst = (double) real_val;
+#ifdef HAVE_GFC_REAL_10
+	  else if (dst_kind == 10)
+	    *(long double*) dst = (long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+	  else if (dst_kind == 16)
+	    *(real128t*) dst = (real128t) real_val;
+#endif
+	  else
+	    goto error;
+	}
+      else if (src_type == BT_COMPLEX)
+	{
+	  if (dst_kind == 4)
+	    *(float*) dst = (float) cmpx_val;
+	  else if (dst_kind == 8)
+	    *(double*) dst = (double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+	  else if (dst_kind == 10)
+	    *(long double*) dst = (long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+	  else if (dst_kind == 16)
+	    *(real128t*) dst = (real128t) cmpx_val;
+#endif
+	  else
+	    goto error;
+	}
+      return;
+    case BT_COMPLEX:
+      if (src_type == BT_INTEGER)
+	{
+	  if (dst_kind == 4)
+	    *(_Complex float*) dst = (_Complex float) int_val;
+	  else if (dst_kind == 8)
+	    *(_Complex double*) dst = (_Complex double) int_val;
+#ifdef HAVE_GFC_REAL_10
+	  else if (dst_kind == 10)
+	    *(_Complex long double*) dst = (_Complex long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+	  else if (dst_kind == 16)
+	    *(complex128t*) dst = (complex128t) int_val;
+#endif
+	  else
+	    goto error;
+	}
+      else if (src_type == BT_REAL)
+	{
+	  if (dst_kind == 4)
+	    *(_Complex float*) dst = (_Complex float) real_val;
+	  else if (dst_kind == 8)
+	    *(_Complex double*) dst = (_Complex double) real_val;
+#ifdef HAVE_GFC_REAL_10
+	  else if (dst_kind == 10)
+	    *(_Complex long double*) dst = (_Complex long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+	  else if (dst_kind == 16)
+	    *(complex128t*) dst = (complex128t) real_val;
+#endif
+	  else
+	    goto error;
+	}
+      else if (src_type == BT_COMPLEX)
+	{
+	  if (dst_kind == 4)
+	    *(_Complex float*) dst = (_Complex float) cmpx_val;
+	  else if (dst_kind == 8)
+	    *(_Complex double*) dst = (_Complex double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+	  else if (dst_kind == 10)
+	    *(_Complex long double*) dst = (_Complex long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+	  else if (dst_kind == 16)
+	    *(complex128t*) dst = (complex128t) cmpx_val;
+#endif
+	  else
+	    goto error;
+	}
+      else
+	goto error;
+      return;
+    default:
+      goto error;
+    }
+
+error:
+  fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
+	   "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
+  if (stat)
+    *stat = 1;
+  else
+    abort ();
+}
+
+
+void
+_gfortran_caf_get (caf_token_t token, size_t offset,
+		   int image_index __attribute__ ((unused)),
+		   gfc_descriptor_t *src,
+		   caf_vector_t *src_vector __attribute__ ((unused)),
+		   gfc_descriptor_t *dest, int src_kind, int dst_kind,
+		   bool may_require_tmp, int *stat)
+{
+  /* FIXME: Handle vector subscripts.  */
+  size_t i, k, size;
+  int j;
+  int rank = GFC_DESCRIPTOR_RANK (dest);
+  size_t src_size = GFC_DESCRIPTOR_SIZE (src);
+  size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
+
+  if (stat)
+    *stat = 0;
+
+  if (rank == 0)
+    {
+      void *sr = (void *) ((char *) MEMTOK (token) + offset);
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	  && dst_kind == src_kind)
+	{
+	  memmove (GFC_DESCRIPTOR_DATA (dest), sr,
+		   dst_size > src_size ? src_size : dst_size);
+	  if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+	    {
+	      if (dst_kind == 1)
+		memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
+			' ', dst_size - src_size);
+	      else /* dst_kind == 4.  */
+		for (i = src_size/4; i < dst_size/4; i++)
+		  ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
+	    }
+	}
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
+				 sr);
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
+				 sr);
+      else
+	convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
+		      dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+      return;
+    }
+
+  size = 1;
+  for (j = 0; j < rank; j++)
+    {
+      ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
+      if (dimextent < 0)
+	dimextent = 0;
+      size *= dimextent;
+    }
+
+  if (size == 0)
+    return;
+
+  if (may_require_tmp)
+    {
+      ptrdiff_t array_offset_sr, array_offset_dst;
+      void *tmp = malloc (size*src_size);
+
+      array_offset_dst = 0;
+      for (i = 0; i < size; i++)
+	{
+	  ptrdiff_t array_offset_sr = 0;
+	  ptrdiff_t stride = 1;
+	  ptrdiff_t extent = 1;
+	  for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+	    {
+	      array_offset_sr += ((i / (extent*stride))
+				  % (src->dim[j]._ubound
+				    - src->dim[j].lower_bound + 1))
+				 * src->dim[j]._stride;
+	      extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+	      stride = src->dim[j]._stride;
+	    }
+	  array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+	  void *sr = (void *)((char *) MEMTOK (token) + offset
+			  + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+          memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
+          array_offset_dst += src_size;
+	}
+
+      array_offset_sr = 0;
+      for (i = 0; i < size; i++)
+	{
+	  ptrdiff_t array_offset_dst = 0;
+	  ptrdiff_t stride = 1;
+	  ptrdiff_t extent = 1;
+	  for (j = 0; j < rank-1; j++)
+	    {
+	      array_offset_dst += ((i / (extent*stride))
+				   % (dest->dim[j]._ubound
+				      - dest->dim[j].lower_bound + 1))
+				  * dest->dim[j]._stride;
+	      extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+	      stride = dest->dim[j]._stride;
+	    }
+	  array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+	  void *dst = dest->base_addr
+		      + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
+          void *sr = tmp + array_offset_sr;
+
+	  if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	      && dst_kind == src_kind)
+	    {
+	      memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
+	      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
+	          && dst_size > src_size)
+		{
+		  if (dst_kind == 1)
+		    memset ((void*)(char*) dst + src_size, ' ',
+			    dst_size-src_size);
+		  else /* dst_kind == 4.  */
+		    for (k = src_size/4; k < dst_size/4; k++)
+		      ((int32_t*) dst)[k] = (int32_t) ' ';
+		}
+	    }
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	    assign_char1_from_char4 (dst_size, src_size, dst, sr);
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	    assign_char4_from_char1 (dst_size, src_size, dst, sr);
+	  else
+	    convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+			  sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+          array_offset_sr += src_size;
+	}
+
+      free (tmp);
+      return;
+    }
+
+  for (i = 0; i < size; i++)
+    {
+      ptrdiff_t array_offset_dst = 0;
+      ptrdiff_t stride = 1;
+      ptrdiff_t extent = 1;
+      for (j = 0; j < rank-1; j++)
+	{
+	  array_offset_dst += ((i / (extent*stride))
+			       % (dest->dim[j]._ubound
+				  - dest->dim[j].lower_bound + 1))
+			      * dest->dim[j]._stride;
+	  extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+          stride = dest->dim[j]._stride;
+	}
+      array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+      void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
+
+      ptrdiff_t array_offset_sr = 0;
+      stride = 1;
+      extent = 1;
+      for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+	{
+	  array_offset_sr += ((i / (extent*stride))
+			       % (src->dim[j]._ubound
+				  - src->dim[j].lower_bound + 1))
+			      * src->dim[j]._stride;
+	  extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+	  stride = src->dim[j]._stride;
+	}
+      array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+      void *sr = (void *)((char *) MEMTOK (token) + offset
+			  + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	  && dst_kind == src_kind)
+	{
+	  memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
+	  if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+	    {
+	      if (dst_kind == 1)
+		memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+	      else /* dst_kind == 4.  */
+		for (k = src_size/4; k < dst_size/4; k++)
+		  ((int32_t*) dst)[k] = (int32_t) ' ';
+	    }
+	}
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	assign_char1_from_char4 (dst_size, src_size, dst, sr);
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	assign_char4_from_char1 (dst_size, src_size, dst, sr);
+      else
+	convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+		      sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+    }
+}
+
+
+void
+_gfortran_caf_send (caf_token_t token, size_t offset,
+		    int image_index __attribute__ ((unused)),
+		    gfc_descriptor_t *dest,
+		    caf_vector_t *dst_vector __attribute__ ((unused)),
+		    gfc_descriptor_t *src, int dst_kind, int src_kind,
+		    bool may_require_tmp, int *stat)
+{
+  /* FIXME: Handle vector subscripts.  */
+  size_t i, k, size;
+  int j;
+  int rank = GFC_DESCRIPTOR_RANK (dest);
+  size_t src_size = GFC_DESCRIPTOR_SIZE (src);
+  size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
+
+  if (stat)
+    *stat = 0;
+
+  if (rank == 0)
+    {
+      void *dst = (void *) ((char *) MEMTOK (token) + offset);
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	  && dst_kind == src_kind)
+	{
+	  memmove (dst, GFC_DESCRIPTOR_DATA (src),
+		   dst_size > src_size ? src_size : dst_size);
+	  if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+	    {
+	      if (dst_kind == 1)
+		memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+	      else /* dst_kind == 4.  */
+		for (i = src_size/4; i < dst_size/4; i++)
+		  ((int32_t*) dst)[i] = (int32_t) ' ';
+	    }
+	}
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	assign_char1_from_char4 (dst_size, src_size, dst,
+				 GFC_DESCRIPTOR_DATA (src));
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	assign_char4_from_char1 (dst_size, src_size, dst,
+				 GFC_DESCRIPTOR_DATA (src));
+      else
+	convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+		      GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
+		      src_kind, stat);
+      return;
+    }
+
+  size = 1;
+  for (j = 0; j < rank; j++)
+    {
+      ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
+      if (dimextent < 0)
+	dimextent = 0;
+      size *= dimextent;
+    }
+
+  if (size == 0)
+    return;
+
+  if (may_require_tmp)
+    {
+      ptrdiff_t array_offset_sr, array_offset_dst;
+      void *tmp;
+
+      if (GFC_DESCRIPTOR_RANK (src) == 0)
+	{
+	  tmp = malloc (src_size);
+	  memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
+	}
+      else
+	{
+	  tmp = malloc (size*src_size);
+	  array_offset_dst = 0;
+	  for (i = 0; i < size; i++)
+	    {
+	      ptrdiff_t array_offset_sr = 0;
+	      ptrdiff_t stride = 1;
+	      ptrdiff_t extent = 1;
+	      for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+		{
+		  array_offset_sr += ((i / (extent*stride))
+				      % (src->dim[j]._ubound
+					 - src->dim[j].lower_bound + 1))
+				     * src->dim[j]._stride;
+		  extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+		  stride = src->dim[j]._stride;
+		}
+	      array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+	      void *sr = (void *) ((char *) src->base_addr
+				   + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+	      memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
+	      array_offset_dst += src_size;
+	    }
+	}
+
+      array_offset_sr = 0;
+      for (i = 0; i < size; i++)
+	{
+	  ptrdiff_t array_offset_dst = 0;
+	  ptrdiff_t stride = 1;
+	  ptrdiff_t extent = 1;
+	  for (j = 0; j < rank-1; j++)
+	    {
+	      array_offset_dst += ((i / (extent*stride))
+				   % (dest->dim[j]._ubound
+				      - dest->dim[j].lower_bound + 1))
+				  * dest->dim[j]._stride;
+	  extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+          stride = dest->dim[j]._stride;
+	    }
+	  array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+	  void *dst = (void *)((char *) MEMTOK (token) + offset
+		      + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
+          void *sr = tmp + array_offset_sr;
+	  if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	      && dst_kind == src_kind)
+	    {
+	      memmove (dst, sr,
+		       dst_size > src_size ? src_size : dst_size);
+	      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
+		  && dst_size > src_size)
+		{
+		  if (dst_kind == 1)
+		    memset ((void*)(char*) dst + src_size, ' ',
+			    dst_size-src_size);
+		  else /* dst_kind == 4.  */
+		    for (k = src_size/4; k < dst_size/4; k++)
+		      ((int32_t*) dst)[k] = (int32_t) ' ';
+		}
+	    }
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	    assign_char1_from_char4 (dst_size, src_size, dst, sr);
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	    assign_char4_from_char1 (dst_size, src_size, dst, sr);
+	  else
+	    convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+			  sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+          if (GFC_DESCRIPTOR_RANK (src))
+	    array_offset_sr += src_size;
+	}
+      free (tmp);
+      return;
+    }
+
+  for (i = 0; i < size; i++)
+    {
+      ptrdiff_t array_offset_dst = 0;
+      ptrdiff_t stride = 1;
+      ptrdiff_t extent = 1;
+      for (j = 0; j < rank-1; j++)
+	{
+	  array_offset_dst += ((i / (extent*stride))
+			       % (dest->dim[j]._ubound
+				  - dest->dim[j].lower_bound + 1))
+			      * dest->dim[j]._stride;
+	  extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+          stride = dest->dim[j]._stride;
+	}
+      array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+      void *dst = (void *)((char *) MEMTOK (token) + offset
+			   + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
+      void *sr;
+      if (GFC_DESCRIPTOR_RANK (src) != 0)
+	{
+	  ptrdiff_t array_offset_sr = 0;
+	  stride = 1;
+	  extent = 1;
+	  for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+	    {
+	      array_offset_sr += ((i / (extent*stride))
+				  % (src->dim[j]._ubound
+				     - src->dim[j].lower_bound + 1))
+				 * src->dim[j]._stride;
+	      extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+	      stride = src->dim[j]._stride;
+	    }
+	  array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+	  sr = (void *)((char *) src->base_addr
+			+ array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+	}
+      else
+	sr = src->base_addr;
+
+      if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	  && dst_kind == src_kind)
+	{
+	  memmove (dst, sr,
+		   dst_size > src_size ? src_size : dst_size);
+	  if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+	    {
+	      if (dst_kind == 1)
+		memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+	      else /* dst_kind == 4.  */
+		for (k = src_size/4; k < dst_size/4; k++)
+		  ((int32_t*) dst)[k] = (int32_t) ' ';
+	    }
+	}
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	assign_char1_from_char4 (dst_size, src_size, dst, sr);
+      else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	assign_char4_from_char1 (dst_size, src_size, dst, sr);
+      else
+	convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+		      sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+    }
+}
+
+
+void
+_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
+		       int dst_image_index, gfc_descriptor_t *dest,
+		       caf_vector_t *dst_vector, caf_token_t src_token,
+		       size_t src_offset,
+		       int src_image_index __attribute__ ((unused)),
+		       gfc_descriptor_t *src,
+		       caf_vector_t *src_vector __attribute__ ((unused)),
+		       int dst_kind, int src_kind, bool may_require_tmp)
+{
+  /* FIXME: Handle vector subscript of 'src_vector'.  */
+  /* For a single image, src->base_addr should be the same as src_token + offset
+     but to play save, we do it properly.  */
+  void *src_base = GFC_DESCRIPTOR_DATA (src);
+  GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token)
+					+ src_offset);
+  _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
+		      src, dst_kind, src_kind, may_require_tmp, NULL);
+  GFC_DESCRIPTOR_DATA (src) = src_base;
+}
+
+
+/* Emitted when a theorectically unreachable part is reached.  */
+const char unreachable[] = "Fatal error: unreachable alternative found.\n";
+
+
+static void
+copy_data (void *ds, void *sr, int dst_type, int src_type,
+	   int dst_kind, int src_kind, size_t dst_size, size_t src_size,
+	   size_t num, int *stat)
+{
+  size_t k;
+  if (dst_type == src_type && dst_kind == src_kind)
+    {
+      memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num);
+      if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
+	  && dst_size > src_size)
+	{
+	  if (dst_kind == 1)
+	    memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
+	  else /* dst_kind == 4.  */
+	    for (k = src_size/4; k < dst_size/4; k++)
+	      ((int32_t*) ds)[k] = (int32_t) ' ';
+	}
+    }
+  else if (dst_type == BT_CHARACTER && dst_kind == 1)
+    assign_char1_from_char4 (dst_size, src_size, ds, sr);
+  else if (dst_type == BT_CHARACTER)
+    assign_char4_from_char1 (dst_size, src_size, ds, sr);
+  else
+    for (k = 0; k < num; ++k)
+      {
+	convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat);
+	ds += dst_size;
+	sr += src_size;
+      }
+}
+
+
+#define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
+  do { \
+    index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
+    num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
+    if (num <= 0 || abs_stride < 1) return; \
+    num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
+  } while (0)
+
+
+static void
+get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index,
+	     caf_single_token_t single_token, gfc_descriptor_t *dst,
+	     gfc_descriptor_t *src, void *ds, void *sr,
+	     int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
+	     size_t num, int *stat)
+{
+  ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
+  size_t next_dst_dim;
+
+  if (unlikely (ref == NULL))
+    /* May be we should issue an error here, because this case should not
+       occur.  */
+    return;
+
+  if (ref->next == NULL)
+    {
+      size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
+      ptrdiff_t array_offset_dst = 0;;
+      size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
+      int src_type = -1;
+
+      switch (ref->type)
+	{
+	case CAF_REF_COMPONENT:
+	  /* Because the token is always registered after the component, its
+	     offset is always greater zeor.  */
+	  if (ref->u.c.caf_token_offset > 0)
+	    copy_data (ds, *(void **)(sr + ref->u.c.offset),
+		       GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst),
+		       dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
+	  else
+	    copy_data (ds, sr + ref->u.c.offset,
+		       GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src),
+		       dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
+	  ++(*i);
+	  return;
+	case CAF_REF_STATIC_ARRAY:
+	  src_type = ref->u.a.static_array_type;
+	  /* Intentionally fall through.  */
+	case CAF_REF_ARRAY:
+	  if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+	    {
+	      for (size_t d = 0; d < dst_rank; ++d)
+		array_offset_dst += dst_index[d];
+	      copy_data (ds + array_offset_dst * dst_size, sr,
+			 GFC_DESCRIPTOR_TYPE (dst),
+			 src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type,
+			 dst_kind, src_kind, dst_size, ref->item_size, num,
+			 stat);
+	      *i += num;
+	      return;
+	    }
+	  break;
+	default:
+	  caf_runtime_error (unreachable);
+	}
+    }
+
+  switch (ref->type)
+    {
+    case CAF_REF_COMPONENT:
+      if (ref->u.c.caf_token_offset > 0)
+	get_for_ref (ref->next, i, dst_index,
+		    *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst,
+		 (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc,
+		     ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0,
+		     1, stat);
+      else
+	get_for_ref (ref->next, i, dst_index, single_token, dst,
+		     (gfc_descriptor_t *)(sr + ref->u.c.offset), ds,
+		     sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1,
+		     stat);
+      return;
+    case CAF_REF_ARRAY:
+      if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+	{
+	  get_for_ref (ref->next, i, dst_index, single_token, dst,
+		       src, ds, sr, dst_kind, src_kind,
+		       dst_dim, 0, 1, stat);
+	  return;
+	}
+      /* Only when on the left most index switch the data pointer to
+	 the array's data pointer.  */
+      if (src_dim == 0)
+	sr = GFC_DESCRIPTOR_DATA (src);
+      switch (ref->u.a.mode[src_dim])
+	{
+	case CAF_ARR_REF_VECTOR:
+	  extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]);
+	  array_offset_src = 0;
+	  dst_index[dst_dim] = 0;
+	  for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
+	       ++idx)
+	    {
+#define KINDCASE(kind, type) case kind: \
+	      array_offset_src = (((index_type) \
+		  ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
+		  - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
+		  * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
+	      break
+
+	      switch (ref->u.a.dim[src_dim].v.kind)
+		{
+		KINDCASE (1, GFC_INTEGER_1);
+		KINDCASE (2, GFC_INTEGER_2);
+		KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		KINDCASE (16, GFC_INTEGER_16);
+#endif
+		default:
+		  caf_runtime_error (unreachable);
+		  return;
+		}
+#undef KINDCASE
+
+	      get_for_ref (ref, i, dst_index, single_token, dst, src,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_FULL:
+	  COMPUTE_NUM_ITEMS (extent_src,
+			     ref->u.a.dim[src_dim].s.stride,
+			     GFC_DIMENSION_LBOUND (src->dim[src_dim]),
+			     GFC_DIMENSION_UBOUND (src->dim[src_dim]));
+	  stride_src = src->dim[src_dim]._stride
+	      * ref->u.a.dim[src_dim].s.stride;
+	  array_offset_src = 0;
+	  dst_index[dst_dim] = 0;
+	  for (index_type idx = 0; idx < extent_src;
+	       ++idx, array_offset_src += stride_src)
+	    {
+	      get_for_ref (ref, i, dst_index, single_token, dst, src,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_RANGE:
+	  COMPUTE_NUM_ITEMS (extent_src,
+			     ref->u.a.dim[src_dim].s.stride,
+			     ref->u.a.dim[src_dim].s.start,
+			     ref->u.a.dim[src_dim].s.end);
+	  array_offset_src = (ref->u.a.dim[src_dim].s.start
+			      - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
+	      * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	  stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
+	      * ref->u.a.dim[src_dim].s.stride;
+	  dst_index[dst_dim] = 0;
+	  /* Increase the dst_dim only, when the src_extent is greater one
+	     or src and dst extent are both one.  Don't increase when the scalar
+	     source is not present in the dst.  */
+	  next_dst_dim = extent_src > 1
+	      || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1
+		  && extent_src == 1) ? (dst_dim + 1) : dst_dim;
+	  for (index_type idx = 0; idx < extent_src; ++idx)
+	    {
+	      get_for_ref (ref, i, dst_index, single_token, dst, src,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, next_dst_dim, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	      array_offset_src += stride_src;
+	    }
+	  return;
+	case CAF_ARR_REF_SINGLE:
+	  array_offset_src = (ref->u.a.dim[src_dim].s.start
+			      - src->dim[src_dim].lower_bound)
+	      * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	  dst_index[dst_dim] = 0;
+	  get_for_ref (ref, i, dst_index, single_token, dst, src, ds,
+		       sr + array_offset_src * ref->item_size,
+		       dst_kind, src_kind, dst_dim, src_dim + 1, 1,
+		       stat);
+	  return;
+	case CAF_ARR_REF_OPEN_END:
+	  COMPUTE_NUM_ITEMS (extent_src,
+			     ref->u.a.dim[src_dim].s.stride,
+			     ref->u.a.dim[src_dim].s.start,
+			     GFC_DIMENSION_UBOUND (src->dim[src_dim]));
+	  stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
+	      * ref->u.a.dim[src_dim].s.stride;
+	  array_offset_src = (ref->u.a.dim[src_dim].s.start
+			      - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
+	      * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	  dst_index[dst_dim] = 0;
+	  for (index_type idx = 0; idx < extent_src; ++idx)
+	    {
+	      get_for_ref (ref, i, dst_index, single_token, dst, src,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	      array_offset_src += stride_src;
+	    }
+	  return;
+	case CAF_ARR_REF_OPEN_START:
+	  COMPUTE_NUM_ITEMS (extent_src,
+			     ref->u.a.dim[src_dim].s.stride,
+			     GFC_DIMENSION_LBOUND (src->dim[src_dim]),
+			     ref->u.a.dim[src_dim].s.end);
+	  stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
+	      * ref->u.a.dim[src_dim].s.stride;
+	  array_offset_src = 0;
+	  dst_index[dst_dim] = 0;
+	  for (index_type idx = 0; idx < extent_src; ++idx)
+	    {
+	      get_for_ref (ref, i, dst_index, single_token, dst, src,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	      array_offset_src += stride_src;
+	    }
+	  return;
+	default:
+	  caf_runtime_error (unreachable);
+	}
+      return;
+    case CAF_REF_STATIC_ARRAY:
+      if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+	{
+	  get_for_ref (ref->next, i, dst_index, single_token, dst,
+		       NULL, ds, sr, dst_kind, src_kind,
+		       dst_dim, 0, 1, stat);
+	  return;
+	}
+      switch (ref->u.a.mode[src_dim])
+	{
+	case CAF_ARR_REF_VECTOR:
+	  array_offset_src = 0;
+	  dst_index[dst_dim] = 0;
+	  for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
+	       ++idx)
+	    {
+#define KINDCASE(kind, type) case kind: \
+	     array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
+	      break
+
+	      switch (ref->u.a.dim[src_dim].v.kind)
+		{
+		KINDCASE (1, GFC_INTEGER_1);
+		KINDCASE (2, GFC_INTEGER_2);
+		KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		KINDCASE (16, GFC_INTEGER_16);
+#endif
+		default:
+		  caf_runtime_error (unreachable);
+		  return;
+		}
+#undef KINDCASE
+
+	      get_for_ref (ref, i, dst_index, single_token, dst, NULL,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_FULL:
+	  dst_index[dst_dim] = 0;
+	  for (array_offset_src = 0 ;
+	       array_offset_src <= ref->u.a.dim[src_dim].s.end;
+	       array_offset_src += ref->u.a.dim[src_dim].s.stride)
+	    {
+	      get_for_ref (ref, i, dst_index, single_token, dst, NULL,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_RANGE:
+	  COMPUTE_NUM_ITEMS (extent_src,
+			     ref->u.a.dim[src_dim].s.stride,
+			     ref->u.a.dim[src_dim].s.start,
+			     ref->u.a.dim[src_dim].s.end);
+	  array_offset_src = ref->u.a.dim[src_dim].s.start;
+	  dst_index[dst_dim] = 0;
+	  for (index_type idx = 0; idx < extent_src; ++idx)
+	    {
+	      get_for_ref (ref, i, dst_index, single_token, dst, NULL,
+			   ds, sr + array_offset_src * ref->item_size,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, stat);
+	      dst_index[dst_dim]
+		  += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	      array_offset_src += ref->u.a.dim[src_dim].s.stride;
+	    }
+	  return;
+	case CAF_ARR_REF_SINGLE:
+	  array_offset_src = ref->u.a.dim[src_dim].s.start;
+	  get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds,
+		       sr + array_offset_src * ref->item_size,
+		       dst_kind, src_kind, dst_dim, src_dim + 1, 1,
+		       stat);
+	  return;
+	/* The OPEN_* are mapped to a RANGE and therefore can not occur.  */
+	case CAF_ARR_REF_OPEN_END:
+	case CAF_ARR_REF_OPEN_START:
+	default:
+	  caf_runtime_error (unreachable);
+	}
+      return;
+    default:
+      caf_runtime_error (unreachable);
+    }
+}
+
+
+void
+_gfortran_caf_get_by_ref (caf_token_t token,
+			  int image_index __attribute__ ((unused)),
+			  gfc_descriptor_t *dst, caf_reference_t *refs,
+			  int dst_kind, int src_kind,
+			  bool may_require_tmp __attribute__ ((unused)),
+			  bool dst_reallocatable, int *stat)
+{
+  const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
+				   "unknown kind in vector-ref.\n";
+  const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
+				"unknown reference type.\n";
+  const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
+				   "unknown array reference type.\n";
+  const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
+				"rank out of range.\n";
+  const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
+				  "extent out of range.\n";
+  const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
+				"can not allocate memory.\n";
+  const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
+      "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
+  const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
+      "two or more array part references are not supported.\n";
+  size_t size, i;
+  size_t dst_index[GFC_MAX_DIMENSIONS];
+  int dst_rank = GFC_DESCRIPTOR_RANK (dst);
+  int dst_cur_dim = 0;
+  size_t src_size = 0;
+  caf_single_token_t single_token = TOKEN (token);
+  void *memptr = single_token->memptr;
+  gfc_descriptor_t *src = single_token->desc;
+  caf_reference_t *riter = refs;
+  long delta;
+  /* Reallocation of dst.data is needed (e.g., array to small).  */
+  bool realloc_needed;
+  /* Reallocation of dst.data is required, because data is not alloced at
+     all.  */
+  bool realloc_required;
+  bool extent_mismatch = false;
+  /* Set when the first non-scalar array reference is encountered.  */
+  bool in_array_ref = false;
+  bool array_extent_fixed = false;
+  realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
+
+  assert (!realloc_needed || dst_reallocatable);
+
+  if (stat)
+    *stat = 0;
+
+  /* Compute the size of the result.  In the beginning size just counts the
+     number of elements.  */
+  size = 1;
+  while (riter)
+    {
+      switch (riter->type)
+	{
+	case CAF_REF_COMPONENT:
+	  if (riter->u.c.caf_token_offset)
+	    {
+	      single_token = *(caf_single_token_t*)
+					 (memptr + riter->u.c.caf_token_offset);
+	      memptr = single_token->memptr;
+	      src = single_token->desc;
+	    }
+	  else
+	    {
+	      memptr += riter->u.c.offset;
+	      src = (gfc_descriptor_t *)memptr;
+	    }
+	  break;
+	case CAF_REF_ARRAY:
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_VECTOR:
+		  delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+		    memptr += (((index_type) \
+			((type *)riter->u.a.dim[i].v.vector)[0]) \
+			- GFC_DIMENSION_LBOUND (src->dim[i])) \
+			* GFC_DIMENSION_STRIDE (src->dim[i]) \
+			* riter->item_size; \
+		    break
+
+		  switch (riter->u.a.dim[i].v.kind)
+		    {
+		    KINDCASE (1, GFC_INTEGER_1);
+		    KINDCASE (2, GFC_INTEGER_2);
+		    KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		    KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		    KINDCASE (16, GFC_INTEGER_16);
+#endif
+		    default:
+		      caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+		      return;
+		    }
+#undef KINDCASE
+		  break;
+		case CAF_ARR_REF_FULL:
+		  COMPUTE_NUM_ITEMS (delta,
+				     riter->u.a.dim[i].s.stride,
+				     GFC_DIMENSION_LBOUND (src->dim[i]),
+				     GFC_DIMENSION_UBOUND (src->dim[i]));
+		  /* The memptr stays unchanged when ref'ing the first element
+		     in a dimension.  */
+		  break;
+		case CAF_ARR_REF_RANGE:
+		  COMPUTE_NUM_ITEMS (delta,
+				     riter->u.a.dim[i].s.stride,
+				     riter->u.a.dim[i].s.start,
+				     riter->u.a.dim[i].s.end);
+		  memptr += (riter->u.a.dim[i].s.start
+			     - GFC_DIMENSION_LBOUND (src->dim[i]))
+		      * GFC_DIMENSION_STRIDE (src->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_SINGLE:
+		  delta = 1;
+		  memptr += (riter->u.a.dim[i].s.start
+			     - GFC_DIMENSION_LBOUND (src->dim[i]))
+		      * GFC_DIMENSION_STRIDE (src->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_OPEN_END:
+		  COMPUTE_NUM_ITEMS (delta,
+				     riter->u.a.dim[i].s.stride,
+				     riter->u.a.dim[i].s.start,
+				     GFC_DIMENSION_UBOUND (src->dim[i]));
+		  memptr += (riter->u.a.dim[i].s.start
+			     - GFC_DIMENSION_LBOUND (src->dim[i]))
+		      * GFC_DIMENSION_STRIDE (src->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_OPEN_START:
+		  COMPUTE_NUM_ITEMS (delta,
+				     riter->u.a.dim[i].s.stride,
+				     GFC_DIMENSION_LBOUND (src->dim[i]),
+				     riter->u.a.dim[i].s.end);
+		  /* The memptr stays unchanged when ref'ing the first element
+		     in a dimension.  */
+		  break;
+		default:
+		  caf_internal_error (unknownarrreftype, stat, NULL, 0);
+		  return;
+		}
+	      if (delta <= 0)
+		return;
+	      /* Check the various properties of the destination array.
+		 Is an array expected and present?  */
+	      if (delta > 1 && dst_rank == 0)
+		{
+		  /* No, an array is required, but not provided.  */
+		  caf_internal_error (extentoutofrange, stat, NULL, 0);
+		  return;
+		}
+	      /* When dst is an array.  */
+	      if (dst_rank > 0)
+		{
+		  /* Check that dst_cur_dim is valid for dst.  Can be
+		     superceeded only by scalar data.  */
+		  if (dst_cur_dim >= dst_rank && delta != 1)
+		    {
+		      caf_internal_error (rankoutofrange, stat, NULL, 0);
+		      return;
+		    }
+		  /* Do further checks, when the source is not scalar.  */
+		  else if (delta != 1)
+		    {
+		      /* Check that the extent is not scalar and we are not in
+			 an array ref for the dst side.  */
+		      if (!in_array_ref)
+			{
+			  /* Check that this is the non-scalar extent.  */
+			  if (!array_extent_fixed)
+			    {
+			      /* In an array extent now.  */
+			      in_array_ref = true;
+			      /* Check that we haven't skipped any scalar
+				 dimensions yet and that the dst is
+				 compatible.  */
+			      if (i > 0
+				  && dst_rank == GFC_DESCRIPTOR_RANK (src))
+				{
+				  if (dst_reallocatable)
+				    {
+				      /* Dst is reallocatable, which means that
+					 the bounds are not set.  Set them.  */
+				      for (dst_cur_dim= 0; dst_cur_dim < (int)i;
+					   ++dst_cur_dim)
+				       GFC_DIMENSION_SET (dst->dim[dst_cur_dim],
+							  1, 1, 1);
+				    }
+				  else
+				    dst_cur_dim = i;
+				}
+			      /* Else press thumbs, that there are enough
+				 dimensional refs to come.  Checked below.  */
+			    }
+			  else
+			    {
+			      caf_internal_error (doublearrayref, stat, NULL,
+						  0);
+			      return;
+			    }
+			}
+		      /* When the realloc is required, then no extent may have
+			 been set.  */
+		      extent_mismatch = realloc_required
+			  || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
+		      /* When it already known, that a realloc is needed or
+			 the extent does not match the needed one.  */
+		      if (realloc_required || realloc_needed
+			  || extent_mismatch)
+			{
+			  /* Check whether dst is reallocatable.  */
+			  if (unlikely (!dst_reallocatable))
+			    {
+			      caf_internal_error (nonallocextentmismatch, stat,
+						  NULL, 0, delta,
+						  GFC_DESCRIPTOR_EXTENT (dst,
+								  dst_cur_dim));
+			      return;
+			    }
+			  /* Only report an error, when the extent needs to be
+			     modified, which is not allowed.  */
+			  else if (!dst_reallocatable && extent_mismatch)
+			    {
+			      caf_internal_error (extentoutofrange, stat, NULL,
+						  0);
+			      return;
+			    }
+			  realloc_needed = true;
+			}
+		      /* Only change the extent when it does not match.  This is
+			 to prevent resetting given array bounds.  */
+		      if (extent_mismatch)
+			GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
+					   size);
+		    }
+
+		  /* Only increase the dim counter, when in an array ref.  */
+		  if (in_array_ref && dst_cur_dim < dst_rank)
+		    ++dst_cur_dim;
+		}
+	      size *= (index_type)delta;
+	    }
+	  if (in_array_ref)
+	    {
+	      array_extent_fixed = true;
+	      in_array_ref = false;
+	      /* Check, if we got less dimensional refs than the rank of dst
+		 expects.  */
+	      assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
+	    }
+	  break;
+	case CAF_REF_STATIC_ARRAY:
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_VECTOR:
+		  delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+		    memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
+			* riter->item_size; \
+		    break
+
+		  switch (riter->u.a.dim[i].v.kind)
+		    {
+		    KINDCASE (1, GFC_INTEGER_1);
+		    KINDCASE (2, GFC_INTEGER_2);
+		    KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		    KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		    KINDCASE (16, GFC_INTEGER_16);
+#endif
+		    default:
+		      caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+		      return;
+		    }
+#undef KINDCASE
+		  break;
+		case CAF_ARR_REF_FULL:
+		  delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
+		      + 1;
+		  /* The memptr stays unchanged when ref'ing the first element
+		     in a dimension.  */
+		  break;
+		case CAF_ARR_REF_RANGE:
+		  COMPUTE_NUM_ITEMS (delta,
+				     riter->u.a.dim[i].s.stride,
+				     riter->u.a.dim[i].s.start,
+				     riter->u.a.dim[i].s.end);
+		  memptr += riter->u.a.dim[i].s.start
+		      * riter->u.a.dim[i].s.stride
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_SINGLE:
+		  delta = 1;
+		  memptr += riter->u.a.dim[i].s.start
+		      * riter->u.a.dim[i].s.stride
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_OPEN_END:
+		  /* This and OPEN_START are mapped to a RANGE and therefore
+		     can not occur here.  */
+		case CAF_ARR_REF_OPEN_START:
+		default:
+		  caf_internal_error (unknownarrreftype, stat, NULL, 0);
+		  return;
+		}
+	      if (delta <= 0)
+		return;
+	      /* Check the various properties of the destination array.
+		 Is an array expected and present?  */
+	      if (delta > 1 && dst_rank == 0)
+		{
+		  /* No, an array is required, but not provided.  */
+		  caf_internal_error (extentoutofrange, stat, NULL, 0);
+		  return;
+		}
+	      /* When dst is an array.  */
+	      if (dst_rank > 0)
+		{
+		  /* Check that dst_cur_dim is valid for dst.  Can be
+		     superceeded only by scalar data.  */
+		  if (dst_cur_dim >= dst_rank && delta != 1)
+		    {
+		      caf_internal_error (rankoutofrange, stat, NULL, 0);
+		      return;
+		    }
+		  /* Do further checks, when the source is not scalar.  */
+		  else if (delta != 1)
+		    {
+		      /* Check that the extent is not scalar and we are not in
+			 an array ref for the dst side.  */
+		      if (!in_array_ref)
+			{
+			  /* Check that this is the non-scalar extent.  */
+			  if (!array_extent_fixed)
+			    {
+			      /* In an array extent now.  */
+			      in_array_ref = true;
+			      /* The dst is not reallocatable, so nothing more
+				 to do, then correct the dim counter.  */
+			      dst_cur_dim = i;
+			    }
+			  else
+			    {
+			      caf_internal_error (doublearrayref, stat, NULL,
+						  0);
+			      return;
+			    }
+			}
+		      /* When the realloc is required, then no extent may have
+			 been set.  */
+		      extent_mismatch = realloc_required
+			  || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
+		      /* When it is already known, that a realloc is needed or
+			 the extent does not match the needed one.  */
+		      if (realloc_required || realloc_needed
+			  || extent_mismatch)
+			{
+			  /* Check whether dst is reallocatable.  */
+			  if (unlikely (!dst_reallocatable))
+			    {
+			      caf_internal_error (nonallocextentmismatch, stat,
+						  NULL, 0, delta,
+						  GFC_DESCRIPTOR_EXTENT (dst,
+								  dst_cur_dim));
+			      return;
+			    }
+			  /* Only report an error, when the extent needs to be
+			     modified, which is not allowed.  */
+			  else if (!dst_reallocatable && extent_mismatch)
+			    {
+			      caf_internal_error (extentoutofrange, stat, NULL,
+						  0);
+			      return;
+			    }
+			  realloc_needed = true;
+			}
+		      /* Only change the extent when it does not match.  This is
+			 to prevent resetting given array bounds.  */
+		      if (extent_mismatch)
+			GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
+					   size);
+		    }
+		  /* Only increase the dim counter, when in an array ref.  */
+		  if (in_array_ref && dst_cur_dim < dst_rank)
+		    ++dst_cur_dim;
+		}
+	      size *= (index_type)delta;
+	    }
+	  if (in_array_ref)
+	    {
+	      array_extent_fixed = true;
+	      in_array_ref = false;
+	      /* Check, if we got less dimensional refs than the rank of dst
+		 expects.  */
+	      assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
+	    }
+	  break;
+	default:
+	  caf_internal_error (unknownreftype, stat, NULL, 0);
+	  return;
+	}
+      src_size = riter->item_size;
+      riter = riter->next;
+    }
+  if (size == 0 || src_size == 0)
+    return;
+  /* Postcondition:
+     - size contains the number of elements to store in the destination array,
+     - src_size gives the size in bytes of each item in the destination array.
+  */
+
+  if (realloc_needed)
+    {
+      if (!array_extent_fixed)
+	{
+	  assert (size == 1);
+	  /* This can happen only, when the result is scalar.  */
+	  for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim)
+	    GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1);
+	}
+
+      GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
+      if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL))
+	{
+	  caf_internal_error (cannotallocdst, stat, NULL, 0);
+	  return;
+	}
+    }
+
+  /* Reset the token.  */
+  single_token = TOKEN (token);
+  memptr = single_token->memptr;
+  src = single_token->desc;
+  memset(dst_index, 0, sizeof (dst_index));
+  i = 0;
+  get_for_ref (refs, &i, dst_index, single_token, dst, src,
+	       GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0,
+	       1, stat);
+}
+
+
+static void
+send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
+	     caf_single_token_t single_token, gfc_descriptor_t *dst,
+	     gfc_descriptor_t *src, void *ds, void *sr,
+	     int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
+	     size_t num, size_t size, int *stat)
+{
+  const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
+      "unknown kind in vector-ref.\n";
+  ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst;
+  const size_t src_rank = GFC_DESCRIPTOR_RANK (src);
+
+  if (unlikely (ref == NULL))
+    /* May be we should issue an error here, because this case should not
+       occur.  */
+    return;
+
+  if (ref->next == NULL)
+    {
+      size_t src_size = GFC_DESCRIPTOR_SIZE (src);
+      ptrdiff_t array_offset_src = 0;;
+      int dst_type = -1;
+
+      switch (ref->type)
+	{
+	case CAF_REF_COMPONENT:
+	  if (ref->u.c.caf_token_offset > 0)
+	    {
+	      if (*(void**)(ds + ref->u.c.offset) == NULL)
+		{
+		  /* Create a scalar temporary array descriptor.  */
+		  gfc_descriptor_t static_dst;
+		  GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
+		  GFC_DESCRIPTOR_DTYPE (&static_dst)
+		      = GFC_DESCRIPTOR_DTYPE (src);
+		  /* The component can be allocated now, because it is a
+		     scalar.  */
+		  _gfortran_caf_register (ref->item_size,
+					  CAF_REGTYPE_COARRAY_ALLOC,
+					  ds + ref->u.c.caf_token_offset,
+					  &static_dst, stat, NULL, 0);
+		  single_token = *(caf_single_token_t *)
+					       (ds + ref->u.c.caf_token_offset);
+		  /* In case of an error in allocation return.  When stat is
+		     NULL, then register_component() terminates on error.  */
+		  if (stat != NULL && *stat)
+		    return;
+		  /* Publish the allocated memory.  */
+		  *((void **)(ds + ref->u.c.offset))
+		      = GFC_DESCRIPTOR_DATA (&static_dst);
+		  ds = GFC_DESCRIPTOR_DATA (&static_dst);
+		  /* Set the type from the src.  */
+		  dst_type = GFC_DESCRIPTOR_TYPE (src);
+		}
+	      else
+		{
+		  single_token = *(caf_single_token_t *)
+					       (ds + ref->u.c.caf_token_offset);
+		  dst = single_token->desc;
+		  if (dst)
+		    {
+		      ds = GFC_DESCRIPTOR_DATA (dst);
+		      dst_type = GFC_DESCRIPTOR_TYPE (dst);
+		    }
+		  else
+		    {
+		      /* When no destination descriptor is present, assume that
+			 source and dest type are identical.  */
+		      dst_type = GFC_DESCRIPTOR_TYPE (src);
+		      ds = *(void **)(ds + ref->u.c.offset);
+		    }
+		}
+	      copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
+			 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
+	    }
+	  else
+	    copy_data (ds + ref->u.c.offset, sr,
+		       dst != NULL ? GFC_DESCRIPTOR_TYPE (dst)
+				   : GFC_DESCRIPTOR_TYPE (src),
+		       GFC_DESCRIPTOR_TYPE (src),
+		       dst_kind, src_kind, ref->item_size, src_size, 1, stat);
+	  ++(*i);
+	  return;
+	case CAF_REF_STATIC_ARRAY:
+	  dst_type = ref->u.a.static_array_type;
+	  /* Intentionally fall through.  */
+	case CAF_REF_ARRAY:
+	  if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
+	    {
+	      if (src_rank > 0)
+		{
+		  for (size_t d = 0; d < src_rank; ++d)
+		    array_offset_src += src_index[d];
+		  copy_data (ds, sr + array_offset_src * ref->item_size,
+			     dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
+					    : dst_type,
+			     GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
+			     ref->item_size, src_size, num, stat);
+		}
+	      else
+		copy_data (ds, sr,
+			   dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
+					  : dst_type,
+			   GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
+			   ref->item_size, src_size, num, stat);
+	      *i += num;
+	      return;
+	    }
+	  break;
+	default:
+	  caf_runtime_error (unreachable);
+	}
+    }
+
+  switch (ref->type)
+    {
+    case CAF_REF_COMPONENT:
+      if (ref->u.c.caf_token_offset > 0)
+	{
+	  if (*(void**)(ds + ref->u.c.offset) == NULL)
+	    {
+	      /* This component refs an unallocated array.  Non-arrays are
+		 caught in the if (!ref->next) above.  */
+	      dst = (gfc_descriptor_t *)(ds + ref->u.c.offset);
+	      /* Assume that the rank and the dimensions fit for copying src
+		 to dst.  */
+	      GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
+	      dst->offset = 0;
+	      stride_dst = 1;
+	      for (size_t d = 0; d < src_rank; ++d)
+		{
+		  extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
+		  GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
+		  GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
+		  GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
+		  stride_dst *= extent_dst;
+		}
+	      /* Null the data-pointer to make register_component allocate
+		 its own memory.  */
+	      GFC_DESCRIPTOR_DATA (dst) = NULL;
+
+	      /* The size of the array is given by size.  */
+	      _gfortran_caf_register (size * ref->item_size,
+				      CAF_REGTYPE_COARRAY_ALLOC,
+				      ds + ref->u.c.caf_token_offset,
+				      dst, stat, NULL, 0);
+	      /* In case of an error in allocation return.  When stat is
+		 NULL, then register_component() terminates on error.  */
+	      if (stat != NULL && *stat)
+		return;
+	    }
+	  single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
+	  send_by_ref (ref->next, i, src_index, single_token,
+		       single_token->desc, src, ds + ref->u.c.offset, sr,
+		       dst_kind, src_kind, 0, src_dim, 1, size, stat);
+	}
+      else
+	send_by_ref (ref->next, i, src_index, single_token,
+		     (gfc_descriptor_t *)(ds + ref->u.c.offset), src,
+		     ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim,
+		     1, size, stat);
+      return;
+    case CAF_REF_ARRAY:
+      if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
+	{
+	  send_by_ref (ref->next, i, src_index, single_token,
+		       (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind,
+		       0, src_dim, 1, size, stat);
+	  return;
+	}
+      /* Only when on the left most index switch the data pointer to
+	 the array's data pointer.  And only for non-static arrays.  */
+      if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
+	ds = GFC_DESCRIPTOR_DATA (dst);
+      switch (ref->u.a.mode[dst_dim])
+	{
+	case CAF_ARR_REF_VECTOR:
+	  array_offset_dst = 0;
+	  src_index[src_dim] = 0;
+	  for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
+	       ++idx)
+	    {
+#define KINDCASE(kind, type) case kind: \
+	      array_offset_dst = (((index_type) \
+		  ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
+		  - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
+		  * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
+	      break
+
+	      switch (ref->u.a.dim[dst_dim].v.kind)
+		{
+		KINDCASE (1, GFC_INTEGER_1);
+		KINDCASE (2, GFC_INTEGER_2);
+		KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		KINDCASE (16, GFC_INTEGER_16);
+#endif
+		default:
+		  caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+		  return;
+		}
+#undef KINDCASE
+
+	      send_by_ref (ref, i, src_index, single_token, dst, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      if (src_rank > 0)
+		src_index[src_dim]
+		    += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_FULL:
+	  COMPUTE_NUM_ITEMS (extent_dst,
+			     ref->u.a.dim[dst_dim].s.stride,
+			     GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
+			     GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
+	  array_offset_dst = 0;
+	  stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+	      * ref->u.a.dim[dst_dim].s.stride;
+	  src_index[src_dim] = 0;
+	  for (index_type idx = 0; idx < extent_dst;
+	       ++idx, array_offset_dst += stride_dst)
+	    {
+	      send_by_ref (ref, i, src_index, single_token, dst, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      if (src_rank > 0)
+		src_index[src_dim]
+		    += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_RANGE:
+	  COMPUTE_NUM_ITEMS (extent_dst,
+			     ref->u.a.dim[dst_dim].s.stride,
+			     ref->u.a.dim[dst_dim].s.start,
+			     ref->u.a.dim[dst_dim].s.end);
+	  array_offset_dst = ref->u.a.dim[dst_dim].s.start
+	      - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
+	  stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+	      * ref->u.a.dim[dst_dim].s.stride;
+	  src_index[src_dim] = 0;
+	  for (index_type idx = 0; idx < extent_dst; ++idx)
+	    {
+	      send_by_ref (ref, i, src_index, single_token, dst, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      if (src_rank > 0)
+		src_index[src_dim]
+		    += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	      array_offset_dst += stride_dst;
+	    }
+	  return;
+	case CAF_ARR_REF_SINGLE:
+	  array_offset_dst = (ref->u.a.dim[dst_dim].s.start
+			       - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]))
+			     * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+	  send_by_ref (ref, i, src_index, single_token, dst, src, ds
+		       + array_offset_dst * ref->item_size, sr,
+		       dst_kind, src_kind, dst_dim + 1, src_dim, 1,
+		       size, stat);
+	  return;
+	case CAF_ARR_REF_OPEN_END:
+	  COMPUTE_NUM_ITEMS (extent_dst,
+			     ref->u.a.dim[dst_dim].s.stride,
+			     ref->u.a.dim[dst_dim].s.start,
+			     GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
+	  array_offset_dst = ref->u.a.dim[dst_dim].s.start
+	      - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
+	  stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+	      * ref->u.a.dim[dst_dim].s.stride;
+	  src_index[src_dim] = 0;
+	  for (index_type idx = 0; idx < extent_dst; ++idx)
+	    {
+	      send_by_ref (ref, i, src_index, single_token, dst, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      if (src_rank > 0)
+		src_index[src_dim]
+		    += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	      array_offset_dst += stride_dst;
+	    }
+	  return;
+	case CAF_ARR_REF_OPEN_START:
+	  COMPUTE_NUM_ITEMS (extent_dst,
+			     ref->u.a.dim[dst_dim].s.stride,
+			     GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
+			     ref->u.a.dim[dst_dim].s.end);
+	  array_offset_dst = 0;
+	  stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+	      * ref->u.a.dim[dst_dim].s.stride;
+	  src_index[src_dim] = 0;
+	  for (index_type idx = 0; idx < extent_dst; ++idx)
+	    {
+	      send_by_ref (ref, i, src_index, single_token, dst, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      if (src_rank > 0)
+		src_index[src_dim]
+		    += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	      array_offset_dst += stride_dst;
+	    }
+	  return;
+	default:
+	  caf_runtime_error (unreachable);
+	}
+      return;
+    case CAF_REF_STATIC_ARRAY:
+      if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
+	{
+	  send_by_ref (ref->next, i, src_index, single_token, NULL,
+		       src, ds, sr, dst_kind, src_kind,
+		       0, src_dim, 1, size, stat);
+	  return;
+	}
+      switch (ref->u.a.mode[dst_dim])
+	{
+	case CAF_ARR_REF_VECTOR:
+	  array_offset_dst = 0;
+	  src_index[src_dim] = 0;
+	  for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
+	       ++idx)
+	    {
+#define KINDCASE(kind, type) case kind: \
+	     array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
+	      break
+
+	      switch (ref->u.a.dim[dst_dim].v.kind)
+		{
+		KINDCASE (1, GFC_INTEGER_1);
+		KINDCASE (2, GFC_INTEGER_2);
+		KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		KINDCASE (16, GFC_INTEGER_16);
+#endif
+		default:
+		  caf_runtime_error (unreachable);
+		  return;
+		}
+#undef KINDCASE
+
+	      send_by_ref (ref, i, src_index, single_token, NULL, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      src_index[src_dim]
+		  += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_FULL:
+	  src_index[src_dim] = 0;
+	  for (array_offset_dst = 0 ;
+	       array_offset_dst <= ref->u.a.dim[dst_dim].s.end;
+	       array_offset_dst += ref->u.a.dim[dst_dim].s.stride)
+	    {
+	      send_by_ref (ref, i, src_index, single_token, NULL, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      if (src_rank > 0)
+		src_index[src_dim]
+		    += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	    }
+	  return;
+	case CAF_ARR_REF_RANGE:
+	  COMPUTE_NUM_ITEMS (extent_dst,
+			     ref->u.a.dim[dst_dim].s.stride,
+			     ref->u.a.dim[dst_dim].s.start,
+			     ref->u.a.dim[dst_dim].s.end);
+	  array_offset_dst = ref->u.a.dim[dst_dim].s.start;
+	  src_index[src_dim] = 0;
+	  for (index_type idx = 0; idx < extent_dst; ++idx)
+	    {
+	      send_by_ref (ref, i, src_index, single_token, NULL, src,
+			   ds + array_offset_dst * ref->item_size, sr,
+			   dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+			   1, size, stat);
+	      if (src_rank > 0)
+		src_index[src_dim]
+		    += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+	      array_offset_dst += ref->u.a.dim[dst_dim].s.stride;
+	    }
+	  return;
+	case CAF_ARR_REF_SINGLE:
+	  array_offset_dst = ref->u.a.dim[dst_dim].s.start;
+	  send_by_ref (ref, i, src_index, single_token, NULL, src,
+		       ds + array_offset_dst * ref->item_size, sr,
+		       dst_kind, src_kind, dst_dim + 1, src_dim, 1,
+		       size, stat);
+	  return;
+	/* The OPEN_* are mapped to a RANGE and therefore can not occur.  */
+	case CAF_ARR_REF_OPEN_END:
+	case CAF_ARR_REF_OPEN_START:
+	default:
+	  caf_runtime_error (unreachable);
+	}
+      return;
+    default:
+      caf_runtime_error (unreachable);
+    }
+}
+
+
+void
+_gfortran_caf_send_by_ref (caf_token_t token,
+			   int image_index __attribute__ ((unused)),
+			   gfc_descriptor_t *src, caf_reference_t *refs,
+			   int dst_kind, int src_kind,
+			   bool may_require_tmp __attribute__ ((unused)),
+			   bool dst_reallocatable, int *stat)
+{
+  const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
+				   "unknown kind in vector-ref.\n";
+  const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): "
+				"unknown reference type.\n";
+  const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): "
+				   "unknown array reference type.\n";
+  const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): "
+				"rank out of range.\n";
+  const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): "
+      "reallocation of array followed by component ref not allowed.\n";
+  const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): "
+				"can not allocate memory.\n";
+  const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): "
+      "extent of non-allocatable array mismatch.\n";
+  const char innercompref[] = "libcaf_single::caf_send_by_ref(): "
+      "inner unallocated component detected.\n";
+  size_t size, i;
+  size_t dst_index[GFC_MAX_DIMENSIONS];
+  int src_rank = GFC_DESCRIPTOR_RANK (src);
+  int src_cur_dim = 0;
+  size_t src_size = 0;
+  caf_single_token_t single_token = TOKEN (token);
+  void *memptr = single_token->memptr;
+  gfc_descriptor_t *dst = single_token->desc;
+  caf_reference_t *riter = refs;
+  long delta;
+  bool extent_mismatch;
+  /* Note that the component is not allocated yet.  */
+  index_type new_component_idx = -1;
+
+  if (stat)
+    *stat = 0;
+
+  /* Compute the size of the result.  In the beginning size just counts the
+     number of elements.  */
+  size = 1;
+  while (riter)
+    {
+      switch (riter->type)
+	{
+	case CAF_REF_COMPONENT:
+	  if (unlikely (new_component_idx != -1))
+	    {
+	      /* Allocating a component in the middle of a component ref is not
+		 support.  We don't know the type to allocate.  */
+	      caf_internal_error (innercompref, stat, NULL, 0);
+	      return;
+	    }
+	  if (riter->u.c.caf_token_offset > 0)
+	    {
+	      /* Check whether the allocatable component is zero, then no
+		 token is present, too.  The token's pointer is not cleared
+		 when the structure is initialized.  */
+	      if (*(void**)(memptr + riter->u.c.offset) == NULL)
+		{
+		  /* This component is not yet allocated.  Check that it is
+		     allocatable here.  */
+		  if (!dst_reallocatable)
+		    {
+		      caf_internal_error (cannotallocdst, stat, NULL, 0);
+		      return;
+		    }
+		  single_token = NULL;
+		  memptr = NULL;
+		  dst = NULL;
+		  break;
+		}
+	      single_token = *(caf_single_token_t*)
+					 (memptr + riter->u.c.caf_token_offset);
+	      memptr += riter->u.c.offset;
+	      dst = single_token->desc;
+	    }
+	  else
+	    {
+	      /* Regular component.  */
+	      memptr += riter->u.c.offset;
+	      dst = (gfc_descriptor_t *)memptr;
+	    }
+	  break;
+	case CAF_REF_ARRAY:
+	  if (dst != NULL)
+	    memptr = GFC_DESCRIPTOR_DATA (dst);
+	  else
+	    dst = src;
+	  /* When the dst array needs to be allocated, then look at the
+	     extent of the source array in the dimension dst_cur_dim.  */
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_VECTOR:
+		  delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+		    memptr += (((index_type) \
+			((type *)riter->u.a.dim[i].v.vector)[0]) \
+			- GFC_DIMENSION_LBOUND (dst->dim[i])) \
+			* GFC_DIMENSION_STRIDE (dst->dim[i]) \
+			* riter->item_size; \
+		    break
+
+		  switch (riter->u.a.dim[i].v.kind)
+		    {
+		    KINDCASE (1, GFC_INTEGER_1);
+		    KINDCASE (2, GFC_INTEGER_2);
+		    KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		    KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		    KINDCASE (16, GFC_INTEGER_16);
+#endif
+		    default:
+		      caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+		      return;
+		    }
+#undef KINDCASE
+		  break;
+		case CAF_ARR_REF_FULL:
+		  if (dst)
+		    COMPUTE_NUM_ITEMS (delta,
+				       riter->u.a.dim[i].s.stride,
+				       GFC_DIMENSION_LBOUND (dst->dim[i]),
+				       GFC_DIMENSION_UBOUND (dst->dim[i]));
+		  else
+		    COMPUTE_NUM_ITEMS (delta,
+				       riter->u.a.dim[i].s.stride,
+				   GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
+				  GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
+		  break;
+		case CAF_ARR_REF_RANGE:
+		  COMPUTE_NUM_ITEMS (delta,
+				     riter->u.a.dim[i].s.stride,
+				     riter->u.a.dim[i].s.start,
+				     riter->u.a.dim[i].s.end);
+		  memptr += (riter->u.a.dim[i].s.start
+			     - dst->dim[i].lower_bound)
+		      * GFC_DIMENSION_STRIDE (dst->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_SINGLE:
+		  delta = 1;
+		  memptr += (riter->u.a.dim[i].s.start
+			     - dst->dim[i].lower_bound)
+		      * GFC_DIMENSION_STRIDE (dst->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_OPEN_END:
+		  if (dst)
+		    COMPUTE_NUM_ITEMS (delta,
+				       riter->u.a.dim[i].s.stride,
+				       riter->u.a.dim[i].s.start,
+				       GFC_DIMENSION_UBOUND (dst->dim[i]));
+		  else
+		    COMPUTE_NUM_ITEMS (delta,
+				       riter->u.a.dim[i].s.stride,
+				       riter->u.a.dim[i].s.start,
+				  GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
+		  memptr += (riter->u.a.dim[i].s.start
+			     - dst->dim[i].lower_bound)
+		      * GFC_DIMENSION_STRIDE (dst->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_OPEN_START:
+		  if (dst)
+		    COMPUTE_NUM_ITEMS (delta,
+				       riter->u.a.dim[i].s.stride,
+				       GFC_DIMENSION_LBOUND (dst->dim[i]),
+				       riter->u.a.dim[i].s.end);
+		  else
+		    COMPUTE_NUM_ITEMS (delta,
+				       riter->u.a.dim[i].s.stride,
+				   GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
+				       riter->u.a.dim[i].s.end);
+		  /* The memptr stays unchanged when ref'ing the first element
+		     in a dimension.  */
+		  break;
+		default:
+		  caf_internal_error (unknownarrreftype, stat, NULL, 0);
+		  return;
+		}
+
+	      if (delta <= 0)
+		return;
+	      /* Check the various properties of the source array.
+		 When src is an array.  */
+	      if (delta > 1 && src_rank > 0)
+		{
+		  /* Check that src_cur_dim is valid for src.  Can be
+		     superceeded only by scalar data.  */
+		  if (src_cur_dim >= src_rank)
+		    {
+		      caf_internal_error (rankoutofrange, stat, NULL, 0);
+		      return;
+		    }
+		  /* Do further checks, when the source is not scalar.  */
+		  else
+		    {
+		      /* When the realloc is required, then no extent may have
+			 been set.  */
+		      extent_mismatch = memptr == NULL
+			  || (dst
+			      && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim)
+			      != delta);
+		      /* When it already known, that a realloc is needed or
+			 the extent does not match the needed one.  */
+		      if (extent_mismatch)
+			{
+			  /* Check whether dst is reallocatable.  */
+			  if (unlikely (!dst_reallocatable))
+			    {
+			      caf_internal_error (nonallocextentmismatch, stat,
+						  NULL, 0, delta,
+						  GFC_DESCRIPTOR_EXTENT (dst,
+								  src_cur_dim));
+			      return;
+			    }
+			  /* Report error on allocatable but missing inner
+			     ref.  */
+			  else if (riter->next != NULL)
+			    {
+			      caf_internal_error (realloconinnerref, stat, NULL,
+						  0);
+			      return;
+			    }
+			}
+		      /* Only change the extent when it does not match.  This is
+			 to prevent resetting given array bounds.  */
+		      if (extent_mismatch)
+			GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta,
+					   size);
+		    }
+		  /* Increase the dim-counter of the src only when the extent
+		     matches.  */
+		  if (src_cur_dim < src_rank
+		      && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta)
+		    ++src_cur_dim;
+		}
+	      size *= (index_type)delta;
+	    }
+	  break;
+	case CAF_REF_STATIC_ARRAY:
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_VECTOR:
+		  delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+		    memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
+			* riter->item_size; \
+		    break
+
+		  switch (riter->u.a.dim[i].v.kind)
+		    {
+		    KINDCASE (1, GFC_INTEGER_1);
+		    KINDCASE (2, GFC_INTEGER_2);
+		    KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+		    KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+		    KINDCASE (16, GFC_INTEGER_16);
+#endif
+		    default:
+		      caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+		      return;
+		    }
+#undef KINDCASE
+		  break;
+		case CAF_ARR_REF_FULL:
+		  delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
+		      + 1;
+		  /* The memptr stays unchanged when ref'ing the first element
+		     in a dimension.  */
+		  break;
+		case CAF_ARR_REF_RANGE:
+		  COMPUTE_NUM_ITEMS (delta,
+				     riter->u.a.dim[i].s.stride,
+				     riter->u.a.dim[i].s.start,
+				     riter->u.a.dim[i].s.end);
+		  memptr += riter->u.a.dim[i].s.start
+		      * riter->u.a.dim[i].s.stride
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_SINGLE:
+		  delta = 1;
+		  memptr += riter->u.a.dim[i].s.start
+		      * riter->u.a.dim[i].s.stride
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_OPEN_END:
+		  /* This and OPEN_START are mapped to a RANGE and therefore
+		     can not occur here.  */
+		case CAF_ARR_REF_OPEN_START:
+		default:
+		  caf_internal_error (unknownarrreftype, stat, NULL, 0);
+		  return;
+		}
+	      if (delta <= 0)
+		return;
+	      /* Check the various properties of the source array.
+		 Only when the source array is not scalar examine its
+		 properties.  */
+	      if (delta > 1 && src_rank > 0)
+		{
+		  /* Check that src_cur_dim is valid for src.  Can be
+		     superceeded only by scalar data.  */
+		  if (src_cur_dim >= src_rank)
+		    {
+		      caf_internal_error (rankoutofrange, stat, NULL, 0);
+		      return;
+		    }
+		  else
+		    {
+		      /* We will not be able to realloc the dst, because that's
+			 a fixed size array.  */
+		      extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim)
+			      != delta;
+		      /* When the extent does not match the needed one we can
+			 only stop here.  */
+		      if (extent_mismatch)
+			{
+			  caf_internal_error (nonallocextentmismatch, stat,
+					      NULL, 0, delta,
+					      GFC_DESCRIPTOR_EXTENT (src,
+								  src_cur_dim));
+			  return;
+			}
+		    }
+		  ++src_cur_dim;
+		}
+	      size *= (index_type)delta;
+	    }
+	  break;
+	default:
+	  caf_internal_error (unknownreftype, stat, NULL, 0);
+	  return;
+	}
+      src_size = riter->item_size;
+      riter = riter->next;
+    }
+  if (size == 0 || src_size == 0)
+    return;
+  /* Postcondition:
+     - size contains the number of elements to store in the destination array,
+     - src_size gives the size in bytes of each item in the destination array.
+  */
+
+  /* Reset the token.  */
+  single_token = TOKEN (token);
+  memptr = single_token->memptr;
+  dst = single_token->desc;
+  memset (dst_index, 0, sizeof (dst_index));
+  i = 0;
+  send_by_ref (refs, &i, dst_index, single_token, dst, src,
+	       memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0,
+	       1, size, stat);
+  assert (i == size);
+}
+
+
+void
+_gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index,
+			      caf_reference_t *dst_refs, caf_token_t src_token,
+			      int src_image_index,
+			      caf_reference_t *src_refs, int dst_kind,
+			      int src_kind, bool may_require_tmp, int *dst_stat,
+			      int *src_stat)
+{
+  gfc_array_void temp;
+
+  _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs,
+			    dst_kind, src_kind, may_require_tmp, true,
+			    src_stat);
+
+  if (src_stat && *src_stat != 0)
+    return;
+
+  _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs,
+			     dst_kind, src_kind, may_require_tmp, true,
+			     dst_stat);
+  if (GFC_DESCRIPTOR_DATA (&temp))
+    free (GFC_DESCRIPTOR_DATA (&temp));
+}
+
+
+void
+_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
+			     int image_index __attribute__ ((unused)),
+			     void *value, int *stat,
+			     int type __attribute__ ((unused)), int kind)
+{
+  assert(kind == 4);
+
+  uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+  __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
+
+  if (stat)
+    *stat = 0;
+}
+
+void
+_gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
+			  int image_index __attribute__ ((unused)),
+			  void *value, int *stat,
+			  int type __attribute__ ((unused)), int kind)
+{
+  assert(kind == 4);
+
+  uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+  __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
+
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+_gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
+			  int image_index __attribute__ ((unused)),
+			  void *old, void *compare, void *new_val, int *stat,
+			  int type __attribute__ ((unused)), int kind)
+{
+  assert(kind == 4);
+
+  uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+  *(uint32_t *) old = *(uint32_t *) compare;
+  (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
+				      *(uint32_t *) new_val, false,
+				      __ATOMIC_RELAXED, __ATOMIC_RELAXED);
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
+			 int image_index __attribute__ ((unused)),
+			 void *value, void *old, int *stat,
+			 int type __attribute__ ((unused)), int kind)
+{
+  assert(kind == 4);
+
+  uint32_t res;
+  uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+  switch (op)
+    {
+    case GFC_CAF_ATOMIC_ADD:
+      res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+      break;
+    case GFC_CAF_ATOMIC_AND:
+      res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+      break;
+    case GFC_CAF_ATOMIC_OR:
+      res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+      break;
+    case GFC_CAF_ATOMIC_XOR:
+      res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+      break;
+    default:
+      __builtin_unreachable();
+    }
+
+  if (old)
+    *(uint32_t *) old = res;
+
+  if (stat)
+    *stat = 0;
+}
+
+void
+_gfortran_caf_event_post (caf_token_t token, size_t index, 
+			  int image_index __attribute__ ((unused)), 
+			  int *stat, char *errmsg __attribute__ ((unused)), 
+			  int errmsg_len __attribute__ ((unused)))
+{
+  uint32_t value = 1;
+  uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+				  * sizeof (uint32_t));
+  __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+  
+  if(stat)
+    *stat = 0;
+}
+
+void
+_gfortran_caf_event_wait (caf_token_t token, size_t index, 
+			  int until_count, int *stat,
+			  char *errmsg __attribute__ ((unused)), 
+			  int errmsg_len __attribute__ ((unused)))
+{
+  uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+				  * sizeof (uint32_t));
+  uint32_t value = (uint32_t)-until_count;
+   __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+  
+   if(stat)
+    *stat = 0;    
+}
+
+void
+_gfortran_caf_event_query (caf_token_t token, size_t index, 
+			   int image_index __attribute__ ((unused)), 
+			   int *count, int *stat)
+{
+  uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+				  * sizeof (uint32_t));
+  __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
+  
+  if(stat)
+    *stat = 0;
+}
+
+void
+_gfortran_caf_lock (caf_token_t token, size_t index,
+		    int image_index __attribute__ ((unused)),
+		    int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
+{
+  const char *msg = "Already locked";
+  bool *lock = &((bool *) MEMTOK (token))[index];
+
+  if (!*lock)
+    {
+      *lock = true;
+      if (aquired_lock)
+	*aquired_lock = (int) true;
+      if (stat)
+	*stat = 0;
+      return;
+    }
+
+  if (aquired_lock)
+    {
+      *aquired_lock = (int) false;
+      if (stat)
+	*stat = 0;
+    return;
+    }
+
+
+  if (stat)
+    {
+      *stat = 1;
+      if (errmsg_len > 0)
+	{
+	  int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
+						      : (int) sizeof (msg);
+	  memcpy (errmsg, msg, len);
+	  if (errmsg_len > len)
+	    memset (&errmsg[len], ' ', errmsg_len-len);
+	}
+      return;
+    }
+  _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
+}
+
+
+void
+_gfortran_caf_unlock (caf_token_t token, size_t index,
+		      int image_index __attribute__ ((unused)),
+		      int *stat, char *errmsg, int errmsg_len)
+{
+  const char *msg = "Variable is not locked";
+  bool *lock = &((bool *) MEMTOK (token))[index];
+
+  if (*lock)
+    {
+      *lock = false;
+      if (stat)
+	*stat = 0;
+      return;
+    }
+
+  if (stat)
+    {
+      *stat = 1;
+      if (errmsg_len > 0)
+	{
+	  int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
+						      : (int) sizeof (msg);
+	  memcpy (errmsg, msg, len);
+	  if (errmsg_len > len)
+	    memset (&errmsg[len], ' ', errmsg_len-len);
+	}
+      return;
+    }
+  _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
+}
+
+int
+_gfortran_caf_is_present (caf_token_t token,
+			  int image_index __attribute__ ((unused)),
+			  caf_reference_t *refs)
+{
+  const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
+				   "only scalar indexes allowed.\n";
+  const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
+				"unknown reference type.\n";
+  const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
+				   "unknown array reference type.\n";
+  size_t i;
+  caf_single_token_t single_token = TOKEN (token);
+  void *memptr = single_token->memptr;
+  gfc_descriptor_t *src = single_token->desc;
+  caf_reference_t *riter = refs;
+
+  while (riter)
+    {
+      switch (riter->type)
+	{
+	case CAF_REF_COMPONENT:
+	  if (riter->u.c.caf_token_offset)
+	    {
+	      single_token = *(caf_single_token_t*)
+					 (memptr + riter->u.c.caf_token_offset);
+	      memptr = single_token->memptr;
+	      src = single_token->desc;
+	    }
+	  else
+	    {
+	      memptr += riter->u.c.offset;
+	      src = (gfc_descriptor_t *)memptr;
+	    }
+	  break;
+	case CAF_REF_ARRAY:
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_SINGLE:
+		  memptr += (riter->u.a.dim[i].s.start
+			     - GFC_DIMENSION_LBOUND (src->dim[i]))
+		      * GFC_DIMENSION_STRIDE (src->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_FULL:
+		  /* A full array ref is allowed on the last reference only.  */
+		  if (riter->next == NULL)
+		    break;
+		  /* else fall through reporting an error.  */
+		  /* FALLTHROUGH */
+		case CAF_ARR_REF_VECTOR:
+		case CAF_ARR_REF_RANGE:
+		case CAF_ARR_REF_OPEN_END:
+		case CAF_ARR_REF_OPEN_START:
+		  caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+		  return 0;
+		default:
+		  caf_internal_error (unknownarrreftype, 0, NULL, 0);
+		  return 0;
+		}
+	    }
+	  break;
+	case CAF_REF_STATIC_ARRAY:
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_SINGLE:
+		  memptr += riter->u.a.dim[i].s.start
+		      * riter->u.a.dim[i].s.stride
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_FULL:
+		  /* A full array ref is allowed on the last reference only.  */
+		  if (riter->next == NULL)
+		    break;
+		  /* else fall through reporting an error.  */
+		  /* FALLTHROUGH */
+		case CAF_ARR_REF_VECTOR:
+		case CAF_ARR_REF_RANGE:
+		case CAF_ARR_REF_OPEN_END:
+		case CAF_ARR_REF_OPEN_START:
+		  caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+		  return 0;
+		default:
+		  caf_internal_error (unknownarrreftype, 0, NULL, 0);
+		  return 0;
+		}
+	    }
+	  break;
+	default:
+	  caf_internal_error (unknownreftype, 0, NULL, 0);
+	  return 0;
+	}
+      riter = riter->next;
+    }
+  return memptr != NULL;
+}