--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/fortran/trans-array.c	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,10619 @@
+/* Array translation routines
+   Copyright (C) 2002-2017 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+   and Steven Bosscher <s.bosscher@student.tudelft.nl>
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+/* trans-array.c-- Various array related code, including scalarization,
+                   allocation, initialization and other support routines.  */
+
+/* How the scalarizer works.
+   In gfortran, array expressions use the same core routines as scalar
+   expressions.
+   First, a Scalarization State (SS) chain is built.  This is done by walking
+   the expression tree, and building a linear list of the terms in the
+   expression.  As the tree is walked, scalar subexpressions are translated.
+
+   The scalarization parameters are stored in a gfc_loopinfo structure.
+   First the start and stride of each term is calculated by
+   gfc_conv_ss_startstride.  During this process the expressions for the array
+   descriptors and data pointers are also translated.
+
+   If the expression is an assignment, we must then resolve any dependencies.
+   In Fortran all the rhs values of an assignment must be evaluated before
+   any assignments take place.  This can require a temporary array to store the
+   values.  We also require a temporary when we are passing array expressions
+   or vector subscripts as procedure parameters.
+
+   Array sections are passed without copying to a temporary.  These use the
+   scalarizer to determine the shape of the section.  The flag
+   loop->array_parameter tells the scalarizer that the actual values and loop
+   variables will not be required.
+
+   The function gfc_conv_loop_setup generates the scalarization setup code.
+   It determines the range of the scalarizing loop variables.  If a temporary
+   is required, this is created and initialized.  Code for scalar expressions
+   taken outside the loop is also generated at this time.  Next the offset and
+   scaling required to translate from loop variables to array indices for each
+   term is calculated.
+
+   A call to gfc_start_scalarized_body marks the start of the scalarized
+   expression.  This creates a scope and declares the loop variables.  Before
+   calling this gfc_make_ss_chain_used must be used to indicate which terms
+   will be used inside this loop.
+
+   The scalar gfc_conv_* functions are then used to build the main body of the
+   scalarization loop.  Scalarization loop variables and precalculated scalar
+   values are automatically substituted.  Note that gfc_advance_se_ss_chain
+   must be used, rather than changing the se->ss directly.
+
+   For assignment expressions requiring a temporary two sub loops are
+   generated.  The first stores the result of the expression in the temporary,
+   the second copies it to the result.  A call to
+   gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
+   the start of the copying loop.  The temporary may be less than full rank.
+
+   Finally gfc_trans_scalarizing_loops is called to generate the implicit do
+   loops.  The loops are added to the pre chain of the loopinfo.  The post
+   chain may still contain cleanup code.
+
+   After the loop code has been added into its parent scope gfc_cleanup_loop
+   is called to free all the SS allocated by the scalarizer.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+#include "tree.h"
+#include "gfortran.h"
+#include "gimple-expr.h"
+#include "trans.h"
+#include "fold-const.h"
+#include "constructor.h"
+#include "trans-types.h"
+#include "trans-array.h"
+#include "trans-const.h"
+#include "dependency.h"
+
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
+
+/* The contents of this structure aren't actually used, just the address.  */
+static gfc_ss gfc_ss_terminator_var;
+gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
+
+
+static tree
+gfc_array_dataptr_type (tree desc)
+{
+  return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
+}
+
+
+/* Build expressions to access the members of an array descriptor.
+   It's surprisingly easy to mess up here, so never access
+   an array descriptor by "brute force", always use these
+   functions.  This also avoids problems if we change the format
+   of an array descriptor.
+
+   To understand these magic numbers, look at the comments
+   before gfc_build_array_type() in trans-types.c.
+
+   The code within these defines should be the only code which knows the format
+   of an array descriptor.
+
+   Any code just needing to read obtain the bounds of an array should use
+   gfc_conv_array_* rather than the following functions as these will return
+   know constant values, and work with arrays which do not have descriptors.
+
+   Don't forget to #undef these!  */
+
+#define DATA_FIELD 0
+#define OFFSET_FIELD 1
+#define DTYPE_FIELD 2
+#define SPAN_FIELD 3
+#define DIMENSION_FIELD 4
+#define CAF_TOKEN_FIELD 5
+
+#define STRIDE_SUBFIELD 0
+#define LBOUND_SUBFIELD 1
+#define UBOUND_SUBFIELD 2
+
+/* This provides READ-ONLY access to the data field.  The field itself
+   doesn't have the proper type.  */
+
+tree
+gfc_conv_descriptor_data_get (tree desc)
+{
+  tree field, type, t;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = TYPE_FIELDS (type);
+  gcc_assert (DATA_FIELD == 0);
+
+  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
+		       field, NULL_TREE);
+  t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
+
+  return t;
+}
+
+/* This provides WRITE access to the data field.
+
+   TUPLES_P is true if we are generating tuples.
+
+   This function gets called through the following macros:
+     gfc_conv_descriptor_data_set
+     gfc_conv_descriptor_data_set.  */
+
+void
+gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
+{
+  tree field, type, t;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = TYPE_FIELDS (type);
+  gcc_assert (DATA_FIELD == 0);
+
+  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
+		       field, NULL_TREE);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
+}
+
+
+/* This provides address access to the data field.  This should only be
+   used by array allocation, passing this on to the runtime.  */
+
+tree
+gfc_conv_descriptor_data_addr (tree desc)
+{
+  tree field, type, t;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = TYPE_FIELDS (type);
+  gcc_assert (DATA_FIELD == 0);
+
+  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
+		       field, NULL_TREE);
+  return gfc_build_addr_expr (NULL_TREE, t);
+}
+
+static tree
+gfc_conv_descriptor_offset (tree desc)
+{
+  tree type;
+  tree field;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+tree
+gfc_conv_descriptor_offset_get (tree desc)
+{
+  return gfc_conv_descriptor_offset (desc);
+}
+
+void
+gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
+				tree value)
+{
+  tree t = gfc_conv_descriptor_offset (desc);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+
+tree
+gfc_conv_descriptor_dtype (tree desc)
+{
+  tree field;
+  tree type;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+static tree
+gfc_conv_descriptor_span (tree desc)
+{
+  tree type;
+  tree field;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+tree
+gfc_conv_descriptor_span_get (tree desc)
+{
+  return gfc_conv_descriptor_span (desc);
+}
+
+void
+gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
+				tree value)
+{
+  tree t = gfc_conv_descriptor_span (desc);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+
+tree
+gfc_conv_descriptor_rank (tree desc)
+{
+  tree tmp;
+  tree dtype;
+
+  dtype = gfc_conv_descriptor_dtype (desc);
+  tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+  tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+			 dtype, tmp);
+  return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
+tree
+gfc_get_descriptor_dimension (tree desc)
+{
+  tree type, field;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
+  gcc_assert (field != NULL_TREE
+	  && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
+	  && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_dimension (tree desc, tree dim)
+{
+  tree tmp;
+
+  tmp = gfc_get_descriptor_dimension (desc);
+
+  return gfc_build_array_ref (tmp, dim, NULL);
+}
+
+
+tree
+gfc_conv_descriptor_token (tree desc)
+{
+  tree type;
+  tree field;
+
+  type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
+  field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
+
+  /* Should be a restricted pointer - except in the finalization wrapper.  */
+  gcc_assert (field != NULL_TREE
+	      && (TREE_TYPE (field) == prvoid_type_node
+		  || TREE_TYPE (field) == pvoid_type_node));
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_stride (tree desc, tree dim)
+{
+  tree tmp;
+  tree field;
+
+  tmp = gfc_conv_descriptor_dimension (desc, dim);
+  field = TYPE_FIELDS (TREE_TYPE (tmp));
+  field = gfc_advance_chain (field, STRIDE_SUBFIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 tmp, field, NULL_TREE);
+  return tmp;
+}
+
+tree
+gfc_conv_descriptor_stride_get (tree desc, tree dim)
+{
+  tree type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  if (integer_zerop (dim)
+      && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
+    return gfc_index_one_node;
+
+  return gfc_conv_descriptor_stride (desc, dim);
+}
+
+void
+gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
+				tree dim, tree value)
+{
+  tree t = gfc_conv_descriptor_stride (desc, dim);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+static tree
+gfc_conv_descriptor_lbound (tree desc, tree dim)
+{
+  tree tmp;
+  tree field;
+
+  tmp = gfc_conv_descriptor_dimension (desc, dim);
+  field = TYPE_FIELDS (TREE_TYPE (tmp));
+  field = gfc_advance_chain (field, LBOUND_SUBFIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 tmp, field, NULL_TREE);
+  return tmp;
+}
+
+tree
+gfc_conv_descriptor_lbound_get (tree desc, tree dim)
+{
+  return gfc_conv_descriptor_lbound (desc, dim);
+}
+
+void
+gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
+				tree dim, tree value)
+{
+  tree t = gfc_conv_descriptor_lbound (desc, dim);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+static tree
+gfc_conv_descriptor_ubound (tree desc, tree dim)
+{
+  tree tmp;
+  tree field;
+
+  tmp = gfc_conv_descriptor_dimension (desc, dim);
+  field = TYPE_FIELDS (TREE_TYPE (tmp));
+  field = gfc_advance_chain (field, UBOUND_SUBFIELD);
+  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 tmp, field, NULL_TREE);
+  return tmp;
+}
+
+tree
+gfc_conv_descriptor_ubound_get (tree desc, tree dim)
+{
+  return gfc_conv_descriptor_ubound (desc, dim);
+}
+
+void
+gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
+				tree dim, tree value)
+{
+  tree t = gfc_conv_descriptor_ubound (desc, dim);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+/* Build a null array descriptor constructor.  */
+
+tree
+gfc_build_null_descriptor (tree type)
+{
+  tree field;
+  tree tmp;
+
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  gcc_assert (DATA_FIELD == 0);
+  field = TYPE_FIELDS (type);
+
+  /* Set a NULL data pointer.  */
+  tmp = build_constructor_single (type, field, null_pointer_node);
+  TREE_CONSTANT (tmp) = 1;
+  /* All other fields are ignored.  */
+
+  return tmp;
+}
+
+
+/* Modify a descriptor such that the lbound of a given dimension is the value
+   specified.  This also updates ubound and offset accordingly.  */
+
+void
+gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
+				  int dim, tree new_lbound)
+{
+  tree offs, ubound, lbound, stride;
+  tree diff, offs_diff;
+
+  new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+
+  offs = gfc_conv_descriptor_offset_get (desc);
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+  stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+
+  /* Get difference (new - old) by which to shift stuff.  */
+  diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			  new_lbound, lbound);
+
+  /* Shift ubound and offset accordingly.  This has to be done before
+     updating the lbound, as they depend on the lbound expression!  */
+  ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			    ubound, diff);
+  gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
+  offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			       diff, stride);
+  offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			  offs, offs_diff);
+  gfc_conv_descriptor_offset_set (block, desc, offs);
+
+  /* Finally set lbound to value we want.  */
+  gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+}
+
+
+/* Obtain offsets for trans-types.c(gfc_get_array_descr_info).  */
+
+void
+gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
+				     tree *dtype_off, tree *dim_off,
+				     tree *dim_size, tree *stride_suboff,
+				     tree *lower_suboff, tree *upper_suboff)
+{
+  tree field;
+  tree type;
+
+  type = TYPE_MAIN_VARIANT (desc_type);
+  field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
+  *data_off = byte_position (field);
+  field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+  *dtype_off = byte_position (field);
+  field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
+  *dim_off = byte_position (field);
+  type = TREE_TYPE (TREE_TYPE (field));
+  *dim_size = TYPE_SIZE_UNIT (type);
+  field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
+  *stride_suboff = byte_position (field);
+  field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
+  *lower_suboff = byte_position (field);
+  field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
+  *upper_suboff = byte_position (field);
+}
+
+
+/* Cleanup those #defines.  */
+
+#undef DATA_FIELD
+#undef OFFSET_FIELD
+#undef DTYPE_FIELD
+#undef SPAN_FIELD
+#undef DIMENSION_FIELD
+#undef CAF_TOKEN_FIELD
+#undef STRIDE_SUBFIELD
+#undef LBOUND_SUBFIELD
+#undef UBOUND_SUBFIELD
+
+
+/* Mark a SS chain as used.  Flags specifies in which loops the SS is used.
+   flags & 1 = Main loop body.
+   flags & 2 = temp copy loop.  */
+
+void
+gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
+{
+  for (; ss != gfc_ss_terminator; ss = ss->next)
+    ss->info->useflags = flags;
+}
+
+
+/* Free a gfc_ss chain.  */
+
+void
+gfc_free_ss_chain (gfc_ss * ss)
+{
+  gfc_ss *next;
+
+  while (ss != gfc_ss_terminator)
+    {
+      gcc_assert (ss != NULL);
+      next = ss->next;
+      gfc_free_ss (ss);
+      ss = next;
+    }
+}
+
+
+static void
+free_ss_info (gfc_ss_info *ss_info)
+{
+  int n;
+
+  ss_info->refcount--;
+  if (ss_info->refcount > 0)
+    return;
+
+  gcc_assert (ss_info->refcount == 0);
+
+  switch (ss_info->type)
+    {
+    case GFC_SS_SECTION:
+      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+	if (ss_info->data.array.subscript[n])
+	  gfc_free_ss_chain (ss_info->data.array.subscript[n]);
+      break;
+
+    default:
+      break;
+    }
+
+  free (ss_info);
+}
+
+
+/* Free a SS.  */
+
+void
+gfc_free_ss (gfc_ss * ss)
+{
+  free_ss_info (ss->info);
+  free (ss);
+}
+
+
+/* Creates and initializes an array type gfc_ss struct.  */
+
+gfc_ss *
+gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
+{
+  gfc_ss *ss;
+  gfc_ss_info *ss_info;
+  int i;
+
+  ss_info = gfc_get_ss_info ();
+  ss_info->refcount++;
+  ss_info->type = type;
+  ss_info->expr = expr;
+
+  ss = gfc_get_ss ();
+  ss->info = ss_info;
+  ss->next = next;
+  ss->dimen = dimen;
+  for (i = 0; i < ss->dimen; i++)
+    ss->dim[i] = i;
+
+  return ss;
+}
+
+
+/* Creates and initializes a temporary type gfc_ss struct.  */
+
+gfc_ss *
+gfc_get_temp_ss (tree type, tree string_length, int dimen)
+{
+  gfc_ss *ss;
+  gfc_ss_info *ss_info;
+  int i;
+
+  ss_info = gfc_get_ss_info ();
+  ss_info->refcount++;
+  ss_info->type = GFC_SS_TEMP;
+  ss_info->string_length = string_length;
+  ss_info->data.temp.type = type;
+
+  ss = gfc_get_ss ();
+  ss->info = ss_info;
+  ss->next = gfc_ss_terminator;
+  ss->dimen = dimen;
+  for (i = 0; i < ss->dimen; i++)
+    ss->dim[i] = i;
+
+  return ss;
+}
+
+
+/* Creates and initializes a scalar type gfc_ss struct.  */
+
+gfc_ss *
+gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
+{
+  gfc_ss *ss;
+  gfc_ss_info *ss_info;
+
+  ss_info = gfc_get_ss_info ();
+  ss_info->refcount++;
+  ss_info->type = GFC_SS_SCALAR;
+  ss_info->expr = expr;
+
+  ss = gfc_get_ss ();
+  ss->info = ss_info;
+  ss->next = next;
+
+  return ss;
+}
+
+
+/* Free all the SS associated with a loop.  */
+
+void
+gfc_cleanup_loop (gfc_loopinfo * loop)
+{
+  gfc_loopinfo *loop_next, **ploop;
+  gfc_ss *ss;
+  gfc_ss *next;
+
+  ss = loop->ss;
+  while (ss != gfc_ss_terminator)
+    {
+      gcc_assert (ss != NULL);
+      next = ss->loop_chain;
+      gfc_free_ss (ss);
+      ss = next;
+    }
+
+  /* Remove reference to self in the parent loop.  */
+  if (loop->parent)
+    for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
+      if (*ploop == loop)
+	{
+	  *ploop = loop->next;
+	  break;
+	}
+
+  /* Free non-freed nested loops.  */
+  for (loop = loop->nested; loop; loop = loop_next)
+    {
+      loop_next = loop->next;
+      gfc_cleanup_loop (loop);
+      free (loop);
+    }
+}
+
+
+static void
+set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
+{
+  int n;
+
+  for (; ss != gfc_ss_terminator; ss = ss->next)
+    {
+      ss->loop = loop;
+
+      if (ss->info->type == GFC_SS_SCALAR
+	  || ss->info->type == GFC_SS_REFERENCE
+	  || ss->info->type == GFC_SS_TEMP)
+	continue;
+
+      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+	if (ss->info->data.array.subscript[n] != NULL)
+	  set_ss_loop (ss->info->data.array.subscript[n], loop);
+    }
+}
+
+
+/* Associate a SS chain with a loop.  */
+
+void
+gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
+{
+  gfc_ss *ss;
+  gfc_loopinfo *nested_loop;
+
+  if (head == gfc_ss_terminator)
+    return;
+
+  set_ss_loop (head, loop);
+
+  ss = head;
+  for (; ss && ss != gfc_ss_terminator; ss = ss->next)
+    {
+      if (ss->nested_ss)
+	{
+	  nested_loop = ss->nested_ss->loop;
+
+	  /* More than one ss can belong to the same loop.  Hence, we add the
+	     loop to the chain only if it is different from the previously
+	     added one, to avoid duplicate nested loops.  */
+	  if (nested_loop != loop->nested)
+	    {
+	      gcc_assert (nested_loop->parent == NULL);
+	      nested_loop->parent = loop;
+
+	      gcc_assert (nested_loop->next == NULL);
+	      nested_loop->next = loop->nested;
+	      loop->nested = nested_loop;
+	    }
+	  else
+	    gcc_assert (nested_loop->parent == loop);
+	}
+
+      if (ss->next == gfc_ss_terminator)
+	ss->loop_chain = loop->ss;
+      else
+	ss->loop_chain = ss->next;
+    }
+  gcc_assert (ss == gfc_ss_terminator);
+  loop->ss = head;
+}
+
+
+/* Returns true if the expression is an array pointer.  */
+
+static bool
+is_pointer_array (tree expr)
+{
+  if (flag_openmp)
+    return false;
+
+  if (expr == NULL_TREE
+      || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
+      || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
+    return false;
+
+  if (TREE_CODE (expr) == VAR_DECL
+      && GFC_DECL_PTR_ARRAY_P (expr))
+    return true;
+
+  if (TREE_CODE (expr) == PARM_DECL
+      && GFC_DECL_PTR_ARRAY_P (expr))
+    return true;
+
+  if (TREE_CODE (expr) == INDIRECT_REF
+      && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
+    return true;
+
+  /* The field declaration is marked as an pointer array.  */
+  if (TREE_CODE (expr) == COMPONENT_REF
+      && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
+      && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
+    return true;
+
+  return false;
+}
+
+
+/* Return the span of an array.  */
+
+static tree
+get_array_span (tree desc, gfc_expr *expr)
+{
+  tree tmp;
+
+  if (is_pointer_array (desc))
+    /* This will have the span field set.  */
+    tmp = gfc_conv_descriptor_span_get (desc);
+  else if (TREE_CODE (desc) == COMPONENT_REF
+	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+	   && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
+    {
+      /* The descriptor is a class _data field and so use the vtable
+	 size for the receiving span field.  */
+      tmp = gfc_get_vptr_from_expr (desc);
+      tmp = gfc_vptr_size_get (tmp);
+    }
+  else if (expr && expr->expr_type == EXPR_VARIABLE
+	   && expr->symtree->n.sym->ts.type == BT_CLASS
+	   && expr->ref->type == REF_COMPONENT
+	   && expr->ref->next->type == REF_ARRAY
+	   && expr->ref->next->next == NULL
+	   && CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
+    {
+      /* Dummys come in sometimes with the descriptor detached from
+	 the class field or declaration.  */
+      tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
+      tmp = gfc_vptr_size_get (tmp);
+    }
+  else
+    {
+      /* If none of the fancy stuff works, the span is the element
+	 size of the array.  */
+      tmp = gfc_get_element_type (TREE_TYPE (desc));
+      tmp = fold_convert (gfc_array_index_type,
+			  size_in_bytes (tmp));
+    }
+  return tmp;
+}
+
+
+/* Generate an initializer for a static pointer or allocatable array.  */
+
+void
+gfc_trans_static_array_pointer (gfc_symbol * sym)
+{
+  tree type;
+
+  gcc_assert (TREE_STATIC (sym->backend_decl));
+  /* Just zero the data member.  */
+  type = TREE_TYPE (sym->backend_decl);
+  DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
+}
+
+
+/* If the bounds of SE's loop have not yet been set, see if they can be
+   determined from array spec AS, which is the array spec of a called
+   function.  MAPPING maps the callee's dummy arguments to the values
+   that the caller is passing.  Add any initialization and finalization
+   code to SE.  */
+
+void
+gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
+				     gfc_se * se, gfc_array_spec * as)
+{
+  int n, dim, total_dim;
+  gfc_se tmpse;
+  gfc_ss *ss;
+  tree lower;
+  tree upper;
+  tree tmp;
+
+  total_dim = 0;
+
+  if (!as || as->type != AS_EXPLICIT)
+    return;
+
+  for (ss = se->ss; ss; ss = ss->parent)
+    {
+      total_dim += ss->loop->dimen;
+      for (n = 0; n < ss->loop->dimen; n++)
+	{
+	  /* The bound is known, nothing to do.  */
+	  if (ss->loop->to[n] != NULL_TREE)
+	    continue;
+
+	  dim = ss->dim[n];
+	  gcc_assert (dim < as->rank);
+	  gcc_assert (ss->loop->dimen <= as->rank);
+
+	  /* Evaluate the lower bound.  */
+	  gfc_init_se (&tmpse, NULL);
+	  gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
+	  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+	  gfc_add_block_to_block (&se->post, &tmpse.post);
+	  lower = fold_convert (gfc_array_index_type, tmpse.expr);
+
+	  /* ...and the upper bound.  */
+	  gfc_init_se (&tmpse, NULL);
+	  gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+	  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+	  gfc_add_block_to_block (&se->post, &tmpse.post);
+	  upper = fold_convert (gfc_array_index_type, tmpse.expr);
+
+	  /* Set the upper bound of the loop to UPPER - LOWER.  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, upper, lower);
+	  tmp = gfc_evaluate_now (tmp, &se->pre);
+	  ss->loop->to[n] = tmp;
+	}
+    }
+
+  gcc_assert (total_dim == as->rank);
+}
+
+
+/* Generate code to allocate an array temporary, or create a variable to
+   hold the data.  If size is NULL, zero the descriptor so that the
+   callee will allocate the array.  If DEALLOC is true, also generate code to
+   free the array afterwards.
+
+   If INITIAL is not NULL, it is packed using internal_pack and the result used
+   as data instead of allocating a fresh, unitialized area of memory.
+
+   Initialization code is added to PRE and finalization code to POST.
+   DYNAMIC is true if the caller may want to extend the array later
+   using realloc.  This prevents us from putting the array on the stack.  */
+
+static void
+gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
+				  gfc_array_info * info, tree size, tree nelem,
+				  tree initial, bool dynamic, bool dealloc)
+{
+  tree tmp;
+  tree desc;
+  bool onstack;
+
+  desc = info->descriptor;
+  info->offset = gfc_index_zero_node;
+  if (size == NULL_TREE || integer_zerop (size))
+    {
+      /* A callee allocated array.  */
+      gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
+      onstack = FALSE;
+    }
+  else
+    {
+      /* Allocate the temporary.  */
+      onstack = !dynamic && initial == NULL_TREE
+			 && (flag_stack_arrays
+			     || gfc_can_put_var_on_stack (size));
+
+      if (onstack)
+	{
+	  /* Make a temporary variable to hold the data.  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
+				 nelem, gfc_index_one_node);
+	  tmp = gfc_evaluate_now (tmp, pre);
+	  tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+				  tmp);
+	  tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
+				  tmp);
+	  tmp = gfc_create_var (tmp, "A");
+	  /* If we're here only because of -fstack-arrays we have to
+	     emit a DECL_EXPR to make the gimplifier emit alloca calls.  */
+	  if (!gfc_can_put_var_on_stack (size))
+	    gfc_add_expr_to_block (pre,
+				   fold_build1_loc (input_location,
+						    DECL_EXPR, TREE_TYPE (tmp),
+						    tmp));
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  gfc_conv_descriptor_data_set (pre, desc, tmp);
+	}
+      else
+	{
+	  /* Allocate memory to hold the data or call internal_pack.  */
+	  if (initial == NULL_TREE)
+	    {
+	      tmp = gfc_call_malloc (pre, NULL, size);
+	      tmp = gfc_evaluate_now (tmp, pre);
+	    }
+	  else
+	    {
+	      tree packed;
+	      tree source_data;
+	      tree was_packed;
+	      stmtblock_t do_copying;
+
+	      tmp = TREE_TYPE (initial); /* Pointer to descriptor.  */
+	      gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
+	      tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
+	      tmp = gfc_get_element_type (tmp);
+	      gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
+	      packed = gfc_create_var (build_pointer_type (tmp), "data");
+
+	      tmp = build_call_expr_loc (input_location,
+				     gfor_fndecl_in_pack, 1, initial);
+	      tmp = fold_convert (TREE_TYPE (packed), tmp);
+	      gfc_add_modify (pre, packed, tmp);
+
+	      tmp = build_fold_indirect_ref_loc (input_location,
+					     initial);
+	      source_data = gfc_conv_descriptor_data_get (tmp);
+
+	      /* internal_pack may return source->data without any allocation
+		 or copying if it is already packed.  If that's the case, we
+		 need to allocate and copy manually.  */
+
+	      gfc_start_block (&do_copying);
+	      tmp = gfc_call_malloc (&do_copying, NULL, size);
+	      tmp = fold_convert (TREE_TYPE (packed), tmp);
+	      gfc_add_modify (&do_copying, packed, tmp);
+	      tmp = gfc_build_memcpy_call (packed, source_data, size);
+	      gfc_add_expr_to_block (&do_copying, tmp);
+
+	      was_packed = fold_build2_loc (input_location, EQ_EXPR,
+					    boolean_type_node, packed,
+					    source_data);
+	      tmp = gfc_finish_block (&do_copying);
+	      tmp = build3_v (COND_EXPR, was_packed, tmp,
+			      build_empty_stmt (input_location));
+	      gfc_add_expr_to_block (pre, tmp);
+
+	      tmp = fold_convert (pvoid_type_node, packed);
+	    }
+
+	  gfc_conv_descriptor_data_set (pre, desc, tmp);
+	}
+    }
+  info->data = gfc_conv_descriptor_data_get (desc);
+
+  /* The offset is zero because we create temporaries with a zero
+     lower bound.  */
+  gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
+
+  if (dealloc && !onstack)
+    {
+      /* Free the temporary.  */
+      tmp = gfc_conv_descriptor_data_get (desc);
+      tmp = gfc_call_free (tmp);
+      gfc_add_expr_to_block (post, tmp);
+    }
+}
+
+
+/* Get the scalarizer array dimension corresponding to actual array dimension
+   given by ARRAY_DIM.
+
+   For example, if SS represents the array ref a(1,:,:,1), it is a
+   bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
+   and 1 for ARRAY_DIM=2.
+   If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
+   scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
+   ARRAY_DIM=3.
+   If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
+   array.  If called on the inner ss, the result would be respectively 0,1,2 for
+   ARRAY_DIM=0,1,2.  If called on the outer ss, the result would be 0,1
+   for ARRAY_DIM=1,2.  */
+
+static int
+get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
+{
+  int array_ref_dim;
+  int n;
+
+  array_ref_dim = 0;
+
+  for (; ss; ss = ss->parent)
+    for (n = 0; n < ss->dimen; n++)
+      if (ss->dim[n] < array_dim)
+	array_ref_dim++;
+
+  return array_ref_dim;
+}
+
+
+static gfc_ss *
+innermost_ss (gfc_ss *ss)
+{
+  while (ss->nested_ss != NULL)
+    ss = ss->nested_ss;
+
+  return ss;
+}
+
+
+
+/* Get the array reference dimension corresponding to the given loop dimension.
+   It is different from the true array dimension given by the dim array in
+   the case of a partial array reference (i.e. a(:,:,1,:) for example)
+   It is different from the loop dimension in the case of a transposed array.
+   */
+
+static int
+get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
+{
+  return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
+					   ss->dim[loop_dim]);
+}
+
+
+/* Generate code to create and initialize the descriptor for a temporary
+   array.  This is used for both temporaries needed by the scalarizer, and
+   functions returning arrays.  Adjusts the loop variables to be
+   zero-based, and calculates the loop bounds for callee allocated arrays.
+   Allocate the array unless it's callee allocated (we have a callee
+   allocated array if 'callee_alloc' is true, or if loop->to[n] is
+   NULL_TREE for any n).  Also fills in the descriptor, data and offset
+   fields of info if known.  Returns the size of the array, or NULL for a
+   callee allocated array.
+
+   'eltype' == NULL signals that the temporary should be a class object.
+   The 'initial' expression is used to obtain the size of the dynamic
+   type; otherwise the allocation and initialization proceeds as for any
+   other expression
+
+   PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
+   gfc_trans_allocate_array_storage.  */
+
+tree
+gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
+			     tree eltype, tree initial, bool dynamic,
+			     bool dealloc, bool callee_alloc, locus * where)
+{
+  gfc_loopinfo *loop;
+  gfc_ss *s;
+  gfc_array_info *info;
+  tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
+  tree type;
+  tree desc;
+  tree tmp;
+  tree size;
+  tree nelem;
+  tree cond;
+  tree or_expr;
+  tree class_expr = NULL_TREE;
+  int n, dim, tmp_dim;
+  int total_dim = 0;
+
+  /* This signals a class array for which we need the size of the
+     dynamic type.  Generate an eltype and then the class expression.  */
+  if (eltype == NULL_TREE && initial)
+    {
+      gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
+      class_expr = build_fold_indirect_ref_loc (input_location, initial);
+      eltype = TREE_TYPE (class_expr);
+      eltype = gfc_get_element_type (eltype);
+      /* Obtain the structure (class) expression.  */
+      class_expr = TREE_OPERAND (class_expr, 0);
+      gcc_assert (class_expr);
+    }
+
+  memset (from, 0, sizeof (from));
+  memset (to, 0, sizeof (to));
+
+  info = &ss->info->data.array;
+
+  gcc_assert (ss->dimen > 0);
+  gcc_assert (ss->loop->dimen == ss->dimen);
+
+  if (warn_array_temporaries && where)
+    gfc_warning (OPT_Warray_temporaries,
+		 "Creating array temporary at %L", where);
+
+  /* Set the lower bound to zero.  */
+  for (s = ss; s; s = s->parent)
+    {
+      loop = s->loop;
+
+      total_dim += loop->dimen;
+      for (n = 0; n < loop->dimen; n++)
+	{
+	  dim = s->dim[n];
+
+	  /* Callee allocated arrays may not have a known bound yet.  */
+	  if (loop->to[n])
+	    loop->to[n] = gfc_evaluate_now (
+			fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type,
+					 loop->to[n], loop->from[n]),
+			pre);
+	  loop->from[n] = gfc_index_zero_node;
+
+	  /* We have just changed the loop bounds, we must clear the
+	     corresponding specloop, so that delta calculation is not skipped
+	     later in gfc_set_delta.  */
+	  loop->specloop[n] = NULL;
+
+	  /* We are constructing the temporary's descriptor based on the loop
+	     dimensions.  As the dimensions may be accessed in arbitrary order
+	     (think of transpose) the size taken from the n'th loop may not map
+	     to the n'th dimension of the array.  We need to reconstruct loop
+	     infos in the right order before using it to set the descriptor
+	     bounds.  */
+	  tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
+	  from[tmp_dim] = loop->from[n];
+	  to[tmp_dim] = loop->to[n];
+
+	  info->delta[dim] = gfc_index_zero_node;
+	  info->start[dim] = gfc_index_zero_node;
+	  info->end[dim] = gfc_index_zero_node;
+	  info->stride[dim] = gfc_index_one_node;
+	}
+    }
+
+  /* Initialize the descriptor.  */
+  type =
+    gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
+			       GFC_ARRAY_UNKNOWN, true);
+  desc = gfc_create_var (type, "atmp");
+  GFC_DECL_PACKED_ARRAY (desc) = 1;
+
+  info->descriptor = desc;
+  size = gfc_index_one_node;
+
+  /* Emit a DECL_EXPR for the variable sized array type in
+     GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
+     sizes works correctly.  */
+  tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
+  if (! TYPE_NAME (arraytype))
+    TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
+					NULL_TREE, arraytype);
+  gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
+				      arraytype, TYPE_NAME (arraytype)));
+
+  /* Fill in the array dtype.  */
+  tmp = gfc_conv_descriptor_dtype (desc);
+  gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+
+  /*
+     Fill in the bounds and stride.  This is a packed array, so:
+
+     size = 1;
+     for (n = 0; n < rank; n++)
+       {
+	 stride[n] = size
+	 delta = ubound[n] + 1 - lbound[n];
+	 size = size * delta;
+       }
+     size = size * sizeof(element);
+  */
+
+  or_expr = NULL_TREE;
+
+  /* If there is at least one null loop->to[n], it is a callee allocated
+     array.  */
+  for (n = 0; n < total_dim; n++)
+    if (to[n] == NULL_TREE)
+      {
+	size = NULL_TREE;
+	break;
+      }
+
+  if (size == NULL_TREE)
+    for (s = ss; s; s = s->parent)
+      for (n = 0; n < s->loop->dimen; n++)
+	{
+	  dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
+
+	  /* For a callee allocated array express the loop bounds in terms
+	     of the descriptor fields.  */
+	  tmp = fold_build2_loc (input_location,
+		MINUS_EXPR, gfc_array_index_type,
+		gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
+		gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
+	  s->loop->to[n] = tmp;
+	}
+  else
+    {
+      for (n = 0; n < total_dim; n++)
+	{
+	  /* Store the stride and bound components in the descriptor.  */
+	  gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
+
+	  gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
+					  gfc_index_zero_node);
+
+	  gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
+
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type,
+				 to[n], gfc_index_one_node);
+
+	  /* Check whether the size for this dimension is negative.  */
+	  cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+				  tmp, gfc_index_zero_node);
+	  cond = gfc_evaluate_now (cond, pre);
+
+	  if (n == 0)
+	    or_expr = cond;
+	  else
+	    or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, or_expr, cond);
+
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+	  size = gfc_evaluate_now (size, pre);
+	}
+    }
+
+  /* Get the size of the array.  */
+  if (size && !callee_alloc)
+    {
+      tree elemsize;
+      /* If or_expr is true, then the extent in at least one
+	 dimension is zero and the size is set to zero.  */
+      size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+			      or_expr, gfc_index_zero_node, size);
+
+      nelem = size;
+      if (class_expr == NULL_TREE)
+	elemsize = fold_convert (gfc_array_index_type,
+			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      else
+	elemsize = gfc_class_vtab_size_get (class_expr);
+
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      size, elemsize);
+    }
+  else
+    {
+      nelem = size;
+      size = NULL_TREE;
+    }
+
+  gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
+				    dynamic, dealloc);
+
+  while (ss->parent)
+    ss = ss->parent;
+
+  if (ss->dimen > ss->loop->temp_dim)
+    ss->loop->temp_dim = ss->dimen;
+
+  return size;
+}
+
+
+/* Return the number of iterations in a loop that starts at START,
+   ends at END, and has step STEP.  */
+
+static tree
+gfc_get_iteration_count (tree start, tree end, tree step)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (step);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
+  tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
+			 build_int_cst (type, 1));
+  tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
+			 build_int_cst (type, 0));
+  return fold_convert (gfc_array_index_type, tmp);
+}
+
+
+/* Extend the data in array DESC by EXTRA elements.  */
+
+static void
+gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
+{
+  tree arg0, arg1;
+  tree tmp;
+  tree size;
+  tree ubound;
+
+  if (integer_zerop (extra))
+    return;
+
+  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
+
+  /* Add EXTRA to the upper bound.  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 ubound, extra);
+  gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
+
+  /* Get the value of the current data pointer.  */
+  arg0 = gfc_conv_descriptor_data_get (desc);
+
+  /* Calculate the new array size.  */
+  size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 ubound, gfc_index_one_node);
+  arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			  fold_convert (size_type_node, tmp),
+			  fold_convert (size_type_node, size));
+
+  /* Call the realloc() function.  */
+  tmp = gfc_call_realloc (pblock, arg0, arg1);
+  gfc_conv_descriptor_data_set (pblock, desc, tmp);
+}
+
+
+/* Return true if the bounds of iterator I can only be determined
+   at run time.  */
+
+static inline bool
+gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
+{
+  return (i->start->expr_type != EXPR_CONSTANT
+	  || i->end->expr_type != EXPR_CONSTANT
+	  || i->step->expr_type != EXPR_CONSTANT);
+}
+
+
+/* Split the size of constructor element EXPR into the sum of two terms,
+   one of which can be determined at compile time and one of which must
+   be calculated at run time.  Set *SIZE to the former and return true
+   if the latter might be nonzero.  */
+
+static bool
+gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
+{
+  if (expr->expr_type == EXPR_ARRAY)
+    return gfc_get_array_constructor_size (size, expr->value.constructor);
+  else if (expr->rank > 0)
+    {
+      /* Calculate everything at run time.  */
+      mpz_set_ui (*size, 0);
+      return true;
+    }
+  else
+    {
+      /* A single element.  */
+      mpz_set_ui (*size, 1);
+      return false;
+    }
+}
+
+
+/* Like gfc_get_array_constructor_element_size, but applied to the whole
+   of array constructor C.  */
+
+static bool
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
+{
+  gfc_constructor *c;
+  gfc_iterator *i;
+  mpz_t val;
+  mpz_t len;
+  bool dynamic;
+
+  mpz_set_ui (*size, 0);
+  mpz_init (len);
+  mpz_init (val);
+
+  dynamic = false;
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      i = c->iterator;
+      if (i && gfc_iterator_has_dynamic_bounds (i))
+	dynamic = true;
+      else
+	{
+	  dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
+	  if (i)
+	    {
+	      /* Multiply the static part of the element size by the
+		 number of iterations.  */
+	      mpz_sub (val, i->end->value.integer, i->start->value.integer);
+	      mpz_fdiv_q (val, val, i->step->value.integer);
+	      mpz_add_ui (val, val, 1);
+	      if (mpz_sgn (val) > 0)
+		mpz_mul (len, len, val);
+	      else
+		mpz_set_ui (len, 0);
+	    }
+	  mpz_add (*size, *size, len);
+	}
+    }
+  mpz_clear (len);
+  mpz_clear (val);
+  return dynamic;
+}
+
+
+/* Make sure offset is a variable.  */
+
+static void
+gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
+			 tree * offsetvar)
+{
+  /* We should have already created the offset variable.  We cannot
+     create it here because we may be in an inner scope.  */
+  gcc_assert (*offsetvar != NULL_TREE);
+  gfc_add_modify (pblock, *offsetvar, *poffset);
+  *poffset = *offsetvar;
+  TREE_USED (*offsetvar) = 1;
+}
+
+
+/* Variables needed for bounds-checking.  */
+static bool first_len;
+static tree first_len_val;
+static bool typespec_chararray_ctor;
+
+static void
+gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
+			      tree offset, gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+
+  gfc_conv_expr (se, expr);
+
+  /* Store the value.  */
+  tmp = build_fold_indirect_ref_loc (input_location,
+				 gfc_conv_descriptor_data_get (desc));
+  tmp = gfc_build_array_ref (tmp, offset, NULL);
+
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+      tree esize;
+
+      esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
+      esize = fold_convert (gfc_charlen_type_node, esize);
+      esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			   gfc_charlen_type_node, esize,
+			   build_int_cst (gfc_charlen_type_node,
+					  gfc_character_kinds[i].bit_size / 8));
+
+      gfc_conv_string_parameter (se);
+      if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  /* The temporary is an array of pointers.  */
+	  se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
+	  gfc_add_modify (&se->pre, tmp, se->expr);
+	}
+      else
+	{
+	  /* The temporary is an array of string values.  */
+	  tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
+	  /* We know the temporary and the value will be the same length,
+	     so can use memcpy.  */
+	  gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
+				 se->string_length, se->expr, expr->ts.kind);
+	}
+      if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
+	{
+	  if (first_len)
+	    {
+	      gfc_add_modify (&se->pre, first_len_val,
+				   se->string_length);
+	      first_len = false;
+	    }
+	  else
+	    {
+	      /* Verify that all constructor elements are of the same
+		 length.  */
+	      tree cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, first_len_val,
+					   se->string_length);
+	      gfc_trans_runtime_check
+		(true, false, cond, &se->pre, &expr->where,
+		 "Different CHARACTER lengths (%ld/%ld) in array constructor",
+		 fold_convert (long_integer_type_node, first_len_val),
+		 fold_convert (long_integer_type_node, se->string_length));
+	    }
+	}
+    }
+  else
+    {
+      /* TODO: Should the frontend already have done this conversion?  */
+      se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
+      gfc_add_modify (&se->pre, tmp, se->expr);
+    }
+
+  gfc_add_block_to_block (pblock, &se->pre);
+  gfc_add_block_to_block (pblock, &se->post);
+}
+
+
+/* Add the contents of an array to the constructor.  DYNAMIC is as for
+   gfc_trans_array_constructor_value.  */
+
+static void
+gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
+				      tree type ATTRIBUTE_UNUSED,
+				      tree desc, gfc_expr * expr,
+				      tree * poffset, tree * offsetvar,
+				      bool dynamic)
+{
+  gfc_se se;
+  gfc_ss *ss;
+  gfc_loopinfo loop;
+  stmtblock_t body;
+  tree tmp;
+  tree size;
+  int n;
+
+  /* We need this to be a variable so we can increment it.  */
+  gfc_put_offset_into_var (pblock, poffset, offsetvar);
+
+  gfc_init_se (&se, NULL);
+
+  /* Walk the array expression.  */
+  ss = gfc_walk_expr (expr);
+  gcc_assert (ss != gfc_ss_terminator);
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, ss);
+
+  /* Initialize the loop.  */
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop, &expr->where);
+
+  /* Make sure the constructed array has room for the new data.  */
+  if (dynamic)
+    {
+      /* Set SIZE to the total number of elements in the subarray.  */
+      size = gfc_index_one_node;
+      for (n = 0; n < loop.dimen; n++)
+	{
+	  tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
+					 gfc_index_one_node);
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+	}
+
+      /* Grow the constructed array by SIZE elements.  */
+      gfc_grow_array (&loop.pre, desc, size);
+    }
+
+  /* Make the loop body.  */
+  gfc_mark_ss_chain_used (ss, 1);
+  gfc_start_scalarized_body (&loop, &body);
+  gfc_copy_loopinfo_to_se (&se, &loop);
+  se.ss = ss;
+
+  gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
+  gcc_assert (se.ss == gfc_ss_terminator);
+
+  /* Increment the offset.  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 *poffset, gfc_index_one_node);
+  gfc_add_modify (&body, *poffset, tmp);
+
+  /* Finish the loop.  */
+  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_add_block_to_block (&loop.pre, &loop.post);
+  tmp = gfc_finish_block (&loop.pre);
+  gfc_add_expr_to_block (pblock, tmp);
+
+  gfc_cleanup_loop (&loop);
+}
+
+
+/* Assign the values to the elements of an array constructor.  DYNAMIC
+   is true if descriptor DESC only contains enough data for the static
+   size calculated by gfc_get_array_constructor_size.  When true, memory
+   for the dynamic parts must be allocated using realloc.  */
+
+static void
+gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
+				   tree desc, gfc_constructor_base base,
+				   tree * poffset, tree * offsetvar,
+				   bool dynamic)
+{
+  tree tmp;
+  tree start = NULL_TREE;
+  tree end = NULL_TREE;
+  tree step = NULL_TREE;
+  stmtblock_t body;
+  gfc_se se;
+  mpz_t size;
+  gfc_constructor *c;
+
+  tree shadow_loopvar = NULL_TREE;
+  gfc_saved_var saved_loopvar;
+
+  mpz_init (size);
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+    {
+      /* If this is an iterator or an array, the offset must be a variable.  */
+      if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
+	gfc_put_offset_into_var (pblock, poffset, offsetvar);
+
+      /* Shadowing the iterator avoids changing its value and saves us from
+	 keeping track of it. Further, it makes sure that there's always a
+	 backend-decl for the symbol, even if there wasn't one before,
+	 e.g. in the case of an iterator that appears in a specification
+	 expression in an interface mapping.  */
+      if (c->iterator)
+	{
+	  gfc_symbol *sym;
+	  tree type;
+
+	  /* Evaluate loop bounds before substituting the loop variable
+	     in case they depend on it.  Such a case is invalid, but it is
+	     not more expensive to do the right thing here.
+	     See PR 44354.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_val (&se, c->iterator->start);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  start = gfc_evaluate_now (se.expr, pblock);
+
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_val (&se, c->iterator->end);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  end = gfc_evaluate_now (se.expr, pblock);
+
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_val (&se, c->iterator->step);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  step = gfc_evaluate_now (se.expr, pblock);
+
+	  sym = c->iterator->var->symtree->n.sym;
+	  type = gfc_typenode_for_spec (&sym->ts);
+
+	  shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
+	  gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
+	}
+
+      gfc_start_block (&body);
+
+      if (c->expr->expr_type == EXPR_ARRAY)
+	{
+	  /* Array constructors can be nested.  */
+	  gfc_trans_array_constructor_value (&body, type, desc,
+					     c->expr->value.constructor,
+					     poffset, offsetvar, dynamic);
+	}
+      else if (c->expr->rank > 0)
+	{
+	  gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
+						poffset, offsetvar, dynamic);
+	}
+      else
+	{
+	  /* This code really upsets the gimplifier so don't bother for now.  */
+	  gfc_constructor *p;
+	  HOST_WIDE_INT n;
+	  HOST_WIDE_INT size;
+
+	  p = c;
+	  n = 0;
+	  while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
+	    {
+	      p = gfc_constructor_next (p);
+	      n++;
+	    }
+	  if (n < 4)
+	    {
+	      /* Scalar values.  */
+	      gfc_init_se (&se, NULL);
+	      gfc_trans_array_ctor_element (&body, desc, *poffset,
+					    &se, c->expr);
+
+	      *poffset = fold_build2_loc (input_location, PLUS_EXPR,
+					  gfc_array_index_type,
+					  *poffset, gfc_index_one_node);
+	    }
+	  else
+	    {
+	      /* Collect multiple scalar constants into a constructor.  */
+	      vec<constructor_elt, va_gc> *v = NULL;
+	      tree init;
+	      tree bound;
+	      tree tmptype;
+	      HOST_WIDE_INT idx = 0;
+
+	      p = c;
+              /* Count the number of consecutive scalar constants.  */
+	      while (p && !(p->iterator
+			    || p->expr->expr_type != EXPR_CONSTANT))
+		{
+		  gfc_init_se (&se, NULL);
+		  gfc_conv_constant (&se, p->expr);
+
+		  if (c->expr->ts.type != BT_CHARACTER)
+		    se.expr = fold_convert (type, se.expr);
+		  /* For constant character array constructors we build
+		     an array of pointers.  */
+		  else if (POINTER_TYPE_P (type))
+		    se.expr = gfc_build_addr_expr
+				(gfc_get_pchar_type (p->expr->ts.kind),
+				 se.expr);
+
+                  CONSTRUCTOR_APPEND_ELT (v,
+                                          build_int_cst (gfc_array_index_type,
+                                                         idx++),
+                                          se.expr);
+		  c = p;
+		  p = gfc_constructor_next (p);
+		}
+
+	      bound = size_int (n - 1);
+              /* Create an array type to hold them.  */
+	      tmptype = build_range_type (gfc_array_index_type,
+					  gfc_index_zero_node, bound);
+	      tmptype = build_array_type (type, tmptype);
+
+	      init = build_constructor (tmptype, v);
+	      TREE_CONSTANT (init) = 1;
+	      TREE_STATIC (init) = 1;
+	      /* Create a static variable to hold the data.  */
+	      tmp = gfc_create_var (tmptype, "data");
+	      TREE_STATIC (tmp) = 1;
+	      TREE_CONSTANT (tmp) = 1;
+	      TREE_READONLY (tmp) = 1;
+	      DECL_INITIAL (tmp) = init;
+	      init = tmp;
+
+	      /* Use BUILTIN_MEMCPY to assign the values.  */
+	      tmp = gfc_conv_descriptor_data_get (desc);
+	      tmp = build_fold_indirect_ref_loc (input_location,
+					     tmp);
+	      tmp = gfc_build_array_ref (tmp, *poffset, NULL);
+	      tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	      init = gfc_build_addr_expr (NULL_TREE, init);
+
+	      size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
+	      bound = build_int_cst (size_type_node, n * size);
+	      tmp = build_call_expr_loc (input_location,
+					 builtin_decl_explicit (BUILT_IN_MEMCPY),
+					 3, tmp, init, bound);
+	      gfc_add_expr_to_block (&body, tmp);
+
+	      *poffset = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type, *poffset,
+				      build_int_cst (gfc_array_index_type, n));
+	    }
+	  if (!INTEGER_CST_P (*poffset))
+            {
+              gfc_add_modify (&body, *offsetvar, *poffset);
+              *poffset = *offsetvar;
+            }
+	}
+
+      /* The frontend should already have done any expansions
+	 at compile-time.  */
+      if (!c->iterator)
+	{
+	  /* Pass the code as is.  */
+	  tmp = gfc_finish_block (&body);
+	  gfc_add_expr_to_block (pblock, tmp);
+	}
+      else
+	{
+	  /* Build the implied do-loop.  */
+	  stmtblock_t implied_do_block;
+	  tree cond;
+	  tree exit_label;
+	  tree loopbody;
+	  tree tmp2;
+
+	  loopbody = gfc_finish_block (&body);
+
+	  /* Create a new block that holds the implied-do loop. A temporary
+	     loop-variable is used.  */
+	  gfc_start_block(&implied_do_block);
+
+	  /* Initialize the loop.  */
+	  gfc_add_modify (&implied_do_block, shadow_loopvar, start);
+
+	  /* If this array expands dynamically, and the number of iterations
+	     is not constant, we won't have allocated space for the static
+	     part of C->EXPR's size.  Do that now.  */
+	  if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
+	    {
+	      /* Get the number of iterations.  */
+	      tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
+
+	      /* Get the static part of C->EXPR's size.  */
+	      gfc_get_array_constructor_element_size (&size, c->expr);
+	      tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
+
+	      /* Grow the array by TMP * TMP2 elements.  */
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type, tmp, tmp2);
+	      gfc_grow_array (&implied_do_block, desc, tmp);
+	    }
+
+	  /* Generate the loop body.  */
+	  exit_label = gfc_build_label_decl (NULL_TREE);
+	  gfc_start_block (&body);
+
+	  /* Generate the exit condition.  Depending on the sign of
+	     the step variable we have to generate the correct
+	     comparison.  */
+	  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+				 step, build_int_cst (TREE_TYPE (step), 0));
+	  cond = fold_build3_loc (input_location, COND_EXPR,
+		      boolean_type_node, tmp,
+		      fold_build2_loc (input_location, GT_EXPR,
+				       boolean_type_node, shadow_loopvar, end),
+		      fold_build2_loc (input_location, LT_EXPR,
+				       boolean_type_node, shadow_loopvar, end));
+	  tmp = build1_v (GOTO_EXPR, exit_label);
+	  TREE_USED (exit_label) = 1;
+	  tmp = build3_v (COND_EXPR, cond, tmp,
+			  build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&body, tmp);
+
+	  /* The main loop body.  */
+	  gfc_add_expr_to_block (&body, loopbody);
+
+	  /* Increase loop variable by step.  */
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 TREE_TYPE (shadow_loopvar), shadow_loopvar,
+				 step);
+	  gfc_add_modify (&body, shadow_loopvar, tmp);
+
+	  /* Finish the loop.  */
+	  tmp = gfc_finish_block (&body);
+	  tmp = build1_v (LOOP_EXPR, tmp);
+	  gfc_add_expr_to_block (&implied_do_block, tmp);
+
+	  /* Add the exit label.  */
+	  tmp = build1_v (LABEL_EXPR, exit_label);
+	  gfc_add_expr_to_block (&implied_do_block, tmp);
+
+	  /* Finish the implied-do loop.  */
+	  tmp = gfc_finish_block(&implied_do_block);
+	  gfc_add_expr_to_block(pblock, tmp);
+
+	  gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
+	}
+    }
+  mpz_clear (size);
+}
+
+
+/* The array constructor code can create a string length with an operand
+   in the form of a temporary variable.  This variable will retain its
+   context (current_function_decl).  If we store this length tree in a
+   gfc_charlen structure which is shared by a variable in another
+   context, the resulting gfc_charlen structure with a variable in a
+   different context, we could trip the assertion in expand_expr_real_1
+   when it sees that a variable has been created in one context and
+   referenced in another.
+
+   If this might be the case, we create a new gfc_charlen structure and
+   link it into the current namespace.  */
+
+static void
+store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
+{
+  if (force_new_cl)
+    {
+      gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
+      *clp = new_cl;
+    }
+  (*clp)->backend_decl = len;
+}
+
+/* A catch-all to obtain the string length for anything that is not
+   a substring of non-constant length, a constant, array or variable.  */
+
+static void
+get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
+{
+  gfc_se se;
+
+  /* Don't bother if we already know the length is a constant.  */
+  if (*len && INTEGER_CST_P (*len))
+    return;
+
+  if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
+	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+    {
+      /* This is easy.  */
+      gfc_conv_const_charlen (e->ts.u.cl);
+      *len = e->ts.u.cl->backend_decl;
+    }
+  else
+    {
+      /* Otherwise, be brutal even if inefficient.  */
+      gfc_init_se (&se, NULL);
+
+      /* No function call, in case of side effects.  */
+      se.no_function_call = 1;
+      if (e->rank == 0)
+	gfc_conv_expr (&se, e);
+      else
+	gfc_conv_expr_descriptor (&se, e);
+
+      /* Fix the value.  */
+      *len = gfc_evaluate_now (se.string_length, &se.pre);
+
+      gfc_add_block_to_block (block, &se.pre);
+      gfc_add_block_to_block (block, &se.post);
+
+      store_backend_decl (&e->ts.u.cl, *len, true);
+    }
+}
+
+
+/* Figure out the string length of a variable reference expression.
+   Used by get_array_ctor_strlen.  */
+
+static void
+get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
+{
+  gfc_ref *ref;
+  gfc_typespec *ts;
+  mpz_t char_len;
+
+  /* Don't bother if we already know the length is a constant.  */
+  if (*len && INTEGER_CST_P (*len))
+    return;
+
+  ts = &expr->symtree->n.sym->ts;
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  /* Array references don't change the string length.  */
+	  break;
+
+	case REF_COMPONENT:
+	  /* Use the length of the component.  */
+	  ts = &ref->u.c.component->ts;
+	  break;
+
+	case REF_SUBSTRING:
+	  if (ref->u.ss.start->expr_type != EXPR_CONSTANT
+	      || ref->u.ss.end->expr_type != EXPR_CONSTANT)
+	    {
+	      /* Note that this might evaluate expr.  */
+	      get_array_ctor_all_strlen (block, expr, len);
+	      return;
+	    }
+	  mpz_init_set_ui (char_len, 1);
+	  mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
+	  mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
+	  *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
+	  *len = convert (gfc_charlen_type_node, *len);
+	  mpz_clear (char_len);
+	  return;
+
+	default:
+	 gcc_unreachable ();
+	}
+    }
+
+  *len = ts->u.cl->backend_decl;
+}
+
+
+/* Figure out the string length of a character array constructor.
+   If len is NULL, don't calculate the length; this happens for recursive calls
+   when a sub-array-constructor is an element but not at the first position,
+   so when we're not interested in the length.
+   Returns TRUE if all elements are character constants.  */
+
+bool
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
+{
+  gfc_constructor *c;
+  bool is_const;
+
+  is_const = TRUE;
+
+  if (gfc_constructor_first (base) == NULL)
+    {
+      if (len)
+	*len = build_int_cstu (gfc_charlen_type_node, 0);
+      return is_const;
+    }
+
+  /* Loop over all constructor elements to find out is_const, but in len we
+     want to store the length of the first, not the last, element.  We can
+     of course exit the loop as soon as is_const is found to be false.  */
+  for (c = gfc_constructor_first (base);
+       c && is_const; c = gfc_constructor_next (c))
+    {
+      switch (c->expr->expr_type)
+	{
+	case EXPR_CONSTANT:
+	  if (len && !(*len && INTEGER_CST_P (*len)))
+	    *len = build_int_cstu (gfc_charlen_type_node,
+				   c->expr->value.character.length);
+	  break;
+
+	case EXPR_ARRAY:
+	  if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
+	    is_const = false;
+	  break;
+
+	case EXPR_VARIABLE:
+	  is_const = false;
+	  if (len)
+	    get_array_ctor_var_strlen (block, c->expr, len);
+	  break;
+
+	default:
+	  is_const = false;
+	  if (len)
+	    get_array_ctor_all_strlen (block, c->expr, len);
+	  break;
+	}
+
+      /* After the first iteration, we don't want the length modified.  */
+      len = NULL;
+    }
+
+  return is_const;
+}
+
+/* Check whether the array constructor C consists entirely of constant
+   elements, and if so returns the number of those elements, otherwise
+   return zero.  Note, an empty or NULL array constructor returns zero.  */
+
+unsigned HOST_WIDE_INT
+gfc_constant_array_constructor_p (gfc_constructor_base base)
+{
+  unsigned HOST_WIDE_INT nelem = 0;
+
+  gfc_constructor *c = gfc_constructor_first (base);
+  while (c)
+    {
+      if (c->iterator
+	  || c->expr->rank > 0
+	  || c->expr->expr_type != EXPR_CONSTANT)
+	return 0;
+      c = gfc_constructor_next (c);
+      nelem++;
+    }
+  return nelem;
+}
+
+
+/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
+   and the tree type of it's elements, TYPE, return a static constant
+   variable that is compile-time initialized.  */
+
+tree
+gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
+{
+  tree tmptype, init, tmp;
+  HOST_WIDE_INT nelem;
+  gfc_constructor *c;
+  gfc_array_spec as;
+  gfc_se se;
+  int i;
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  /* First traverse the constructor list, converting the constants
+     to tree to build an initializer.  */
+  nelem = 0;
+  c = gfc_constructor_first (expr->value.constructor);
+  while (c)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_constant (&se, c->expr);
+      if (c->expr->ts.type != BT_CHARACTER)
+	se.expr = fold_convert (type, se.expr);
+      else if (POINTER_TYPE_P (type))
+	se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
+				       se.expr);
+      CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
+                              se.expr);
+      c = gfc_constructor_next (c);
+      nelem++;
+    }
+
+  /* Next determine the tree type for the array.  We use the gfortran
+     front-end's gfc_get_nodesc_array_type in order to create a suitable
+     GFC_ARRAY_TYPE_P that may be used by the scalarizer.  */
+
+  memset (&as, 0, sizeof (gfc_array_spec));
+
+  as.rank = expr->rank;
+  as.type = AS_EXPLICIT;
+  if (!expr->shape)
+    {
+      as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+      as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
+				      NULL, nelem - 1);
+    }
+  else
+    for (i = 0; i < expr->rank; i++)
+      {
+	int tmp = (int) mpz_get_si (expr->shape[i]);
+        as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+        as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
+					NULL, tmp - 1);
+      }
+
+  tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
+
+  /* as is not needed anymore.  */
+  for (i = 0; i < as.rank + as.corank; i++)
+    {
+      gfc_free_expr (as.lower[i]);
+      gfc_free_expr (as.upper[i]);
+    }
+
+  init = build_constructor (tmptype, v);
+
+  TREE_CONSTANT (init) = 1;
+  TREE_STATIC (init) = 1;
+
+  tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
+		    tmptype);
+  DECL_ARTIFICIAL (tmp) = 1;
+  DECL_IGNORED_P (tmp) = 1;
+  TREE_STATIC (tmp) = 1;
+  TREE_CONSTANT (tmp) = 1;
+  TREE_READONLY (tmp) = 1;
+  DECL_INITIAL (tmp) = init;
+  pushdecl (tmp);
+
+  return tmp;
+}
+
+
+/* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
+   This mostly initializes the scalarizer state info structure with the
+   appropriate values to directly use the array created by the function
+   gfc_build_constant_array_constructor.  */
+
+static void
+trans_constant_array_constructor (gfc_ss * ss, tree type)
+{
+  gfc_array_info *info;
+  tree tmp;
+  int i;
+
+  tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
+
+  info = &ss->info->data.array;
+
+  info->descriptor = tmp;
+  info->data = gfc_build_addr_expr (NULL_TREE, tmp);
+  info->offset = gfc_index_zero_node;
+
+  for (i = 0; i < ss->dimen; i++)
+    {
+      info->delta[i] = gfc_index_zero_node;
+      info->start[i] = gfc_index_zero_node;
+      info->end[i] = gfc_index_zero_node;
+      info->stride[i] = gfc_index_one_node;
+    }
+}
+
+
+static int
+get_rank (gfc_loopinfo *loop)
+{
+  int rank;
+
+  rank = 0;
+  for (; loop; loop = loop->parent)
+    rank += loop->dimen;
+
+  return rank;
+}
+
+
+/* Helper routine of gfc_trans_array_constructor to determine if the
+   bounds of the loop specified by LOOP are constant and simple enough
+   to use with trans_constant_array_constructor.  Returns the
+   iteration count of the loop if suitable, and NULL_TREE otherwise.  */
+
+static tree
+constant_array_constructor_loop_size (gfc_loopinfo * l)
+{
+  gfc_loopinfo *loop;
+  tree size = gfc_index_one_node;
+  tree tmp;
+  int i, total_dim;
+
+  total_dim = get_rank (l);
+
+  for (loop = l; loop; loop = loop->parent)
+    {
+      for (i = 0; i < loop->dimen; i++)
+	{
+	  /* If the bounds aren't constant, return NULL_TREE.  */
+	  if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
+	    return NULL_TREE;
+	  if (!integer_zerop (loop->from[i]))
+	    {
+	      /* Only allow nonzero "from" in one-dimensional arrays.  */
+	      if (total_dim != 1)
+		return NULL_TREE;
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     loop->to[i], loop->from[i]);
+	    }
+	  else
+	    tmp = loop->to[i];
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp, gfc_index_one_node);
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, size, tmp);
+	}
+    }
+
+  return size;
+}
+
+
+static tree *
+get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
+{
+  gfc_ss *ss;
+  int n;
+
+  gcc_assert (array->nested_ss == NULL);
+
+  for (ss = array; ss; ss = ss->parent)
+    for (n = 0; n < ss->loop->dimen; n++)
+      if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
+	return &(ss->loop->to[n]);
+
+  gcc_unreachable ();
+}
+
+
+static gfc_loopinfo *
+outermost_loop (gfc_loopinfo * loop)
+{
+  while (loop->parent != NULL)
+    loop = loop->parent;
+
+  return loop;
+}
+
+
+/* Array constructors are handled by constructing a temporary, then using that
+   within the scalarization loop.  This is not optimal, but seems by far the
+   simplest method.  */
+
+static void
+trans_array_constructor (gfc_ss * ss, locus * where)
+{
+  gfc_constructor_base c;
+  tree offset;
+  tree offsetvar;
+  tree desc;
+  tree type;
+  tree tmp;
+  tree *loop_ubound0;
+  bool dynamic;
+  bool old_first_len, old_typespec_chararray_ctor;
+  tree old_first_len_val;
+  gfc_loopinfo *loop, *outer_loop;
+  gfc_ss_info *ss_info;
+  gfc_expr *expr;
+  gfc_ss *s;
+  tree neg_len;
+  char *msg;
+
+  /* Save the old values for nested checking.  */
+  old_first_len = first_len;
+  old_first_len_val = first_len_val;
+  old_typespec_chararray_ctor = typespec_chararray_ctor;
+
+  loop = ss->loop;
+  outer_loop = outermost_loop (loop);
+  ss_info = ss->info;
+  expr = ss_info->expr;
+
+  /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
+     typespec was given for the array constructor.  */
+  typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
+			     && expr->ts.u.cl
+			     && expr->ts.u.cl->length_from_typespec);
+
+  if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+      && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
+    {
+      first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
+      first_len = true;
+    }
+
+  gcc_assert (ss->dimen == ss->loop->dimen);
+
+  c = expr->value.constructor;
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      bool const_string;
+      bool force_new_cl = false;
+
+      /* get_array_ctor_strlen walks the elements of the constructor, if a
+	 typespec was given, we already know the string length and want the one
+	 specified there.  */
+      if (typespec_chararray_ctor && expr->ts.u.cl->length
+	  && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	{
+	  gfc_se length_se;
+
+	  const_string = false;
+	  gfc_init_se (&length_se, NULL);
+	  gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
+			      gfc_charlen_type_node);
+	  ss_info->string_length = length_se.expr;
+
+	  /* Check if the character length is negative.  If it is, then
+	     set LEN = 0.  */
+	  neg_len = fold_build2_loc (input_location, LT_EXPR,
+				     boolean_type_node, ss_info->string_length,
+				     build_int_cst (gfc_charlen_type_node, 0));
+	  /* Print a warning if bounds checking is enabled.  */
+	  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+	    {
+	      msg = xasprintf ("Negative character length treated as LEN = 0");
+	      gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
+				       where, msg);
+	      free (msg);
+	    }
+
+	  ss_info->string_length
+	    = fold_build3_loc (input_location, COND_EXPR,
+			       gfc_charlen_type_node, neg_len,
+			       build_int_cst (gfc_charlen_type_node, 0),
+			       ss_info->string_length);
+	  ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
+						     &length_se.pre);
+
+	  gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &length_se.post);
+	}
+      else
+	{
+	  const_string = get_array_ctor_strlen (&outer_loop->pre, c,
+						&ss_info->string_length);
+	  force_new_cl = true;
+	}
+
+      /* Complex character array constructors should have been taken care of
+	 and not end up here.  */
+      gcc_assert (ss_info->string_length);
+
+      store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
+
+      type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
+      if (const_string)
+	type = build_pointer_type (type);
+    }
+  else
+    type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
+				  ? &CLASS_DATA (expr)->ts : &expr->ts);
+
+  /* See if the constructor determines the loop bounds.  */
+  dynamic = false;
+
+  loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
+
+  if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
+    {
+      /* We have a multidimensional parameter.  */
+      for (s = ss; s; s = s->parent)
+	{
+	  int n;
+	  for (n = 0; n < s->loop->dimen; n++)
+	    {
+	      s->loop->from[n] = gfc_index_zero_node;
+	      s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
+						     gfc_index_integer_kind);
+	      s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
+						gfc_array_index_type,
+						s->loop->to[n],
+						gfc_index_one_node);
+	    }
+	}
+    }
+
+  if (*loop_ubound0 == NULL_TREE)
+    {
+      mpz_t size;
+
+      /* We should have a 1-dimensional, zero-based loop.  */
+      gcc_assert (loop->parent == NULL && loop->nested == NULL);
+      gcc_assert (loop->dimen == 1);
+      gcc_assert (integer_zerop (loop->from[0]));
+
+      /* Split the constructor size into a static part and a dynamic part.
+	 Allocate the static size up-front and record whether the dynamic
+	 size might be nonzero.  */
+      mpz_init (size);
+      dynamic = gfc_get_array_constructor_size (&size, c);
+      mpz_sub_ui (size, size, 1);
+      loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
+      mpz_clear (size);
+    }
+
+  /* Special case constant array constructors.  */
+  if (!dynamic)
+    {
+      unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
+      if (nelem > 0)
+	{
+	  tree size = constant_array_constructor_loop_size (loop);
+	  if (size && compare_tree_int (size, nelem) == 0)
+	    {
+	      trans_constant_array_constructor (ss, type);
+	      goto finish;
+	    }
+	}
+    }
+
+  gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
+			       NULL_TREE, dynamic, true, false, where);
+
+  desc = ss_info->data.array.descriptor;
+  offset = gfc_index_zero_node;
+  offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
+  TREE_NO_WARNING (offsetvar) = 1;
+  TREE_USED (offsetvar) = 0;
+  gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
+				     &offset, &offsetvar, dynamic);
+
+  /* If the array grows dynamically, the upper bound of the loop variable
+     is determined by the array's final upper bound.  */
+  if (dynamic)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     offsetvar, gfc_index_one_node);
+      tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
+      gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
+      if (*loop_ubound0 && VAR_P (*loop_ubound0))
+	gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
+      else
+	*loop_ubound0 = tmp;
+    }
+
+  if (TREE_USED (offsetvar))
+    pushdecl (offsetvar);
+  else
+    gcc_assert (INTEGER_CST_P (offset));
+
+#if 0
+  /* Disable bound checking for now because it's probably broken.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      gcc_unreachable ();
+    }
+#endif
+
+finish:
+  /* Restore old values of globals.  */
+  first_len = old_first_len;
+  first_len_val = old_first_len_val;
+  typespec_chararray_ctor = old_typespec_chararray_ctor;
+}
+
+
+/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
+   called after evaluating all of INFO's vector dimensions.  Go through
+   each such vector dimension and see if we can now fill in any missing
+   loop bounds.  */
+
+static void
+set_vector_loop_bounds (gfc_ss * ss)
+{
+  gfc_loopinfo *loop, *outer_loop;
+  gfc_array_info *info;
+  gfc_se se;
+  tree tmp;
+  tree desc;
+  tree zero;
+  int n;
+  int dim;
+
+  outer_loop = outermost_loop (ss->loop);
+
+  info = &ss->info->data.array;
+
+  for (; ss; ss = ss->parent)
+    {
+      loop = ss->loop;
+
+      for (n = 0; n < loop->dimen; n++)
+	{
+	  dim = ss->dim[n];
+	  if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
+	      || loop->to[n] != NULL)
+	    continue;
+
+	  /* Loop variable N indexes vector dimension DIM, and we don't
+	     yet know the upper bound of loop variable N.  Set it to the
+	     difference between the vector's upper and lower bounds.  */
+	  gcc_assert (loop->from[n] == gfc_index_zero_node);
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->info->type == GFC_SS_VECTOR);
+
+	  gfc_init_se (&se, NULL);
+	  desc = info->subscript[dim]->info->data.array.descriptor;
+	  zero = gfc_rank_cst[0];
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     gfc_conv_descriptor_ubound_get (desc, zero),
+			     gfc_conv_descriptor_lbound_get (desc, zero));
+	  tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
+	  loop->to[n] = tmp;
+	}
+    }
+}
+
+
+/* Tells whether a scalar argument to an elemental procedure is saved out
+   of a scalarization loop as a value or as a reference.  */
+
+bool
+gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
+{
+  if (ss_info->type != GFC_SS_REFERENCE)
+    return false;
+
+  /* If the actual argument can be absent (in other words, it can
+     be a NULL reference), don't try to evaluate it; pass instead
+     the reference directly.  */
+  if (ss_info->can_be_null_ref)
+    return true;
+
+  /* If the expression is of polymorphic type, it's actual size is not known,
+     so we avoid copying it anywhere.  */
+  if (ss_info->data.scalar.dummy_arg
+      && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS
+      && ss_info->expr->ts.type == BT_CLASS)
+    return true;
+
+  /* If the expression is a data reference of aggregate type,
+     and the data reference is not used on the left hand side,
+     avoid a copy by saving a reference to the content.  */
+  if (!ss_info->data.scalar.needs_temporary
+      && (ss_info->expr->ts.type == BT_DERIVED
+	  || ss_info->expr->ts.type == BT_CLASS)
+      && gfc_expr_is_variable (ss_info->expr))
+    return true;
+
+  /* Otherwise the expression is evaluated to a temporary variable before the
+     scalarization loop.  */
+  return false;
+}
+
+
+/* Add the pre and post chains for all the scalar expressions in a SS chain
+   to loop.  This is called after the loop parameters have been calculated,
+   but before the actual scalarizing loops.  */
+
+static void
+gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
+		      locus * where)
+{
+  gfc_loopinfo *nested_loop, *outer_loop;
+  gfc_se se;
+  gfc_ss_info *ss_info;
+  gfc_array_info *info;
+  gfc_expr *expr;
+  int n;
+
+  /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
+     arguments could get evaluated multiple times.  */
+  if (ss->is_alloc_lhs)
+    return;
+
+  outer_loop = outermost_loop (loop);
+
+  /* TODO: This can generate bad code if there are ordering dependencies,
+     e.g., a callee allocated function and an unknown size constructor.  */
+  gcc_assert (ss != NULL);
+
+  for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gcc_assert (ss);
+
+      /* Cross loop arrays are handled from within the most nested loop.  */
+      if (ss->nested_ss != NULL)
+	continue;
+
+      ss_info = ss->info;
+      expr = ss_info->expr;
+      info = &ss_info->data.array;
+
+      switch (ss_info->type)
+	{
+	case GFC_SS_SCALAR:
+	  /* Scalar expression.  Evaluate this now.  This includes elemental
+	     dimension indices, but not array section bounds.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr);
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+
+	  if (expr->ts.type != BT_CHARACTER
+	      && !gfc_is_alloc_class_scalar_function (expr))
+	    {
+	      /* Move the evaluation of scalar expressions outside the
+		 scalarization loop, except for WHERE assignments.  */
+	      if (subscript)
+		se.expr = convert(gfc_array_index_type, se.expr);
+	      if (!ss_info->where)
+		se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
+	      gfc_add_block_to_block (&outer_loop->pre, &se.post);
+	    }
+	  else
+	    gfc_add_block_to_block (&outer_loop->post, &se.post);
+
+	  ss_info->data.scalar.value = se.expr;
+	  ss_info->string_length = se.string_length;
+	  break;
+
+	case GFC_SS_REFERENCE:
+	  /* Scalar argument to elemental procedure.  */
+	  gfc_init_se (&se, NULL);
+	  if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
+	    gfc_conv_expr_reference (&se, expr);
+	  else
+	    {
+	      /* Evaluate the argument outside the loop and pass
+		 a reference to the value.  */
+	      gfc_conv_expr (&se, expr);
+	    }
+
+	  /* Ensure that a pointer to the string is stored.  */
+	  if (expr->ts.type == BT_CHARACTER)
+	    gfc_conv_string_parameter (&se);
+
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  if (gfc_is_class_scalar_expr (expr))
+	    /* This is necessary because the dynamic type will always be
+	       large than the declared type.  In consequence, assigning
+	       the value to a temporary could segfault.
+	       OOP-TODO: see if this is generally correct or is the value
+	       has to be written to an allocated temporary, whose address
+	       is passed via ss_info.  */
+	    ss_info->data.scalar.value = se.expr;
+	  else
+	    ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
+							   &outer_loop->pre);
+
+	  ss_info->string_length = se.string_length;
+	  break;
+
+	case GFC_SS_SECTION:
+	  /* Add the expressions for scalar and vector subscripts.  */
+	  for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+	    if (info->subscript[n])
+	      gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
+
+	  set_vector_loop_bounds (ss);
+	  break;
+
+	case GFC_SS_VECTOR:
+	  /* Get the vector's descriptor and store it in SS.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_descriptor (&se, expr);
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  info->descriptor = se.expr;
+	  break;
+
+	case GFC_SS_INTRINSIC:
+	  gfc_add_intrinsic_ss_code (loop, ss);
+	  break;
+
+	case GFC_SS_FUNCTION:
+	  /* Array function return value.  We call the function and save its
+	     result in a temporary for use inside the loop.  */
+	  gfc_init_se (&se, NULL);
+	  se.loop = loop;
+	  se.ss = ss;
+	  gfc_conv_expr (&se, expr);
+	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  ss_info->string_length = se.string_length;
+	  break;
+
+	case GFC_SS_CONSTRUCTOR:
+	  if (expr->ts.type == BT_CHARACTER
+	      && ss_info->string_length == NULL
+	      && expr->ts.u.cl
+	      && expr->ts.u.cl->length
+	      && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	    {
+	      gfc_init_se (&se, NULL);
+	      gfc_conv_expr_type (&se, expr->ts.u.cl->length,
+				  gfc_charlen_type_node);
+	      ss_info->string_length = se.expr;
+	      gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	      gfc_add_block_to_block (&outer_loop->post, &se.post);
+	    }
+	  trans_array_constructor (ss, where);
+	  break;
+
+        case GFC_SS_TEMP:
+	case GFC_SS_COMPONENT:
+          /* Do nothing.  These are handled elsewhere.  */
+          break;
+
+	default:
+	  gcc_unreachable ();
+	}
+    }
+
+  if (!subscript)
+    for (nested_loop = loop->nested; nested_loop;
+	 nested_loop = nested_loop->next)
+      gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
+}
+
+
+/* Translate expressions for the descriptor and data pointer of a SS.  */
+/*GCC ARRAYS*/
+
+static void
+gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
+{
+  gfc_se se;
+  gfc_ss_info *ss_info;
+  gfc_array_info *info;
+  tree tmp;
+
+  ss_info = ss->info;
+  info = &ss_info->data.array;
+
+  /* Get the descriptor for the array to be scalarized.  */
+  gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
+  gfc_init_se (&se, NULL);
+  se.descriptor_only = 1;
+  gfc_conv_expr_lhs (&se, ss_info->expr);
+  gfc_add_block_to_block (block, &se.pre);
+  info->descriptor = se.expr;
+  ss_info->string_length = se.string_length;
+
+  if (base)
+    {
+      if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
+	  && ss_info->expr->ts.u.cl->length == NULL)
+	{
+	  /* Emit a DECL_EXPR for the variable sized array type in
+	     GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
+	     sizes works correctly.  */
+	  tree arraytype = TREE_TYPE (
+		GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
+	  if (! TYPE_NAME (arraytype))
+	    TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
+						NULL_TREE, arraytype);
+	  gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
+						TYPE_NAME (arraytype)));
+	}
+      /* Also the data pointer.  */
+      tmp = gfc_conv_array_data (se.expr);
+      /* If this is a variable or address of a variable we use it directly.
+         Otherwise we must evaluate it now to avoid breaking dependency
+	 analysis by pulling the expressions for elemental array indices
+	 inside the loop.  */
+      if (!(DECL_P (tmp)
+	    || (TREE_CODE (tmp) == ADDR_EXPR
+		&& DECL_P (TREE_OPERAND (tmp, 0)))))
+	tmp = gfc_evaluate_now (tmp, block);
+      info->data = tmp;
+
+      tmp = gfc_conv_array_offset (se.expr);
+      info->offset = gfc_evaluate_now (tmp, block);
+
+      /* Make absolutely sure that the saved_offset is indeed saved
+	 so that the variable is still accessible after the loops
+	 are translated.  */
+      info->saved_offset = info->offset;
+    }
+}
+
+
+/* Initialize a gfc_loopinfo structure.  */
+
+void
+gfc_init_loopinfo (gfc_loopinfo * loop)
+{
+  int n;
+
+  memset (loop, 0, sizeof (gfc_loopinfo));
+  gfc_init_block (&loop->pre);
+  gfc_init_block (&loop->post);
+
+  /* Initially scalarize in order and default to no loop reversal.  */
+  for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+    {
+      loop->order[n] = n;
+      loop->reverse[n] = GFC_INHIBIT_REVERSE;
+    }
+
+  loop->ss = gfc_ss_terminator;
+}
+
+
+/* Copies the loop variable info to a gfc_se structure. Does not copy the SS
+   chain.  */
+
+void
+gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
+{
+  se->loop = loop;
+}
+
+
+/* Return an expression for the data pointer of an array.  */
+
+tree
+gfc_conv_array_data (tree descriptor)
+{
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+  if (GFC_ARRAY_TYPE_P (type))
+    {
+      if (TREE_CODE (type) == POINTER_TYPE)
+        return descriptor;
+      else
+        {
+          /* Descriptorless arrays.  */
+	  return gfc_build_addr_expr (NULL_TREE, descriptor);
+        }
+    }
+  else
+    return gfc_conv_descriptor_data_get (descriptor);
+}
+
+
+/* Return an expression for the base offset of an array.  */
+
+tree
+gfc_conv_array_offset (tree descriptor)
+{
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+  if (GFC_ARRAY_TYPE_P (type))
+    return GFC_TYPE_ARRAY_OFFSET (type);
+  else
+    return gfc_conv_descriptor_offset_get (descriptor);
+}
+
+
+/* Get an expression for the array stride.  */
+
+tree
+gfc_conv_array_stride (tree descriptor, int dim)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+
+  /* For descriptorless arrays use the array size.  */
+  tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
+  if (tmp != NULL_TREE)
+    return tmp;
+
+  tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
+  return tmp;
+}
+
+
+/* Like gfc_conv_array_stride, but for the lower bound.  */
+
+tree
+gfc_conv_array_lbound (tree descriptor, int dim)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+
+  tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
+  if (tmp != NULL_TREE)
+    return tmp;
+
+  tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
+  return tmp;
+}
+
+
+/* Like gfc_conv_array_stride, but for the upper bound.  */
+
+tree
+gfc_conv_array_ubound (tree descriptor, int dim)
+{
+  tree tmp;
+  tree type;
+
+  type = TREE_TYPE (descriptor);
+
+  tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
+  if (tmp != NULL_TREE)
+    return tmp;
+
+  /* This should only ever happen when passing an assumed shape array
+     as an actual parameter.  The value will never be used.  */
+  if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
+    return gfc_index_zero_node;
+
+  tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
+  return tmp;
+}
+
+
+/* Generate code to perform an array index bound check.  */
+
+static tree
+trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
+			 locus * where, bool check_upper)
+{
+  tree fault;
+  tree tmp_lo, tmp_up;
+  tree descriptor;
+  char *msg;
+  const char * name = NULL;
+
+  if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+    return index;
+
+  descriptor = ss->info->data.array.descriptor;
+
+  index = gfc_evaluate_now (index, &se->pre);
+
+  /* We find a name for the error message.  */
+  name = ss->info->expr->symtree->n.sym->name;
+  gcc_assert (name != NULL);
+
+  if (VAR_P (descriptor))
+    name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
+
+  /* If upper bound is present, include both bounds in the error message.  */
+  if (check_upper)
+    {
+      tmp_lo = gfc_conv_array_lbound (descriptor, n);
+      tmp_up = gfc_conv_array_ubound (descriptor, n);
+
+      if (name)
+	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+			 "outside of expected range (%%ld:%%ld)", n+1, name);
+      else
+	msg = xasprintf ("Index '%%ld' of dimension %d "
+			 "outside of expected range (%%ld:%%ld)", n+1);
+
+      fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       index, tmp_lo);
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node, index),
+			       fold_convert (long_integer_type_node, tmp_lo),
+			       fold_convert (long_integer_type_node, tmp_up));
+      fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			       index, tmp_up);
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node, index),
+			       fold_convert (long_integer_type_node, tmp_lo),
+			       fold_convert (long_integer_type_node, tmp_up));
+      free (msg);
+    }
+  else
+    {
+      tmp_lo = gfc_conv_array_lbound (descriptor, n);
+
+      if (name)
+	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+			 "below lower bound of %%ld", n+1, name);
+      else
+	msg = xasprintf ("Index '%%ld' of dimension %d "
+			 "below lower bound of %%ld", n+1);
+
+      fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       index, tmp_lo);
+      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+			       fold_convert (long_integer_type_node, index),
+			       fold_convert (long_integer_type_node, tmp_lo));
+      free (msg);
+    }
+
+  return index;
+}
+
+
+/* Return the offset for an index.  Performs bound checking for elemental
+   dimensions.  Single element references are processed separately.
+   DIM is the array dimension, I is the loop dimension.  */
+
+static tree
+conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
+			 gfc_array_ref * ar, tree stride)
+{
+  gfc_array_info *info;
+  tree index;
+  tree desc;
+  tree data;
+
+  info = &ss->info->data.array;
+
+  /* Get the index into the array for this dimension.  */
+  if (ar)
+    {
+      gcc_assert (ar->type != AR_ELEMENT);
+      switch (ar->dimen_type[dim])
+	{
+	case DIMEN_THIS_IMAGE:
+	  gcc_unreachable ();
+	  break;
+	case DIMEN_ELEMENT:
+	  /* Elemental dimension.  */
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->info->type == GFC_SS_SCALAR);
+	  /* We've already translated this value outside the loop.  */
+	  index = info->subscript[dim]->info->data.scalar.value;
+
+	  index = trans_array_bound_check (se, ss, index, dim, &ar->where,
+					   ar->as->type != AS_ASSUMED_SIZE
+					   || dim < ar->dimen - 1);
+	  break;
+
+	case DIMEN_VECTOR:
+	  gcc_assert (info && se->loop);
+	  gcc_assert (info->subscript[dim]
+		      && info->subscript[dim]->info->type == GFC_SS_VECTOR);
+	  desc = info->subscript[dim]->info->data.array.descriptor;
+
+	  /* Get a zero-based index into the vector.  */
+	  index = fold_build2_loc (input_location, MINUS_EXPR,
+				   gfc_array_index_type,
+				   se->loop->loopvar[i], se->loop->from[i]);
+
+	  /* Multiply the index by the stride.  */
+	  index = fold_build2_loc (input_location, MULT_EXPR,
+				   gfc_array_index_type,
+				   index, gfc_conv_array_stride (desc, 0));
+
+	  /* Read the vector to get an index into info->descriptor.  */
+	  data = build_fold_indirect_ref_loc (input_location,
+					  gfc_conv_array_data (desc));
+	  index = gfc_build_array_ref (data, index, NULL);
+	  index = gfc_evaluate_now (index, &se->pre);
+	  index = fold_convert (gfc_array_index_type, index);
+
+	  /* Do any bounds checking on the final info->descriptor index.  */
+	  index = trans_array_bound_check (se, ss, index, dim, &ar->where,
+					   ar->as->type != AS_ASSUMED_SIZE
+					   || dim < ar->dimen - 1);
+	  break;
+
+	case DIMEN_RANGE:
+	  /* Scalarized dimension.  */
+	  gcc_assert (info && se->loop);
+
+	  /* Multiply the loop variable by the stride and delta.  */
+	  index = se->loop->loopvar[i];
+	  if (!integer_onep (info->stride[dim]))
+	    index = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type, index,
+				     info->stride[dim]);
+	  if (!integer_zerop (info->delta[dim]))
+	    index = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, index,
+				     info->delta[dim]);
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+    }
+  else
+    {
+      /* Temporary array or derived type component.  */
+      gcc_assert (se->loop);
+      index = se->loop->loopvar[se->loop->order[i]];
+
+      /* Pointer functions can have stride[0] different from unity.
+	 Use the stride returned by the function call and stored in
+	 the descriptor for the temporary.  */
+      if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
+	  && se->ss->info->expr
+	  && se->ss->info->expr->symtree
+	  && se->ss->info->expr->symtree->n.sym->result
+	  && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
+	stride = gfc_conv_descriptor_stride_get (info->descriptor,
+						 gfc_rank_cst[dim]);
+
+      if (info->delta[dim] && !integer_zerop (info->delta[dim]))
+	index = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, index, info->delta[dim]);
+    }
+
+  /* Multiply by the stride.  */
+  if (!integer_onep (stride))
+    index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     index, stride);
+
+  return index;
+}
+
+
+/* Build a scalarized array reference using the vptr 'size'.  */
+
+static bool
+build_class_array_ref (gfc_se *se, tree base, tree index)
+{
+  tree type;
+  tree size;
+  tree offset;
+  tree decl = NULL_TREE;
+  tree tmp;
+  gfc_expr *expr = se->ss->info->expr;
+  gfc_ref *ref;
+  gfc_ref *class_ref = NULL;
+  gfc_typespec *ts;
+
+  if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
+      && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
+      && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
+    decl = se->expr;
+  else
+    {
+      if (expr == NULL
+	  || (expr->ts.type != BT_CLASS
+	      && !gfc_is_alloc_class_array_function (expr)
+	      && !gfc_is_class_array_ref (expr, NULL)))
+	return false;
+
+      if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+	ts = &expr->symtree->n.sym->ts;
+      else
+	ts = NULL;
+
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS
+	      && ref->next && ref->next->type == REF_COMPONENT
+	      && strcmp (ref->next->u.c.component->name, "_data") == 0
+	      && ref->next->next
+	      && ref->next->next->type == REF_ARRAY
+	      && ref->next->next->u.ar.type != AR_ELEMENT)
+	    {
+	      ts = &ref->u.c.component->ts;
+	      class_ref = ref;
+	      break;
+	    }
+	}
+
+      if (ts == NULL)
+	return false;
+    }
+
+  if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
+      && expr->symtree->n.sym == expr->symtree->n.sym->result)
+    {
+      gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
+      decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
+    }
+  else if (expr && gfc_is_alloc_class_array_function (expr))
+    {
+      size = NULL_TREE;
+      decl = NULL_TREE;
+      for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0))
+	{
+	  tree type;
+	  type = TREE_TYPE (tmp);
+	  while (type)
+	    {
+	      if (GFC_CLASS_TYPE_P (type))
+		decl = tmp;
+	      if (type != TYPE_CANONICAL (type))
+		type = TYPE_CANONICAL (type);
+	      else
+		type = NULL_TREE;
+	    }
+	  if (VAR_P (tmp))
+	    break;
+	}
+
+      if (decl == NULL_TREE)
+	return false;
+    }
+  else if (class_ref == NULL)
+    {
+      if (decl == NULL_TREE)
+	decl = expr->symtree->n.sym->backend_decl;
+      /* For class arrays the tree containing the class is stored in
+	 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
+	 For all others it's sym's backend_decl directly.  */
+      if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+    }
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, expr);
+      gfc_add_block_to_block (&se->pre, &tmpse.pre);
+      decl = tmpse.expr;
+      class_ref->next = ref;
+    }
+
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+
+  if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
+    return false;
+
+  size = gfc_class_vtab_size_get (decl);
+
+  /* For unlimited polymorphic entities then _len component needs to be
+     multiplied with the size.  If no _len component is present, then
+     gfc_class_len_or_zero_get () return a zero_node.  */
+  tmp = gfc_class_len_or_zero_get (decl);
+  if (!integer_zerop (tmp))
+    size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
+			fold_convert (TREE_TYPE (index), size),
+			fold_build2 (MAX_EXPR, TREE_TYPE (index),
+				     fold_convert (TREE_TYPE (index), tmp),
+				     fold_convert (TREE_TYPE (index),
+						   integer_one_node)));
+  else
+    size = fold_convert (TREE_TYPE (index), size);
+
+  /* Build the address of the element.  */
+  type = TREE_TYPE (TREE_TYPE (base));
+  offset = fold_build2_loc (input_location, MULT_EXPR,
+			    gfc_array_index_type,
+			    index, size);
+  tmp = gfc_build_addr_expr (pvoid_type_node, base);
+  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+  tmp = fold_convert (build_pointer_type (type), tmp);
+
+  /* Return the element in the se expression.  */
+  se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+  return true;
+}
+
+
+/* Build a scalarized reference to an array.  */
+
+static void
+gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
+{
+  gfc_array_info *info;
+  tree decl = NULL_TREE;
+  tree index;
+  tree tmp;
+  gfc_ss *ss;
+  gfc_expr *expr;
+  int n;
+
+  ss = se->ss;
+  expr = ss->info->expr;
+  info = &ss->info->data.array;
+  if (ar)
+    n = se->loop->order[0];
+  else
+    n = 0;
+
+  index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
+  /* Add the offset for this dimension to the stored offset for all other
+     dimensions.  */
+  if (info->offset && !integer_zerop (info->offset))
+    index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     index, info->offset);
+
+  if (expr && ((is_subref_array (expr)
+		&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
+	       || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
+					 || expr->expr_type == EXPR_FUNCTION))))
+    decl = expr->symtree->n.sym->backend_decl;
+
+  /* A pointer array component can be detected from its field decl. Fix
+     the descriptor, mark the resulting variable decl and pass it to
+     gfc_build_array_ref.  */
+  if (is_pointer_array (info->descriptor))
+    {
+      if (TREE_CODE (info->descriptor) == COMPONENT_REF)
+	{
+	  decl = gfc_evaluate_now (info->descriptor, &se->pre);
+	  GFC_DECL_PTR_ARRAY_P (decl) = 1;
+	  TREE_USED (decl) = 1;
+	}
+      else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
+	decl = TREE_OPERAND (info->descriptor, 0);
+
+      if (decl == NULL_TREE)
+	decl = info->descriptor;
+    }
+
+  tmp = build_fold_indirect_ref_loc (input_location, info->data);
+
+  /* Use the vptr 'size' field to access a class the element of a class
+     array.  */
+  if (build_class_array_ref (se, tmp, index))
+    return;
+
+  se->expr = gfc_build_array_ref (tmp, index, decl);
+}
+
+
+/* Translate access of temporary array.  */
+
+void
+gfc_conv_tmp_array_ref (gfc_se * se)
+{
+  se->string_length = se->ss->info->string_length;
+  gfc_conv_scalarized_array_ref (se, NULL);
+  gfc_advance_se_ss_chain (se);
+}
+
+/* Add T to the offset pair *OFFSET, *CST_OFFSET.  */
+
+static void
+add_to_offset (tree *cst_offset, tree *offset, tree t)
+{
+  if (TREE_CODE (t) == INTEGER_CST)
+    *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
+  else
+    {
+      if (!integer_zerop (*offset))
+	*offset = fold_build2_loc (input_location, PLUS_EXPR,
+				   gfc_array_index_type, *offset, t);
+      else
+	*offset = t;
+    }
+}
+
+
+static tree
+build_array_ref (tree desc, tree offset, tree decl, tree vptr)
+{
+  tree tmp;
+  tree type;
+  tree cdesc;
+
+  /* For class arrays the class declaration is stored in the saved
+     descriptor.  */
+  if (INDIRECT_REF_P (desc)
+      && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
+      && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
+    cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
+				  TREE_OPERAND (desc, 0)));
+  else
+    cdesc = desc;
+
+  /* Class container types do not always have the GFC_CLASS_TYPE_P
+     but the canonical type does.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
+      && TREE_CODE (cdesc) == COMPONENT_REF)
+    {
+      type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
+      if (TYPE_CANONICAL (type)
+	  && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
+	vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
+    }
+
+  tmp = gfc_conv_array_data (desc);
+  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+  tmp = gfc_build_array_ref (tmp, offset, decl, vptr);
+  return tmp;
+}
+
+
+/* Build an array reference.  se->expr already holds the array descriptor.
+   This should be either a variable, indirect variable reference or component
+   reference.  For arrays which do not have a descriptor, se->expr will be
+   the data pointer.
+   a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
+
+void
+gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
+		    locus * where)
+{
+  int n;
+  tree offset, cst_offset;
+  tree tmp;
+  tree stride;
+  tree decl = NULL_TREE;
+  gfc_se indexse;
+  gfc_se tmpse;
+  gfc_symbol * sym = expr->symtree->n.sym;
+  char *var_name = NULL;
+
+  if (ar->dimen == 0)
+    {
+      gcc_assert (ar->codimen);
+
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
+	se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
+      else
+	{
+	  if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
+	      && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
+	    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+	  /* Use the actual tree type and not the wrapped coarray.  */
+	  if (!se->want_pointer)
+	    se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
+				     se->expr);
+	}
+
+      return;
+    }
+
+  /* Handle scalarized references separately.  */
+  if (ar->type != AR_ELEMENT)
+    {
+      gfc_conv_scalarized_array_ref (se, ar);
+      gfc_advance_se_ss_chain (se);
+      return;
+    }
+
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      size_t len;
+      gfc_ref *ref;
+
+      len = strlen (sym->name) + 1;
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_ARRAY && &ref->u.ar == ar)
+	    break;
+	  if (ref->type == REF_COMPONENT)
+	    len += 2 + strlen (ref->u.c.component->name);
+	}
+
+      var_name = XALLOCAVEC (char, len);
+      strcpy (var_name, sym->name);
+
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_ARRAY && &ref->u.ar == ar)
+	    break;
+	  if (ref->type == REF_COMPONENT)
+	    {
+	      strcat (var_name, "%%");
+	      strcat (var_name, ref->u.c.component->name);
+	    }
+	}
+    }
+
+  cst_offset = offset = gfc_index_zero_node;
+  add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
+
+  /* Calculate the offsets from all the dimensions.  Make sure to associate
+     the final offset so that we form a chain of loop invariant summands.  */
+  for (n = ar->dimen - 1; n >= 0; n--)
+    {
+      /* Calculate the index for this dimension.  */
+      gfc_init_se (&indexse, se);
+      gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &indexse.pre);
+
+      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+	{
+	  /* Check array bounds.  */
+	  tree cond;
+	  char *msg;
+
+	  /* Evaluate the indexse.expr only once.  */
+	  indexse.expr = save_expr (indexse.expr);
+
+	  /* Lower bound.  */
+	  tmp = gfc_conv_array_lbound (se->expr, n);
+	  if (sym->attr.temporary)
+	    {
+	      gfc_init_se (&tmpse, se);
+	      gfc_conv_expr_type (&tmpse, ar->as->lower[n],
+				  gfc_array_index_type);
+	      gfc_add_block_to_block (&se->pre, &tmpse.pre);
+	      tmp = tmpse.expr;
+	    }
+
+	  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  indexse.expr, tmp);
+	  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+			   "below lower bound of %%ld", n+1, var_name);
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
+				   fold_convert (long_integer_type_node,
+						 indexse.expr),
+				   fold_convert (long_integer_type_node, tmp));
+	  free (msg);
+
+	  /* Upper bound, but not for the last dimension of assumed-size
+	     arrays.  */
+	  if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
+	    {
+	      tmp = gfc_conv_array_ubound (se->expr, n);
+	      if (sym->attr.temporary)
+		{
+		  gfc_init_se (&tmpse, se);
+		  gfc_conv_expr_type (&tmpse, ar->as->upper[n],
+				      gfc_array_index_type);
+		  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+		  tmp = tmpse.expr;
+		}
+
+	      cond = fold_build2_loc (input_location, GT_EXPR,
+				      boolean_type_node, indexse.expr, tmp);
+	      msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+			       "above upper bound of %%ld", n+1, var_name);
+	      gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
+				   fold_convert (long_integer_type_node,
+						 indexse.expr),
+				   fold_convert (long_integer_type_node, tmp));
+	      free (msg);
+	    }
+	}
+
+      /* Multiply the index by the stride.  */
+      stride = gfc_conv_array_stride (se->expr, n);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     indexse.expr, stride);
+
+      /* And add it to the total.  */
+      add_to_offset (&cst_offset, &offset, tmp);
+    }
+
+  if (!integer_zerop (cst_offset))
+    offset = fold_build2_loc (input_location, PLUS_EXPR,
+			      gfc_array_index_type, offset, cst_offset);
+
+  /* A pointer array component can be detected from its field decl. Fix
+     the descriptor, mark the resulting variable decl and pass it to
+     build_array_ref.  */
+  if (!expr->ts.deferred && !sym->attr.codimension
+      && is_pointer_array (se->expr))
+    {
+      if (TREE_CODE (se->expr) == COMPONENT_REF)
+	{
+	  decl = gfc_evaluate_now (se->expr, &se->pre);
+	  GFC_DECL_PTR_ARRAY_P (decl) = 1;
+	  TREE_USED (decl) = 1;
+	}
+      else if (TREE_CODE (se->expr) == INDIRECT_REF)
+	decl = TREE_OPERAND (se->expr, 0);
+      else
+	decl = se->expr;
+    }
+  else if (expr->ts.deferred
+	   || (sym->ts.type == BT_CHARACTER
+	       && sym->attr.select_type_temporary))
+    decl = sym->backend_decl;
+  else if (sym->ts.type == BT_CLASS)
+    decl = NULL_TREE;
+
+  se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
+}
+
+
+/* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
+   LOOP_DIM dimension (if any) to array's offset.  */
+
+static void
+add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
+		  gfc_array_ref *ar, int array_dim, int loop_dim)
+{
+  gfc_se se;
+  gfc_array_info *info;
+  tree stride, index;
+
+  info = &ss->info->data.array;
+
+  gfc_init_se (&se, NULL);
+  se.loop = loop;
+  se.expr = info->descriptor;
+  stride = gfc_conv_array_stride (info->descriptor, array_dim);
+  index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
+  gfc_add_block_to_block (pblock, &se.pre);
+
+  info->offset = fold_build2_loc (input_location, PLUS_EXPR,
+				  gfc_array_index_type,
+				  info->offset, index);
+  info->offset = gfc_evaluate_now (info->offset, pblock);
+}
+
+
+/* Generate the code to be executed immediately before entering a
+   scalarization loop.  */
+
+static void
+gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
+			 stmtblock_t * pblock)
+{
+  tree stride;
+  gfc_ss_info *ss_info;
+  gfc_array_info *info;
+  gfc_ss_type ss_type;
+  gfc_ss *ss, *pss;
+  gfc_loopinfo *ploop;
+  gfc_array_ref *ar;
+  int i;
+
+  /* This code will be executed before entering the scalarization loop
+     for this dimension.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      ss_info = ss->info;
+
+      if ((ss_info->useflags & flag) == 0)
+	continue;
+
+      ss_type = ss_info->type;
+      if (ss_type != GFC_SS_SECTION
+	  && ss_type != GFC_SS_FUNCTION
+	  && ss_type != GFC_SS_CONSTRUCTOR
+	  && ss_type != GFC_SS_COMPONENT)
+	continue;
+
+      info = &ss_info->data.array;
+
+      gcc_assert (dim < ss->dimen);
+      gcc_assert (ss->dimen == loop->dimen);
+
+      if (info->ref)
+	ar = &info->ref->u.ar;
+      else
+	ar = NULL;
+
+      if (dim == loop->dimen - 1 && loop->parent != NULL)
+	{
+	  /* If we are in the outermost dimension of this loop, the previous
+	     dimension shall be in the parent loop.  */
+	  gcc_assert (ss->parent != NULL);
+
+	  pss = ss->parent;
+	  ploop = loop->parent;
+
+	  /* ss and ss->parent are about the same array.  */
+	  gcc_assert (ss_info == pss->info);
+	}
+      else
+	{
+	  ploop = loop;
+	  pss = ss;
+	}
+
+      if (dim == loop->dimen - 1)
+	i = 0;
+      else
+	i = dim + 1;
+
+      /* For the time being, there is no loop reordering.  */
+      gcc_assert (i == ploop->order[i]);
+      i = ploop->order[i];
+
+      if (dim == loop->dimen - 1 && loop->parent == NULL)
+	{
+	  stride = gfc_conv_array_stride (info->descriptor,
+					  innermost_ss (ss)->dim[i]);
+
+	  /* Calculate the stride of the innermost loop.  Hopefully this will
+	     allow the backend optimizers to do their stuff more effectively.
+	   */
+	  info->stride0 = gfc_evaluate_now (stride, pblock);
+
+	  /* For the outermost loop calculate the offset due to any
+	     elemental dimensions.  It will have been initialized with the
+	     base offset of the array.  */
+	  if (info->ref)
+	    {
+	      for (i = 0; i < ar->dimen; i++)
+		{
+		  if (ar->dimen_type[i] != DIMEN_ELEMENT)
+		    continue;
+
+		  add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
+		}
+	    }
+	}
+      else
+	/* Add the offset for the previous loop dimension.  */
+	add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
+
+      /* Remember this offset for the second loop.  */
+      if (dim == loop->temp_dim - 1 && loop->parent == NULL)
+        info->saved_offset = info->offset;
+    }
+}
+
+
+/* Start a scalarized expression.  Creates a scope and declares loop
+   variables.  */
+
+void
+gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
+{
+  int dim;
+  int n;
+  int flags;
+
+  gcc_assert (!loop->array_parameter);
+
+  for (dim = loop->dimen - 1; dim >= 0; dim--)
+    {
+      n = loop->order[dim];
+
+      gfc_start_block (&loop->code[n]);
+
+      /* Create the loop variable.  */
+      loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
+
+      if (dim < loop->temp_dim)
+	flags = 3;
+      else
+	flags = 1;
+      /* Calculate values that will be constant within this loop.  */
+      gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
+    }
+  gfc_start_block (pbody);
+}
+
+
+/* Generates the actual loop code for a scalarization loop.  */
+
+void
+gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
+			       stmtblock_t * pbody)
+{
+  stmtblock_t block;
+  tree cond;
+  tree tmp;
+  tree loopbody;
+  tree exit_label;
+  tree stmt;
+  tree init;
+  tree incr;
+
+  if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
+		      | OMPWS_SCALARIZER_BODY))
+      == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
+      && n == loop->dimen - 1)
+    {
+      /* We create an OMP_FOR construct for the outermost scalarized loop.  */
+      init = make_tree_vec (1);
+      cond = make_tree_vec (1);
+      incr = make_tree_vec (1);
+
+      /* Cycle statement is implemented with a goto.  Exit statement must not
+	 be present for this loop.  */
+      exit_label = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (exit_label) = 1;
+
+      /* Label for cycle statements (if needed).  */
+      tmp = build1_v (LABEL_EXPR, exit_label);
+      gfc_add_expr_to_block (pbody, tmp);
+
+      stmt = make_node (OMP_FOR);
+
+      TREE_TYPE (stmt) = void_type_node;
+      OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
+
+      OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
+						 OMP_CLAUSE_SCHEDULE);
+      OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
+	= OMP_CLAUSE_SCHEDULE_STATIC;
+      if (ompws_flags & OMPWS_NOWAIT)
+	OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
+	  = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
+
+      /* Initialize the loopvar.  */
+      TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
+					 loop->from[n]);
+      OMP_FOR_INIT (stmt) = init;
+      /* The exit condition.  */
+      TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
+					   boolean_type_node,
+					   loop->loopvar[n], loop->to[n]);
+      SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
+      OMP_FOR_COND (stmt) = cond;
+      /* Increment the loopvar.  */
+      tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			loop->loopvar[n], gfc_index_one_node);
+      TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
+	  void_type_node, loop->loopvar[n], tmp);
+      OMP_FOR_INCR (stmt) = incr;
+
+      ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
+      gfc_add_expr_to_block (&loop->code[n], stmt);
+    }
+  else
+    {
+      bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
+			     && (loop->temp_ss == NULL);
+
+      loopbody = gfc_finish_block (pbody);
+
+      if (reverse_loop)
+	std::swap (loop->from[n], loop->to[n]);
+
+      /* Initialize the loopvar.  */
+      if (loop->loopvar[n] != loop->from[n])
+	gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
+
+      exit_label = gfc_build_label_decl (NULL_TREE);
+
+      /* Generate the loop body.  */
+      gfc_init_block (&block);
+
+      /* The exit condition.  */
+      cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
+			  boolean_type_node, loop->loopvar[n], loop->to[n]);
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      TREE_USED (exit_label) = 1;
+      tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* The main body.  */
+      gfc_add_expr_to_block (&block, loopbody);
+
+      /* Increment the loopvar.  */
+      tmp = fold_build2_loc (input_location,
+			     reverse_loop ? MINUS_EXPR : PLUS_EXPR,
+			     gfc_array_index_type, loop->loopvar[n],
+			     gfc_index_one_node);
+
+      gfc_add_modify (&block, loop->loopvar[n], tmp);
+
+      /* Build the loop.  */
+      tmp = gfc_finish_block (&block);
+      tmp = build1_v (LOOP_EXPR, tmp);
+      gfc_add_expr_to_block (&loop->code[n], tmp);
+
+      /* Add the exit label.  */
+      tmp = build1_v (LABEL_EXPR, exit_label);
+      gfc_add_expr_to_block (&loop->code[n], tmp);
+    }
+
+}
+
+
+/* Finishes and generates the loops for a scalarized expression.  */
+
+void
+gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
+{
+  int dim;
+  int n;
+  gfc_ss *ss;
+  stmtblock_t *pblock;
+  tree tmp;
+
+  pblock = body;
+  /* Generate the loops.  */
+  for (dim = 0; dim < loop->dimen; dim++)
+    {
+      n = loop->order[dim];
+      gfc_trans_scalarized_loop_end (loop, n, pblock);
+      loop->loopvar[n] = NULL_TREE;
+      pblock = &loop->code[n];
+    }
+
+  tmp = gfc_finish_block (pblock);
+  gfc_add_expr_to_block (&loop->pre, tmp);
+
+  /* Clear all the used flags.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    if (ss->parent == NULL)
+      ss->info->useflags = 0;
+}
+
+
+/* Finish the main body of a scalarized expression, and start the secondary
+   copying body.  */
+
+void
+gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
+{
+  int dim;
+  int n;
+  stmtblock_t *pblock;
+  gfc_ss *ss;
+
+  pblock = body;
+  /* We finish as many loops as are used by the temporary.  */
+  for (dim = 0; dim < loop->temp_dim - 1; dim++)
+    {
+      n = loop->order[dim];
+      gfc_trans_scalarized_loop_end (loop, n, pblock);
+      loop->loopvar[n] = NULL_TREE;
+      pblock = &loop->code[n];
+    }
+
+  /* We don't want to finish the outermost loop entirely.  */
+  n = loop->order[loop->temp_dim - 1];
+  gfc_trans_scalarized_loop_end (loop, n, pblock);
+
+  /* Restore the initial offsets.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gfc_ss_type ss_type;
+      gfc_ss_info *ss_info;
+
+      ss_info = ss->info;
+
+      if ((ss_info->useflags & 2) == 0)
+	continue;
+
+      ss_type = ss_info->type;
+      if (ss_type != GFC_SS_SECTION
+	  && ss_type != GFC_SS_FUNCTION
+	  && ss_type != GFC_SS_CONSTRUCTOR
+	  && ss_type != GFC_SS_COMPONENT)
+	continue;
+
+      ss_info->data.array.offset = ss_info->data.array.saved_offset;
+    }
+
+  /* Restart all the inner loops we just finished.  */
+  for (dim = loop->temp_dim - 2; dim >= 0; dim--)
+    {
+      n = loop->order[dim];
+
+      gfc_start_block (&loop->code[n]);
+
+      loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
+
+      gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
+    }
+
+  /* Start a block for the secondary copying code.  */
+  gfc_start_block (body);
+}
+
+
+/* Precalculate (either lower or upper) bound of an array section.
+     BLOCK: Block in which the (pre)calculation code will go.
+     BOUNDS[DIM]: Where the bound value will be stored once evaluated.
+     VALUES[DIM]: Specified bound (NULL <=> unspecified).
+     DESC: Array descriptor from which the bound will be picked if unspecified
+       (either lower or upper bound according to LBOUND).  */
+
+static void
+evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
+		tree desc, int dim, bool lbound, bool deferred)
+{
+  gfc_se se;
+  gfc_expr * input_val = values[dim];
+  tree *output = &bounds[dim];
+
+
+  if (input_val)
+    {
+      /* Specified section bound.  */
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
+      gfc_add_block_to_block (block, &se.pre);
+      *output = se.expr;
+    }
+  else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      /* The gfc_conv_array_lbound () routine returns a constant zero for
+	 deferred length arrays, which in the scalarizer wreaks havoc, when
+	 copying to a (newly allocated) one-based array.
+	 Keep returning the actual result in sync for both bounds.  */
+      *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
+							 gfc_rank_cst[dim]):
+			 gfc_conv_descriptor_ubound_get (desc,
+							 gfc_rank_cst[dim]);
+    }
+  else
+    {
+      /* No specific bound specified so use the bound of the array.  */
+      *output = lbound ? gfc_conv_array_lbound (desc, dim) :
+			 gfc_conv_array_ubound (desc, dim);
+    }
+  *output = gfc_evaluate_now (*output, block);
+}
+
+
+/* Calculate the lower bound of an array section.  */
+
+static void
+gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
+{
+  gfc_expr *stride = NULL;
+  tree desc;
+  gfc_se se;
+  gfc_array_info *info;
+  gfc_array_ref *ar;
+
+  gcc_assert (ss->info->type == GFC_SS_SECTION);
+
+  info = &ss->info->data.array;
+  ar = &info->ref->u.ar;
+
+  if (ar->dimen_type[dim] == DIMEN_VECTOR)
+    {
+      /* We use a zero-based index to access the vector.  */
+      info->start[dim] = gfc_index_zero_node;
+      info->end[dim] = NULL;
+      info->stride[dim] = gfc_index_one_node;
+      return;
+    }
+
+  gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
+	      || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
+  desc = info->descriptor;
+  stride = ar->stride[dim];
+
+
+  /* Calculate the start of the range.  For vector subscripts this will
+     be the range of the vector.  */
+  evaluate_bound (block, info->start, ar->start, desc, dim, true,
+		  ar->as->type == AS_DEFERRED);
+
+  /* Similarly calculate the end.  Although this is not used in the
+     scalarizer, it is needed when checking bounds and where the end
+     is an expression with side-effects.  */
+  evaluate_bound (block, info->end, ar->end, desc, dim, false,
+		  ar->as->type == AS_DEFERRED);
+
+
+  /* Calculate the stride.  */
+  if (stride == NULL)
+    info->stride[dim] = gfc_index_one_node;
+  else
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_type (&se, stride, gfc_array_index_type);
+      gfc_add_block_to_block (block, &se.pre);
+      info->stride[dim] = gfc_evaluate_now (se.expr, block);
+    }
+}
+
+
+/* Calculates the range start and stride for a SS chain.  Also gets the
+   descriptor and data pointer.  The range of vector subscripts is the size
+   of the vector.  Array bounds are also checked.  */
+
+void
+gfc_conv_ss_startstride (gfc_loopinfo * loop)
+{
+  int n;
+  tree tmp;
+  gfc_ss *ss;
+  tree desc;
+
+  gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
+  loop->dimen = 0;
+  /* Determine the rank of the loop.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      switch (ss->info->type)
+	{
+	case GFC_SS_SECTION:
+	case GFC_SS_CONSTRUCTOR:
+	case GFC_SS_FUNCTION:
+	case GFC_SS_COMPONENT:
+	  loop->dimen = ss->dimen;
+	  goto done;
+
+	/* As usual, lbound and ubound are exceptions!.  */
+	case GFC_SS_INTRINSIC:
+	  switch (ss->info->expr->value.function.isym->id)
+	    {
+	    case GFC_ISYM_LBOUND:
+	    case GFC_ISYM_UBOUND:
+	    case GFC_ISYM_LCOBOUND:
+	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_THIS_IMAGE:
+	      loop->dimen = ss->dimen;
+	      goto done;
+
+	    default:
+	      break;
+	    }
+
+	default:
+	  break;
+	}
+    }
+
+  /* We should have determined the rank of the expression by now.  If
+     not, that's bad news.  */
+  gcc_unreachable ();
+
+done:
+  /* Loop over all the SS in the chain.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gfc_ss_info *ss_info;
+      gfc_array_info *info;
+      gfc_expr *expr;
+
+      ss_info = ss->info;
+      expr = ss_info->expr;
+      info = &ss_info->data.array;
+
+      if (expr && expr->shape && !info->shape)
+	info->shape = expr->shape;
+
+      switch (ss_info->type)
+	{
+	case GFC_SS_SECTION:
+	  /* Get the descriptor for the array.  If it is a cross loops array,
+	     we got the descriptor already in the outermost loop.  */
+	  if (ss->parent == NULL)
+	    gfc_conv_ss_descriptor (&outer_loop->pre, ss,
+				    !loop->array_parameter);
+
+	  for (n = 0; n < ss->dimen; n++)
+	    gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
+	  break;
+
+	case GFC_SS_INTRINSIC:
+	  switch (expr->value.function.isym->id)
+	    {
+	    /* Fall through to supply start and stride.  */
+	    case GFC_ISYM_LBOUND:
+	    case GFC_ISYM_UBOUND:
+	      {
+		gfc_expr *arg;
+
+		/* This is the variant without DIM=...  */
+		gcc_assert (expr->value.function.actual->next->expr == NULL);
+
+		arg = expr->value.function.actual->expr;
+		if (arg->rank == -1)
+		  {
+		    gfc_se se;
+		    tree rank, tmp;
+
+		    /* The rank (hence the return value's shape) is unknown,
+		       we have to retrieve it.  */
+		    gfc_init_se (&se, NULL);
+		    se.descriptor_only = 1;
+		    gfc_conv_expr (&se, arg);
+		    /* This is a bare variable, so there is no preliminary
+		       or cleanup code.  */
+		    gcc_assert (se.pre.head == NULL_TREE
+				&& se.post.head == NULL_TREE);
+		    rank = gfc_conv_descriptor_rank (se.expr);
+		    tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					   gfc_array_index_type,
+					   fold_convert (gfc_array_index_type,
+							 rank),
+					   gfc_index_one_node);
+		    info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
+		    info->start[0] = gfc_index_zero_node;
+		    info->stride[0] = gfc_index_one_node;
+		    continue;
+		  }
+		  /* Otherwise fall through GFC_SS_FUNCTION.  */
+		  gcc_fallthrough ();
+	      }
+	    case GFC_ISYM_LCOBOUND:
+	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_THIS_IMAGE:
+	      break;
+
+	    default:
+	      continue;
+	    }
+
+	  /* FALLTHRU */
+	case GFC_SS_CONSTRUCTOR:
+	case GFC_SS_FUNCTION:
+	  for (n = 0; n < ss->dimen; n++)
+	    {
+	      int dim = ss->dim[n];
+
+	      info->start[dim]  = gfc_index_zero_node;
+	      info->end[dim]    = gfc_index_zero_node;
+	      info->stride[dim] = gfc_index_one_node;
+	    }
+	  break;
+
+	default:
+	  break;
+	}
+    }
+
+  /* The rest is just runtime bound checking.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      stmtblock_t block;
+      tree lbound, ubound;
+      tree end;
+      tree size[GFC_MAX_DIMENSIONS];
+      tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
+      gfc_array_info *info;
+      char *msg;
+      int dim;
+
+      gfc_start_block (&block);
+
+      for (n = 0; n < loop->dimen; n++)
+	size[n] = NULL_TREE;
+
+      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+	{
+	  stmtblock_t inner;
+	  gfc_ss_info *ss_info;
+	  gfc_expr *expr;
+	  locus *expr_loc;
+	  const char *expr_name;
+
+	  ss_info = ss->info;
+	  if (ss_info->type != GFC_SS_SECTION)
+	    continue;
+
+	  /* Catch allocatable lhs in f2003.  */
+	  if (flag_realloc_lhs && ss->is_alloc_lhs)
+	    continue;
+
+	  expr = ss_info->expr;
+	  expr_loc = &expr->where;
+	  expr_name = expr->symtree->name;
+
+	  gfc_start_block (&inner);
+
+	  /* TODO: range checking for mapped dimensions.  */
+	  info = &ss_info->data.array;
+
+	  /* This code only checks ranges.  Elemental and vector
+	     dimensions are checked later.  */
+	  for (n = 0; n < loop->dimen; n++)
+	    {
+	      bool check_upper;
+
+	      dim = ss->dim[n];
+	      if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+		continue;
+
+	      if (dim == info->ref->u.ar.dimen - 1
+		  && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+		check_upper = false;
+	      else
+		check_upper = true;
+
+	      /* Zero stride is not allowed.  */
+	      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				     info->stride[dim], gfc_index_zero_node);
+	      msg = xasprintf ("Zero stride is not allowed, for dimension %d "
+			       "of array '%s'", dim + 1, expr_name);
+	      gfc_trans_runtime_check (true, false, tmp, &inner,
+				       expr_loc, msg);
+	      free (msg);
+
+	      desc = info->descriptor;
+
+	      /* This is the run-time equivalent of resolve.c's
+		 check_dimension().  The logical is more readable there
+		 than it is here, with all the trees.  */
+	      lbound = gfc_conv_array_lbound (desc, dim);
+	      end = info->end[dim];
+	      if (check_upper)
+		ubound = gfc_conv_array_ubound (desc, dim);
+	      else
+		ubound = NULL;
+
+	      /* non_zerosized is true when the selected range is not
+		 empty.  */
+	      stride_pos = fold_build2_loc (input_location, GT_EXPR,
+					boolean_type_node, info->stride[dim],
+					gfc_index_zero_node);
+	      tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+				     info->start[dim], end);
+	      stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					    boolean_type_node, stride_pos, tmp);
+
+	      stride_neg = fold_build2_loc (input_location, LT_EXPR,
+				     boolean_type_node,
+				     info->stride[dim], gfc_index_zero_node);
+	      tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+				     info->start[dim], end);
+	      stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					    boolean_type_node,
+					    stride_neg, tmp);
+	      non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+					       boolean_type_node,
+					       stride_pos, stride_neg);
+
+	      /* Check the start of the range against the lower and upper
+		 bounds of the array, if the range is not empty.
+	         If upper bound is present, include both bounds in the
+		 error message.  */
+	      if (check_upper)
+		{
+		  tmp = fold_build2_loc (input_location, LT_EXPR,
+					 boolean_type_node,
+					 info->start[dim], lbound);
+		  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					 boolean_type_node,
+					 non_zerosized, tmp);
+		  tmp2 = fold_build2_loc (input_location, GT_EXPR,
+					  boolean_type_node,
+					  info->start[dim], ubound);
+		  tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					  boolean_type_node,
+					  non_zerosized, tmp2);
+		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+				   "outside of expected range (%%ld:%%ld)",
+				   dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, info->start[dim]),
+		     fold_convert (long_integer_type_node, lbound),
+		     fold_convert (long_integer_type_node, ubound));
+		  gfc_trans_runtime_check (true, false, tmp2, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, info->start[dim]),
+		     fold_convert (long_integer_type_node, lbound),
+		     fold_convert (long_integer_type_node, ubound));
+		  free (msg);
+		}
+	      else
+		{
+		  tmp = fold_build2_loc (input_location, LT_EXPR,
+					 boolean_type_node,
+					 info->start[dim], lbound);
+		  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					 boolean_type_node, non_zerosized, tmp);
+		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+				   "below lower bound of %%ld",
+				   dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, info->start[dim]),
+		     fold_convert (long_integer_type_node, lbound));
+		  free (msg);
+		}
+
+	      /* Compute the last element of the range, which is not
+		 necessarily "end" (think 0:5:3, which doesn't contain 5)
+		 and check it against both lower and upper bounds.  */
+
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, end,
+				     info->start[dim]);
+	      tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+				     gfc_array_index_type, tmp,
+				     info->stride[dim]);
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, end, tmp);
+	      tmp2 = fold_build2_loc (input_location, LT_EXPR,
+				      boolean_type_node, tmp, lbound);
+	      tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				      boolean_type_node, non_zerosized, tmp2);
+	      if (check_upper)
+		{
+		  tmp3 = fold_build2_loc (input_location, GT_EXPR,
+					  boolean_type_node, tmp, ubound);
+		  tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					  boolean_type_node, non_zerosized, tmp3);
+		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+				   "outside of expected range (%%ld:%%ld)",
+				   dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp2, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, tmp),
+		     fold_convert (long_integer_type_node, ubound),
+		     fold_convert (long_integer_type_node, lbound));
+		  gfc_trans_runtime_check (true, false, tmp3, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, tmp),
+		     fold_convert (long_integer_type_node, ubound),
+		     fold_convert (long_integer_type_node, lbound));
+		  free (msg);
+		}
+	      else
+		{
+		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
+				   "below lower bound of %%ld",
+				   dim + 1, expr_name);
+		  gfc_trans_runtime_check (true, false, tmp2, &inner,
+					   expr_loc, msg,
+		     fold_convert (long_integer_type_node, tmp),
+		     fold_convert (long_integer_type_node, lbound));
+		  free (msg);
+		}
+
+	      /* Check the section sizes match.  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, end,
+				     info->start[dim]);
+	      tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
+				     gfc_array_index_type, tmp,
+				     info->stride[dim]);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type,
+				     gfc_index_one_node, tmp);
+	      tmp = fold_build2_loc (input_location, MAX_EXPR,
+				     gfc_array_index_type, tmp,
+				     build_int_cst (gfc_array_index_type, 0));
+	      /* We remember the size of the first section, and check all the
+		 others against this.  */
+	      if (size[n])
+		{
+		  tmp3 = fold_build2_loc (input_location, NE_EXPR,
+					  boolean_type_node, tmp, size[n]);
+		  msg = xasprintf ("Array bound mismatch for dimension %d "
+				   "of array '%s' (%%ld/%%ld)",
+				   dim + 1, expr_name);
+
+		  gfc_trans_runtime_check (true, false, tmp3, &inner,
+					   expr_loc, msg,
+			fold_convert (long_integer_type_node, tmp),
+			fold_convert (long_integer_type_node, size[n]));
+
+		  free (msg);
+		}
+	      else
+		size[n] = gfc_evaluate_now (tmp, &inner);
+	    }
+
+	  tmp = gfc_finish_block (&inner);
+
+	  /* For optional arguments, only check bounds if the argument is
+	     present.  */
+	  if (expr->symtree->n.sym->attr.optional
+	      || expr->symtree->n.sym->attr.not_always_present)
+	    tmp = build3_v (COND_EXPR,
+			    gfc_conv_expr_present (expr->symtree->n.sym),
+			    tmp, build_empty_stmt (input_location));
+
+	  gfc_add_expr_to_block (&block, tmp);
+
+	}
+
+      tmp = gfc_finish_block (&block);
+      gfc_add_expr_to_block (&outer_loop->pre, tmp);
+    }
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    gfc_conv_ss_startstride (loop);
+}
+
+/* Return true if both symbols could refer to the same data object.  Does
+   not take account of aliasing due to equivalence statements.  */
+
+static int
+symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
+		     bool lsym_target, bool rsym_pointer, bool rsym_target)
+{
+  /* Aliasing isn't possible if the symbols have different base types.  */
+  if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
+    return 0;
+
+  /* Pointers can point to other pointers and target objects.  */
+
+  if ((lsym_pointer && (rsym_pointer || rsym_target))
+      || (rsym_pointer && (lsym_pointer || lsym_target)))
+    return 1;
+
+  /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
+     and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
+     checked above.  */
+  if (lsym_target && rsym_target
+      && ((lsym->attr.dummy && !lsym->attr.contiguous
+	   && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
+	  || (rsym->attr.dummy && !rsym->attr.contiguous
+	      && (!rsym->attr.dimension
+		  || rsym->as->type == AS_ASSUMED_SHAPE))))
+    return 1;
+
+  return 0;
+}
+
+
+/* Return true if the two SS could be aliased, i.e. both point to the same data
+   object.  */
+/* TODO: resolve aliases based on frontend expressions.  */
+
+static int
+gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
+{
+  gfc_ref *lref;
+  gfc_ref *rref;
+  gfc_expr *lexpr, *rexpr;
+  gfc_symbol *lsym;
+  gfc_symbol *rsym;
+  bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
+
+  lexpr = lss->info->expr;
+  rexpr = rss->info->expr;
+
+  lsym = lexpr->symtree->n.sym;
+  rsym = rexpr->symtree->n.sym;
+
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+  rsym_pointer = rsym->attr.pointer;
+  rsym_target = rsym->attr.target;
+
+  if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
+			   rsym_pointer, rsym_target))
+    return 1;
+
+  if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
+      && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
+    return 0;
+
+  /* For derived types we must check all the component types.  We can ignore
+     array references as these will have the same base type as the previous
+     component ref.  */
+  for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
+    {
+      if (lref->type != REF_COMPONENT)
+	continue;
+
+      lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
+      lsym_target  = lsym_target  || lref->u.c.sym->attr.target;
+
+      if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
+			       rsym_pointer, rsym_target))
+	return 1;
+
+      if ((lsym_pointer && (rsym_pointer || rsym_target))
+	  || (rsym_pointer && (lsym_pointer || lsym_target)))
+	{
+	  if (gfc_compare_types (&lref->u.c.component->ts,
+				 &rsym->ts))
+	    return 1;
+	}
+
+      for (rref = rexpr->ref; rref != rss->info->data.array.ref;
+	   rref = rref->next)
+	{
+	  if (rref->type != REF_COMPONENT)
+	    continue;
+
+	  rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
+	  rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
+
+	  if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
+				   lsym_pointer, lsym_target,
+				   rsym_pointer, rsym_target))
+	    return 1;
+
+	  if ((lsym_pointer && (rsym_pointer || rsym_target))
+	      || (rsym_pointer && (lsym_pointer || lsym_target)))
+	    {
+	      if (gfc_compare_types (&lref->u.c.component->ts,
+				     &rref->u.c.sym->ts))
+		return 1;
+	      if (gfc_compare_types (&lref->u.c.sym->ts,
+				     &rref->u.c.component->ts))
+		return 1;
+	      if (gfc_compare_types (&lref->u.c.component->ts,
+				     &rref->u.c.component->ts))
+		return 1;
+	    }
+	}
+    }
+
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+
+  for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
+    {
+      if (rref->type != REF_COMPONENT)
+	break;
+
+      rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
+      rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
+
+      if (symbols_could_alias (rref->u.c.sym, lsym,
+			       lsym_pointer, lsym_target,
+			       rsym_pointer, rsym_target))
+	return 1;
+
+      if ((lsym_pointer && (rsym_pointer || rsym_target))
+	  || (rsym_pointer && (lsym_pointer || lsym_target)))
+	{
+	  if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
+	    return 1;
+	}
+    }
+
+  return 0;
+}
+
+
+/* Resolve array data dependencies.  Creates a temporary if required.  */
+/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
+   dependency.c.  */
+
+void
+gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
+			       gfc_ss * rss)
+{
+  gfc_ss *ss;
+  gfc_ref *lref;
+  gfc_ref *rref;
+  gfc_ss_info *ss_info;
+  gfc_expr *dest_expr;
+  gfc_expr *ss_expr;
+  int nDepend = 0;
+  int i, j;
+
+  loop->temp_ss = NULL;
+  dest_expr = dest->info->expr;
+
+  for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
+    {
+      ss_info = ss->info;
+      ss_expr = ss_info->expr;
+
+      if (ss_info->array_outer_dependency)
+	{
+	  nDepend = 1;
+	  break;
+	}
+
+      if (ss_info->type != GFC_SS_SECTION)
+	{
+	  if (flag_realloc_lhs
+	      && dest_expr != ss_expr
+	      && gfc_is_reallocatable_lhs (dest_expr)
+	      && ss_expr->rank)
+	    nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
+
+	  /* Check for cases like   c(:)(1:2) = c(2)(2:3)  */
+	  if (!nDepend && dest_expr->rank > 0
+	      && dest_expr->ts.type == BT_CHARACTER
+	      && ss_expr->expr_type == EXPR_VARIABLE)
+
+	    nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
+
+	  if (ss_info->type == GFC_SS_REFERENCE
+	      && gfc_check_dependency (dest_expr, ss_expr, false))
+	    ss_info->data.scalar.needs_temporary = 1;
+
+	  if (nDepend)
+	    break;
+	  else
+	    continue;
+	}
+
+      if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
+	{
+	  if (gfc_could_be_alias (dest, ss)
+	      || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
+	    {
+	      nDepend = 1;
+	      break;
+	    }
+	}
+      else
+	{
+	  lref = dest_expr->ref;
+	  rref = ss_expr->ref;
+
+	  nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
+
+	  if (nDepend == 1)
+	    break;
+
+	  for (i = 0; i < dest->dimen; i++)
+	    for (j = 0; j < ss->dimen; j++)
+	      if (i != j
+		  && dest->dim[i] == ss->dim[j])
+		{
+		  /* If we don't access array elements in the same order,
+		     there is a dependency.  */
+		  nDepend = 1;
+		  goto temporary;
+		}
+#if 0
+	  /* TODO : loop shifting.  */
+	  if (nDepend == 1)
+	    {
+	      /* Mark the dimensions for LOOP SHIFTING */
+	      for (n = 0; n < loop->dimen; n++)
+	        {
+	          int dim = dest->data.info.dim[n];
+
+		  if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+		    depends[n] = 2;
+		  else if (! gfc_is_same_range (&lref->u.ar,
+						&rref->u.ar, dim, 0))
+		    depends[n] = 1;
+	         }
+
+	      /* Put all the dimensions with dependencies in the
+		 innermost loops.  */
+	      dim = 0;
+	      for (n = 0; n < loop->dimen; n++)
+		{
+		  gcc_assert (loop->order[n] == n);
+		  if (depends[n])
+		  loop->order[dim++] = n;
+		}
+	      for (n = 0; n < loop->dimen; n++)
+	        {
+		  if (! depends[n])
+		  loop->order[dim++] = n;
+		}
+
+	      gcc_assert (dim == loop->dimen);
+	      break;
+	    }
+#endif
+	}
+    }
+
+temporary:
+
+  if (nDepend == 1)
+    {
+      tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
+      if (GFC_ARRAY_TYPE_P (base_type)
+	  || GFC_DESCRIPTOR_TYPE_P (base_type))
+	base_type = gfc_get_element_type (base_type);
+      loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
+				       loop->dimen);
+      gfc_add_ss_to_loop (loop, loop->temp_ss);
+    }
+  else
+    loop->temp_ss = NULL;
+}
+
+
+/* Browse through each array's information from the scalarizer and set the loop
+   bounds according to the "best" one (per dimension), i.e. the one which
+   provides the most information (constant bounds, shape, etc.).  */
+
+static void
+set_loop_bounds (gfc_loopinfo *loop)
+{
+  int n, dim, spec_dim;
+  gfc_array_info *info;
+  gfc_array_info *specinfo;
+  gfc_ss *ss;
+  tree tmp;
+  gfc_ss **loopspec;
+  bool dynamic[GFC_MAX_DIMENSIONS];
+  mpz_t *cshape;
+  mpz_t i;
+  bool nonoptional_arr;
+
+  gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
+  loopspec = loop->specloop;
+
+  mpz_init (i);
+  for (n = 0; n < loop->dimen; n++)
+    {
+      loopspec[n] = NULL;
+      dynamic[n] = false;
+
+      /* If there are both optional and nonoptional array arguments, scalarize
+	 over the nonoptional; otherwise, it does not matter as then all
+	 (optional) arrays have to be present per F2008, 125.2.12p3(6).  */
+
+      nonoptional_arr = false;
+
+      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+	if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
+	    && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
+	  {
+	    nonoptional_arr = true;
+	    break;
+	  }
+
+      /* We use one SS term, and use that to determine the bounds of the
+	 loop for this dimension.  We try to pick the simplest term.  */
+      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+	{
+	  gfc_ss_type ss_type;
+
+	  ss_type = ss->info->type;
+	  if (ss_type == GFC_SS_SCALAR
+	      || ss_type == GFC_SS_TEMP
+	      || ss_type == GFC_SS_REFERENCE
+	      || (ss->info->can_be_null_ref && nonoptional_arr))
+	    continue;
+
+	  info = &ss->info->data.array;
+	  dim = ss->dim[n];
+
+	  if (loopspec[n] != NULL)
+	    {
+	      specinfo = &loopspec[n]->info->data.array;
+	      spec_dim = loopspec[n]->dim[n];
+	    }
+	  else
+	    {
+	      /* Silence uninitialized warnings.  */
+	      specinfo = NULL;
+	      spec_dim = 0;
+	    }
+
+	  if (info->shape)
+	    {
+	      gcc_assert (info->shape[dim]);
+	      /* The frontend has worked out the size for us.  */
+	      if (!loopspec[n]
+		  || !specinfo->shape
+		  || !integer_zerop (specinfo->start[spec_dim]))
+		/* Prefer zero-based descriptors if possible.  */
+		loopspec[n] = ss;
+	      continue;
+	    }
+
+	  if (ss_type == GFC_SS_CONSTRUCTOR)
+	    {
+	      gfc_constructor_base base;
+	      /* An unknown size constructor will always be rank one.
+		 Higher rank constructors will either have known shape,
+		 or still be wrapped in a call to reshape.  */
+	      gcc_assert (loop->dimen == 1);
+
+	      /* Always prefer to use the constructor bounds if the size
+		 can be determined at compile time.  Prefer not to otherwise,
+		 since the general case involves realloc, and it's better to
+		 avoid that overhead if possible.  */
+	      base = ss->info->expr->value.constructor;
+	      dynamic[n] = gfc_get_array_constructor_size (&i, base);
+	      if (!dynamic[n] || !loopspec[n])
+		loopspec[n] = ss;
+	      continue;
+	    }
+
+	  /* Avoid using an allocatable lhs in an assignment, since
+	     there might be a reallocation coming.  */
+	  if (loopspec[n] && ss->is_alloc_lhs)
+	    continue;
+
+	  if (!loopspec[n])
+	    loopspec[n] = ss;
+	  /* Criteria for choosing a loop specifier (most important first):
+	     doesn't need realloc
+	     stride of one
+	     known stride
+	     known lower bound
+	     known upper bound
+	   */
+	  else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+	    loopspec[n] = ss;
+	  else if (integer_onep (info->stride[dim])
+		   && !integer_onep (specinfo->stride[spec_dim]))
+	    loopspec[n] = ss;
+	  else if (INTEGER_CST_P (info->stride[dim])
+		   && !INTEGER_CST_P (specinfo->stride[spec_dim]))
+	    loopspec[n] = ss;
+	  else if (INTEGER_CST_P (info->start[dim])
+		   && !INTEGER_CST_P (specinfo->start[spec_dim])
+		   && integer_onep (info->stride[dim])
+		      == integer_onep (specinfo->stride[spec_dim])
+		   && INTEGER_CST_P (info->stride[dim])
+		      == INTEGER_CST_P (specinfo->stride[spec_dim]))
+	    loopspec[n] = ss;
+	  /* We don't work out the upper bound.
+	     else if (INTEGER_CST_P (info->finish[n])
+	     && ! INTEGER_CST_P (specinfo->finish[n]))
+	     loopspec[n] = ss; */
+	}
+
+      /* We should have found the scalarization loop specifier.  If not,
+	 that's bad news.  */
+      gcc_assert (loopspec[n]);
+
+      info = &loopspec[n]->info->data.array;
+      dim = loopspec[n]->dim[n];
+
+      /* Set the extents of this range.  */
+      cshape = info->shape;
+      if (cshape && INTEGER_CST_P (info->start[dim])
+	  && INTEGER_CST_P (info->stride[dim]))
+	{
+	  loop->from[n] = info->start[dim];
+	  mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
+	  mpz_sub_ui (i, i, 1);
+	  /* To = from + (size - 1) * stride.  */
+	  tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
+	  if (!integer_onep (info->stride[dim]))
+	    tmp = fold_build2_loc (input_location, MULT_EXPR,
+				   gfc_array_index_type, tmp,
+				   info->stride[dim]);
+	  loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type,
+					 loop->from[n], tmp);
+	}
+      else
+	{
+	  loop->from[n] = info->start[dim];
+	  switch (loopspec[n]->info->type)
+	    {
+	    case GFC_SS_CONSTRUCTOR:
+	      /* The upper bound is calculated when we expand the
+		 constructor.  */
+	      gcc_assert (loop->to[n] == NULL_TREE);
+	      break;
+
+	    case GFC_SS_SECTION:
+	      /* Use the end expression if it exists and is not constant,
+		 so that it is only evaluated once.  */
+	      loop->to[n] = info->end[dim];
+	      break;
+
+	    case GFC_SS_FUNCTION:
+	      /* The loop bound will be set when we generate the call.  */
+	      gcc_assert (loop->to[n] == NULL_TREE);
+	      break;
+
+	    case GFC_SS_INTRINSIC:
+	      {
+		gfc_expr *expr = loopspec[n]->info->expr;
+
+		/* The {l,u}bound of an assumed rank.  */
+		gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
+			     || expr->value.function.isym->id == GFC_ISYM_UBOUND)
+			     && expr->value.function.actual->next->expr == NULL
+			     && expr->value.function.actual->expr->rank == -1);
+
+		loop->to[n] = info->end[dim];
+		break;
+	      }
+
+	    default:
+	      gcc_unreachable ();
+	    }
+	}
+
+      /* Transform everything so we have a simple incrementing variable.  */
+      if (integer_onep (info->stride[dim]))
+	info->delta[dim] = gfc_index_zero_node;
+      else
+	{
+	  /* Set the delta for this section.  */
+	  info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
+	  /* Number of iterations is (end - start + step) / step.
+	     with start = 0, this simplifies to
+	     last = end / step;
+	     for (i = 0; i<=last; i++){...};  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, loop->to[n],
+				 loop->from[n]);
+	  tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
+				 gfc_array_index_type, tmp, info->stride[dim]);
+	  tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+				 tmp, build_int_cst (gfc_array_index_type, -1));
+	  loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
+	  /* Make the loop variable start at 0.  */
+	  loop->from[n] = gfc_index_zero_node;
+	}
+    }
+  mpz_clear (i);
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    set_loop_bounds (loop);
+}
+
+
+/* Initialize the scalarization loop.  Creates the loop variables.  Determines
+   the range of the loop variables.  Creates a temporary if required.
+   Also generates code for scalar expressions which have been
+   moved outside the loop.  */
+
+void
+gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
+{
+  gfc_ss *tmp_ss;
+  tree tmp;
+
+  set_loop_bounds (loop);
+
+  /* Add all the scalar code that can be taken out of the loops.
+     This may include calculating the loop bounds, so do it before
+     allocating the temporary.  */
+  gfc_add_loop_ss_code (loop, loop->ss, false, where);
+
+  tmp_ss = loop->temp_ss;
+  /* If we want a temporary then create it.  */
+  if (tmp_ss != NULL)
+    {
+      gfc_ss_info *tmp_ss_info;
+
+      tmp_ss_info = tmp_ss->info;
+      gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
+      gcc_assert (loop->parent == NULL);
+
+      /* Make absolutely sure that this is a complete type.  */
+      if (tmp_ss_info->string_length)
+	tmp_ss_info->data.temp.type
+		= gfc_get_character_type_len_for_eltype
+			(TREE_TYPE (tmp_ss_info->data.temp.type),
+			 tmp_ss_info->string_length);
+
+      tmp = tmp_ss_info->data.temp.type;
+      memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
+      tmp_ss_info->type = GFC_SS_SECTION;
+
+      gcc_assert (tmp_ss->dimen != 0);
+
+      gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
+				   NULL_TREE, false, true, false, where);
+    }
+
+  /* For array parameters we don't have loop variables, so don't calculate the
+     translations.  */
+  if (!loop->array_parameter)
+    gfc_set_delta (loop);
+}
+
+
+/* Calculates how to transform from loop variables to array indices for each
+   array: once loop bounds are chosen, sets the difference (DELTA field) between
+   loop bounds and array reference bounds, for each array info.  */
+
+void
+gfc_set_delta (gfc_loopinfo *loop)
+{
+  gfc_ss *ss, **loopspec;
+  gfc_array_info *info;
+  tree tmp;
+  int n, dim;
+
+  gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
+  loopspec = loop->specloop;
+
+  /* Calculate the translation from loop variables to array indices.  */
+  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+    {
+      gfc_ss_type ss_type;
+
+      ss_type = ss->info->type;
+      if (ss_type != GFC_SS_SECTION
+	  && ss_type != GFC_SS_COMPONENT
+	  && ss_type != GFC_SS_CONSTRUCTOR)
+	continue;
+
+      info = &ss->info->data.array;
+
+      for (n = 0; n < ss->dimen; n++)
+	{
+	  /* If we are specifying the range the delta is already set.  */
+	  if (loopspec[n] != ss)
+	    {
+	      dim = ss->dim[n];
+
+	      /* Calculate the offset relative to the loop variable.
+		 First multiply by the stride.  */
+	      tmp = loop->from[n];
+	      if (!integer_onep (info->stride[dim]))
+		tmp = fold_build2_loc (input_location, MULT_EXPR,
+				       gfc_array_index_type,
+				       tmp, info->stride[dim]);
+
+	      /* Then subtract this from our starting value.  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     info->start[dim], tmp);
+
+	      info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
+	    }
+	}
+    }
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    gfc_set_delta (loop);
+}
+
+
+/* Calculate the size of a given array dimension from the bounds.  This
+   is simply (ubound - lbound + 1) if this expression is positive
+   or 0 if it is negative (pick either one if it is zero).  Optionally
+   (if or_expr is present) OR the (expression != 0) condition to it.  */
+
+tree
+gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
+{
+  tree res;
+  tree cond;
+
+  /* Calculate (ubound - lbound + 1).  */
+  res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 ubound, lbound);
+  res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
+			 gfc_index_one_node);
+
+  /* Check whether the size for this dimension is negative.  */
+  cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
+			  gfc_index_zero_node);
+  res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+			 gfc_index_zero_node, res);
+
+  /* Build OR expression.  */
+  if (or_expr)
+    *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				boolean_type_node, *or_expr, cond);
+
+  return res;
+}
+
+
+/* For an array descriptor, get the total number of elements.  This is just
+   the product of the extents along from_dim to to_dim.  */
+
+static tree
+gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
+{
+  tree res;
+  int dim;
+
+  res = gfc_index_one_node;
+
+  for (dim = from_dim; dim < to_dim; ++dim)
+    {
+      tree lbound;
+      tree ubound;
+      tree extent;
+
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+
+      extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+      res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     res, extent);
+    }
+
+  return res;
+}
+
+
+/* Full size of an array.  */
+
+tree
+gfc_conv_descriptor_size (tree desc, int rank)
+{
+  return gfc_conv_descriptor_size_1 (desc, 0, rank);
+}
+
+
+/* Size of a coarray for all dimensions but the last.  */
+
+tree
+gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
+{
+  return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
+}
+
+
+/* Fills in an array descriptor, and returns the size of the array.
+   The size will be a simple_val, ie a variable or a constant.  Also
+   calculates the offset of the base.  The pointer argument overflow,
+   which should be of integer type, will increase in value if overflow
+   occurs during the size calculation.  Returns the size of the array.
+   {
+    stride = 1;
+    offset = 0;
+    for (n = 0; n < rank; n++)
+      {
+	a.lbound[n] = specified_lower_bound;
+	offset = offset + a.lbond[n] * stride;
+	size = 1 - lbound;
+	a.ubound[n] = specified_upper_bound;
+	a.stride[n] = stride;
+	size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
+	overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
+	stride = stride * size;
+      }
+    for (n = rank; n < rank+corank; n++)
+      (Set lcobound/ucobound as above.)
+    element_size = sizeof (array element);
+    if (!rank)
+      return element_size
+    stride = (size_t) stride;
+    overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
+    stride = stride * element_size;
+    return (stride);
+   }  */
+/*GCC ARRAYS*/
+
+static tree
+gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
+		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
+		     stmtblock_t * descriptor_block, tree * overflow,
+		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
+		     tree expr3_desc, bool e3_is_array_constr, gfc_expr *expr)
+{
+  tree type;
+  tree tmp;
+  tree size;
+  tree offset;
+  tree stride;
+  tree element_size;
+  tree or_expr;
+  tree thencase;
+  tree elsecase;
+  tree cond;
+  tree var;
+  stmtblock_t thenblock;
+  stmtblock_t elseblock;
+  gfc_expr *ubound;
+  gfc_se se;
+  int n;
+
+  type = TREE_TYPE (descriptor);
+
+  stride = gfc_index_one_node;
+  offset = gfc_index_zero_node;
+
+  /* Set the dtype before the alloc, because registration of coarrays needs
+     it initialized.  */
+  if (expr->ts.type == BT_CHARACTER
+      && expr->ts.deferred
+      && VAR_P (expr->ts.u.cl->backend_decl))
+    {
+      type = gfc_typenode_for_spec (&expr->ts);
+      tmp = gfc_conv_descriptor_dtype (descriptor);
+      gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
+    }
+  else
+    {
+      tmp = gfc_conv_descriptor_dtype (descriptor);
+      gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
+    }
+
+  or_expr = boolean_false_node;
+
+  for (n = 0; n < rank; n++)
+    {
+      tree conv_lbound;
+      tree conv_ubound;
+
+      /* We have 3 possibilities for determining the size of the array:
+	 lower == NULL    => lbound = 1, ubound = upper[n]
+	 upper[n] = NULL  => lbound = 1, ubound = lower[n]
+	 upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
+      ubound = upper[n];
+
+      /* Set lower bound.  */
+      gfc_init_se (&se, NULL);
+      if (expr3_desc != NULL_TREE)
+	{
+	  if (e3_is_array_constr)
+	    /* The lbound of a constant array [] starts at zero, but when
+	       allocating it, the standard expects the array to start at
+	       one.  */
+	    se.expr = gfc_index_one_node;
+	  else
+	    se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
+						      gfc_rank_cst[n]);
+	}
+      else if (lower == NULL)
+	se.expr = gfc_index_one_node;
+      else
+	{
+	  gcc_assert (lower[n]);
+	  if (ubound)
+	    {
+	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+	      gfc_add_block_to_block (pblock, &se.pre);
+	    }
+	  else
+	    {
+	      se.expr = gfc_index_one_node;
+	      ubound = lower[n];
+	    }
+	}
+      gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], se.expr);
+      conv_lbound = se.expr;
+
+      /* Work out the offset for this component.  */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     se.expr, stride);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type, offset, tmp);
+
+      /* Set upper bound.  */
+      gfc_init_se (&se, NULL);
+      if (expr3_desc != NULL_TREE)
+	{
+	  if (e3_is_array_constr)
+	    {
+	      /* The lbound of a constant array [] starts at zero, but when
+	       allocating it, the standard expects the array to start at
+	       one.  Therefore fix the upper bound to be
+	       (desc.ubound - desc.lbound)+ 1.  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     gfc_conv_descriptor_ubound_get (
+				       expr3_desc, gfc_rank_cst[n]),
+				     gfc_conv_descriptor_lbound_get (
+				       expr3_desc, gfc_rank_cst[n]));
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, tmp,
+				     gfc_index_one_node);
+	      se.expr = gfc_evaluate_now (tmp, pblock);
+	    }
+	  else
+	    se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
+						      gfc_rank_cst[n]);
+	}
+      else
+	{
+	  gcc_assert (ubound);
+	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  if (ubound->expr_type == EXPR_FUNCTION)
+	    se.expr = gfc_evaluate_now (se.expr, pblock);
+	}
+      gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], se.expr);
+      conv_ubound = se.expr;
+
+      /* Store the stride.  */
+      gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], stride);
+
+      /* Calculate size and check whether extent is negative.  */
+      size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
+      size = gfc_evaluate_now (size, pblock);
+
+      /* Check whether multiplying the stride by the number of
+	 elements in this dimension would overflow. We must also check
+	 whether the current dimension has zero size in order to avoid
+	 division by zero.
+      */
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type,
+			     fold_convert (gfc_array_index_type,
+					   TYPE_MAX_VALUE (gfc_array_index_type)),
+					   size);
+      cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
+					    boolean_type_node, tmp, stride),
+			   PRED_FORTRAN_OVERFLOW);
+      tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			     integer_one_node, integer_zero_node);
+      cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
+					    boolean_type_node, size,
+					    gfc_index_zero_node),
+			   PRED_FORTRAN_SIZE_ZERO);
+      tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			     integer_zero_node, tmp);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			     *overflow, tmp);
+      *overflow = gfc_evaluate_now (tmp, pblock);
+
+      /* Multiply the stride by the number of elements in this dimension.  */
+      stride = fold_build2_loc (input_location, MULT_EXPR,
+				gfc_array_index_type, stride, size);
+      stride = gfc_evaluate_now (stride, pblock);
+    }
+
+  for (n = rank; n < rank + corank; n++)
+    {
+      ubound = upper[n];
+
+      /* Set lower bound.  */
+      gfc_init_se (&se, NULL);
+      if (lower == NULL || lower[n] == NULL)
+	{
+	  gcc_assert (n == rank + corank - 1);
+	  se.expr = gfc_index_one_node;
+	}
+      else
+	{
+	  if (ubound || n == rank + corank - 1)
+	    {
+	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+	      gfc_add_block_to_block (pblock, &se.pre);
+	    }
+	  else
+	    {
+	      se.expr = gfc_index_one_node;
+	      ubound = lower[n];
+	    }
+	}
+      gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], se.expr);
+
+      if (n < rank + corank - 1)
+	{
+	  gfc_init_se (&se, NULL);
+	  gcc_assert (ubound);
+	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
+					  gfc_rank_cst[n], se.expr);
+	}
+    }
+
+  /* The stride is the number of elements in the array, so multiply by the
+     size of an element to get the total size.  Obviously, if there is a
+     SOURCE expression (expr3) we must use its element size.  */
+  if (expr3_elem_size != NULL_TREE)
+    tmp = expr3_elem_size;
+  else if (expr3 != NULL)
+    {
+      if (expr3->ts.type == BT_CLASS)
+	{
+	  gfc_se se_sz;
+	  gfc_expr *sz = gfc_copy_expr (expr3);
+	  gfc_add_vptr_component (sz);
+	  gfc_add_size_component (sz);
+	  gfc_init_se (&se_sz, NULL);
+	  gfc_conv_expr (&se_sz, sz);
+	  gfc_free_expr (sz);
+	  tmp = se_sz.expr;
+	}
+      else
+	{
+	  tmp = gfc_typenode_for_spec (&expr3->ts);
+	  tmp = TYPE_SIZE_UNIT (tmp);
+	}
+    }
+  else
+    tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+
+  /* Convert to size_t.  */
+  element_size = fold_convert (size_type_node, tmp);
+
+  if (rank == 0)
+    return element_size;
+
+  *nelems = gfc_evaluate_now (stride, pblock);
+  stride = fold_convert (size_type_node, stride);
+
+  /* First check for overflow. Since an array of type character can
+     have zero element_size, we must check for that before
+     dividing.  */
+  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			 size_type_node,
+			 TYPE_MAX_VALUE (size_type_node), element_size);
+  cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
+					boolean_type_node, tmp, stride),
+		       PRED_FORTRAN_OVERFLOW);
+  tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			 integer_one_node, integer_zero_node);
+  cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
+					boolean_type_node, element_size,
+					build_int_cst (size_type_node, 0)),
+		       PRED_FORTRAN_SIZE_ZERO);
+  tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+			 integer_zero_node, tmp);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			 *overflow, tmp);
+  *overflow = gfc_evaluate_now (tmp, pblock);
+
+  size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			  stride, element_size);
+
+  if (poffset != NULL)
+    {
+      offset = gfc_evaluate_now (offset, pblock);
+      *poffset = offset;
+    }
+
+  if (integer_zerop (or_expr))
+    return size;
+  if (integer_onep (or_expr))
+    return build_int_cst (size_type_node, 0);
+
+  var = gfc_create_var (TREE_TYPE (size), "size");
+  gfc_start_block (&thenblock);
+  gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
+  thencase = gfc_finish_block (&thenblock);
+
+  gfc_start_block (&elseblock);
+  gfc_add_modify (&elseblock, var, size);
+  elsecase = gfc_finish_block (&elseblock);
+
+  tmp = gfc_evaluate_now (or_expr, pblock);
+  tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+  gfc_add_expr_to_block (pblock, tmp);
+
+  return var;
+}
+
+
+/* Retrieve the last ref from the chain.  This routine is specific to
+   gfc_array_allocate ()'s needs.  */
+
+bool
+retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
+{
+  gfc_ref *ref, *prev_ref;
+
+  ref = *ref_in;
+  /* Prevent warnings for uninitialized variables.  */
+  prev_ref = *prev_ref_in;
+  while (ref && ref->next != NULL)
+    {
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
+      prev_ref = ref;
+      ref = ref->next;
+    }
+
+  if (ref == NULL || ref->type != REF_ARRAY)
+    return false;
+
+  *ref_in = ref;
+  *prev_ref_in = prev_ref;
+  return true;
+}
+
+/* Initializes the descriptor and generates a call to _gfor_allocate.  Does
+   the work for an ALLOCATE statement.  */
+/*GCC ARRAYS*/
+
+bool
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
+		    tree errlen, tree label_finish, tree expr3_elem_size,
+		    tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
+		    bool e3_is_array_constr)
+{
+  tree tmp;
+  tree pointer;
+  tree offset = NULL_TREE;
+  tree token = NULL_TREE;
+  tree size;
+  tree msg;
+  tree error = NULL_TREE;
+  tree overflow; /* Boolean storing whether size calculation overflows.  */
+  tree var_overflow = NULL_TREE;
+  tree cond;
+  tree set_descriptor;
+  stmtblock_t set_descriptor_block;
+  stmtblock_t elseblock;
+  gfc_expr **lower;
+  gfc_expr **upper;
+  gfc_ref *ref, *prev_ref = NULL, *coref;
+  bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
+      non_ulimate_coarray_ptr_comp;
+
+  ref = expr->ref;
+
+  /* Find the last reference in the chain.  */
+  if (!retrieve_last_ref (&ref, &prev_ref))
+    return false;
+
+  /* Take the allocatable and coarray properties solely from the expr-ref's
+     attributes and not from source=-expression.  */
+  if (!prev_ref)
+    {
+      allocatable = expr->symtree->n.sym->attr.allocatable;
+      dimension = expr->symtree->n.sym->attr.dimension;
+      non_ulimate_coarray_ptr_comp = false;
+    }
+  else
+    {
+      allocatable = prev_ref->u.c.component->attr.allocatable;
+      /* Pointer components in coarrayed derived types must be treated
+	 specially in that they are registered without a check if the are
+	 already associated.  This does not hold for ultimate coarray
+	 pointers.  */
+      non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
+	      && !prev_ref->u.c.component->attr.codimension);
+      dimension = prev_ref->u.c.component->attr.dimension;
+    }
+
+  /* For allocatable/pointer arrays in derived types, one of the refs has to be
+     a coarray.  In this case it does not matter whether we are on this_image
+     or not.  */
+  coarray = false;
+  for (coref = expr->ref; coref; coref = coref->next)
+    if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
+      {
+	coarray = true;
+	break;
+      }
+
+  if (!dimension)
+    gcc_assert (coarray);
+
+  if (ref->u.ar.type == AR_FULL && expr3 != NULL)
+    {
+      gfc_ref *old_ref = ref;
+      /* F08:C633: Array shape from expr3.  */
+      ref = expr3->ref;
+
+      /* Find the last reference in the chain.  */
+      if (!retrieve_last_ref (&ref, &prev_ref))
+	{
+	  if (expr3->expr_type == EXPR_FUNCTION
+	      && gfc_expr_attr (expr3).dimension)
+	    ref = old_ref;
+	  else
+	    return false;
+	}
+      alloc_w_e3_arr_spec = true;
+    }
+
+  /* Figure out the size of the array.  */
+  switch (ref->u.ar.type)
+    {
+    case AR_ELEMENT:
+      if (!coarray)
+	{
+	  lower = NULL;
+	  upper = ref->u.ar.start;
+	  break;
+	}
+      /* Fall through.  */
+
+    case AR_SECTION:
+      lower = ref->u.ar.start;
+      upper = ref->u.ar.end;
+      break;
+
+    case AR_FULL:
+      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
+		  || alloc_w_e3_arr_spec);
+
+      lower = ref->u.ar.as->lower;
+      upper = ref->u.ar.as->upper;
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+
+  overflow = integer_zero_node;
+
+  gfc_init_block (&set_descriptor_block);
+  /* Take the corank only from the actual ref and not from the coref.  The
+     later will mislead the generation of the array dimensions for allocatable/
+     pointer components in derived types.  */
+  size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
+							   : ref->u.ar.as->rank,
+			      coarray ? ref->u.ar.as->corank : 0,
+			      &offset, lower, upper,
+			      &se->pre, &set_descriptor_block, &overflow,
+			      expr3_elem_size, nelems, expr3, e3_arr_desc,
+			      e3_is_array_constr, expr);
+
+  if (dimension)
+    {
+      var_overflow = gfc_create_var (integer_type_node, "overflow");
+      gfc_add_modify (&se->pre, var_overflow, overflow);
+
+      if (status == NULL_TREE)
+	{
+	  /* Generate the block of code handling overflow.  */
+	  msg = gfc_build_addr_expr (pchar_type_node,
+		    gfc_build_localized_cstring_const
+  			("Integer overflow when calculating the amount of "
+  			 "memory to allocate"));
+	  error = build_call_expr_loc (input_location,
+				       gfor_fndecl_runtime_error, 1, msg);
+	}
+      else
+	{
+	  tree status_type = TREE_TYPE (status);
+	  stmtblock_t set_status_block;
+
+	  gfc_start_block (&set_status_block);
+	  gfc_add_modify (&set_status_block, status,
+			  build_int_cst (status_type, LIBERROR_ALLOCATION));
+	  error = gfc_finish_block (&set_status_block);
+	}
+    }
+
+  gfc_start_block (&elseblock);
+
+  /* Allocate memory to store the data.  */
+  if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+  if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
+    {
+      pointer = non_ulimate_coarray_ptr_comp ? se->expr
+				      : gfc_conv_descriptor_data_get (se->expr);
+      token = gfc_conv_descriptor_token (se->expr);
+      token = gfc_build_addr_expr (NULL_TREE, token);
+    }
+  else
+    pointer = gfc_conv_descriptor_data_get (se->expr);
+  STRIP_NOPS (pointer);
+
+  /* The allocatable variant takes the old pointer as first argument.  */
+  if (allocatable)
+    gfc_allocate_allocatable (&elseblock, pointer, size, token,
+			      status, errmsg, errlen, label_finish, expr,
+			      coref != NULL ? coref->u.ar.as->corank : 0);
+  else if (non_ulimate_coarray_ptr_comp && token)
+    /* The token is set only for GFC_FCOARRAY_LIB mode.  */
+    gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
+				errmsg, errlen,
+				GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
+  else
+    gfc_allocate_using_malloc (&elseblock, pointer, size, status);
+
+  if (dimension)
+    {
+      cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
+			   boolean_type_node, var_overflow, integer_zero_node),
+			   PRED_FORTRAN_OVERFLOW);
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			     error, gfc_finish_block (&elseblock));
+    }
+  else
+    tmp = gfc_finish_block (&elseblock);
+
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Update the array descriptors.  */
+  if (dimension)
+    gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+
+  /* Pointer arrays need the span field to be set.  */
+  if (is_pointer_array (se->expr)
+      || (expr->ts.type == BT_CLASS
+	  && CLASS_DATA (expr)->attr.class_pointer))
+    {
+      if (expr3 && expr3_elem_size != NULL_TREE)
+	tmp = expr3_elem_size;
+      else
+	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr)));
+      tmp = fold_convert (gfc_array_index_type, tmp);
+      gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
+    }
+
+  set_descriptor = gfc_finish_block (&set_descriptor_block);
+  if (status != NULL_TREE)
+    {
+      cond = fold_build2_loc (input_location, EQ_EXPR,
+			  boolean_type_node, status,
+			  build_int_cst (TREE_TYPE (status), 0));
+      gfc_add_expr_to_block (&se->pre,
+		 fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				  cond,
+				  set_descriptor,
+				  build_empty_stmt (input_location)));
+    }
+  else
+      gfc_add_expr_to_block (&se->pre, set_descriptor);
+
+  return true;
+}
+
+
+/* Create an array constructor from an initialization expression.
+   We assume the frontend already did any expansions and conversions.  */
+
+tree
+gfc_conv_array_initializer (tree type, gfc_expr * expr)
+{
+  gfc_constructor *c;
+  tree tmp;
+  offset_int wtmp;
+  gfc_se se;
+  tree index, range;
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  if (expr->expr_type == EXPR_VARIABLE
+      && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+      && expr->symtree->n.sym->value)
+    expr = expr->symtree->n.sym->value;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_CONSTANT:
+    case EXPR_STRUCTURE:
+      /* A single scalar or derived type value.  Create an array with all
+         elements equal to that value.  */
+      gfc_init_se (&se, NULL);
+
+      if (expr->expr_type == EXPR_CONSTANT)
+	gfc_conv_constant (&se, expr);
+      else
+	gfc_conv_structure (&se, expr, 1);
+
+      wtmp = wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) + 1;
+      /* This will probably eat buckets of memory for large arrays.  */
+      while (wtmp != 0)
+        {
+	  CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
+	  wtmp -= 1;
+        }
+      break;
+
+    case EXPR_ARRAY:
+      /* Create a vector of all the elements.  */
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; c = gfc_constructor_next (c))
+        {
+          if (c->iterator)
+            {
+              /* Problems occur when we get something like
+                 integer :: a(lots) = (/(i, i=1, lots)/)  */
+              gfc_fatal_error ("The number of elements in the array "
+			       "constructor at %L requires an increase of "
+			       "the allowed %d upper limit. See "
+			       "%<-fmax-array-constructor%> option",
+			       &expr->where, flag_max_array_constructor);
+	      return NULL_TREE;
+	    }
+          if (mpz_cmp_si (c->offset, 0) != 0)
+            index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+          else
+            index = NULL_TREE;
+
+	  if (mpz_cmp_si (c->repeat, 1) > 0)
+	    {
+	      tree tmp1, tmp2;
+	      mpz_t maxval;
+
+	      mpz_init (maxval);
+	      mpz_add (maxval, c->offset, c->repeat);
+	      mpz_sub_ui (maxval, maxval, 1);
+	      tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+	      if (mpz_cmp_si (c->offset, 0) != 0)
+		{
+		  mpz_add_ui (maxval, c->offset, 1);
+		  tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+		}
+	      else
+		tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+
+	      range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
+	      mpz_clear (maxval);
+	    }
+	  else
+	    range = NULL;
+
+          gfc_init_se (&se, NULL);
+	  switch (c->expr->expr_type)
+	    {
+	    case EXPR_CONSTANT:
+	      gfc_conv_constant (&se, c->expr);
+	      break;
+
+	    case EXPR_STRUCTURE:
+              gfc_conv_structure (&se, c->expr, 1);
+	      break;
+
+	    default:
+	      /* Catch those occasional beasts that do not simplify
+		 for one reason or another, assuming that if they are
+		 standard defying the frontend will catch them.  */
+	      gfc_conv_expr (&se, c->expr);
+	      break;
+	    }
+
+	  if (range == NULL_TREE)
+	    CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+	  else
+	    {
+	      if (index != NULL_TREE)
+		CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+	      CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+	    }
+        }
+      break;
+
+    case EXPR_NULL:
+      return gfc_build_null_descriptor (type);
+
+    default:
+      gcc_unreachable ();
+    }
+
+  /* Create a constructor from the list of elements.  */
+  tmp = build_constructor (type, v);
+  TREE_CONSTANT (tmp) = 1;
+  return tmp;
+}
+
+
+/* Generate code to evaluate non-constant coarray cobounds.  */
+
+void
+gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
+			  const gfc_symbol *sym)
+{
+  int dim;
+  tree ubound;
+  tree lbound;
+  gfc_se se;
+  gfc_array_spec *as;
+
+  as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+
+  for (dim = as->rank; dim < as->rank + as->corank; dim++)
+    {
+      /* Evaluate non-constant array bound expressions.  */
+      lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+      if (as->lower[dim] && !INTEGER_CST_P (lbound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, lbound, se.expr);
+        }
+      ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+      if (as->upper[dim] && !INTEGER_CST_P (ubound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, ubound, se.expr);
+        }
+    }
+}
+
+
+/* Generate code to evaluate non-constant array bounds.  Sets *poffset and
+   returns the size (in elements) of the array.  */
+
+static tree
+gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
+                        stmtblock_t * pblock)
+{
+  gfc_array_spec *as;
+  tree size;
+  tree stride;
+  tree offset;
+  tree ubound;
+  tree lbound;
+  tree tmp;
+  gfc_se se;
+
+  int dim;
+
+  as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+
+  size = gfc_index_one_node;
+  offset = gfc_index_zero_node;
+  for (dim = 0; dim < as->rank; dim++)
+    {
+      /* Evaluate non-constant array bound expressions.  */
+      lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+      if (as->lower[dim] && !INTEGER_CST_P (lbound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, lbound, se.expr);
+        }
+      ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+      if (as->upper[dim] && !INTEGER_CST_P (ubound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, ubound, se.expr);
+        }
+      /* The offset of this dimension.  offset = offset - lbound * stride.  */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     lbound, size);
+      offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+				offset, tmp);
+
+      /* The size of this dimension, and the stride of the next.  */
+      if (dim + 1 < as->rank)
+        stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
+      else
+	stride = GFC_TYPE_ARRAY_SIZE (type);
+
+      if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
+        {
+          /* Calculate stride = size * (ubound + 1 - lbound).  */
+          tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 gfc_index_one_node, lbound);
+          tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, ubound, tmp);
+          tmp = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type, size, tmp);
+          if (stride)
+            gfc_add_modify (pblock, stride, tmp);
+          else
+            stride = gfc_evaluate_now (tmp, pblock);
+
+	  /* Make sure that negative size arrays are translated
+	     to being zero size.  */
+	  tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+				 stride, gfc_index_zero_node);
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 gfc_array_index_type, tmp,
+				 stride, gfc_index_zero_node);
+	  gfc_add_modify (pblock, stride, tmp);
+        }
+
+      size = stride;
+    }
+
+  gfc_trans_array_cobounds (type, pblock, sym);
+  gfc_trans_vla_type_sizes (sym, pblock);
+
+  *poffset = offset;
+  return size;
+}
+
+
+/* Generate code to initialize/allocate an array variable.  */
+
+void
+gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
+				 gfc_wrapped_block * block)
+{
+  stmtblock_t init;
+  tree type;
+  tree tmp = NULL_TREE;
+  tree size;
+  tree offset;
+  tree space;
+  tree inittree;
+  bool onstack;
+
+  gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
+
+  /* Do nothing for USEd variables.  */
+  if (sym->attr.use_assoc)
+    return;
+
+  type = TREE_TYPE (decl);
+  gcc_assert (GFC_ARRAY_TYPE_P (type));
+  onstack = TREE_CODE (type) != POINTER_TYPE;
+
+  gfc_init_block (&init);
+
+  /* Evaluate character string length.  */
+  if (sym->ts.type == BT_CHARACTER
+      && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+    {
+      gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+
+      gfc_trans_vla_type_sizes (sym, &init);
+
+      /* Emit a DECL_EXPR for this variable, which will cause the
+	 gimplifier to allocate storage, and all that good stuff.  */
+      tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
+      gfc_add_expr_to_block (&init, tmp);
+    }
+
+  if (onstack)
+    {
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
+    }
+
+  type = TREE_TYPE (type);
+
+  gcc_assert (!sym->attr.use_assoc);
+  gcc_assert (!TREE_STATIC (decl));
+  gcc_assert (!sym->module);
+
+  if (sym->ts.type == BT_CHARACTER
+      && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+    gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+
+  size = gfc_trans_array_bounds (type, sym, &offset, &init);
+
+  /* Don't actually allocate space for Cray Pointees.  */
+  if (sym->attr.cray_pointee)
+    {
+      if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
+	gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      return;
+    }
+
+  if (flag_stack_arrays)
+    {
+      gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
+      space = build_decl (sym->declared_at.lb->location,
+			  VAR_DECL, create_tmp_var_name ("A"),
+			  TREE_TYPE (TREE_TYPE (decl)));
+      gfc_trans_vla_type_sizes (sym, &init);
+    }
+  else
+    {
+      /* The size is the number of elements in the array, so multiply by the
+	 size of an element to get the total size.  */
+      tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      size, fold_convert (gfc_array_index_type, tmp));
+
+      /* Allocate memory to hold the data.  */
+      tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
+      gfc_add_modify (&init, decl, tmp);
+
+      /* Free the temporary.  */
+      tmp = gfc_call_free (decl);
+      space = NULL_TREE;
+    }
+
+  /* Set offset of the array.  */
+  if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+  /* Automatic arrays should not have initializers.  */
+  gcc_assert (!sym->value);
+
+  inittree = gfc_finish_block (&init);
+
+  if (space)
+    {
+      tree addr;
+      pushdecl (space);
+
+      /* Don't create new scope, emit the DECL_EXPR in exactly the scope
+         where also space is located.  */
+      gfc_init_block (&init);
+      tmp = fold_build1_loc (input_location, DECL_EXPR,
+			     TREE_TYPE (space), space);
+      gfc_add_expr_to_block (&init, tmp);
+      addr = fold_build1_loc (sym->declared_at.lb->location,
+			      ADDR_EXPR, TREE_TYPE (decl), space);
+      gfc_add_modify (&init, decl, addr);
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      tmp = NULL_TREE;
+    }
+  gfc_add_init_cleanup (block, inittree, tmp);
+}
+
+
+/* Generate entry and exit code for g77 calling convention arrays.  */
+
+void
+gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
+{
+  tree parm;
+  tree type;
+  locus loc;
+  tree offset;
+  tree tmp;
+  tree stmt;
+  stmtblock_t init;
+
+  gfc_save_backend_locus (&loc);
+  gfc_set_backend_locus (&sym->declared_at);
+
+  /* Descriptor type.  */
+  parm = sym->backend_decl;
+  type = TREE_TYPE (parm);
+  gcc_assert (GFC_ARRAY_TYPE_P (type));
+
+  gfc_start_block (&init);
+
+  if (sym->ts.type == BT_CHARACTER
+      && VAR_P (sym->ts.u.cl->backend_decl))
+    gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+
+  /* Evaluate the bounds of the array.  */
+  gfc_trans_array_bounds (type, sym, &offset, &init);
+
+  /* Set the offset.  */
+  if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+  /* Set the pointer itself if we aren't using the parameter directly.  */
+  if (TREE_CODE (parm) != PARM_DECL)
+    {
+      tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
+      gfc_add_modify (&init, parm, tmp);
+    }
+  stmt = gfc_finish_block (&init);
+
+  gfc_restore_backend_locus (&loc);
+
+  /* Add the initialization code to the start of the function.  */
+
+  if (sym->attr.optional || sym->attr.not_always_present)
+    {
+      tmp = gfc_conv_expr_present (sym);
+      stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+    }
+
+  gfc_add_init_cleanup (block, stmt, NULL_TREE);
+}
+
+
+/* Modify the descriptor of an array parameter so that it has the
+   correct lower bound.  Also move the upper bound accordingly.
+   If the array is not packed, it will be copied into a temporary.
+   For each dimension we set the new lower and upper bounds.  Then we copy the
+   stride and calculate the offset for this dimension.  We also work out
+   what the stride of a packed array would be, and see it the two match.
+   If the array need repacking, we set the stride to the values we just
+   calculated, recalculate the offset and copy the array data.
+   Code is also added to copy the data back at the end of the function.
+   */
+
+void
+gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
+			    gfc_wrapped_block * block)
+{
+  tree size;
+  tree type;
+  tree offset;
+  locus loc;
+  stmtblock_t init;
+  tree stmtInit, stmtCleanup;
+  tree lbound;
+  tree ubound;
+  tree dubound;
+  tree dlbound;
+  tree dumdesc;
+  tree tmp;
+  tree stride, stride2;
+  tree stmt_packed;
+  tree stmt_unpacked;
+  tree partial;
+  gfc_se se;
+  int n;
+  int checkparm;
+  int no_repack;
+  bool optional_arg;
+  gfc_array_spec *as;
+  bool is_classarray = IS_CLASS_ARRAY (sym);
+
+  /* Do nothing for pointer and allocatable arrays.  */
+  if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
+      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
+      || sym->attr.allocatable
+      || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
+    return;
+
+  if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
+    {
+      gfc_trans_g77_array (sym, block);
+      return;
+    }
+
+  loc.nextc = NULL;
+  gfc_save_backend_locus (&loc);
+  /* loc.nextc is not set by save_backend_locus but the location routines
+     depend on it.  */
+  if (loc.nextc == NULL)
+    loc.nextc = loc.lb->line;
+  gfc_set_backend_locus (&sym->declared_at);
+
+  /* Descriptor type.  */
+  type = TREE_TYPE (tmpdesc);
+  gcc_assert (GFC_ARRAY_TYPE_P (type));
+  dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
+  if (is_classarray)
+    /* For a class array the dummy array descriptor is in the _class
+       component.  */
+    dumdesc = gfc_class_data_get (dumdesc);
+  else
+    dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
+  as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+  gfc_start_block (&init);
+
+  if (sym->ts.type == BT_CHARACTER
+      && VAR_P (sym->ts.u.cl->backend_decl))
+    gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+
+  checkparm = (as->type == AS_EXPLICIT
+	       && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
+
+  no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
+		|| GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
+
+  if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
+    {
+      /* For non-constant shape arrays we only check if the first dimension
+	 is contiguous.  Repacking higher dimensions wouldn't gain us
+	 anything as we still don't know the array stride.  */
+      partial = gfc_create_var (boolean_type_node, "partial");
+      TREE_USED (partial) = 1;
+      tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+			     gfc_index_one_node);
+      gfc_add_modify (&init, partial, tmp);
+    }
+  else
+    partial = NULL_TREE;
+
+  /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
+     here, however I think it does the right thing.  */
+  if (no_repack)
+    {
+      /* Set the first stride.  */
+      stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
+      stride = gfc_evaluate_now (stride, &init);
+
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			     stride, gfc_index_zero_node);
+      tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node, stride);
+      stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
+      gfc_add_modify (&init, stride, tmp);
+
+      /* Allow the user to disable array repacking.  */
+      stmt_unpacked = NULL_TREE;
+    }
+  else
+    {
+      gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
+      /* A library call to repack the array if necessary.  */
+      tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
+      stmt_unpacked = build_call_expr_loc (input_location,
+				       gfor_fndecl_in_pack, 1, tmp);
+
+      stride = gfc_index_one_node;
+
+      if (warn_array_temporaries)
+	gfc_warning (OPT_Warray_temporaries,
+		     "Creating array temporary at %L", &loc);
+    }
+
+  /* This is for the case where the array data is used directly without
+     calling the repack function.  */
+  if (no_repack || partial != NULL_TREE)
+    stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
+  else
+    stmt_packed = NULL_TREE;
+
+  /* Assign the data pointer.  */
+  if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
+    {
+      /* Don't repack unknown shape arrays when the first stride is 1.  */
+      tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
+			     partial, stmt_packed, stmt_unpacked);
+    }
+  else
+    tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
+  gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
+
+  offset = gfc_index_zero_node;
+  size = gfc_index_one_node;
+
+  /* Evaluate the bounds of the array.  */
+  for (n = 0; n < as->rank; n++)
+    {
+      if (checkparm || !as->upper[n])
+	{
+	  /* Get the bounds of the actual parameter.  */
+	  dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
+	  dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
+	}
+      else
+	{
+	  dubound = NULL_TREE;
+	  dlbound = NULL_TREE;
+	}
+
+      lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
+      if (!INTEGER_CST_P (lbound))
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, as->lower[n],
+			      gfc_array_index_type);
+	  gfc_add_block_to_block (&init, &se.pre);
+	  gfc_add_modify (&init, lbound, se.expr);
+	}
+
+      ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
+      /* Set the desired upper bound.  */
+      if (as->upper[n])
+	{
+	  /* We know what we want the upper bound to be.  */
+	  if (!INTEGER_CST_P (ubound))
+	    {
+	      gfc_init_se (&se, NULL);
+	      gfc_conv_expr_type (&se, as->upper[n],
+				  gfc_array_index_type);
+	      gfc_add_block_to_block (&init, &se.pre);
+	      gfc_add_modify (&init, ubound, se.expr);
+	    }
+
+	  /* Check the sizes match.  */
+	  if (checkparm)
+	    {
+	      /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)).  */
+	      char * msg;
+	      tree temp;
+
+	      temp = fold_build2_loc (input_location, MINUS_EXPR,
+				      gfc_array_index_type, ubound, lbound);
+	      temp = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type,
+				      gfc_index_one_node, temp);
+	      stride2 = fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type, dubound,
+					 dlbound);
+	      stride2 = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type,
+					 gfc_index_one_node, stride2);
+	      tmp = fold_build2_loc (input_location, NE_EXPR,
+				     gfc_array_index_type, temp, stride2);
+	      msg = xasprintf ("Dimension %d of array '%s' has extent "
+			       "%%ld instead of %%ld", n+1, sym->name);
+
+	      gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
+			fold_convert (long_integer_type_node, temp),
+			fold_convert (long_integer_type_node, stride2));
+
+	      free (msg);
+	    }
+	}
+      else
+	{
+	  /* For assumed shape arrays move the upper bound by the same amount
+	     as the lower bound.  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, dubound, dlbound);
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, tmp, lbound);
+	  gfc_add_modify (&init, ubound, tmp);
+	}
+      /* The offset of this dimension.  offset = offset - lbound * stride.  */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     lbound, stride);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type, offset, tmp);
+
+      /* The size of this dimension, and the stride of the next.  */
+      if (n + 1 < as->rank)
+	{
+	  stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
+
+	  if (no_repack || partial != NULL_TREE)
+	    stmt_unpacked =
+	      gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
+
+	  /* Figure out the stride if not a known constant.  */
+	  if (!INTEGER_CST_P (stride))
+	    {
+	      if (no_repack)
+		stmt_packed = NULL_TREE;
+	      else
+		{
+		  /* Calculate stride = size * (ubound + 1 - lbound).  */
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type,
+					 gfc_index_one_node, lbound);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type, ubound, tmp);
+		  size = fold_build2_loc (input_location, MULT_EXPR,
+					  gfc_array_index_type, size, tmp);
+		  stmt_packed = size;
+		}
+
+	      /* Assign the stride.  */
+	      if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
+		tmp = fold_build3_loc (input_location, COND_EXPR,
+				       gfc_array_index_type, partial,
+				       stmt_unpacked, stmt_packed);
+	      else
+		tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
+	      gfc_add_modify (&init, stride, tmp);
+	    }
+	}
+      else
+	{
+	  stride = GFC_TYPE_ARRAY_SIZE (type);
+
+	  if (stride && !INTEGER_CST_P (stride))
+	    {
+	      /* Calculate size = stride * (ubound + 1 - lbound).  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     gfc_index_one_node, lbound);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type,
+				     ubound, tmp);
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type,
+				     GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
+	      gfc_add_modify (&init, stride, tmp);
+	    }
+	}
+    }
+
+  gfc_trans_array_cobounds (type, &init, sym);
+
+  /* Set the offset.  */
+  if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
+    gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
+  gfc_trans_vla_type_sizes (sym, &init);
+
+  stmtInit = gfc_finish_block (&init);
+
+  /* Only do the entry/initialization code if the arg is present.  */
+  dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
+  optional_arg = (sym->attr.optional
+		  || (sym->ns->proc_name->attr.entry_master
+		      && sym->attr.dummy));
+  if (optional_arg)
+    {
+      tmp = gfc_conv_expr_present (sym);
+      stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
+			   build_empty_stmt (input_location));
+    }
+
+  /* Cleanup code.  */
+  if (no_repack)
+    stmtCleanup = NULL_TREE;
+  else
+    {
+      stmtblock_t cleanup;
+      gfc_start_block (&cleanup);
+
+      if (sym->attr.intent != INTENT_IN)
+	{
+	  /* Copy the data back.  */
+	  tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
+	  gfc_add_expr_to_block (&cleanup, tmp);
+	}
+
+      /* Free the temporary.  */
+      tmp = gfc_call_free (tmpdesc);
+      gfc_add_expr_to_block (&cleanup, tmp);
+
+      stmtCleanup = gfc_finish_block (&cleanup);
+
+      /* Only do the cleanup if the array was repacked.  */
+      if (is_classarray)
+	/* For a class array the dummy array descriptor is in the _class
+	   component.  */
+	tmp = gfc_class_data_get (dumdesc);
+      else
+	tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
+      tmp = gfc_conv_descriptor_data_get (tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, tmpdesc);
+      stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
+			      build_empty_stmt (input_location));
+
+      if (optional_arg)
+	{
+	  tmp = gfc_conv_expr_present (sym);
+	  stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
+				  build_empty_stmt (input_location));
+	}
+    }
+
+  /* We don't need to free any memory allocated by internal_pack as it will
+     be freed at the end of the function by pop_context.  */
+  gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
+
+  gfc_restore_backend_locus (&loc);
+}
+
+
+/* Calculate the overall offset, including subreferences.  */
+static void
+gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+			bool subref, gfc_expr *expr)
+{
+  tree tmp;
+  tree field;
+  tree stride;
+  tree index;
+  gfc_ref *ref;
+  gfc_se start;
+  int n;
+
+  /* If offset is NULL and this is not a subreferenced array, there is
+     nothing to do.  */
+  if (offset == NULL_TREE)
+    {
+      if (subref)
+	offset = gfc_index_zero_node;
+      else
+	return;
+    }
+
+  tmp = build_array_ref (desc, offset, NULL, NULL);
+
+  /* Offset the data pointer for pointer assignments from arrays with
+     subreferences; e.g. my_integer => my_type(:)%integer_component.  */
+  if (subref)
+    {
+      /* Go past the array reference.  */
+      for (ref = expr->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY &&
+	      ref->u.ar.type != AR_ELEMENT)
+	  {
+	    ref = ref->next;
+	    break;
+	  }
+
+      /* Calculate the offset for each subsequent subreference.  */
+      for (; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_COMPONENT:
+	      field = ref->u.c.component->backend_decl;
+	      gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (field),
+				     tmp, field, NULL_TREE);
+	      break;
+
+	    case REF_SUBSTRING:
+	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+	      gfc_init_se (&start, NULL);
+	      gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+	      gfc_add_block_to_block (block, &start.pre);
+	      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+	      break;
+
+	    case REF_ARRAY:
+	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
+			    && ref->u.ar.type == AR_ELEMENT);
+
+	      /* TODO - Add bounds checking.  */
+	      stride = gfc_index_one_node;
+	      index = gfc_index_zero_node;
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		{
+		  tree itmp;
+		  tree jtmp;
+
+		  /* Update the index.  */
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
+		  itmp = gfc_evaluate_now (start.expr, block);
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
+		  jtmp = gfc_evaluate_now (start.expr, block);
+		  itmp = fold_build2_loc (input_location, MINUS_EXPR,
+					  gfc_array_index_type, itmp, jtmp);
+		  itmp = fold_build2_loc (input_location, MULT_EXPR,
+					  gfc_array_index_type, itmp, stride);
+		  index = fold_build2_loc (input_location, PLUS_EXPR,
+					  gfc_array_index_type, itmp, index);
+		  index = gfc_evaluate_now (index, block);
+
+		  /* Update the stride.  */
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
+		  itmp =  fold_build2_loc (input_location, MINUS_EXPR,
+					   gfc_array_index_type, start.expr,
+					   jtmp);
+		  itmp =  fold_build2_loc (input_location, PLUS_EXPR,
+					   gfc_array_index_type,
+					   gfc_index_one_node, itmp);
+		  stride =  fold_build2_loc (input_location, MULT_EXPR,
+					     gfc_array_index_type, stride, itmp);
+		  stride = gfc_evaluate_now (stride, block);
+		}
+
+	      /* Apply the index to obtain the array element.  */
+	      tmp = gfc_build_array_ref (tmp, index, NULL);
+	      break;
+
+	    default:
+	      gcc_unreachable ();
+	      break;
+	    }
+	}
+    }
+
+  /* Set the target data pointer.  */
+  offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+  gfc_conv_descriptor_data_set (block, parm, offset);
+}
+
+
+/* gfc_conv_expr_descriptor needs the string length an expression
+   so that the size of the temporary can be obtained.  This is done
+   by adding up the string lengths of all the elements in the
+   expression.  Function with non-constant expressions have their
+   string lengths mapped onto the actual arguments using the
+   interface mapping machinery in trans-expr.c.  */
+static void
+get_array_charlen (gfc_expr *expr, gfc_se *se)
+{
+  gfc_interface_mapping mapping;
+  gfc_formal_arglist *formal;
+  gfc_actual_arglist *arg;
+  gfc_se tse;
+
+  if (expr->ts.u.cl->length
+	&& gfc_is_constant_expr (expr->ts.u.cl->length))
+    {
+      if (!expr->ts.u.cl->backend_decl)
+	gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+      return;
+    }
+
+  switch (expr->expr_type)
+    {
+    case EXPR_OP:
+      get_array_charlen (expr->value.op.op1, se);
+
+      /* For parentheses the expression ts.u.cl is identical.  */
+      if (expr->value.op.op == INTRINSIC_PARENTHESES)
+	return;
+
+     expr->ts.u.cl->backend_decl =
+		gfc_create_var (gfc_charlen_type_node, "sln");
+
+      if (expr->value.op.op2)
+	{
+	  get_array_charlen (expr->value.op.op2, se);
+
+	  gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
+
+	  /* Add the string lengths and assign them to the expression
+	     string length backend declaration.  */
+	  gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+			  fold_build2_loc (input_location, PLUS_EXPR,
+				gfc_charlen_type_node,
+				expr->value.op.op1->ts.u.cl->backend_decl,
+				expr->value.op.op2->ts.u.cl->backend_decl));
+	}
+      else
+	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+			expr->value.op.op1->ts.u.cl->backend_decl);
+      break;
+
+    case EXPR_FUNCTION:
+      if (expr->value.function.esym == NULL
+	    || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	{
+	  gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+	  break;
+	}
+
+      /* Map expressions involving the dummy arguments onto the actual
+	 argument expressions.  */
+      gfc_init_interface_mapping (&mapping);
+      formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
+      arg = expr->value.function.actual;
+
+      /* Set se = NULL in the calls to the interface mapping, to suppress any
+	 backend stuff.  */
+      for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+	{
+	  if (!arg->expr)
+	    continue;
+	  if (formal->sym)
+	  gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+	}
+
+      gfc_init_se (&tse, NULL);
+
+      /* Build the expression for the character length and convert it.  */
+      gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
+
+      gfc_add_block_to_block (&se->pre, &tse.pre);
+      gfc_add_block_to_block (&se->post, &tse.post);
+      tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
+      tse.expr = fold_build2_loc (input_location, MAX_EXPR,
+				  gfc_charlen_type_node, tse.expr,
+				  build_int_cst (gfc_charlen_type_node, 0));
+      expr->ts.u.cl->backend_decl = tse.expr;
+      gfc_free_interface_mapping (&mapping);
+      break;
+
+    default:
+      gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+      break;
+    }
+}
+
+
+/* Helper function to check dimensions.  */
+static bool
+transposed_dims (gfc_ss *ss)
+{
+  int n;
+
+  for (n = 0; n < ss->dimen; n++)
+    if (ss->dim[n] != n)
+      return true;
+  return false;
+}
+
+
+/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
+   AR_FULL, suitable for the scalarizer.  */
+
+static gfc_ss *
+walk_coarray (gfc_expr *e)
+{
+  gfc_ss *ss;
+
+  gcc_assert (gfc_get_corank (e) > 0);
+
+  ss = gfc_walk_expr (e);
+
+  /* Fix scalar coarray.  */
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_ref *ref;
+
+      ref = e->ref;
+      while (ref)
+	{
+	  if (ref->type == REF_ARRAY
+	      && ref->u.ar.codimen > 0)
+	    break;
+
+	  ref = ref->next;
+	}
+
+      gcc_assert (ref != NULL);
+      if (ref->u.ar.type == AR_ELEMENT)
+	ref->u.ar.type = AR_SECTION;
+      ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
+    }
+
+  return ss;
+}
+
+
+/* Convert an array for passing as an actual argument.  Expressions and
+   vector subscripts are evaluated and stored in a temporary, which is then
+   passed.  For whole arrays the descriptor is passed.  For array sections
+   a modified copy of the descriptor is passed, but using the original data.
+
+   This function is also used for array pointer assignments, and there
+   are three cases:
+
+     - se->want_pointer && !se->direct_byref
+	 EXPR is an actual argument.  On exit, se->expr contains a
+	 pointer to the array descriptor.
+
+     - !se->want_pointer && !se->direct_byref
+	 EXPR is an actual argument to an intrinsic function or the
+	 left-hand side of a pointer assignment.  On exit, se->expr
+	 contains the descriptor for EXPR.
+
+     - !se->want_pointer && se->direct_byref
+	 EXPR is the right-hand side of a pointer assignment and
+	 se->expr is the descriptor for the previously-evaluated
+	 left-hand side.  The function creates an assignment from
+	 EXPR to se->expr.
+
+
+   The se->force_tmp flag disables the non-copying descriptor optimization
+   that is used for transpose. It may be used in cases where there is an
+   alias between the transpose argument and another argument in the same
+   function call.  */
+
+void
+gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
+{
+  gfc_ss *ss;
+  gfc_ss_type ss_type;
+  gfc_ss_info *ss_info;
+  gfc_loopinfo loop;
+  gfc_array_info *info;
+  int need_tmp;
+  int n;
+  tree tmp;
+  tree desc;
+  stmtblock_t block;
+  tree start;
+  tree offset;
+  int full;
+  bool subref_array_target = false;
+  gfc_expr *arg, *ss_expr;
+
+  if (se->want_coarray)
+    ss = walk_coarray (expr);
+  else
+    ss = gfc_walk_expr (expr);
+
+  gcc_assert (ss != NULL);
+  gcc_assert (ss != gfc_ss_terminator);
+
+  ss_info = ss->info;
+  ss_type = ss_info->type;
+  ss_expr = ss_info->expr;
+
+  /* Special case: TRANSPOSE which needs no temporary.  */
+  while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
+      && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr)))
+    {
+      /* This is a call to transpose which has already been handled by the
+	 scalarizer, so that we just need to get its argument's descriptor.  */
+      gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+      expr = expr->value.function.actual->expr;
+    }
+
+  /* Special case things we know we can pass easily.  */
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      /* If we have a linear array section, we can pass it directly.
+	 Otherwise we need to copy it into a temporary.  */
+
+      gcc_assert (ss_type == GFC_SS_SECTION);
+      gcc_assert (ss_expr == expr);
+      info = &ss_info->data.array;
+
+      /* Get the descriptor for the array.  */
+      gfc_conv_ss_descriptor (&se->pre, ss, 0);
+      desc = info->descriptor;
+
+      subref_array_target = se->direct_byref && is_subref_array (expr);
+      need_tmp = gfc_ref_needs_temporary_p (expr->ref)
+			&& !subref_array_target;
+
+      if (se->force_tmp)
+	need_tmp = 1;
+
+      if (need_tmp)
+	full = 0;
+      else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	{
+	  /* Create a new descriptor if the array doesn't have one.  */
+	  full = 0;
+	}
+      else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
+	full = 1;
+      else if (se->direct_byref)
+	full = 0;
+      else
+	full = gfc_full_array_ref_p (info->ref, NULL);
+
+      if (full && !transposed_dims (ss))
+	{
+	  if (se->direct_byref && !se->byref_noassign)
+	    {
+	      /* Copy the descriptor for pointer assignments.  */
+	      gfc_add_modify (&se->pre, se->expr, desc);
+
+	      /* Add any offsets from subreferences.  */
+	      gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
+				      subref_array_target, expr);
+
+	      /* ....and set the span field.  */
+	      tmp = get_array_span (desc, expr);
+	      gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
+	    }
+	  else if (se->want_pointer)
+	    {
+	      /* We pass full arrays directly.  This means that pointers and
+		 allocatable arrays should also work.  */
+	      se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+	    }
+	  else
+	    {
+	      se->expr = desc;
+	    }
+
+	  if (expr->ts.type == BT_CHARACTER)
+	    se->string_length = gfc_get_expr_charlen (expr);
+
+	  gfc_free_ss_chain (ss);
+	  return;
+	}
+      break;
+
+    case EXPR_FUNCTION:
+      /* A transformational function return value will be a temporary
+	 array descriptor.  We still need to go through the scalarizer
+	 to create the descriptor.  Elemental functions are handled as
+	 arbitrary expressions, i.e. copy to a temporary.  */
+
+      if (se->direct_byref)
+	{
+	  gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
+
+	  /* For pointer assignments pass the descriptor directly.  */
+	  if (se->ss == NULL)
+	    se->ss = ss;
+	  else
+	    gcc_assert (se->ss == ss);
+
+	  if (!is_pointer_array (se->expr))
+	    {
+	      tmp = gfc_get_element_type (TREE_TYPE (se->expr));
+	      tmp = fold_convert (gfc_array_index_type,
+				  size_in_bytes (tmp));
+	      gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
+	    }
+
+	  se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+	  gfc_conv_expr (se, expr);
+
+	  gfc_free_ss_chain (ss);
+	  return;
+	}
+
+      if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
+	{
+	  if (ss_expr != expr)
+	    /* Elemental function.  */
+	    gcc_assert ((expr->value.function.esym != NULL
+			 && expr->value.function.esym->attr.elemental)
+			|| (expr->value.function.isym != NULL
+			    && expr->value.function.isym->elemental)
+			|| gfc_inline_intrinsic_function_p (expr));
+	  else
+	    gcc_assert (ss_type == GFC_SS_INTRINSIC);
+
+	  need_tmp = 1;
+	  if (expr->ts.type == BT_CHARACTER
+		&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	    get_array_charlen (expr, se);
+
+	  info = NULL;
+	}
+      else
+	{
+	  /* Transformational function.  */
+	  info = &ss_info->data.array;
+	  need_tmp = 0;
+	}
+      break;
+
+    case EXPR_ARRAY:
+      /* Constant array constructors don't need a temporary.  */
+      if (ss_type == GFC_SS_CONSTRUCTOR
+	  && expr->ts.type != BT_CHARACTER
+	  && gfc_constant_array_constructor_p (expr->value.constructor))
+	{
+	  need_tmp = 0;
+	  info = &ss_info->data.array;
+	}
+      else
+	{
+	  need_tmp = 1;
+	  info = NULL;
+	}
+      break;
+
+    default:
+      /* Something complicated.  Copy it into a temporary.  */
+      need_tmp = 1;
+      info = NULL;
+      break;
+    }
+
+  /* If we are creating a temporary, we don't need to bother about aliases
+     anymore.  */
+  if (need_tmp)
+    se->force_tmp = 0;
+
+  gfc_init_loopinfo (&loop);
+
+  /* Associate the SS with the loop.  */
+  gfc_add_ss_to_loop (&loop, ss);
+
+  /* Tell the scalarizer not to bother creating loop variables, etc.  */
+  if (!need_tmp)
+    loop.array_parameter = 1;
+  else
+    /* The right-hand side of a pointer assignment mustn't use a temporary.  */
+    gcc_assert (!se->direct_byref);
+
+  /* Setup the scalarizing loops and bounds.  */
+  gfc_conv_ss_startstride (&loop);
+
+  if (need_tmp)
+    {
+      if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+	get_array_charlen (expr, se);
+
+      /* Tell the scalarizer to make a temporary.  */
+      loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
+				      ((expr->ts.type == BT_CHARACTER)
+				       ? expr->ts.u.cl->backend_decl
+				       : NULL),
+				      loop.dimen);
+
+      se->string_length = loop.temp_ss->info->string_length;
+      gcc_assert (loop.temp_ss->dimen == loop.dimen);
+      gfc_add_ss_to_loop (&loop, loop.temp_ss);
+    }
+
+  gfc_conv_loop_setup (&loop, & expr->where);
+
+  if (need_tmp)
+    {
+      /* Copy into a temporary and pass that.  We don't need to copy the data
+         back because expressions and vector subscripts must be INTENT_IN.  */
+      /* TODO: Optimize passing function return values.  */
+      gfc_se lse;
+      gfc_se rse;
+      bool deep_copy;
+
+      /* Start the copying loops.  */
+      gfc_mark_ss_chain_used (loop.temp_ss, 1);
+      gfc_mark_ss_chain_used (ss, 1);
+      gfc_start_scalarized_body (&loop, &block);
+
+      /* Copy each data element.  */
+      gfc_init_se (&lse, NULL);
+      gfc_copy_loopinfo_to_se (&lse, &loop);
+      gfc_init_se (&rse, NULL);
+      gfc_copy_loopinfo_to_se (&rse, &loop);
+
+      lse.ss = loop.temp_ss;
+      rse.ss = ss;
+
+      gfc_conv_scalarized_array_ref (&lse, NULL);
+      if (expr->ts.type == BT_CHARACTER)
+	{
+	  gfc_conv_expr (&rse, expr);
+	  if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
+	    rse.expr = build_fold_indirect_ref_loc (input_location,
+						rse.expr);
+	}
+      else
+        gfc_conv_expr_val (&rse, expr);
+
+      gfc_add_block_to_block (&block, &rse.pre);
+      gfc_add_block_to_block (&block, &lse.pre);
+
+      lse.string_length = rse.string_length;
+
+      deep_copy = !se->data_not_needed
+		  && (expr->expr_type == EXPR_VARIABLE
+		      || expr->expr_type == EXPR_ARRAY);
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
+				     deep_copy, false);
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* Finish the copying loops.  */
+      gfc_trans_scalarizing_loops (&loop, &block);
+
+      desc = loop.temp_ss->info->data.array.descriptor;
+    }
+  else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
+    {
+      desc = info->descriptor;
+      se->string_length = ss_info->string_length;
+    }
+  else
+    {
+      /* We pass sections without copying to a temporary.  Make a new
+	 descriptor and point it at the section we want.  The loop variable
+	 limits will be the limits of the section.
+	 A function may decide to repack the array to speed up access, but
+	 we're not bothered about that here.  */
+      int dim, ndim, codim;
+      tree parm;
+      tree parmtype;
+      tree stride;
+      tree from;
+      tree to;
+      tree base;
+      bool onebased = false, rank_remap;
+
+      ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
+      rank_remap = ss->dimen < ndim;
+
+      if (se->want_coarray)
+	{
+	  gfc_array_ref *ar = &info->ref->u.ar;
+
+	  codim = gfc_get_corank (expr);
+	  for (n = 0; n < codim - 1; n++)
+	    {
+	      /* Make sure we are not lost somehow.  */
+	      gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
+
+	      /* Make sure the call to gfc_conv_section_startstride won't
+		 generate unnecessary code to calculate stride.  */
+	      gcc_assert (ar->stride[n + ndim] == NULL);
+
+	      gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
+	      loop.from[n + loop.dimen] = info->start[n + ndim];
+	      loop.to[n + loop.dimen]   = info->end[n + ndim];
+	    }
+
+	  gcc_assert (n == codim - 1);
+	  evaluate_bound (&loop.pre, info->start, ar->start,
+			  info->descriptor, n + ndim, true,
+			  ar->as->type == AS_DEFERRED);
+	  loop.from[n + loop.dimen] = info->start[n + ndim];
+	}
+      else
+	codim = 0;
+
+      /* Set the string_length for a character array.  */
+      if (expr->ts.type == BT_CHARACTER)
+	se->string_length =  gfc_get_expr_charlen (expr);
+
+      /* If we have an array section or are assigning make sure that
+	 the lower bound is 1.  References to the full
+	 array should otherwise keep the original bounds.  */
+      if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
+	for (dim = 0; dim < loop.dimen; dim++)
+	  if (!integer_onep (loop.from[dim]))
+	    {
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, gfc_index_one_node,
+				     loop.from[dim]);
+	      loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
+					      gfc_array_index_type,
+					      loop.to[dim], tmp);
+	      loop.from[dim] = gfc_index_one_node;
+	    }
+
+      desc = info->descriptor;
+      if (se->direct_byref && !se->byref_noassign)
+	{
+	  /* For pointer assignments we fill in the destination....  */
+	  parm = se->expr;
+	  parmtype = TREE_TYPE (parm);
+
+	  /* ....and set the span field.  */
+	  tmp = get_array_span (desc, expr);
+	  gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
+	}
+      else
+	{
+	  /* Otherwise make a new one.  */
+	  parmtype = gfc_get_element_type (TREE_TYPE (desc));
+	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
+						loop.from, loop.to, 0,
+						GFC_ARRAY_UNKNOWN, false);
+	  parm = gfc_create_var (parmtype, "parm");
+
+	  /* When expression is a class object, then add the class' handle to
+	     the parm_decl.  */
+	  if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
+	    {
+	      gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+	      gfc_se classse;
+
+	      /* class_expr can be NULL, when no _class ref is in expr.
+		 We must not fix this here with a gfc_fix_class_ref ().  */
+	      if (class_expr)
+		{
+		  gfc_init_se (&classse, NULL);
+		  gfc_conv_expr (&classse, class_expr);
+		  gfc_free_expr (class_expr);
+
+		  gcc_assert (classse.pre.head == NULL_TREE
+			      && classse.post.head == NULL_TREE);
+		  gfc_allocate_lang_decl (parm);
+		  GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
+		}
+	    }
+	}
+
+      offset = gfc_index_zero_node;
+
+      /* The following can be somewhat confusing.  We have two
+         descriptors, a new one and the original array.
+         {parm, parmtype, dim} refer to the new one.
+         {desc, type, n, loop} refer to the original, which maybe
+         a descriptorless array.
+         The bounds of the scalarization are the bounds of the section.
+         We don't have to worry about numeric overflows when calculating
+         the offsets because all elements are within the array data.  */
+
+      /* Set the dtype.  */
+      tmp = gfc_conv_descriptor_dtype (parm);
+      gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
+
+      /* Set offset for assignments to pointer only to zero if it is not
+         the full array.  */
+      if ((se->direct_byref || se->use_offset)
+	  && ((info->ref && info->ref->u.ar.type != AR_FULL)
+	      || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
+	base = gfc_index_zero_node;
+      else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
+      else
+	base = NULL_TREE;
+
+      for (n = 0; n < ndim; n++)
+	{
+	  stride = gfc_conv_array_stride (desc, n);
+
+	  /* Work out the offset.  */
+	  if (info->ref
+	      && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+	    {
+	      gcc_assert (info->subscript[n]
+			  && info->subscript[n]->info->type == GFC_SS_SCALAR);
+	      start = info->subscript[n]->info->data.scalar.value;
+	    }
+	  else
+	    {
+	      /* Evaluate and remember the start of the section.  */
+	      start = info->start[n];
+	      stride = gfc_evaluate_now (stride, &loop.pre);
+	    }
+
+	  tmp = gfc_conv_array_lbound (desc, n);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+				 start, tmp);
+	  tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+				 tmp, stride);
+	  offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+				    offset, tmp);
+
+	  if (info->ref
+	      && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+	    {
+	      /* For elemental dimensions, we only need the offset.  */
+	      continue;
+	    }
+
+	  /* Vector subscripts need copying and are handled elsewhere.  */
+	  if (info->ref)
+	    gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
+
+	  /* look for the corresponding scalarizer dimension: dim.  */
+	  for (dim = 0; dim < ndim; dim++)
+	    if (ss->dim[dim] == n)
+	      break;
+
+	  /* loop exited early: the DIM being looked for has been found.  */
+	  gcc_assert (dim < ndim);
+
+	  /* Set the new lower bound.  */
+	  from = loop.from[dim];
+	  to = loop.to[dim];
+
+	  onebased = integer_onep (from);
+	  gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], from);
+
+	  /* Set the new upper bound.  */
+	  gfc_conv_descriptor_ubound_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], to);
+
+	  /* Multiply the stride by the section stride to get the
+	     total stride.  */
+	  stride = fold_build2_loc (input_location, MULT_EXPR,
+				    gfc_array_index_type,
+				    stride, info->stride[n]);
+
+	  if ((se->direct_byref || se->use_offset)
+	      && ((info->ref && info->ref->u.ar.type != AR_FULL)
+		  || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
+	    {
+	      base = fold_build2_loc (input_location, MINUS_EXPR,
+				      TREE_TYPE (base), base, stride);
+	    }
+	  else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
+	    {
+	      bool toonebased;
+	      tmp = gfc_conv_array_lbound (desc, n);
+	      toonebased = integer_onep (tmp);
+	      // lb(arr) - from (- start + 1)
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     TREE_TYPE (base), tmp, from);
+	      if (onebased && toonebased)
+		{
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 TREE_TYPE (base), tmp, start);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 TREE_TYPE (base), tmp,
+					 gfc_index_one_node);
+		}
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     TREE_TYPE (base), tmp,
+				     gfc_conv_array_stride (desc, n));
+	      base = fold_build2_loc (input_location, PLUS_EXPR,
+				     TREE_TYPE (base), tmp, base);
+	    }
+
+	  /* Store the new stride.  */
+	  gfc_conv_descriptor_stride_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], stride);
+	}
+
+      for (n = loop.dimen; n < loop.dimen + codim; n++)
+	{
+	  from = loop.from[n];
+	  to = loop.to[n];
+	  gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+					  gfc_rank_cst[n], from);
+	  if (n < loop.dimen + codim - 1)
+	    gfc_conv_descriptor_ubound_set (&loop.pre, parm,
+					    gfc_rank_cst[n], to);
+	}
+
+      if (se->data_not_needed)
+	gfc_conv_descriptor_data_set (&loop.pre, parm,
+				      gfc_index_zero_node);
+      else
+	/* Point the data pointer at the 1st element in the section.  */
+	gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+				subref_array_target, expr);
+
+      /* Force the offset to be -1, when the lower bound of the highest
+	 dimension is one and the symbol is present and is not a
+	 pointer/allocatable or associated.  */
+      if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	   && !se->data_not_needed)
+	  || (se->use_offset && base != NULL_TREE))
+	{
+	  /* Set the offset depending on base.  */
+	  tmp = rank_remap && !se->direct_byref ?
+		fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, base,
+				 offset)
+	      : base;
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
+	}
+      else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
+	       && (!rank_remap || se->use_offset)
+	       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+	{
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm,
+					 gfc_conv_descriptor_offset_get (desc));
+	}
+      else if (onebased && (!rank_remap || se->use_offset)
+	  && expr->symtree
+	  && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
+	       && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
+	  && !expr->symtree->n.sym->attr.allocatable
+	  && !expr->symtree->n.sym->attr.pointer
+	  && !expr->symtree->n.sym->attr.host_assoc
+	  && !expr->symtree->n.sym->attr.use_assoc)
+	{
+	  /* Set the offset to -1.  */
+	  mpz_t minus_one;
+	  mpz_init_set_si (minus_one, -1);
+	  tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
+	}
+      else
+	{
+	  /* Only the callee knows what the correct offset it, so just set
+	     it to zero here.  */
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
+	}
+      desc = parm;
+    }
+
+  /* For class arrays add the class tree into the saved descriptor to
+     enable getting of _vptr and the like.  */
+  if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
+      && IS_CLASS_ARRAY (expr->symtree->n.sym))
+    {
+      gfc_allocate_lang_decl (desc);
+      GFC_DECL_SAVED_DESCRIPTOR (desc) =
+	  DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
+	    GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
+	  : expr->symtree->n.sym->backend_decl;
+    }
+  else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
+	   && IS_CLASS_ARRAY (expr))
+    {
+      tree vtype;
+      gfc_allocate_lang_decl (desc);
+      tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
+      GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
+      vtype = gfc_class_vptr_get (tmp);
+      gfc_add_modify (&se->pre, vtype,
+		      gfc_build_addr_expr (TREE_TYPE (vtype),
+				      gfc_find_vtab (&expr->ts)->backend_decl));
+    }
+  if (!se->direct_byref || se->byref_noassign)
+    {
+      /* Get a pointer to the new descriptor.  */
+      if (se->want_pointer)
+	se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+      else
+	se->expr = desc;
+    }
+
+  gfc_add_block_to_block (&se->pre, &loop.pre);
+  gfc_add_block_to_block (&se->post, &loop.post);
+
+  /* Cleanup the scalarizer.  */
+  gfc_cleanup_loop (&loop);
+}
+
+/* Helper function for gfc_conv_array_parameter if array size needs to be
+   computed.  */
+
+static void
+array_parameter_size (tree desc, gfc_expr *expr, tree *size)
+{
+  tree elem;
+  if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+    *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
+  else if (expr->rank > 1)
+    *size = build_call_expr_loc (input_location,
+			     gfor_fndecl_size0, 1,
+			     gfc_build_addr_expr (NULL, desc));
+  else
+    {
+      tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
+      tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
+
+      *size = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type, ubound, lbound);
+      *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			       *size, gfc_index_one_node);
+      *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+			       *size, gfc_index_zero_node);
+    }
+  elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+  *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			   *size, fold_convert (gfc_array_index_type, elem));
+}
+
+/* Convert an array for passing as an actual parameter.  */
+/* TODO: Optimize passing g77 arrays.  */
+
+void
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
+			  const gfc_symbol *fsym, const char *proc_name,
+			  tree *size)
+{
+  tree ptr;
+  tree desc;
+  tree tmp = NULL_TREE;
+  tree stmt;
+  tree parent = DECL_CONTEXT (current_function_decl);
+  bool full_array_var;
+  bool this_array_result;
+  bool contiguous;
+  bool no_pack;
+  bool array_constructor;
+  bool good_allocatable;
+  bool ultimate_ptr_comp;
+  bool ultimate_alloc_comp;
+  gfc_symbol *sym;
+  stmtblock_t block;
+  gfc_ref *ref;
+
+  ultimate_ptr_comp = false;
+  ultimate_alloc_comp = false;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ref->next == NULL)
+        break;
+
+      if (ref->type == REF_COMPONENT)
+	{
+	  ultimate_ptr_comp = ref->u.c.component->attr.pointer;
+	  ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
+	}
+    }
+
+  full_array_var = false;
+  contiguous = false;
+
+  if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
+    full_array_var = gfc_full_array_ref_p (ref, &contiguous);
+
+  sym = full_array_var ? expr->symtree->n.sym : NULL;
+
+  /* The symbol should have an array specification.  */
+  gcc_assert (!sym || sym->as || ref->u.ar.as);
+
+  if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
+    {
+      get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
+      expr->ts.u.cl->backend_decl = tmp;
+      se->string_length = tmp;
+    }
+
+  /* Is this the result of the enclosing procedure?  */
+  this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
+  if (this_array_result
+	&& (sym->backend_decl != current_function_decl)
+	&& (sym->backend_decl != parent))
+    this_array_result = false;
+
+  /* Passing address of the array if it is not pointer or assumed-shape.  */
+  if (full_array_var && g77 && !this_array_result
+      && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+    {
+      tmp = gfc_get_symbol_decl (sym);
+
+      if (sym->ts.type == BT_CHARACTER)
+	se->string_length = sym->ts.u.cl->backend_decl;
+
+      if (!sym->attr.pointer
+	  && sym->as
+	  && sym->as->type != AS_ASSUMED_SHAPE
+	  && sym->as->type != AS_DEFERRED
+	  && sym->as->type != AS_ASSUMED_RANK
+	  && !sym->attr.allocatable)
+        {
+	  /* Some variables are declared directly, others are declared as
+	     pointers and allocated on the heap.  */
+          if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
+            se->expr = tmp;
+          else
+	    se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
+	  return;
+        }
+
+      if (sym->attr.allocatable)
+        {
+	  if (sym->attr.dummy || sym->attr.result)
+	    {
+	      gfc_conv_expr_descriptor (se, expr);
+	      tmp = se->expr;
+	    }
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
+	  se->expr = gfc_conv_array_data (tmp);
+          return;
+        }
+    }
+
+  /* A convenient reduction in scope.  */
+  contiguous = g77 && !this_array_result && contiguous;
+
+  /* There is no need to pack and unpack the array, if it is contiguous
+     and not a deferred- or assumed-shape array, or if it is simply
+     contiguous.  */
+  no_pack = ((sym && sym->as
+		  && !sym->attr.pointer
+		  && sym->as->type != AS_DEFERRED
+		  && sym->as->type != AS_ASSUMED_RANK
+		  && sym->as->type != AS_ASSUMED_SHAPE)
+		      ||
+	     (ref && ref->u.ar.as
+		  && ref->u.ar.as->type != AS_DEFERRED
+		  && ref->u.ar.as->type != AS_ASSUMED_RANK
+		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
+		      ||
+	     gfc_is_simply_contiguous (expr, false, true));
+
+  no_pack = contiguous && no_pack;
+
+  /* Array constructors are always contiguous and do not need packing.  */
+  array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
+
+  /* Same is true of contiguous sections from allocatable variables.  */
+  good_allocatable = contiguous
+		       && expr->symtree
+		       && expr->symtree->n.sym->attr.allocatable;
+
+  /* Or ultimate allocatable components.  */
+  ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
+
+  if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
+    {
+      gfc_conv_expr_descriptor (se, expr);
+      /* Deallocate the allocatable components of structures that are
+	 not variable.  */
+      if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+	   && expr->ts.u.derived->attr.alloc_comp
+	   && expr->expr_type != EXPR_VARIABLE)
+	{
+	  tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
+
+	  /* The components shall be deallocated before their containing entity.  */
+	  gfc_prepend_expr_to_block (&se->post, tmp);
+	}
+      if (expr->ts.type == BT_CHARACTER)
+	se->string_length = expr->ts.u.cl->backend_decl;
+      if (size)
+	array_parameter_size (se->expr, expr, size);
+      se->expr = gfc_conv_array_data (se->expr);
+      return;
+    }
+
+  if (this_array_result)
+    {
+      /* Result of the enclosing function.  */
+      gfc_conv_expr_descriptor (se, expr);
+      if (size)
+	array_parameter_size (se->expr, expr, size);
+      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+
+      if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
+	      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
+	se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
+								 se->expr));
+
+      return;
+    }
+  else
+    {
+      /* Every other type of array.  */
+      se->want_pointer = 1;
+      gfc_conv_expr_descriptor (se, expr);
+
+      if (size)
+	array_parameter_size (build_fold_indirect_ref_loc (input_location,
+						       se->expr),
+				  expr, size);
+    }
+
+  /* Deallocate the allocatable components of structures that are
+     not variable, for descriptorless arguments.
+     Arguments with a descriptor are handled in gfc_conv_procedure_call.  */
+  if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+	  && expr->ts.u.derived->attr.alloc_comp
+	  && expr->expr_type != EXPR_VARIABLE)
+    {
+      tmp = build_fold_indirect_ref_loc (input_location, se->expr);
+      tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
+
+      /* The components shall be deallocated before their containing entity.  */
+      gfc_prepend_expr_to_block (&se->post, tmp);
+    }
+
+  if (g77 || (fsym && fsym->attr.contiguous
+	      && !gfc_is_simply_contiguous (expr, false, true)))
+    {
+      tree origptr = NULL_TREE;
+
+      desc = se->expr;
+
+      /* For contiguous arrays, save the original value of the descriptor.  */
+      if (!g77)
+	{
+	  origptr = gfc_create_var (pvoid_type_node, "origptr");
+	  tmp = build_fold_indirect_ref_loc (input_location, desc);
+	  tmp = gfc_conv_array_data (tmp);
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				 TREE_TYPE (origptr), origptr,
+				 fold_convert (TREE_TYPE (origptr), tmp));
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+
+      /* Repack the array.  */
+      if (warn_array_temporaries)
+	{
+	  if (fsym)
+	    gfc_warning (OPT_Warray_temporaries,
+			 "Creating array temporary at %L for argument %qs",
+			 &expr->where, fsym->name);
+	  else
+	    gfc_warning (OPT_Warray_temporaries,
+			 "Creating array temporary at %L", &expr->where);
+	}
+
+      ptr = build_call_expr_loc (input_location,
+			     gfor_fndecl_in_pack, 1, desc);
+
+      if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	{
+	  tmp = gfc_conv_expr_present (sym);
+	  ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+			tmp, fold_convert (TREE_TYPE (se->expr), ptr),
+			fold_convert (TREE_TYPE (se->expr), null_pointer_node));
+	}
+
+      ptr = gfc_evaluate_now (ptr, &se->pre);
+
+      /* Use the packed data for the actual argument, except for contiguous arrays,
+	 where the descriptor's data component is set.  */
+      if (g77)
+	se->expr = ptr;
+      else
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, desc);
+
+	  gfc_ss * ss = gfc_walk_expr (expr);
+	  if (!transposed_dims (ss))
+	    gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
+	  else
+	    {
+	      tree old_field, new_field;
+
+	      /* The original descriptor has transposed dims so we can't reuse
+		 it directly; we have to create a new one.  */
+	      tree old_desc = tmp;
+	      tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
+
+	      old_field = gfc_conv_descriptor_dtype (old_desc);
+	      new_field = gfc_conv_descriptor_dtype (new_desc);
+	      gfc_add_modify (&se->pre, new_field, old_field);
+
+	      old_field = gfc_conv_descriptor_offset (old_desc);
+	      new_field = gfc_conv_descriptor_offset (new_desc);
+	      gfc_add_modify (&se->pre, new_field, old_field);
+
+	      for (int i = 0; i < expr->rank; i++)
+		{
+		  old_field = gfc_conv_descriptor_dimension (old_desc,
+			gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
+		  new_field = gfc_conv_descriptor_dimension (new_desc,
+			gfc_rank_cst[i]);
+		  gfc_add_modify (&se->pre, new_field, old_field);
+		}
+
+	      if (flag_coarray == GFC_FCOARRAY_LIB
+		  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
+		  && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
+		     == GFC_ARRAY_ALLOCATABLE)
+		{
+		  old_field = gfc_conv_descriptor_token (old_desc);
+		  new_field = gfc_conv_descriptor_token (new_desc);
+		  gfc_add_modify (&se->pre, new_field, old_field);
+		}
+
+	      gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
+	      se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
+	    }
+	  gfc_free_ss (ss);
+	}
+
+      if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
+	{
+	  char * msg;
+
+	  if (fsym && proc_name)
+	    msg = xasprintf ("An array temporary was created for argument "
+			     "'%s' of procedure '%s'", fsym->name, proc_name);
+	  else
+	    msg = xasprintf ("An array temporary was created");
+
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 desc);
+	  tmp = gfc_conv_array_data (tmp);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+	  if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	    tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				   boolean_type_node,
+				   gfc_conv_expr_present (sym), tmp);
+
+	  gfc_trans_runtime_check (false, true, tmp, &se->pre,
+				   &expr->where, msg);
+	  free (msg);
+	}
+
+      gfc_start_block (&block);
+
+      /* Copy the data back.  */
+      if (fsym == NULL || fsym->attr.intent != INTENT_IN)
+	{
+	  tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_in_unpack, 2, desc, ptr);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      /* Free the temporary.  */
+      tmp = gfc_call_free (ptr);
+      gfc_add_expr_to_block (&block, tmp);
+
+      stmt = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      /* Only if it was repacked.  This code needs to be executed before the
+         loop cleanup code.  */
+      tmp = build_fold_indirect_ref_loc (input_location,
+				     desc);
+      tmp = gfc_conv_array_data (tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+      if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			       boolean_type_node,
+			       gfc_conv_expr_present (sym), tmp);
+
+      tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&block, &se->post);
+
+      gfc_init_block (&se->post);
+
+      /* Reset the descriptor pointer.  */
+      if (!g77)
+        {
+          tmp = build_fold_indirect_ref_loc (input_location, desc);
+          gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
+        }
+
+      gfc_add_block_to_block (&se->post, &block);
+    }
+}
+
+
+/* This helper function calculates the size in words of a full array.  */
+
+tree
+gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
+{
+  tree idx;
+  tree nelems;
+  tree tmp;
+  idx = gfc_rank_cst[rank - 1];
+  nelems = gfc_conv_descriptor_ubound_get (decl, idx);
+  tmp = gfc_conv_descriptor_lbound_get (decl, idx);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 nelems, tmp);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 tmp, gfc_index_one_node);
+  tmp = gfc_evaluate_now (tmp, block);
+
+  nelems = gfc_conv_descriptor_stride_get (decl, idx);
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			 nelems, tmp);
+  return gfc_evaluate_now (tmp, block);
+}
+
+
+/* Allocate dest to the same size as src, and copy src -> dest.
+   If no_malloc is set, only the copy is done.  */
+
+static tree
+duplicate_allocatable (tree dest, tree src, tree type, int rank,
+		       bool no_malloc, bool no_memcpy, tree str_sz,
+		       tree add_when_allocated)
+{
+  tree tmp;
+  tree size;
+  tree nelems;
+  tree null_cond;
+  tree null_data;
+  stmtblock_t block;
+
+  /* If the source is null, set the destination to null.  Then,
+     allocate memory to the destination.  */
+  gfc_init_block (&block);
+
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+    {
+      gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      if (str_sz != NULL_TREE)
+	size = str_sz;
+      else
+	size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+
+      if (!no_malloc)
+	{
+	  tmp = gfc_call_malloc (&block, type, size);
+	  gfc_add_modify (&block, dest, fold_convert (type, tmp));
+	}
+
+      if (!no_memcpy)
+	{
+	  tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+	  tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+				     fold_convert (size_type_node, size));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
+  else
+    {
+      gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      if (rank)
+	nelems = gfc_full_array_size (&block, src, rank);
+      else
+	nelems = gfc_index_one_node;
+
+      if (str_sz != NULL_TREE)
+	tmp = fold_convert (gfc_array_index_type, str_sz);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      nelems, tmp);
+      if (!no_malloc)
+	{
+	  tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
+	  tmp = gfc_call_malloc (&block, tmp, size);
+	  gfc_conv_descriptor_data_set (&block, dest, tmp);
+	}
+
+      /* We know the temporary and the value will be the same length,
+	 so can use memcpy.  */
+      if (!no_memcpy)
+	{
+	  tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+	  tmp = build_call_expr_loc (input_location, tmp, 3,
+				     gfc_conv_descriptor_data_get (dest),
+				     gfc_conv_descriptor_data_get (src),
+				     fold_convert (size_type_node, size));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
+
+  gfc_add_expr_to_block (&block, add_when_allocated);
+  tmp = gfc_finish_block (&block);
+
+  /* Null the destination if the source is null; otherwise do
+     the allocate and copy.  */
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
+    null_cond = src;
+  else
+    null_cond = gfc_conv_descriptor_data_get (src);
+
+  null_cond = convert (pvoid_type_node, null_cond);
+  null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       null_cond, null_pointer_node);
+  return build3_v (COND_EXPR, null_cond, tmp, null_data);
+}
+
+
+/* Allocate dest to the same size as src, and copy data src -> dest.  */
+
+tree
+gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
+			   tree add_when_allocated)
+{
+  return duplicate_allocatable (dest, src, type, rank, false, false,
+				NULL_TREE, add_when_allocated);
+}
+
+
+/* Copy data src -> dest.  */
+
+tree
+gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
+{
+  return duplicate_allocatable (dest, src, type, rank, true, false,
+				NULL_TREE, NULL_TREE);
+}
+
+/* Allocate dest to the same size as src, but don't copy anything.  */
+
+tree
+gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
+{
+  return duplicate_allocatable (dest, src, type, rank, false, true,
+				NULL_TREE, NULL_TREE);
+}
+
+
+static tree
+duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
+			       tree type, int rank)
+{
+  tree tmp;
+  tree size;
+  tree nelems;
+  tree null_cond;
+  tree null_data;
+  stmtblock_t block, globalblock;
+
+  /* If the source is null, set the destination to null.  Then,
+     allocate memory to the destination.  */
+  gfc_init_block (&block);
+  gfc_init_block (&globalblock);
+
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+    {
+      gfc_se se;
+      symbol_attribute attr;
+      tree dummy_desc;
+
+      gfc_init_se (&se, NULL);
+      gfc_clear_attr (&attr);
+      attr.allocatable = 1;
+      dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
+      gfc_add_block_to_block (&globalblock, &se.pre);
+      size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+
+      gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
+      gfc_allocate_using_caf_lib (&block, dummy_desc, size,
+				  gfc_build_addr_expr (NULL_TREE, dest_tok),
+				  NULL_TREE, NULL_TREE, NULL_TREE,
+				  GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+
+      gfc_allocate_using_caf_lib (&block, dummy_desc,
+				  fold_convert (size_type_node, size),
+				  gfc_build_addr_expr (NULL_TREE, dest_tok),
+				  NULL_TREE, NULL_TREE, NULL_TREE,
+				  GFC_CAF_COARRAY_ALLOC);
+
+      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+      tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+				 fold_convert (size_type_node, size));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  else
+    {
+      /* Set the rank or unitialized memory access may be reported.  */
+      tmp = gfc_conv_descriptor_dtype (dest);
+      gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
+
+      if (rank)
+	nelems = gfc_full_array_size (&block, src, rank);
+      else
+	nelems = integer_one_node;
+
+      tmp = fold_convert (size_type_node,
+			  TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			      fold_convert (size_type_node, nelems), tmp);
+
+      gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+      gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
+							      size),
+				  gfc_build_addr_expr (NULL_TREE, dest_tok),
+				  NULL_TREE, NULL_TREE, NULL_TREE,
+				  GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      gfc_allocate_using_caf_lib (&block, dest,
+				  fold_convert (size_type_node, size),
+				  gfc_build_addr_expr (NULL_TREE, dest_tok),
+				  NULL_TREE, NULL_TREE, NULL_TREE,
+				  GFC_CAF_COARRAY_ALLOC);
+
+      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+      tmp = build_call_expr_loc (input_location, tmp, 3,
+				 gfc_conv_descriptor_data_get (dest),
+				 gfc_conv_descriptor_data_get (src),
+				 fold_convert (size_type_node, size));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  tmp = gfc_finish_block (&block);
+
+  /* Null the destination if the source is null; otherwise do
+     the register and copy.  */
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
+    null_cond = src;
+  else
+    null_cond = gfc_conv_descriptor_data_get (src);
+
+  null_cond = convert (pvoid_type_node, null_cond);
+  null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       null_cond, null_pointer_node);
+  gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
+						 null_data));
+  return gfc_finish_block (&globalblock);
+}
+
+
+/* Helper function to abstract whether coarray processing is enabled.  */
+
+static bool
+caf_enabled (int caf_mode)
+{
+  return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
+      == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
+}
+
+
+/* Helper function to abstract whether coarray processing is enabled
+   and we are in a derived type coarray.  */
+
+static bool
+caf_in_coarray (int caf_mode)
+{
+  static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+			 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
+  return (caf_mode & pat) == pat;
+}
+
+
+/* Helper function to abstract whether coarray is to deallocate only.  */
+
+bool
+gfc_caf_is_dealloc_only (int caf_mode)
+{
+  return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
+      == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   deallocate, nullify or copy allocatable components.  This is the work horse
+   function for the functions named in this enum.  */
+
+enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
+      COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
+      ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
+
+static gfc_actual_arglist *pdt_param_list;
+
+static tree
+structure_alloc_comps (gfc_symbol * der_type, tree decl,
+		       tree dest, int rank, int purpose, int caf_mode)
+{
+  gfc_component *c;
+  gfc_loopinfo loop;
+  stmtblock_t fnblock;
+  stmtblock_t loopbody;
+  stmtblock_t tmpblock;
+  tree decl_type;
+  tree tmp;
+  tree comp;
+  tree dcmp;
+  tree nelems;
+  tree index;
+  tree var;
+  tree cdecl;
+  tree ctype;
+  tree vref, dref;
+  tree null_cond = NULL_TREE;
+  tree add_when_allocated;
+  tree dealloc_fndecl;
+  tree caf_token;
+  gfc_symbol *vtab;
+  int caf_dereg_mode;
+  symbol_attribute *attr;
+  bool deallocate_called;
+
+  gfc_init_block (&fnblock);
+
+  decl_type = TREE_TYPE (decl);
+
+  if ((POINTER_TYPE_P (decl_type))
+	|| (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
+    {
+      decl = build_fold_indirect_ref_loc (input_location, decl);
+      /* Deref dest in sync with decl, but only when it is not NULL.  */
+      if (dest)
+	dest = build_fold_indirect_ref_loc (input_location, dest);
+
+      /* Update the decl_type because it got dereferenced.  */
+      decl_type = TREE_TYPE (decl);
+    }
+
+  /* If this is an array of derived types with allocatable components
+     build a loop and recursively call this function.  */
+  if (TREE_CODE (decl_type) == ARRAY_TYPE
+      || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
+    {
+      tmp = gfc_conv_array_data (decl);
+      var = build_fold_indirect_ref_loc (input_location, tmp);
+
+      /* Get the number of elements - 1 and set the counter.  */
+      if (GFC_DESCRIPTOR_TYPE_P (decl_type))
+	{
+	  /* Use the descriptor for an allocatable array.  Since this
+	     is a full array reference, we only need the descriptor
+	     information from dimension = rank.  */
+	  tmp = gfc_full_array_size (&fnblock, decl, rank);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, tmp,
+				 gfc_index_one_node);
+
+	  null_cond = gfc_conv_descriptor_data_get (decl);
+	  null_cond = fold_build2_loc (input_location, NE_EXPR,
+				       boolean_type_node, null_cond,
+				       build_int_cst (TREE_TYPE (null_cond), 0));
+	}
+      else
+	{
+	  /*  Otherwise use the TYPE_DOMAIN information.  */
+	  tmp = array_type_nelts (decl_type);
+	  tmp = fold_convert (gfc_array_index_type, tmp);
+	}
+
+      /* Remember that this is, in fact, the no. of elements - 1.  */
+      nelems = gfc_evaluate_now (tmp, &fnblock);
+      index = gfc_create_var (gfc_array_index_type, "S");
+
+      /* Build the body of the loop.  */
+      gfc_init_block (&loopbody);
+
+      vref = gfc_build_array_ref (var, index, NULL);
+
+      if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
+	  && !caf_enabled (caf_mode))
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 gfc_conv_array_data (dest));
+	  dref = gfc_build_array_ref (tmp, index, NULL);
+	  tmp = structure_alloc_comps (der_type, vref, dref, rank,
+				       COPY_ALLOC_COMP, 0);
+	}
+      else
+	tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
+				     caf_mode);
+
+      gfc_add_expr_to_block (&loopbody, tmp);
+
+      /* Build the loop and return.  */
+      gfc_init_loopinfo (&loop);
+      loop.dimen = 1;
+      loop.from[0] = gfc_index_zero_node;
+      loop.loopvar[0] = index;
+      loop.to[0] = nelems;
+      gfc_trans_scalarizing_loops (&loop, &loopbody);
+      gfc_add_block_to_block (&fnblock, &loop.pre);
+
+      tmp = gfc_finish_block (&fnblock);
+      /* When copying allocateable components, the above implements the
+	 deep copy.  Nevertheless is a deep copy only allowed, when the current
+	 component is allocated, for which code will be generated in
+	 gfc_duplicate_allocatable (), where the deep copy code is just added
+	 into the if's body, by adding tmp (the deep copy code) as last
+	 argument to gfc_duplicate_allocatable ().  */
+      if (purpose == COPY_ALLOC_COMP
+	  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+	tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
+					 tmp);
+      else if (null_cond != NULL_TREE)
+	tmp = build3_v (COND_EXPR, null_cond, tmp,
+			build_empty_stmt (input_location));
+
+      return tmp;
+    }
+
+  if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
+    {
+      tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				   DEALLOCATE_PDT_COMP, 0);
+      gfc_add_expr_to_block (&fnblock, tmp);
+    }
+  else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
+    {
+      tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				   NULLIFY_ALLOC_COMP, 0);
+      gfc_add_expr_to_block (&fnblock, tmp);
+    }
+
+  /* Otherwise, act on the components or recursively call self to
+     act on a chain of components.  */
+  for (c = der_type->components; c; c = c->next)
+    {
+      bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
+				  || c->ts.type == BT_CLASS)
+				    && c->ts.u.derived->attr.alloc_comp;
+      bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
+	|| (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
+
+      cdecl = c->backend_decl;
+      ctype = TREE_TYPE (cdecl);
+
+      switch (purpose)
+	{
+	case DEALLOCATE_ALLOC_COMP:
+
+	  gfc_init_block (&tmpblock);
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+
+	  /* Shortcut to get the attributes of the component.  */
+	  if (c->ts.type == BT_CLASS)
+	    {
+	      attr = &CLASS_DATA (c)->attr;
+	      if (attr->class_pointer)
+		continue;
+	    }
+	  else
+	    {
+	      attr = &c->attr;
+	      if (attr->pointer)
+		continue;
+	    }
+
+	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+	     || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+	    /* Call the finalizer, which will free the memory and nullify the
+	       pointer of an array.  */
+	    deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
+							 caf_enabled (caf_mode))
+		&& attr->dimension;
+	  else
+	    deallocate_called = false;
+
+	  /* Add the _class ref for classes.  */
+	  if (c->ts.type == BT_CLASS && attr->allocatable)
+	    comp = gfc_class_data_get (comp);
+
+	  add_when_allocated = NULL_TREE;
+	  if (cmp_has_alloc_comps
+	      && !c->attr.pointer && !c->attr.proc_pointer
+	      && !same_type
+	      && !deallocate_called)
+	    {
+	      /* Add checked deallocation of the components.  This code is
+		 obviously added because the finalizer is not trusted to free
+		 all memory.  */
+	      if (c->ts.type == BT_CLASS)
+		{
+		  rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
+		  add_when_allocated
+		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
+					       comp, NULL_TREE, rank, purpose,
+					       caf_mode);
+		}
+	      else
+		{
+		  rank = c->as ? c->as->rank : 0;
+		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
+							      comp, NULL_TREE,
+							      rank, purpose,
+							      caf_mode);
+		}
+	    }
+
+	  if (attr->allocatable && !same_type
+	      && (!attr->codimension || caf_enabled (caf_mode)))
+	    {
+	      /* Handle all types of components besides components of the
+		 same_type as the current one, because those would create an
+		 endless loop.  */
+	      caf_dereg_mode
+		  = (caf_in_coarray (caf_mode) || attr->codimension)
+		  ? (gfc_caf_is_dealloc_only (caf_mode)
+		     ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
+		     : GFC_CAF_COARRAY_DEREGISTER)
+		  : GFC_CAF_COARRAY_NOCOARRAY;
+
+	      caf_token = NULL_TREE;
+	      /* Coarray components are handled directly by
+		 deallocate_with_status.  */
+	      if (!attr->codimension
+		  && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
+		{
+		  if (c->caf_token)
+		    caf_token = fold_build3_loc (input_location, COMPONENT_REF,
+						 TREE_TYPE (c->caf_token),
+						 decl, c->caf_token, NULL_TREE);
+		  else if (attr->dimension && !attr->proc_pointer)
+		    caf_token = gfc_conv_descriptor_token (comp);
+		}
+	      if (attr->dimension && !attr->codimension && !attr->proc_pointer)
+		/* When this is an array but not in conjunction with a coarray
+		   then add the data-ref.  For coarray'ed arrays the data-ref
+		   is added by deallocate_with_status.  */
+		comp = gfc_conv_descriptor_data_get (comp);
+
+	      tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
+						NULL_TREE, NULL_TREE, true,
+						NULL, caf_dereg_mode,
+						add_when_allocated, caf_token);
+
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	    }
+	  else if (attr->allocatable && !attr->codimension
+		   && !deallocate_called)
+	    {
+	      /* Case of recursive allocatable derived types.  */
+	      tree is_allocated;
+	      tree ubound;
+	      tree cdesc;
+	      stmtblock_t dealloc_block;
+
+	      gfc_init_block (&dealloc_block);
+	      if (add_when_allocated)
+		gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
+
+	      /* Convert the component into a rank 1 descriptor type.  */
+	      if (attr->dimension)
+		{
+		  tmp = gfc_get_element_type (TREE_TYPE (comp));
+		  ubound = gfc_full_array_size (&dealloc_block, comp,
+						c->ts.type == BT_CLASS
+						? CLASS_DATA (c)->as->rank
+						: c->as->rank);
+		}
+	      else
+		{
+		  tmp = TREE_TYPE (comp);
+		  ubound = build_int_cst (gfc_array_index_type, 1);
+		}
+
+	      cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+						 &ubound, 1,
+						 GFC_ARRAY_ALLOCATABLE, false);
+
+	      cdesc = gfc_create_var (cdesc, "cdesc");
+	      DECL_ARTIFICIAL (cdesc) = 1;
+
+	      gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
+			      gfc_get_dtype_rank_type (1, tmp));
+	      gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
+					      gfc_index_zero_node,
+					      gfc_index_one_node);
+	      gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
+					      gfc_index_zero_node,
+					      gfc_index_one_node);
+	      gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
+					      gfc_index_zero_node, ubound);
+
+	      if (attr->dimension)
+		comp = gfc_conv_descriptor_data_get (comp);
+
+	      gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
+
+	      /* Now call the deallocator.  */
+	      vtab = gfc_find_vtab (&c->ts);
+	      if (vtab->backend_decl == NULL)
+		gfc_get_symbol_decl (vtab);
+	      tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
+	      dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
+	      dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
+							    dealloc_fndecl);
+	      tmp = build_int_cst (TREE_TYPE (comp), 0);
+	      is_allocated = fold_build2_loc (input_location, NE_EXPR,
+					      boolean_type_node, tmp,
+					      comp);
+	      cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
+
+	      tmp = build_call_expr_loc (input_location,
+					 dealloc_fndecl, 1,
+					 cdesc);
+	      gfc_add_expr_to_block (&dealloc_block, tmp);
+
+	      tmp = gfc_finish_block (&dealloc_block);
+
+	      tmp = fold_build3_loc (input_location, COND_EXPR,
+				     void_type_node, is_allocated, tmp,
+				     build_empty_stmt (input_location));
+
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	    }
+	  else if (add_when_allocated)
+	    gfc_add_expr_to_block (&tmpblock, add_when_allocated);
+
+	  if (c->ts.type == BT_CLASS && attr->allocatable
+	      && (!attr->codimension || !caf_enabled (caf_mode)))
+	    {
+	      /* Finally, reset the vptr to the declared type vtable and, if
+		 necessary reset the _len field.
+
+		 First recover the reference to the component and obtain
+		 the vptr.  */
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      tmp = gfc_class_vptr_get (comp);
+
+	      if (UNLIMITED_POLY (c))
+		{
+		  /* Both vptr and _len field should be nulled.  */
+		  gfc_add_modify (&tmpblock, tmp,
+				  build_int_cst (TREE_TYPE (tmp), 0));
+		  tmp = gfc_class_len_get (comp);
+		  gfc_add_modify (&tmpblock, tmp,
+				  build_int_cst (TREE_TYPE (tmp), 0));
+		}
+	      else
+		{
+		  /* Build the vtable address and set the vptr with it.  */
+		  tree vtab;
+		  gfc_symbol *vtable;
+		  vtable = gfc_find_derived_vtab (c->ts.u.derived);
+		  vtab = vtable->backend_decl;
+		  if (vtab == NULL_TREE)
+		    vtab = gfc_get_symbol_decl (vtable);
+		  vtab = gfc_build_addr_expr (NULL, vtab);
+		  vtab = fold_convert (TREE_TYPE (tmp), vtab);
+		  gfc_add_modify (&tmpblock, tmp, vtab);
+		}
+	    }
+
+	  /* Now add the deallocation of this component.  */
+	  gfc_add_block_to_block (&fnblock, &tmpblock);
+	  break;
+
+	case NULLIFY_ALLOC_COMP:
+	  /* Nullify
+	     - allocatable components (regular or in class)
+	     - components that have allocatable components
+	     - pointer components when in a coarray.
+	     Skip everything else especially proc_pointers, which may come
+	     coupled with the regular pointer attribute.  */
+	  if (c->attr.proc_pointer
+	      || !(c->attr.allocatable || (c->ts.type == BT_CLASS
+					   && CLASS_DATA (c)->attr.allocatable)
+		   || (cmp_has_alloc_comps
+		       && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+			   || (c->ts.type == BT_CLASS
+			       && !CLASS_DATA (c)->attr.class_pointer)))
+		   || (caf_in_coarray (caf_mode) && c->attr.pointer)))
+	    continue;
+
+	  /* Process class components first, because they always have the
+	     pointer-attribute set which would be caught wrong else.  */
+	  if (c->ts.type == BT_CLASS
+	      && (CLASS_DATA (c)->attr.allocatable
+		  || CLASS_DATA (c)->attr.class_pointer))
+	    {
+	      /* Allocatable CLASS components.  */
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+
+	      comp = gfc_class_data_get (comp);
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
+		gfc_conv_descriptor_data_set (&fnblock, comp,
+					      null_pointer_node);
+	      else
+		{
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
+	      cmp_has_alloc_comps = false;
+	    }
+	  /* Coarrays need the component to be nulled before the api-call
+	     is made.  */
+	  else if (c->attr.pointer || c->attr.allocatable)
+	    {
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      if (c->attr.dimension || c->attr.codimension)
+		gfc_conv_descriptor_data_set (&fnblock, comp,
+					      null_pointer_node);
+	      else
+		gfc_add_modify (&fnblock, comp,
+				build_int_cst (TREE_TYPE (comp), 0));
+	      if (gfc_deferred_strlen (c, &comp))
+		{
+		  comp = fold_build3_loc (input_location, COMPONENT_REF,
+					  TREE_TYPE (comp),
+					  decl, comp, NULL_TREE);
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 TREE_TYPE (comp), comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
+	      cmp_has_alloc_comps = false;
+	    }
+
+	  if (flag_coarray == GFC_FCOARRAY_LIB
+	      && (caf_in_coarray (caf_mode) || c->attr.codimension))
+	    {
+	      /* Register the component with the coarray library.  */
+	      tree token;
+
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      if (c->attr.dimension || c->attr.codimension)
+		{
+		  /* Set the dtype, because caf_register needs it.  */
+		  gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
+				  gfc_get_dtype (TREE_TYPE (comp)));
+		  tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					 decl, cdecl, NULL_TREE);
+		  token = gfc_conv_descriptor_token (tmp);
+		}
+	      else
+		{
+		  gfc_se se;
+
+		  gfc_init_se (&se, NULL);
+		  token = fold_build3_loc (input_location, COMPONENT_REF,
+					   pvoid_type_node, decl, c->caf_token,
+					   NULL_TREE);
+		  comp = gfc_conv_scalar_to_descriptor (&se, comp,
+							c->ts.type == BT_CLASS
+							? CLASS_DATA (c)->attr
+							: c->attr);
+		  gfc_add_block_to_block (&fnblock, &se.pre);
+		}
+
+	      gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
+					  gfc_build_addr_expr (NULL_TREE,
+							       token),
+					  NULL_TREE, NULL_TREE, NULL_TREE,
+					  GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
+	    }
+
+	  if (cmp_has_alloc_comps)
+	    {
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      rank = c->as ? c->as->rank : 0;
+	      tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
+					   rank, purpose, caf_mode);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  break;
+
+	case REASSIGN_CAF_COMP:
+	  if (caf_enabled (caf_mode)
+	      && (c->attr.codimension
+		  || (c->ts.type == BT_CLASS
+		      && (CLASS_DATA (c)->attr.coarray_comp
+			  || caf_in_coarray (caf_mode)))
+		  || (c->ts.type == BT_DERIVED
+		      && (c->ts.u.derived->attr.coarray_comp
+			  || caf_in_coarray (caf_mode))))
+	      && !same_type)
+	    {
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+	      dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      dest, cdecl, NULL_TREE);
+
+	      if (c->attr.codimension)
+		{
+		  if (c->ts.type == BT_CLASS)
+		    {
+		      comp = gfc_class_data_get (comp);
+		      dcmp = gfc_class_data_get (dcmp);
+		    }
+		  gfc_conv_descriptor_data_set (&fnblock, dcmp,
+					   gfc_conv_descriptor_data_get (comp));
+		}
+	      else
+		{
+		  tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
+					       rank, purpose, caf_mode
+					   | GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
+	    }
+	  break;
+
+	case COPY_ALLOC_COMP:
+	  if (c->attr.pointer)
+	    continue;
+
+	  /* We need source and destination components.  */
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
+				  cdecl, NULL_TREE);
+	  dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
+				  cdecl, NULL_TREE);
+	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
+
+	  if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+	    {
+	      tree ftn_tree;
+	      tree size;
+	      tree dst_data;
+	      tree src_data;
+	      tree null_data;
+
+	      dst_data = gfc_class_data_get (dcmp);
+	      src_data = gfc_class_data_get (comp);
+	      size = fold_convert (size_type_node,
+				   gfc_class_vtab_size_get (comp));
+
+	      if (CLASS_DATA (c)->attr.dimension)
+		{
+		  nelems = gfc_conv_descriptor_size (src_data,
+						     CLASS_DATA (c)->as->rank);
+		  size = fold_build2_loc (input_location, MULT_EXPR,
+					  size_type_node, size,
+					  fold_convert (size_type_node,
+							nelems));
+		}
+	      else
+		nelems = build_int_cst (size_type_node, 1);
+
+	      if (CLASS_DATA (c)->attr.dimension
+		  || CLASS_DATA (c)->attr.codimension)
+		{
+		  src_data = gfc_conv_descriptor_data_get (src_data);
+		  dst_data = gfc_conv_descriptor_data_get (dst_data);
+		}
+
+	      gfc_init_block (&tmpblock);
+
+	      /* Coarray component have to have the same allocation status and
+		 shape/type-parameter/effective-type on the LHS and RHS of an
+		 intrinsic assignment. Hence, we did not deallocated them - and
+		 do not allocate them here.  */
+	      if (!CLASS_DATA (c)->attr.codimension)
+		{
+		  ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
+		  tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
+		  gfc_add_modify (&tmpblock, dst_data,
+				  fold_convert (TREE_TYPE (dst_data), tmp));
+		}
+
+	      tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
+					     UNLIMITED_POLY (c));
+	      gfc_add_expr_to_block (&tmpblock, tmp);
+	      tmp = gfc_finish_block (&tmpblock);
+
+	      gfc_init_block (&tmpblock);
+	      gfc_add_modify (&tmpblock, dst_data,
+			      fold_convert (TREE_TYPE (dst_data),
+					    null_pointer_node));
+	      null_data = gfc_finish_block (&tmpblock);
+
+	      null_cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, src_data,
+				           null_pointer_node);
+
+	      gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
+							 tmp, null_data));
+	      continue;
+	    }
+
+	  /* To implement guarded deep copy, i.e., deep copy only allocatable
+	     components that are really allocated, the deep copy code has to
+	     be generated first and then added to the if-block in
+	     gfc_duplicate_allocatable ().  */
+	  if (cmp_has_alloc_comps && !c->attr.proc_pointer
+	      && !same_type)
+	    {
+	      rank = c->as ? c->as->rank : 0;
+	      tmp = fold_convert (TREE_TYPE (dcmp), comp);
+	      gfc_add_modify (&fnblock, dcmp, tmp);
+	      add_when_allocated = structure_alloc_comps (c->ts.u.derived,
+							  comp, dcmp,
+							  rank, purpose,
+							  caf_mode);
+	    }
+	  else
+	    add_when_allocated = NULL_TREE;
+
+	  if (gfc_deferred_strlen (c, &tmp))
+	    {
+	      tree len, size;
+	      len = tmp;
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     decl, len, NULL_TREE);
+	      len = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     dest, len, NULL_TREE);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     TREE_TYPE (len), len, tmp);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      size = size_of_string_in_bytes (c->ts.kind, len);
+	      /* This component can not have allocatable components,
+		 therefore add_when_allocated of duplicate_allocatable ()
+		 is always NULL.  */
+	      tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
+					   false, false, size, NULL_TREE);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
+		   && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
+		       || caf_in_coarray (caf_mode)))
+	    {
+	      rank = c->as ? c->as->rank : 0;
+	      if (c->attr.codimension)
+		tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
+	      else if (flag_coarray == GFC_FCOARRAY_LIB
+		       && caf_in_coarray (caf_mode))
+		{
+		  tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp)
+				       : fold_build3_loc (input_location,
+							  COMPONENT_REF,
+							  pvoid_type_node, dest,
+							  c->caf_token,
+							  NULL_TREE);
+		  tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
+						       ctype, rank);
+		}
+	      else
+		tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
+						 add_when_allocated);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else
+	    if (cmp_has_alloc_comps)
+	      gfc_add_expr_to_block (&fnblock, add_when_allocated);
+
+	  break;
+
+	case ALLOCATE_PDT_COMP:
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+
+	  /* Set the PDT KIND and LEN fields.  */
+	  if (c->attr.pdt_kind || c->attr.pdt_len)
+	    {
+	      gfc_se tse;
+	      gfc_expr *c_expr = NULL;
+	      gfc_actual_arglist *param = pdt_param_list;
+	      gfc_init_se (&tse, NULL);
+	      for (; param; param = param->next)
+		if (!strcmp (c->name, param->name))
+		  c_expr = param->expr;
+
+	      if (!c_expr)
+		c_expr = c->initializer;
+
+	      if (c_expr)
+		{
+		  gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+		  gfc_add_modify (&fnblock, comp, tse.expr);
+		}
+	    }
+
+	  if (c->attr.pdt_string)
+	    {
+	      gfc_se tse;
+	      gfc_init_se (&tse, NULL);
+	      tree strlen;
+	      /* Convert the parameterized string length to its value. The
+		 string length is stored in a hidden field in the same way as
+		 deferred string lengths.  */
+	      gfc_insert_parameter_exprs (c->ts.u.cl->length, pdt_param_list);
+	      if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
+		{
+		  gfc_conv_expr_type (&tse, c->ts.u.cl->length,
+				      TREE_TYPE (strlen));
+		  strlen = fold_build3_loc (input_location, COMPONENT_REF,
+					    TREE_TYPE (strlen),
+					    decl, strlen, NULL_TREE);
+		  gfc_add_modify (&fnblock, strlen, tse.expr);
+		  c->ts.u.cl->backend_decl = strlen;
+		}
+	      /* Scalar parameterizied strings can be allocated now.  */
+	      if (!c->as)
+		{
+		  tmp = fold_convert (gfc_array_index_type, strlen);
+		  tmp = size_of_string_in_bytes (c->ts.kind, tmp);
+		  tmp = gfc_evaluate_now (tmp, &fnblock);
+		  tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
+		  gfc_add_modify (&fnblock, comp, tmp);
+		}
+	    }
+
+	  /* Allocate paramterized arrays of parameterized derived types.  */
+	  if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+	      && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+		   && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+	    continue;
+
+	  if (c->ts.type == BT_CLASS)
+	    comp = gfc_class_data_get (comp);
+
+	  if (c->attr.pdt_array)
+	    {
+	      gfc_se tse;
+	      int i;
+	      tree size = gfc_index_one_node;
+	      tree offset = gfc_index_zero_node;
+	      tree lower, upper;
+	      gfc_expr *e;
+
+	      /* This chunk takes the expressions for 'lower' and 'upper'
+		 in the arrayspec and substitutes in the expressions for
+		 the parameters from 'pdt_param_list'. The descriptor
+		 fields can then be filled from the values so obtained.  */
+	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
+	      for (i = 0; i < c->as->rank; i++)
+		{
+		  gfc_init_se (&tse, NULL);
+		  e = gfc_copy_expr (c->as->lower[i]);
+		  gfc_insert_parameter_exprs (e, pdt_param_list);
+		  gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+		  gfc_free_expr (e);
+		  lower = tse.expr;
+		  gfc_conv_descriptor_lbound_set (&fnblock, comp,
+						  gfc_rank_cst[i],
+						  lower);
+		  e = gfc_copy_expr (c->as->upper[i]);
+		  gfc_insert_parameter_exprs (e, pdt_param_list);
+		  gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+		  gfc_free_expr (e);
+		  upper = tse.expr;
+		  gfc_conv_descriptor_ubound_set (&fnblock, comp,
+						  gfc_rank_cst[i],
+						  upper);
+		  gfc_conv_descriptor_stride_set (&fnblock, comp,
+						  gfc_rank_cst[i],
+						  size);
+		  size = gfc_evaluate_now (size, &fnblock);
+		  offset = fold_build2_loc (input_location,
+					    MINUS_EXPR,
+					    gfc_array_index_type,
+					    offset, size);
+		  offset = gfc_evaluate_now (offset, &fnblock);
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type,
+					 upper, lower);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type,
+					 tmp, gfc_index_one_node);
+		  size = fold_build2_loc (input_location, MULT_EXPR,
+					  gfc_array_index_type, size, tmp);
+		}
+	      gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
+	      if (c->ts.type == BT_CLASS)
+		{
+		  tmp = gfc_get_vptr_from_expr (comp);
+		  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+		    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+		  tmp = gfc_vptr_size_get (tmp);
+		}
+	      else
+		tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
+	      tmp = fold_convert (gfc_array_index_type, tmp);
+	      size = fold_build2_loc (input_location, MULT_EXPR,
+				      gfc_array_index_type, size, tmp);
+	      size = gfc_evaluate_now (size, &fnblock);
+	      tmp = gfc_call_malloc (&fnblock, NULL, size);
+	      gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
+	      tmp = gfc_conv_descriptor_dtype (comp);
+	      gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
+	    }
+
+	  /* Recurse in to PDT components.  */
+	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+	      && !(c->attr.pointer || c->attr.allocatable))
+	    {
+	      bool is_deferred = false;
+	      gfc_actual_arglist *tail = c->param_list;
+
+	      for (; tail; tail = tail->next)
+		if (!tail->expr)
+		  is_deferred = true;
+
+	      tail = is_deferred ? pdt_param_list : c->param_list;
+	      tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
+					   c->as ? c->as->rank : 0,
+					   tail);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+	  break;
+
+	case DEALLOCATE_PDT_COMP:
+	  /* Deallocate array or parameterized string length components
+	     of parameterized derived types.  */
+	  if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+	      && !c->attr.pdt_string
+	      && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+		   && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+	    continue;
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+	  if (c->ts.type == BT_CLASS)
+	    comp = gfc_class_data_get (comp);
+
+	  /* Recurse in to PDT components.  */
+	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+	      && (!c->attr.pointer && !c->attr.allocatable))
+	    {
+	      tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
+					     c->as ? c->as->rank : 0);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+	  if (c->attr.pdt_array)
+	    {
+	      tmp = gfc_conv_descriptor_data_get (comp);
+	      null_cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, tmp,
+					   build_int_cst (TREE_TYPE (tmp), 0));
+	      tmp = gfc_call_free (tmp);
+	      tmp = build3_v (COND_EXPR, null_cond, tmp,
+			      build_empty_stmt (input_location));
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+	    }
+	  else if (c->attr.pdt_string)
+	    {
+	      null_cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, comp,
+					   build_int_cst (TREE_TYPE (comp), 0));
+	      tmp = gfc_call_free (comp);
+	      tmp = build3_v (COND_EXPR, null_cond, tmp,
+			      build_empty_stmt (input_location));
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
+	      gfc_add_modify (&fnblock, comp, tmp);
+	    }
+
+	  break;
+
+	case CHECK_PDT_DUMMY:
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+	  if (c->ts.type == BT_CLASS)
+	    comp = gfc_class_data_get (comp);
+
+	  /* Recurse in to PDT components.  */
+	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+	    {
+	      tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
+					 c->as ? c->as->rank : 0,
+					 pdt_param_list);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+	  if (!c->attr.pdt_len)
+	    continue;
+	  else
+	    {
+	      gfc_se tse;
+	      gfc_expr *c_expr = NULL;
+	      gfc_actual_arglist *param = pdt_param_list;
+
+	      gfc_init_se (&tse, NULL);
+	      for (; param; param = param->next)
+		if (!strcmp (c->name, param->name))
+		  c_expr = param->expr;
+
+	      if (c_expr)
+		{
+		  tree error, cond, cname;
+		  gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+		  cond = fold_build2_loc (input_location, NE_EXPR,
+					  boolean_type_node,
+					  comp, tse.expr);
+		  cname = gfc_build_cstring_const (c->name);
+		  cname = gfc_build_addr_expr (pchar_type_node, cname);
+		  error = gfc_trans_runtime_error (true, NULL,
+						   "The value of the PDT LEN "
+						   "parameter '%s' does not "
+						   "agree with that in the "
+						   "dummy declaration",
+						   cname);
+		  tmp = fold_build3_loc (input_location, COND_EXPR,
+					 void_type_node, cond, error,
+					 build_empty_stmt (input_location));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
+	    }
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	  break;
+	}
+    }
+
+  return gfc_finish_block (&fnblock);
+}
+
+/* Recursively traverse an object of derived type, generating code to
+   nullify allocatable components.  */
+
+tree
+gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
+			int caf_mode)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				NULLIFY_ALLOC_COMP,
+			      GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   deallocate allocatable components.  */
+
+tree
+gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
+			   int caf_mode)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				DEALLOCATE_ALLOC_COMP,
+			      GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   deallocate allocatable components.  But do not deallocate coarrays.
+   To be used for intrinsic assignment, which may not change the allocation
+   status of coarrays.  */
+
+tree
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				DEALLOCATE_ALLOC_COMP, 0);
+}
+
+
+tree
+gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
+{
+  return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   copy it and its allocatable components.  */
+
+tree
+gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
+		     int caf_mode)
+{
+  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
+				caf_mode);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+   copy only its allocatable components.  */
+
+tree
+gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+{
+  return structure_alloc_comps (der_type, decl, dest, rank,
+				COPY_ONLY_ALLOC_COMP, 0);
+}
+
+
+/* Recursively traverse an object of paramterized derived type, generating
+   code to allocate parameterized components.  */
+
+tree
+gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
+		       gfc_actual_arglist *param_list)
+{
+  tree res;
+  gfc_actual_arglist *old_param_list = pdt_param_list;
+  pdt_param_list = param_list;
+  res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+			       ALLOCATE_PDT_COMP, 0);
+  pdt_param_list = old_param_list;
+  return res;
+}
+
+/* Recursively traverse an object of paramterized derived type, generating
+   code to deallocate parameterized components.  */
+
+tree
+gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				DEALLOCATE_PDT_COMP, 0);
+}
+
+
+/* Recursively traverse a dummy of paramterized derived type to check the
+   values of LEN parameters.  */
+
+tree
+gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
+		     gfc_actual_arglist *param_list)
+{
+  tree res;
+  gfc_actual_arglist *old_param_list = pdt_param_list;
+  pdt_param_list = param_list;
+  res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+			       CHECK_PDT_DUMMY, 0);
+  pdt_param_list = old_param_list;
+  return res;
+}
+
+
+/* Returns the value of LBOUND for an expression.  This could be broken out
+   from gfc_conv_intrinsic_bound but this seemed to be simpler.  This is
+   called by gfc_alloc_allocatable_for_assignment.  */
+static tree
+get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
+{
+  tree lbound;
+  tree ubound;
+  tree stride;
+  tree cond, cond1, cond3, cond4;
+  tree tmp;
+  gfc_ref *ref;
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      tmp = gfc_rank_cst[dim];
+      lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
+      ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
+      stride = gfc_conv_descriptor_stride_get (desc, tmp);
+      cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+			       ubound, lbound);
+      cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+			       stride, gfc_index_zero_node);
+      cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			       boolean_type_node, cond3, cond1);
+      cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			       stride, gfc_index_zero_node);
+      if (assumed_size)
+	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				tmp, build_int_cst (gfc_array_index_type,
+						    expr->rank - 1));
+      else
+	cond = boolean_false_node;
+
+      cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+			       boolean_type_node, cond3, cond4);
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+			      boolean_type_node, cond, cond1);
+
+      return fold_build3_loc (input_location, COND_EXPR,
+			      gfc_array_index_type, cond,
+			      lbound, gfc_index_one_node);
+    }
+
+  if (expr->expr_type == EXPR_FUNCTION)
+    {
+      /* A conversion function, so use the argument.  */
+      gcc_assert (expr->value.function.isym
+		  && expr->value.function.isym->conversion);
+      expr = expr->value.function.actual->expr;
+    }
+
+  if (expr->expr_type == EXPR_VARIABLE)
+    {
+      tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT
+		&& ref->u.c.component->as
+		&& ref->next
+		&& ref->next->u.ar.type == AR_FULL)
+	    tmp = TREE_TYPE (ref->u.c.component->backend_decl);
+	}
+      return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
+    }
+
+  return gfc_index_one_node;
+}
+
+
+/* Returns true if an expression represents an lhs that can be reallocated
+   on assignment.  */
+
+bool
+gfc_is_reallocatable_lhs (gfc_expr *expr)
+{
+  gfc_ref * ref;
+
+  if (!expr->ref)
+    return false;
+
+  /* An allocatable class variable with no reference.  */
+  if (expr->symtree->n.sym->ts.type == BT_CLASS
+      && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
+      && expr->ref && expr->ref->type == REF_COMPONENT
+      && strcmp (expr->ref->u.c.component->name, "_data") == 0
+      && expr->ref->next == NULL)
+    return true;
+
+  /* An allocatable variable.  */
+  if (expr->symtree->n.sym->attr.allocatable
+	&& expr->ref
+	&& expr->ref->type == REF_ARRAY
+	&& expr->ref->u.ar.type == AR_FULL)
+    return true;
+
+  /* All that can be left are allocatable components.  */
+  if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+       && expr->symtree->n.sym->ts.type != BT_CLASS)
+	|| !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+    return false;
+
+  /* Find a component ref followed by an array reference.  */
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->next
+	  && ref->type == REF_COMPONENT
+	  && ref->next->type == REF_ARRAY
+	  && !ref->next->next)
+      break;
+
+  if (!ref)
+    return false;
+
+  /* Return true if valid reallocatable lhs.  */
+  if (ref->u.c.component->attr.allocatable
+	&& ref->next->u.ar.type == AR_FULL)
+    return true;
+
+  return false;
+}
+
+
+static tree
+concat_str_length (gfc_expr* expr)
+{
+  tree type;
+  tree len1;
+  tree len2;
+  gfc_se se;
+
+  type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
+  len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+  if (len1 == NULL_TREE)
+    {
+      if (expr->value.op.op1->expr_type == EXPR_OP)
+	len1 = concat_str_length (expr->value.op.op1);
+      else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
+	len1 = build_int_cst (gfc_charlen_type_node,
+			expr->value.op.op1->value.character.length);
+      else if (expr->value.op.op1->ts.u.cl->length)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
+	  len1 = se.expr;
+	}
+      else
+	{
+	  /* Last resort!  */
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  se.descriptor_only = 1;
+	  gfc_conv_expr (&se, expr->value.op.op1);
+	  len1 = se.string_length;
+	}
+    }
+
+  type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
+  len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+  if (len2 == NULL_TREE)
+    {
+      if (expr->value.op.op2->expr_type == EXPR_OP)
+	len2 = concat_str_length (expr->value.op.op2);
+      else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
+	len2 = build_int_cst (gfc_charlen_type_node,
+			expr->value.op.op2->value.character.length);
+      else if (expr->value.op.op2->ts.u.cl->length)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
+	  len2 = se.expr;
+	}
+      else
+	{
+	  /* Last resort!  */
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  se.descriptor_only = 1;
+	  gfc_conv_expr (&se, expr->value.op.op2);
+	  len2 = se.string_length;
+	}
+    }
+
+  gcc_assert(len1 && len2);
+  len1 = fold_convert (gfc_charlen_type_node, len1);
+  len2 = fold_convert (gfc_charlen_type_node, len2);
+
+  return fold_build2_loc (input_location, PLUS_EXPR,
+			  gfc_charlen_type_node, len1, len2);
+}
+
+
+/* Allocate the lhs of an assignment to an allocatable array, otherwise
+   reallocate it.  */
+
+tree
+gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
+				      gfc_expr *expr1,
+				      gfc_expr *expr2)
+{
+  stmtblock_t realloc_block;
+  stmtblock_t alloc_block;
+  stmtblock_t fblock;
+  gfc_ss *rss;
+  gfc_ss *lss;
+  gfc_array_info *linfo;
+  tree realloc_expr;
+  tree alloc_expr;
+  tree size1;
+  tree size2;
+  tree array1;
+  tree cond_null;
+  tree cond;
+  tree tmp;
+  tree tmp2;
+  tree lbound;
+  tree ubound;
+  tree desc;
+  tree old_desc;
+  tree desc2;
+  tree offset;
+  tree jump_label1;
+  tree jump_label2;
+  tree neq_size;
+  tree lbd;
+  int n;
+  int dim;
+  gfc_array_spec * as;
+  bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
+		  && gfc_caf_attr (expr1, true).codimension);
+  tree token;
+  gfc_se caf_se;
+
+  /* x = f(...) with x allocatable.  In this case, expr1 is the rhs.
+     Find the lhs expression in the loop chain and set expr1 and
+     expr2 accordingly.  */
+  if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
+    {
+      expr2 = expr1;
+      /* Find the ss for the lhs.  */
+      lss = loop->ss;
+      for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+	if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
+	  break;
+      if (lss == gfc_ss_terminator)
+	return NULL_TREE;
+      expr1 = lss->info->expr;
+    }
+
+  /* Bail out if this is not a valid allocate on assignment.  */
+  if (!gfc_is_reallocatable_lhs (expr1)
+	|| (expr2 && !expr2->rank))
+    return NULL_TREE;
+
+  /* Find the ss for the lhs.  */
+  lss = loop->ss;
+  for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+    if (lss->info->expr == expr1)
+      break;
+
+  if (lss == gfc_ss_terminator)
+    return NULL_TREE;
+
+  linfo = &lss->info->data.array;
+
+  /* Find an ss for the rhs. For operator expressions, we see the
+     ss's for the operands. Any one of these will do.  */
+  rss = loop->ss;
+  for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
+    if (rss->info->expr != expr1 && rss != loop->temp_ss)
+      break;
+
+  if (expr2 && rss == gfc_ss_terminator)
+    return NULL_TREE;
+
+  gfc_start_block (&fblock);
+
+  /* Since the lhs is allocatable, this must be a descriptor type.
+     Get the data and array size.  */
+  desc = linfo->descriptor;
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+  array1 = gfc_conv_descriptor_data_get (desc);
+
+  /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
+     deallocated if expr is an array of different shape or any of the
+     corresponding length type parameter values of variable and expr
+     differ."  This assures F95 compatibility.  */
+  jump_label1 = gfc_build_label_decl (NULL_TREE);
+  jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+  /* Allocate if data is NULL.  */
+  cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			 array1, build_int_cst (TREE_TYPE (array1), 0));
+
+  if (expr1->ts.deferred)
+    cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
+  else
+    cond_null= gfc_evaluate_now (cond_null, &fblock);
+
+  tmp = build3_v (COND_EXPR, cond_null,
+		  build1_v (GOTO_EXPR, jump_label1),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Get arrayspec if expr is a full array.  */
+  if (expr2 && expr2->expr_type == EXPR_FUNCTION
+	&& expr2->value.function.isym
+	&& expr2->value.function.isym->conversion)
+    {
+      /* For conversion functions, take the arg.  */
+      gfc_expr *arg = expr2->value.function.actual->expr;
+      as = gfc_get_full_arrayspec_from_expr (arg);
+    }
+  else if (expr2)
+    as = gfc_get_full_arrayspec_from_expr (expr2);
+  else
+    as = NULL;
+
+  /* If the lhs shape is not the same as the rhs jump to setting the
+     bounds and doing the reallocation.......  */
+  for (n = 0; n < expr1->rank; n++)
+    {
+      /* Check the shape.  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     loop->to[n], loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, lbound);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, ubound);
+      cond = fold_build2_loc (input_location, NE_EXPR,
+			      boolean_type_node,
+			      tmp, gfc_index_zero_node);
+      tmp = build3_v (COND_EXPR, cond,
+		      build1_v (GOTO_EXPR, jump_label1),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&fblock, tmp);
+    }
+
+  /* ....else jump past the (re)alloc code.  */
+  tmp = build1_v (GOTO_EXPR, jump_label2);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Add the label to start automatic (re)allocation.  */
+  tmp = build1_v (LABEL_EXPR, jump_label1);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* If the lhs has not been allocated, its bounds will not have been
+     initialized and so its size is set to zero.  */
+  size1 = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_init_block (&alloc_block);
+  gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
+  gfc_init_block (&realloc_block);
+  gfc_add_modify (&realloc_block, size1,
+		  gfc_conv_descriptor_size (desc, expr1->rank));
+  tmp = build3_v (COND_EXPR, cond_null,
+		  gfc_finish_block (&alloc_block),
+		  gfc_finish_block (&realloc_block));
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Get the rhs size and fix it.  */
+  if (expr2)
+    desc2 = rss->info->data.array.descriptor;
+  else
+    desc2 = NULL_TREE;
+
+  size2 = gfc_index_one_node;
+  for (n = 0; n < expr2->rank; n++)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     loop->to[n], loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+      size2 = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_array_index_type,
+			       tmp, size2);
+    }
+  size2 = gfc_evaluate_now (size2, &fblock);
+
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  size1, size2);
+
+  /* If the lhs is deferred length, assume that the element size
+     changes and force a reallocation.  */
+  if (expr1->ts.deferred)
+    neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
+  else
+    neq_size = gfc_evaluate_now (cond, &fblock);
+
+  /* Deallocation of allocatable components will have to occur on
+     reallocation.  Fix the old descriptor now.  */
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    old_desc = gfc_evaluate_now (desc, &fblock);
+  else
+    old_desc = NULL_TREE;
+
+  /* Now modify the lhs descriptor and the associated scalarizer
+     variables. F2003 7.4.1.3: "If variable is or becomes an
+     unallocated allocatable variable, then it is allocated with each
+     deferred type parameter equal to the corresponding type parameters
+     of expr , with the shape of expr , and with each lower bound equal
+     to the corresponding element of LBOUND(expr)."
+     Reuse size1 to keep a dimension-by-dimension track of the
+     stride of the new array.  */
+  size1 = gfc_index_one_node;
+  offset = gfc_index_zero_node;
+
+  for (n = 0; n < expr2->rank; n++)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     loop->to[n], loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+
+      lbound = gfc_index_one_node;
+      ubound = tmp;
+
+      if (as)
+	{
+	  lbd = get_std_lbound (expr2, desc2, n,
+				as->type == AS_ASSUMED_SIZE);
+	  ubound = fold_build2_loc (input_location,
+				    MINUS_EXPR,
+				    gfc_array_index_type,
+				    ubound, lbound);
+	  ubound = fold_build2_loc (input_location,
+				    PLUS_EXPR,
+				    gfc_array_index_type,
+				    ubound, lbd);
+	  lbound = lbd;
+	}
+
+      gfc_conv_descriptor_lbound_set (&fblock, desc,
+				      gfc_rank_cst[n],
+				      lbound);
+      gfc_conv_descriptor_ubound_set (&fblock, desc,
+				      gfc_rank_cst[n],
+				      ubound);
+      gfc_conv_descriptor_stride_set (&fblock, desc,
+				      gfc_rank_cst[n],
+				      size1);
+      lbound = gfc_conv_descriptor_lbound_get (desc,
+					       gfc_rank_cst[n]);
+      tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+			      gfc_array_index_type,
+			      lbound, size1);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type,
+				offset, tmp2);
+      size1 = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_array_index_type,
+			       tmp, size1);
+    }
+
+  /* Set the lhs descriptor and scalarizer offsets.  For rank > 1,
+     the array offset is saved and the info.offset is used for a
+     running offset.  Use the saved_offset instead.  */
+  tmp = gfc_conv_descriptor_offset (desc);
+  gfc_add_modify (&fblock, tmp, offset);
+  if (linfo->saved_offset
+      && VAR_P (linfo->saved_offset))
+    gfc_add_modify (&fblock, linfo->saved_offset, tmp);
+
+  /* Now set the deltas for the lhs.  */
+  for (n = 0; n < expr1->rank; n++)
+    {
+      tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      dim = lss->dim[n];
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type, tmp,
+			     loop->from[dim]);
+      if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
+	gfc_add_modify (&fblock, linfo->delta[dim], tmp);
+    }
+
+  /* Get the new lhs size in bytes.  */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      if (expr2->ts.deferred)
+	{
+	  if (VAR_P (expr2->ts.u.cl->backend_decl))
+	    tmp = expr2->ts.u.cl->backend_decl;
+	  else
+	    tmp = rss->info->string_length;
+	}
+      else
+	{
+	  tmp = expr2->ts.u.cl->backend_decl;
+	  if (!tmp && expr2->expr_type == EXPR_OP
+	      && expr2->value.op.op == INTRINSIC_CONCAT)
+	    {
+	      tmp = concat_str_length (expr2);
+	      expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+	    }
+	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+	}
+
+      if (expr1->ts.u.cl->backend_decl
+	  && VAR_P (expr1->ts.u.cl->backend_decl))
+	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+      else
+	gfc_add_modify (&fblock, lss->info->string_length, tmp);
+    }
+  else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+    {
+      tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+      tmp = fold_build2_loc (input_location, MULT_EXPR,
+			     gfc_array_index_type, tmp,
+			     expr1->ts.u.cl->backend_decl);
+    }
+  else
+    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+  tmp = fold_convert (gfc_array_index_type, tmp);
+  size2 = fold_build2_loc (input_location, MULT_EXPR,
+			   gfc_array_index_type,
+			   tmp, size2);
+  size2 = fold_convert (size_type_node, size2);
+  size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+			   size2, size_one_node);
+  size2 = gfc_evaluate_now (size2, &fblock);
+
+  /* For deferred character length, the 'size' field of the dtype might
+     have changed so set the dtype.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+      && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      tree type;
+      tmp = gfc_conv_descriptor_dtype (desc);
+      if (expr2->ts.u.cl->backend_decl)
+	type = gfc_typenode_for_spec (&expr2->ts);
+      else
+	type = gfc_typenode_for_spec (&expr1->ts);
+
+      gfc_add_modify (&fblock, tmp,
+		      gfc_get_dtype_rank_type (expr1->rank,type));
+    }
+  else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
+		      gfc_get_dtype (TREE_TYPE (desc)));
+    }
+
+  /* Realloc expression.  Note that the scalarizer uses desc.data
+     in the array reference - (*desc.data)[<element>].  */
+  gfc_init_block (&realloc_block);
+  gfc_init_se (&caf_se, NULL);
+
+  if (coarray)
+    {
+      token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
+      if (token == NULL_TREE)
+	{
+	  tmp = gfc_get_tree_for_caf_expr (expr1);
+	  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+	    tmp = build_fold_indirect_ref (tmp);
+	  gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
+				    expr1);
+	  token = gfc_build_addr_expr (NULL_TREE, token);
+	}
+
+      gfc_add_block_to_block (&realloc_block, &caf_se.pre);
+    }
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
+					      expr1->rank);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+    }
+
+  if (!coarray)
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
+				 fold_convert (pvoid_type_node, array1),
+				 size2);
+      gfc_conv_descriptor_data_set (&realloc_block,
+				    desc, tmp);
+    }
+  else
+    {
+      tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_caf_deregister, 5, token,
+				 build_int_cst (integer_type_node,
+					       GFC_CAF_COARRAY_DEALLOCATE_ONLY),
+				 null_pointer_node, null_pointer_node,
+				 integer_zero_node);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+      tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_caf_register,
+				 7, size2,
+				 build_int_cst (integer_type_node,
+					   GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
+				 token, gfc_build_addr_expr (NULL_TREE, desc),
+				 null_pointer_node, null_pointer_node,
+				 integer_zero_node);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+    }
+
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+				    expr1->rank);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+    }
+
+  gfc_add_block_to_block (&realloc_block, &caf_se.post);
+  realloc_expr = gfc_finish_block (&realloc_block);
+
+  /* Only reallocate if sizes are different.  */
+  tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
+		  build_empty_stmt (input_location));
+  realloc_expr = tmp;
+
+
+  /* Malloc expression.  */
+  gfc_init_block (&alloc_block);
+  if (!coarray)
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_MALLOC),
+				 1, size2);
+      gfc_conv_descriptor_data_set (&alloc_block,
+				    desc, tmp);
+    }
+  else
+    {
+      tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_caf_register,
+				 7, size2,
+				 build_int_cst (integer_type_node,
+						GFC_CAF_COARRAY_ALLOC),
+				 token, gfc_build_addr_expr (NULL_TREE, desc),
+				 null_pointer_node, null_pointer_node,
+				 integer_zero_node);
+      gfc_add_expr_to_block (&alloc_block, tmp);
+    }
+
+
+  /* We already set the dtype in the case of deferred character
+     length arrays.  */
+  if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+	&& ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+	    || coarray)))
+    {
+      tmp = gfc_conv_descriptor_dtype (desc);
+      gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+    }
+
+  if ((expr1->ts.type == BT_DERIVED)
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+				    expr1->rank);
+      gfc_add_expr_to_block (&alloc_block, tmp);
+    }
+  alloc_expr = gfc_finish_block (&alloc_block);
+
+  /* Malloc if not allocated; realloc otherwise.  */
+  tmp = build_int_cst (TREE_TYPE (array1), 0);
+  cond = fold_build2_loc (input_location, EQ_EXPR,
+			  boolean_type_node,
+			  array1, tmp);
+  tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  /* Make sure that the scalarizer data pointer is updated.  */
+  if (linfo->data && VAR_P (linfo->data))
+    {
+      tmp = gfc_conv_descriptor_data_get (desc);
+      gfc_add_modify (&fblock, linfo->data, tmp);
+    }
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, jump_label2);
+  gfc_add_expr_to_block (&fblock, tmp);
+
+  return gfc_finish_block (&fblock);
+}
+
+
+/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
+   Do likewise, recursively if necessary, with the allocatable components of
+   derived types.  */
+
+void
+gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
+{
+  tree type;
+  tree tmp;
+  tree descriptor;
+  stmtblock_t init;
+  stmtblock_t cleanup;
+  locus loc;
+  int rank;
+  bool sym_has_alloc_comp, has_finalizer;
+
+  sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
+			|| sym->ts.type == BT_CLASS)
+			  && sym->ts.u.derived->attr.alloc_comp;
+  has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
+		   ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+
+  /* Make sure the frontend gets these right.  */
+  gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
+	      || has_finalizer);
+
+  gfc_save_backend_locus (&loc);
+  gfc_set_backend_locus (&sym->declared_at);
+  gfc_init_block (&init);
+
+  gcc_assert (VAR_P (sym->backend_decl)
+	      || TREE_CODE (sym->backend_decl) == PARM_DECL);
+
+  if (sym->ts.type == BT_CHARACTER
+      && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+    {
+      gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+      gfc_trans_vla_type_sizes (sym, &init);
+    }
+
+  /* Dummy, use associated and result variables don't need anything special.  */
+  if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
+    {
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      gfc_restore_backend_locus (&loc);
+      return;
+    }
+
+  descriptor = sym->backend_decl;
+
+  /* Although static, derived types with default initializers and
+     allocatable components must not be nulled wholesale; instead they
+     are treated component by component.  */
+  if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
+    {
+      /* SAVEd variables are not freed on exit.  */
+      gfc_trans_static_array_pointer (sym);
+
+      gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+      gfc_restore_backend_locus (&loc);
+      return;
+    }
+
+  /* Get the descriptor type.  */
+  type = TREE_TYPE (sym->backend_decl);
+
+  if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
+      && !(sym->attr.pointer || sym->attr.allocatable))
+    {
+      if (!sym->attr.save
+	  && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
+	{
+	  if (sym->value == NULL
+	      || !gfc_has_default_initializer (sym->ts.u.derived))
+	    {
+	      rank = sym->as ? sym->as->rank : 0;
+	      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
+					    descriptor, rank);
+	      gfc_add_expr_to_block (&init, tmp);
+	    }
+	  else
+	    gfc_init_default_dt (sym, &init, false);
+	}
+    }
+  else if (!GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      /* If the backend_decl is not a descriptor, we must have a pointer
+	 to one.  */
+      descriptor = build_fold_indirect_ref_loc (input_location,
+						sym->backend_decl);
+      type = TREE_TYPE (descriptor);
+    }
+
+  /* NULLIFY the data pointer, for non-saved allocatables.  */
+  if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
+    {
+      gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
+      if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+	{
+	  /* Declare the variable static so its array descriptor stays present
+	     after leaving the scope.  It may still be accessed through another
+	     image.  This may happen, for example, with the caf_mpi
+	     implementation.  */
+	  TREE_STATIC (descriptor) = 1;
+	  tmp = gfc_conv_descriptor_token (descriptor);
+	  gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
+						    null_pointer_node));
+	}
+    }
+
+  gfc_restore_backend_locus (&loc);
+  gfc_init_block (&cleanup);
+
+  /* Allocatable arrays need to be freed when they go out of scope.
+     The allocatable components of pointers must not be touched.  */
+  if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
+      && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
+      && !sym->ns->proc_name->attr.is_main_program)
+    {
+      gfc_expr *e;
+      sym->attr.referenced = 1;
+      e = gfc_lval_expr_from_sym (sym);
+      gfc_add_finalizer_call (&cleanup, e);
+      gfc_free_expr (e);
+    }
+  else if ((!sym->attr.allocatable || !has_finalizer)
+      && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
+      && !sym->attr.pointer && !sym->attr.save
+      && !sym->ns->proc_name->attr.is_main_program)
+    {
+      int rank;
+      rank = sym->as ? sym->as->rank : 0;
+      tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
+      gfc_add_expr_to_block (&cleanup, tmp);
+    }
+
+  if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
+      && !sym->attr.save && !sym->attr.result
+      && !sym->ns->proc_name->attr.is_main_program)
+    {
+      gfc_expr *e;
+      e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
+      tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
+					NULL_TREE, NULL_TREE, true, e,
+					sym->attr.codimension
+					? GFC_CAF_COARRAY_DEREGISTER
+					: GFC_CAF_COARRAY_NOCOARRAY);
+      if (e)
+	gfc_free_expr (e);
+      gfc_add_expr_to_block (&cleanup, tmp);
+    }
+
+  gfc_add_init_cleanup (block, gfc_finish_block (&init),
+			gfc_finish_block (&cleanup));
+}
+
+/************ Expression Walking Functions ******************/
+
+/* Walk a variable reference.
+
+   Possible extension - multiple component subscripts.
+    x(:,:) = foo%a(:)%b(:)
+   Transforms to
+    forall (i=..., j=...)
+      x(i,j) = foo%a(j)%b(i)
+    end forall
+   This adds a fair amount of complexity because you need to deal with more
+   than one ref.  Maybe handle in a similar manner to vector subscripts.
+   Maybe not worth the effort.  */
+
+
+static gfc_ss *
+gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_ref *ref;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+      break;
+
+  return gfc_walk_array_ref (ss, expr, ref);
+}
+
+
+gfc_ss *
+gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
+{
+  gfc_array_ref *ar;
+  gfc_ss *newss;
+  int n;
+
+  for (; ref; ref = ref->next)
+    {
+      if (ref->type == REF_SUBSTRING)
+	{
+	  ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
+	  ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
+	}
+
+      /* We're only interested in array sections from now on.  */
+      if (ref->type != REF_ARRAY)
+	continue;
+
+      ar = &ref->u.ar;
+
+      switch (ar->type)
+	{
+	case AR_ELEMENT:
+	  for (n = ar->dimen - 1; n >= 0; n--)
+	    ss = gfc_get_scalar_ss (ss, ar->start[n]);
+	  break;
+
+	case AR_FULL:
+	  newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
+	  newss->info->data.array.ref = ref;
+
+	  /* Make sure array is the same as array(:,:), this way
+	     we don't need to special case all the time.  */
+	  ar->dimen = ar->as->rank;
+	  for (n = 0; n < ar->dimen; n++)
+	    {
+	      ar->dimen_type[n] = DIMEN_RANGE;
+
+	      gcc_assert (ar->start[n] == NULL);
+	      gcc_assert (ar->end[n] == NULL);
+	      gcc_assert (ar->stride[n] == NULL);
+	    }
+	  ss = newss;
+	  break;
+
+	case AR_SECTION:
+	  newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
+	  newss->info->data.array.ref = ref;
+
+	  /* We add SS chains for all the subscripts in the section.  */
+	  for (n = 0; n < ar->dimen; n++)
+	    {
+	      gfc_ss *indexss;
+
+	      switch (ar->dimen_type[n])
+		{
+		case DIMEN_ELEMENT:
+		  /* Add SS for elemental (scalar) subscripts.  */
+		  gcc_assert (ar->start[n]);
+		  indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
+		  indexss->loop_chain = gfc_ss_terminator;
+		  newss->info->data.array.subscript[n] = indexss;
+		  break;
+
+		case DIMEN_RANGE:
+                  /* We don't add anything for sections, just remember this
+                     dimension for later.  */
+		  newss->dim[newss->dimen] = n;
+		  newss->dimen++;
+		  break;
+
+		case DIMEN_VECTOR:
+		  /* Create a GFC_SS_VECTOR index in which we can store
+		     the vector's descriptor.  */
+		  indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
+					      1, GFC_SS_VECTOR);
+		  indexss->loop_chain = gfc_ss_terminator;
+		  newss->info->data.array.subscript[n] = indexss;
+		  newss->dim[newss->dimen] = n;
+		  newss->dimen++;
+		  break;
+
+		default:
+		  /* We should know what sort of section it is by now.  */
+		  gcc_unreachable ();
+		}
+	    }
+	  /* We should have at least one non-elemental dimension,
+	     unless we are creating a descriptor for a (scalar) coarray.  */
+	  gcc_assert (newss->dimen > 0
+		      || newss->info->data.array.ref->u.ar.as->corank > 0);
+	  ss = newss;
+	  break;
+
+	default:
+	  /* We should know what sort of section it is by now.  */
+	  gcc_unreachable ();
+	}
+
+    }
+  return ss;
+}
+
+
+/* Walk an expression operator. If only one operand of a binary expression is
+   scalar, we must also add the scalar term to the SS chain.  */
+
+static gfc_ss *
+gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_ss *head;
+  gfc_ss *head2;
+
+  head = gfc_walk_subexpr (ss, expr->value.op.op1);
+  if (expr->value.op.op2 == NULL)
+    head2 = head;
+  else
+    head2 = gfc_walk_subexpr (head, expr->value.op.op2);
+
+  /* All operands are scalar.  Pass back and let the caller deal with it.  */
+  if (head2 == ss)
+    return head2;
+
+  /* All operands require scalarization.  */
+  if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
+    return head2;
+
+  /* One of the operands needs scalarization, the other is scalar.
+     Create a gfc_ss for the scalar expression.  */
+  if (head == ss)
+    {
+      /* First operand is scalar.  We build the chain in reverse order, so
+         add the scalar SS after the second operand.  */
+      head = head2;
+      while (head && head->next != ss)
+	head = head->next;
+      /* Check we haven't somehow broken the chain.  */
+      gcc_assert (head);
+      head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
+    }
+  else				/* head2 == head */
+    {
+      gcc_assert (head2 == head);
+      /* Second operand is scalar.  */
+      head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
+    }
+
+  return head2;
+}
+
+
+/* Reverse a SS chain.  */
+
+gfc_ss *
+gfc_reverse_ss (gfc_ss * ss)
+{
+  gfc_ss *next;
+  gfc_ss *head;
+
+  gcc_assert (ss != NULL);
+
+  head = gfc_ss_terminator;
+  while (ss != gfc_ss_terminator)
+    {
+      next = ss->next;
+      /* Check we didn't somehow break the chain.  */
+      gcc_assert (next != NULL);
+      ss->next = head;
+      head = ss;
+      ss = next;
+    }
+
+  return (head);
+}
+
+
+/* Given an expression referring to a procedure, return the symbol of its
+   interface.  We can't get the procedure symbol directly as we have to handle
+   the case of (deferred) type-bound procedures.  */
+
+gfc_symbol *
+gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
+{
+  gfc_symbol *sym;
+  gfc_ref *ref;
+
+  if (procedure_ref == NULL)
+    return NULL;
+
+  /* Normal procedure case.  */
+  if (procedure_ref->expr_type == EXPR_FUNCTION
+      && procedure_ref->value.function.esym)
+    sym = procedure_ref->value.function.esym;
+  else
+    sym = procedure_ref->symtree->n.sym;
+
+  /* Typebound procedure case.  */
+  for (ref = procedure_ref->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	  && ref->u.c.component->attr.proc_pointer)
+	sym = ref->u.c.component->ts.interface;
+      else
+	sym = NULL;
+    }
+
+  return sym;
+}
+
+
+/* Walk the arguments of an elemental function.
+   PROC_EXPR is used to check whether an argument is permitted to be absent.  If
+   it is NULL, we don't do the check and the argument is assumed to be present.
+*/
+
+gfc_ss *
+gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
+				  gfc_symbol *proc_ifc, gfc_ss_type type)
+{
+  gfc_formal_arglist *dummy_arg;
+  int scalar;
+  gfc_ss *head;
+  gfc_ss *tail;
+  gfc_ss *newss;
+
+  head = gfc_ss_terminator;
+  tail = NULL;
+
+  if (proc_ifc)
+    dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
+  else
+    dummy_arg = NULL;
+
+  scalar = 1;
+  for (; arg; arg = arg->next)
+    {
+      if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
+	goto loop_continue;
+
+      newss = gfc_walk_subexpr (head, arg->expr);
+      if (newss == head)
+	{
+	  /* Scalar argument.  */
+	  gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
+	  newss = gfc_get_scalar_ss (head, arg->expr);
+	  newss->info->type = type;
+	  if (dummy_arg)
+	    newss->info->data.scalar.dummy_arg = dummy_arg->sym;
+	}
+      else
+	scalar = 0;
+
+      if (dummy_arg != NULL
+	  && dummy_arg->sym->attr.optional
+	  && arg->expr->expr_type == EXPR_VARIABLE
+	  && (gfc_expr_attr (arg->expr).optional
+	      || gfc_expr_attr (arg->expr).allocatable
+	      || gfc_expr_attr (arg->expr).pointer))
+	newss->info->can_be_null_ref = true;
+
+      head = newss;
+      if (!tail)
+        {
+          tail = head;
+          while (tail->next != gfc_ss_terminator)
+            tail = tail->next;
+        }
+
+loop_continue:
+      if (dummy_arg != NULL)
+	dummy_arg = dummy_arg->next;
+    }
+
+  if (scalar)
+    {
+      /* If all the arguments are scalar we don't need the argument SS.  */
+      gfc_free_ss_chain (head);
+      /* Pass it back.  */
+      return ss;
+    }
+
+  /* Add it onto the existing chain.  */
+  tail->next = ss;
+  return head;
+}
+
+
+/* Walk a function call.  Scalar functions are passed back, and taken out of
+   scalarization loops.  For elemental functions we walk their arguments.
+   The result of functions returning arrays is stored in a temporary outside
+   the loop, so that the function is only called once.  Hence we do not need
+   to walk their arguments.  */
+
+static gfc_ss *
+gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_intrinsic_sym *isym;
+  gfc_symbol *sym;
+  gfc_component *comp = NULL;
+
+  isym = expr->value.function.isym;
+
+  /* Handle intrinsic functions separately.  */
+  if (isym)
+    return gfc_walk_intrinsic_function (ss, expr, isym);
+
+  sym = expr->value.function.esym;
+  if (!sym)
+    sym = expr->symtree->n.sym;
+
+  if (gfc_is_alloc_class_array_function (expr))
+    return gfc_get_array_ss (ss, expr,
+			     CLASS_DATA (expr->value.function.esym->result)->as->rank,
+			     GFC_SS_FUNCTION);
+
+  /* A function that returns arrays.  */
+  comp = gfc_get_proc_ptr_comp (expr);
+  if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
+      || (comp && comp->attr.dimension))
+    return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
+
+  /* Walk the parameters of an elemental function.  For now we always pass
+     by reference.  */
+  if (sym->attr.elemental || (comp && comp->attr.elemental))
+    {
+      gfc_ss *old_ss = ss;
+
+      ss = gfc_walk_elemental_function_args (old_ss,
+					     expr->value.function.actual,
+					     gfc_get_proc_ifc_for_expr (expr),
+					     GFC_SS_REFERENCE);
+      if (ss != old_ss
+	  && (comp
+	      || sym->attr.proc_pointer
+	      || sym->attr.if_source != IFSRC_DECL
+	      || sym->attr.array_outer_dependency))
+	ss->info->array_outer_dependency = 1;
+    }
+
+  /* Scalar functions are OK as these are evaluated outside the scalarization
+     loop.  Pass back and let the caller deal with it.  */
+  return ss;
+}
+
+
+/* An array temporary is constructed for array constructors.  */
+
+static gfc_ss *
+gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
+{
+  return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
+}
+
+
+/* Walk an expression.  Add walked expressions to the head of the SS chain.
+   A wholly scalar expression will not be added.  */
+
+gfc_ss *
+gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
+{
+  gfc_ss *head;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      head = gfc_walk_variable_expr (ss, expr);
+      return head;
+
+    case EXPR_OP:
+      head = gfc_walk_op_expr (ss, expr);
+      return head;
+
+    case EXPR_FUNCTION:
+      head = gfc_walk_function_expr (ss, expr);
+      return head;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_STRUCTURE:
+      /* Pass back and let the caller deal with it.  */
+      break;
+
+    case EXPR_ARRAY:
+      head = gfc_walk_array_constructor (ss, expr);
+      return head;
+
+    case EXPR_SUBSTRING:
+      /* Pass back and let the caller deal with it.  */
+      break;
+
+    default:
+      gfc_internal_error ("bad expression type during walk (%d)",
+		      expr->expr_type);
+    }
+  return ss;
+}
+
+
+/* Entry point for expression walking.
+   A return value equal to the passed chain means this is
+   a scalar expression.  It is up to the caller to take whatever action is
+   necessary to translate these.  */
+
+gfc_ss *
+gfc_walk_expr (gfc_expr * expr)
+{
+  gfc_ss *res;
+
+  res = gfc_walk_subexpr (gfc_ss_terminator, expr);
+  return gfc_reverse_ss (res);
+}