re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

2011-04-04  Tobias Burnus  <burnus@net-b.de>
            Mikael Morin  <mikael.morin@sfr.fr>

        PR fortran/18918
        * check.c (is_coarray): Update - because of DIMEN_THIS_IMAGE.
        * expr.c (gfc_is_coindexed): Ditto.
        * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_THIS_IMAGE.
        * interface.c (compare_parameter): Use gfc_expr_attr and
        gfc_is_coindexed.
        * resolve.c (check_dimension, compare_spec_to_ref,
        resolve_allocate_expr, check_data_variable): Update for
        DIMEN_THIS_IMAGE.
        * simplify.c (gfc_simplify_lcobound, gfc_simplify_this_image,
        gfc_simplify_ucobound): Allow non-constant bounds.
        * trans-array.c (gfc_set_loop_bounds_from_array_spec,
        gfc_trans_create_temp_array, gfc_trans_constant_array_constructor,
        gfc_set_vector_loop_bounds, gfc_conv_array_index_offset,
        gfc_start_scalarized_body, gfc_trans_scalarizing_loops,
        gfc_trans_scalarized_loop_boundary, gfc_conv_section_startstride,
        gfc_conv_ss_startstride, gfc_conv_loop_setup,
        gfc_trans_array_bounds, gfc_conv_expr_descriptor,
        gfc_walk_variable_expr): Handle codimen.
        * trans-decl.c (gfc_build_qualified_array): Save cobounds.
        * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2.
        (conv_intrinsic_cobound): New function.
        (gfc_conv_intrinsic_function): Call it.
        (gfc_walk_intrinsic_function, gfc_add_intrinsic_ss_code): Handle
        ucobound, lcobound, this_image.
        * fortran/trans-types.c (gfc_build_array_type): Save cobounds.
        (gfc_get_dtype): Honour corank.
        (gfc_get_nodesc_array_type): Save corank and codimensions.
        (gfc_get_array_type_bounds): Save cobound.
        * fortran/trans.h (gfc_ss_info,gfc_loopinfo): Add codimen item.
        (gfc_array_kind): Add corank item.
        (GFC_TYPE_ARRAY_CORANK): New macro.

2011-04-04  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_10.f90: Add coarray descriptor diagnostic
        check.
        * gfortran.dg/coarray_13.f90: Add checks for run-time cobounds.
        * gfortran.dg/coarray_15.f90: New.


Co-Authored-By: Mikael Morin <mikael.morin@sfr.fr>

From-SVN: r171949

16 files changed, 705 insertions, 136 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 16d824a..f9513db 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,39 @@
+2011-04-04  Tobias Burnus  <burnus@net-b.de>
+	    Mikael Morin  <mikael.morin@sfr.fr>
+
+	PR fortran/18918
+	* check.c (is_coarray): Update - because of DIMEN_THIS_IMAGE.
+	* expr.c (gfc_is_coindexed): Ditto.
+	* gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_THIS_IMAGE.
+	* interface.c (compare_parameter): Use gfc_expr_attr and
+	gfc_is_coindexed.
+	* resolve.c (check_dimension, compare_spec_to_ref,
+	resolve_allocate_expr, check_data_variable): Update for
+	DIMEN_THIS_IMAGE.
+	* simplify.c (gfc_simplify_lcobound, gfc_simplify_this_image,
+	gfc_simplify_ucobound): Allow non-constant bounds.
+	* trans-array.c (gfc_set_loop_bounds_from_array_spec,
+	gfc_trans_create_temp_array, gfc_trans_constant_array_constructor,
+	gfc_set_vector_loop_bounds, gfc_conv_array_index_offset,
+	gfc_start_scalarized_body, gfc_trans_scalarizing_loops,
+	gfc_trans_scalarized_loop_boundary, gfc_conv_section_startstride,
+	gfc_conv_ss_startstride, gfc_conv_loop_setup,
+	gfc_trans_array_bounds, gfc_conv_expr_descriptor,
+	gfc_walk_variable_expr): Handle codimen.
+	* trans-decl.c (gfc_build_qualified_array): Save cobounds.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2.
+	(conv_intrinsic_cobound): New function.
+	(gfc_conv_intrinsic_function): Call it.
+	(gfc_walk_intrinsic_function, gfc_add_intrinsic_ss_code): Handle
+	ucobound, lcobound, this_image.
+	* fortran/trans-types.c (gfc_build_array_type): Save cobounds.
+	(gfc_get_dtype): Honour corank.
+	(gfc_get_nodesc_array_type): Save corank and codimensions.
+	(gfc_get_array_type_bounds): Save cobound.
+	* fortran/trans.h (gfc_ss_info,gfc_loopinfo): Add codimen item.
+	(gfc_array_kind): Add corank item.
+	(GFC_TYPE_ARRAY_CORANK): New macro.
+
 2011-04-03  Kai Tietz  <ktietz@redhat.com>
 
 	PR middle-end/48422
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index adb4b953..bb56122 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -219,9 +219,15 @@ is_coarray (gfc_expr *e)
     {
       if (ref->type == REF_COMPONENT)
 	coarray = ref->u.c.component->attr.codimension;
-      else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
-	       || ref->u.ar.codimen != 0) 
+      else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0)
 	coarray = false;
+      else if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0) 
+	{
+	  int n;
+	  for (n = 0; n < ref->u.ar.codimen; n++)
+	    if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+	      coarray = false;
+	}
     }
 
   return coarray;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 58b6036..287a2a2 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4129,7 +4129,12 @@ gfc_is_coindexed (gfc_expr *e)
 
   for (ref = e->ref; ref; ref = ref->next)
     if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
-      return true;
+      {
+	int n;
+	for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+	  if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+	    return true;
+      }
 
   return false;
 }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index eec737c..495923a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1486,7 +1486,7 @@ extern gfc_interface_info current_interface;
 
 enum gfc_array_ref_dimen_type
 {
-  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
+  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_THIS_IMAGE, DIMEN_UNKNOWN
 };
 
 typedef struct gfc_array_ref
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b0b74c1..00fd24a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1564,8 +1564,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       gfc_ref *last = NULL;
 
       if (actual->expr_type != EXPR_VARIABLE
-	  || (actual->ref == NULL
-	      && !actual->symtree->n.sym->attr.codimension))
+	  || !gfc_expr_attr (actual).codimension)
 	{
 	  if (where)
 	    gfc_error ("Actual argument to '%s' at %L must be a coarray",
@@ -1573,15 +1572,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  return 0;
 	}
 
+      if (gfc_is_coindexed (actual))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be a coarray "
+		       "and not coindexed", formal->name, &actual->where);
+	  return 0;
+	}
+
       for (ref = actual->ref; ref; ref = ref->next)
 	{
-	  if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
-	    {
-	      if (where)
-		gfc_error ("Actual argument to '%s' at %L must be a coarray "
-			   "and not coindexed", formal->name, &ref->u.ar.where);
-	      return 0;
-	    }
 	  if (ref->type == REF_ARRAY && ref->u.ar.as->corank
 	      && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
 	    {
@@ -1595,14 +1595,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	    last = ref;
 	}
 
-      if (last && !last->u.c.component->attr.codimension)
-      	{
-	  if (where)
-	    gfc_error ("Actual argument to '%s' at %L must be a coarray",
-		       formal->name, &actual->where);
-	  return 0;
-	}
-
       /* F2008, 12.5.2.6.  */
       if (formal->attr.allocatable &&
 	  ((last && last->u.c.component->as->corank != formal->as->corank)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1fef22b..01999e5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4157,6 +4157,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
   switch (ar->dimen_type[i])
     {
     case DIMEN_VECTOR:
+    case DIMEN_THIS_IMAGE:
       break;
 
     case DIMEN_STAR:
@@ -4324,7 +4325,8 @@ compare_spec_to_ref (gfc_array_ref *ar)
   if (ar->codimen != 0)
     for (i = as->rank; i < as->rank + as->corank; i++)
       {
-	if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+	if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
+	    && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
 	  {
 	    gfc_error ("Coindex of codimension %d must be a scalar at %L",
 		       i + 1 - as->rank, &ar->where);
@@ -4334,6 +4336,14 @@ compare_spec_to_ref (gfc_array_ref *ar)
 	  return FAILURE;
       }
 
+  if (as->corank && ar->codimen == 0)
+    {
+      int n;
+      ar->codimen = as->corank;
+      for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
+	ar->dimen_type[n] = DIMEN_THIS_IMAGE;
+    }
+
   return SUCCESS;
 }
 
@@ -6848,12 +6858,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
   ar = &ref2->u.ar;
 
-  if (codimension && ar->codimen == 0)
-    {
-      gfc_error ("Coarray specification required in ALLOCATE statement "
-		 "at %L", &e->where);
-      goto failure;
-    }
+  if (codimension)
+    for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
+      if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
+	{
+	  gfc_error ("Coarray specification required in ALLOCATE statement "
+		     "at %L", &e->where);
+	  goto failure;
+	}
 
   for (i = 0; i < ar->dimen; i++)
     {
@@ -6876,6 +6888,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 	case DIMEN_UNKNOWN:
 	case DIMEN_VECTOR:
 	case DIMEN_STAR:
+	case DIMEN_THIS_IMAGE:
 	  gfc_error ("Bad array specification in ALLOCATE statement at %L",
 		     &e->where);
 	  goto failure;
@@ -12501,18 +12514,18 @@ check_data_variable (gfc_data_variable *var, locus *where)
 
   has_pointer = sym->attr.pointer;
 
+  if (gfc_is_coindexed (e))
+    {
+      gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
+		 where);
+      return FAILURE;
+    }
+
   for (ref = e->ref; ref; ref = ref->next)
     {
       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
 	has_pointer = 1;
 
-      if (ref->type == REF_ARRAY && ref->u.ar.codimen)
-	{
-	  gfc_error ("DATA element '%s' at %L cannot have a coindex",
-		     sym->name, where);
-	  return FAILURE;
-	}
-
       if (has_pointer
 	    && ref->type == REF_ARRAY
 	    && ref->u.ar.type != AR_FULL)
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 69edad8..2a99445 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3632,16 +3632,7 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_expr *
 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  gfc_expr *e;
-  /* return simplify_cobound (array, dim, kind, 0);*/
-
-  e = simplify_cobound (array, dim, kind, 0);
-  if (e != NULL)
-    return e;
-
-  gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
-	     "cobounds at %L", &array->where);
-  return &gfc_bad_expr;
+  return simplify_cobound (array, dim, kind, 0);
 }
 
 gfc_expr *
@@ -6338,7 +6329,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
       as = ref->u.ar.as;
 
   if (as->type == AS_DEFERRED)
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   if (dim == NULL)
     {
@@ -6357,8 +6348,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
 
 	      for (j = 0; j < d; j++)
 		gfc_free_expr (bounds[j]);
-	      if (bounds[d] == NULL)
-		goto not_implemented;
+
 	      return bounds[d];
 	    }
 	}
@@ -6383,10 +6373,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
     }
   else
     {
-      gfc_expr *e;
       /* A DIM argument is specified.  */
       if (dim->expr_type != EXPR_CONSTANT)
-	goto not_implemented; /*return NULL;*/
+	return NULL;
 
       d = mpz_get_si (dim->value.integer);
 
@@ -6396,18 +6385,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
 	  return &gfc_bad_expr;
 	}
 
-      /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
-      e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
-      if (e != NULL)
-	return e;
-      else
-	goto not_implemented;
+      return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
+				 true);
    }
-
-not_implemented:
-  gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
-	     "cobounds at %L", &coarray->where);
-  return &gfc_bad_expr;
 }
 
 
@@ -6420,16 +6400,7 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_expr *
 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  gfc_expr *e;
-  /* return simplify_cobound (array, dim, kind, 1);*/
-
-  e = simplify_cobound (array, dim, kind, 1);
-  if (e != NULL)
-    return e;
-
-  gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
-	     "cobounds at %L", &array->where);
-  return &gfc_bad_expr;
+  return simplify_cobound (array, dim, kind, 1);
 }
 
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ac08c42..0046d0ac 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -562,7 +562,7 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
   tree tmp;
 
   if (as && as->type == AS_EXPLICIT)
-    for (n = 0; n < se->loop->dimen; n++)
+    for (n = 0; n < se->loop->dimen + se->loop->codimen; n++)
       {
 	dim = se->ss->data.info.dim[n];
 	gcc_assert (dim < as->rank);
@@ -576,18 +576,22 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
 	    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);
-	    se->loop->to[n] = tmp;
+	    if (se->loop->codimen == 0
+		|| n < se->loop->dimen + se->loop->codimen - 1)
+	      {
+		/* ...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);
+		se->loop->to[n] = tmp;
+	      }
 	  }
       }
 }
@@ -885,6 +889,13 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 			      size, tmp);
       size = gfc_evaluate_now (size, pre);
     }
+  for (n = info->dimen; n < info->dimen + info->codimen; n++)
+    {
+      gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
+                                      gfc_index_zero_node);
+      if (n < info->dimen + info->codimen - 1)
+	gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
+    }
 
   /* Get the size of the array.  */
 
@@ -1777,7 +1788,7 @@ gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
   info->data = gfc_build_addr_expr (NULL_TREE, tmp);
   info->offset = gfc_index_zero_node;
 
-  for (i = 0; i < info->dimen; i++)
+  for (i = 0; i < info->dimen + info->codimen; i++)
     {
       info->delta[i] = gfc_index_zero_node;
       info->start[i] = gfc_index_zero_node;
@@ -2018,7 +2029,7 @@ gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
   int n;
   int dim;
 
-  for (n = 0; n < loop->dimen; n++)
+  for (n = 0; n < loop->dimen + loop->codimen; n++)
     {
       dim = info->dim[n];
       if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
@@ -2452,6 +2463,9 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
       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]
@@ -2813,7 +2827,7 @@ gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
 
   gcc_assert (!loop->array_parameter);
 
-  for (dim = loop->dimen - 1; dim >= 0; dim--)
+  for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
     {
       n = loop->order[dim];
 
@@ -2967,7 +2981,7 @@ gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
 
   pblock = body;
   /* Generate the loops.  */
-  for (dim = 0; dim < loop->dimen; dim++)
+  for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
     {
       n = loop->order[dim];
       gfc_trans_scalarized_loop_end (loop, n, pblock);
@@ -3043,11 +3057,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
 /* Calculate the lower bound of an array section.  */
 
 static void
-gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
+gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
+			      bool coarray, bool coarray_last)
 {
   gfc_expr *start;
   gfc_expr *end;
-  gfc_expr *stride;
+  gfc_expr *stride = NULL;
   tree desc;
   gfc_se se;
   gfc_ss_info *info;
@@ -3060,8 +3075,9 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
     {
       /* We use a zero-based index to access the vector.  */
       info->start[dim] = gfc_index_zero_node;
-      info->stride[dim] = gfc_index_one_node;
       info->end[dim] = NULL;
+      if (!coarray)
+	info->stride[dim] = gfc_index_one_node;
       return;
     }
 
@@ -3069,7 +3085,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
   desc = info->descriptor;
   start = info->ref->u.ar.start[dim];
   end = info->ref->u.ar.end[dim];
-  stride = info->ref->u.ar.stride[dim];
+  if (!coarray)
+    stride = info->ref->u.ar.stride[dim];
 
   /* Calculate the start of the range.  For vector subscripts this will
      be the range of the vector.  */
@@ -3091,25 +3108,28 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
   /* 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.  */
-  if (end)
+  if (!coarray_last)
     {
-      /* Specified section start.  */
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_type (&se, end, gfc_array_index_type);
-      gfc_add_block_to_block (&loop->pre, &se.pre);
-      info->end[dim] = se.expr;
-    }
-  else
-    {
-      /* No upper bound specified so use the bound of the array.  */
-      info->end[dim] = gfc_conv_array_ubound (desc, dim);
+      if (end)
+	{
+	  /* Specified section start.  */
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, end, gfc_array_index_type);
+	  gfc_add_block_to_block (&loop->pre, &se.pre);
+	  info->end[dim] = se.expr;
+	}
+      else
+	{
+	  /* No upper bound specified so use the bound of the array.  */
+	  info->end[dim] = gfc_conv_array_ubound (desc, dim);
+	}
+      info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
     }
-  info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
 
   /* Calculate the stride.  */
-  if (stride == NULL)
+  if (!coarray && stride == NULL)
     info->stride[dim] = gfc_index_one_node;
-  else
+  else if (!coarray)
     {
       gfc_init_se (&se, NULL);
       gfc_conv_expr_type (&se, stride, gfc_array_index_type);
@@ -3143,6 +3163,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	case GFC_SS_FUNCTION:
 	case GFC_SS_COMPONENT:
 	  loop->dimen = ss->data.info.dimen;
+	  loop->codimen = ss->data.info.codimen;
 	  break;
 
 	/* As usual, lbound and ubound are exceptions!.  */
@@ -3152,6 +3173,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	    case GFC_ISYM_LBOUND:
 	    case GFC_ISYM_UBOUND:
 	      loop->dimen = ss->data.info.dimen;
+	      loop->codimen = 0;
+	      break;
+
+	    case GFC_ISYM_LCOBOUND:
+	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_THIS_IMAGE:
+	      loop->dimen = ss->data.info.dimen;
+	      loop->codimen = ss->data.info.codimen;
+	      break;
 
 	    default:
 	      break;
@@ -3164,7 +3194,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 
   /* We should have determined the rank of the expression by now.  If
      not, that's bad news.  */
-  gcc_assert (loop->dimen != 0);
+  gcc_assert (loop->dimen + loop->codimen != 0);
 
   /* Loop over all the SS in the chain.  */
   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
@@ -3179,7 +3209,14 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	  gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
 
 	  for (n = 0; n < ss->data.info.dimen; n++)
-	    gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
+	    gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
+					  false, false);
+	  for (n = ss->data.info.dimen;
+	       n < ss->data.info.dimen + ss->data.info.codimen; n++)
+	    gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
+					  n == ss->data.info.dimen
+					       + ss->data.info.codimen -1);
+
 	  break;
 
 	case GFC_SS_INTRINSIC:
@@ -3188,7 +3225,11 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	    /* Fall through to supply start and stride.  */
 	    case GFC_ISYM_LBOUND:
 	    case GFC_ISYM_UBOUND:
+	    case GFC_ISYM_LCOBOUND:
+	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_THIS_IMAGE:
 	      break;
+
 	    default:
 	      continue;
 	    }
@@ -3697,6 +3738,7 @@ temporary:
       loop->temp_ss->data.temp.type = base_type;
       loop->temp_ss->string_length = dest->string_length;
       loop->temp_ss->data.temp.dimen = loop->dimen;
+      loop->temp_ss->data.temp.codimen = loop->codimen;
       loop->temp_ss->next = gfc_ss_terminator;
       gfc_add_ss_to_loop (loop, loop->temp_ss);
     }
@@ -3725,7 +3767,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
   mpz_t i;
 
   mpz_init (i);
-  for (n = 0; n < loop->dimen; n++)
+  for (n = 0; n < loop->dimen + loop->codimen; n++)
     {
       loopspec[n] = NULL;
       dynamic[n] = false;
@@ -3807,7 +3849,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
 	     known lower bound
 	     known upper bound
 	   */
-	  else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+	  else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+		   || n >= loop->dimen)
 	    loopspec[n] = ss;
 	  else if (integer_onep (info->stride[dim])
 		   && !integer_onep (specinfo->stride[spec_dim]))
@@ -3833,7 +3876,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
 
       /* Set the extents of this range.  */
       cshape = loopspec[n]->shape;
-      if (cshape && INTEGER_CST_P (info->start[dim])
+      if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
 	  && INTEGER_CST_P (info->stride[dim]))
 	{
 	  loop->from[n] = info->start[dim];
@@ -3877,9 +3920,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
 	}
 
       /* Transform everything so we have a simple incrementing variable.  */
-      if (integer_onep (info->stride[dim]))
+      if (n < loop->dimen && integer_onep (info->stride[dim]))
 	info->delta[dim] = gfc_index_zero_node;
-      else
+      else if (n < loop->dimen)
 	{
 	  /* Set the delta for this section.  */
 	  info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
@@ -4663,7 +4706,26 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
 
       size = stride;
     }
-
+  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);
+        }
+    }
   gfc_trans_vla_type_sizes (sym, pblock);
 
   *poffset = offset;
@@ -5626,6 +5688,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 
       se->string_length = loop.temp_ss->string_length;
       loop.temp_ss->data.temp.dimen = loop.dimen;
+      loop.temp_ss->data.temp.codimen = loop.codimen;
       gfc_add_ss_to_loop (&loop, loop.temp_ss);
     }
 
@@ -5689,7 +5752,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	 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;
+      int dim, ndim, codim;
       tree parm;
       tree parmtype;
       tree stride;
@@ -5712,8 +5775,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	{
 	  /* Otherwise make a new one.  */
 	  parmtype = gfc_get_element_type (TREE_TYPE (desc));
-	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
-						loop.from, loop.to, 0,
+	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
+						loop.codimen, loop.from,
+						loop.to, 0,
 						GFC_ARRAY_UNKNOWN, false);
 	  parm = gfc_create_var (parmtype, "parm");
 	}
@@ -5744,6 +5808,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	base = NULL_TREE;
 
       ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
+      codim = info->codimen;
       for (n = 0; n < ndim; n++)
 	{
 	  stride = gfc_conv_array_stride (desc, n);
@@ -5845,6 +5910,26 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 					  gfc_rank_cst[dim], stride);
 	}
 
+      for (n = ndim; n < ndim + codim; n++)
+	{
+	  /* look for the corresponding scalarizer dimension: dim.  */
+	  for (dim = 0; dim < ndim + codim; dim++)
+	    if (info->dim[dim] == n)
+	      break;
+
+	  /* loop exited early: the DIM being looked for has been found.  */
+	  gcc_assert (dim < ndim + codim);
+
+	  from = loop.from[dim];
+	  to = loop.to[dim];
+	  gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], from);
+	  if (n < ndim + codim - 1)
+	    gfc_conv_descriptor_ubound_set (&loop.pre, parm,
+					    gfc_rank_cst[dim], to);
+	  dim++;
+	}
+
       if (se->data_not_needed)
 	gfc_conv_descriptor_data_set (&loop.pre, parm,
 				      gfc_index_zero_node);
@@ -7311,7 +7396,7 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
       switch (ar->type)
 	{
 	case AR_ELEMENT:
-	  for (n = 0; n < ar->dimen; n++)
+	  for (n = 0; n < ar->dimen + ar->codimen; n++)
 	    {
 	      newss = gfc_get_ss ();
 	      newss->type = GFC_SS_SCALAR;
@@ -7327,11 +7412,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
 	  newss->expr = expr;
 	  newss->next = ss;
 	  newss->data.info.dimen = ar->as->rank;
+	  newss->data.info.codimen = 0;
 	  newss->data.info.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;
+	  ar->codimen = 0;
 	  for (n = 0; n < ar->dimen; n++)
 	    {
 	      newss->data.info.dim[n] = n;
@@ -7341,6 +7428,14 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
 	      gcc_assert (ar->end[n] == NULL);
 	      gcc_assert (ar->stride[n] == NULL);
 	    }
+	  for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
+	    {
+	      newss->data.info.dim[n] = n;
+	      ar->dimen_type[n] = DIMEN_RANGE;
+
+	      gcc_assert (ar->start[n] == NULL);
+	      gcc_assert (ar->end[n] == NULL);
+	    }
 	  ss = newss;
 	  break;
 
@@ -7350,15 +7445,18 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
 	  newss->expr = expr;
 	  newss->next = ss;
 	  newss->data.info.dimen = 0;
+	  newss->data.info.codimen = 0;
 	  newss->data.info.ref = ref;
 
           /* We add SS chains for all the subscripts in the section.  */
-	  for (n = 0; n < ar->dimen; n++)
+	  for (n = 0; n < ar->dimen + ar->codimen; n++)
 	    {
 	      gfc_ss *indexss;
 
 	      switch (ar->dimen_type[n])
 		{
+	        case DIMEN_THIS_IMAGE:
+		  continue;
 		case DIMEN_ELEMENT:
 		  /* Add SS for elemental (scalar) subscripts.  */
 		  gcc_assert (ar->start[n]);
@@ -7373,8 +7471,10 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
 		case DIMEN_RANGE:
                   /* We don't add anything for sections, just remember this
                      dimension for later.  */
-		  newss->data.info.dim[newss->data.info.dimen] = n;
-		  newss->data.info.dimen++;
+		  newss->data.info.dim[newss->data.info.dimen
+				       + newss->data.info.codimen] = n;
+		  if (n < ar->dimen)
+		    newss->data.info.dimen++;
 		  break;
 
 		case DIMEN_VECTOR:
@@ -7386,8 +7486,10 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
 		  indexss->next = gfc_ss_terminator;
 		  indexss->loop_chain = gfc_ss_terminator;
 		  newss->data.info.subscript[n] = indexss;
-		  newss->data.info.dim[newss->data.info.dimen] = n;
-		  newss->data.info.dimen++;
+		  newss->data.info.dim[newss->data.info.dimen
+				       + newss->data.info.codimen] = n;
+		  if (n < ar->dimen)
+		    newss->data.info.dimen++;
 		  break;
 
 		default:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index a0bbe53..cc6fced 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -767,6 +767,22 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 	  TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
 	}
     }
+  for (dim = GFC_TYPE_ARRAY_RANK (type);
+       dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
+    {
+      if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
+	{
+	  GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+	  TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+	}
+      /* Don't try to use the unknown ubound for the last coarray dimension.  */
+      if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
+          && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
+	{
+	  GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+	  TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+	}
+    }
   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
     {
       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index fa3e4c2..a3c2ecd 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -932,6 +932,7 @@ trans_num_images (gfc_se * se)
   se->expr = gfort_gvar_caf_num_images;
 }
 
+
 /* Evaluate a single upper or lower bound.  */
 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 
@@ -969,9 +970,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   else
     {
       /* use the passed argument.  */
-      gcc_assert (arg->next->expr);
+      gcc_assert (arg2->expr);
       gfc_init_se (&argse, NULL);
-      gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
       gfc_add_block_to_block (&se->pre, &argse.pre);
       bound = argse.expr;
       /* Convert from one based to zero based.  */
@@ -1117,6 +1118,128 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
 
 static void
+conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_actual_arglist *arg2;
+  gfc_se argse;
+  gfc_ss *ss;
+  tree bound, resbound, resbound2, desc, cond, tmp;
+  tree type;
+  gfc_array_spec * as;
+  int corank;
+
+  gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
+	      || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+	      || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
+
+  arg = expr->value.function.actual;
+  arg2 = arg->next;
+
+  gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
+  corank = gfc_get_corank (arg->expr);
+
+  as = gfc_get_full_arrayspec_from_expr (arg->expr);
+  gcc_assert (as);
+
+  ss = gfc_walk_expr (arg->expr);
+  gcc_assert (ss != gfc_ss_terminator);
+  ss->data.info.codimen = corank;
+  gfc_init_se (&argse, NULL);
+
+  gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  if (se->ss)
+    {
+      mpz_t mpz_rank;
+      tree tree_rank;
+
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (!arg2->expr);
+      gcc_assert (corank > 0);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->expr == expr);
+
+      mpz_init_set_ui (mpz_rank, arg->expr->rank);
+      tree_rank = gfc_conv_mpz_to_tree (mpz_rank, gfc_index_integer_kind);
+
+      bound = se->loop->loopvar[0];
+      bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
+			   se->ss->data.info.delta[0]);
+      bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
+			   tree_rank);
+      gfc_advance_se_ss_chain (se);
+    }
+  else
+    {
+      /* use the passed argument.  */
+      gcc_assert (arg2->expr);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      bound = argse.expr;
+
+      if (INTEGER_CST_P (bound))
+	{
+	  int hi, low;
+
+	  hi = TREE_INT_CST_HIGH (bound);
+	  low = TREE_INT_CST_LOW (bound);
+	  if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+	    gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+		       "dimension index", expr->value.function.isym->name,
+		       &expr->where);
+	}
+      else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+        {
+	  bound = gfc_evaluate_now (bound, &se->pre);
+	  cond = fold_build2 (LT_EXPR, boolean_type_node,
+			      bound, build_int_cst (TREE_TYPE (bound), 1));
+	  tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+	  tmp = fold_build2 (GT_EXPR, boolean_type_node, bound, tmp);
+	  cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+				   gfc_msg_fault);
+	}
+
+
+      /* Substract 1 to get to zero based and add dimensions.  */
+      switch (arg->expr->rank)
+	{
+	case 0:
+	  bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
+			       gfc_index_one_node);
+	case 1:
+	  break;
+	default:
+	  bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
+			       gfc_rank_cst[arg->expr->rank - 1]);
+	}
+    }
+
+  resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+
+  if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
+    {
+      cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
+			  build_int_cst (TREE_TYPE (bound),
+			  arg->expr->rank + corank - 1));
+      resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
+      se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+			      resbound, resbound2);
+    }
+  else
+    se->expr = resbound;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = convert (type, se->expr);
+}
+
+
+static void
 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 {
   tree arg, cabs;
@@ -5960,6 +6083,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bound (se, expr, 0);
       break;
 
+    case GFC_ISYM_LCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
     case GFC_ISYM_TRANSPOSE:
       /* The scalarizer has already been set up for reversed dimension access
 	 order ; now we just get the argument value normally.  */
@@ -6117,6 +6244,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bound (se, expr, 1);
       break;
 
+    case GFC_ISYM_UCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
     case GFC_ISYM_XOR:
       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
       break;
@@ -6126,7 +6257,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_THIS_IMAGE:
-      trans_this_image (se, expr);
+      if (expr->value.function.actual)
+	conv_intrinsic_cobound (se, expr);
+      else
+	trans_this_image (se, expr);
       break;
 
     case GFC_ISYM_NUM_IMAGES:
@@ -6261,6 +6395,9 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
     {
     case GFC_ISYM_UBOUND:
     case GFC_ISYM_LBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_LCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
       break;
 
     default:
@@ -6269,8 +6406,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 }
 
 
-/* UBOUND and LBOUND intrinsics with one parameter are expanded into code
-   inside the scalarization loop.  */
+/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
+   are expanded into code inside the scalarization loop.  */
 
 static gfc_ss *
 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
@@ -6407,7 +6544,10 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
   switch (isym->id)
     {
     case GFC_ISYM_LBOUND:
+    case GFC_ISYM_LCOBOUND:
     case GFC_ISYM_UBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
       return gfc_walk_intrinsic_bound (ss, expr);
 
     case GFC_ISYM_TRANSFER:
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 8ecceea..7e12f08 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1249,6 +1249,17 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
       ubound[n] = gfc_conv_array_bound (as->upper[n]);
     }
 
+  for (n = as->rank; n < as->rank + as->corank; n++)
+    {
+      if (as->lower[n] == NULL)
+        lbound[n] = gfc_index_one_node;
+      else
+        lbound[n] = gfc_conv_array_bound (as->lower[n]);
+
+      if (n < as->rank + as->corank - 1)
+	ubound[n] = gfc_conv_array_bound (as->upper[n]);
+    }
+
   if (as->type == AS_ASSUMED_SHAPE)
     akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
 		       : GFC_ARRAY_ASSUMED_SHAPE;
@@ -1477,6 +1488,25 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
       if (packed == PACKED_NO || packed == PACKED_PARTIAL)
         known_stride = 0;
     }
+  for (n = as->rank; n < as->rank + as->corank; n++)
+    {
+      expr = as->lower[n];
+      if (expr->expr_type == EXPR_CONSTANT)
+	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+				    gfc_index_integer_kind);
+      else
+      	tmp = NULL_TREE;
+      GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
+
+      expr = as->upper[n];
+      if (expr && expr->expr_type == EXPR_CONSTANT)
+	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+				    gfc_index_integer_kind);
+      else
+ 	tmp = NULL_TREE;
+      if (n < as->rank + as->corank - 1)
+      GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+    }
 
   if (known_offset)
     {
@@ -1495,6 +1525,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
     GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
 
   GFC_TYPE_ARRAY_RANK (type) = as->rank;
+  GFC_TYPE_ARRAY_CORANK (type) = as->corank;
   GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
   range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 			    NULL_TREE);
@@ -1654,6 +1685,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
     = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
 
   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
+  GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
   GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 19e86bb..543ad52 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -104,7 +104,7 @@ gfc_se;
 
 typedef struct gfc_ss_info
 {
-  int dimen;
+  int dimen, codimen;
   /* The ref that holds information on this section.  */
   gfc_ref *ref;
   /* The descriptor of this array.  */
@@ -198,7 +198,7 @@ typedef struct gfc_ss
     {
       /* The rank of the temporary.  May be less than the rank of the
          assigned expression.  */
-      int dimen;
+      int dimen, codimen;
       tree type;
     }
     temp;
@@ -231,7 +231,7 @@ typedef struct gfc_loopinfo
   stmtblock_t pre;
   stmtblock_t post;
 
-  int dimen;
+  int dimen, codimen;
 
   /* All the SS involved with this loop.  */
   gfc_ss *ss;
@@ -713,7 +713,7 @@ enum gfc_array_kind
    variable-sized in some other frontends.  Due to gengtype deficiency the GTY
    options of such types have to agree across all frontends. */
 struct GTY((variable_size))	lang_type	 {
-  int rank;
+  int rank, corank;
   enum gfc_array_kind akind;
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
@@ -768,6 +768,7 @@ struct GTY((variable_size)) lang_decl {
 #define GFC_TYPE_ARRAY_STRIDE(node, dim) \
   (TYPE_LANG_SPECIFIC(node)->stride[dim])
 #define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
+#define GFC_TYPE_ARRAY_CORANK(node) (TYPE_LANG_SPECIFIC(node)->corank)
 #define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
 #define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
 #define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1fa2c64..3204df3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2011-04-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray_10.f90: Add coarray descriptor diagnostic check.
+	* gfortran.dg/coarray_13.f90: Add checks for run-time cobounds.
+	* gfortran.dg/coarray_15.f90: New.
+
 2011-04-04  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
 	* gfortran.dg/bessel_6.f90: Use dg-add-options ieee.
diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90
index 6ee425d..d32e254 100644
--- a/gcc/testsuite/gfortran.dg/coarray_10.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_10.f90
@@ -44,3 +44,9 @@ subroutine rank_mismatch()
   A(1)[1,1] = 1         ! { dg-error "Too few codimensions" }
   A(1)[1,1:1] = 1       ! { dg-error "Too few codimensions" }
 end subroutine rank_mismatch
+
+subroutine rank_mismatch2()
+  implicit none
+  integer, allocatable:: A(:)[:,:,:]
+  allocate(A(1)[7:8,4:*]) ! { dg-error "Unexpected .*. for codimension 2 of 3" }
+end subroutine rank_mismatch2
diff --git a/gcc/testsuite/gfortran.dg/coarray_13.f90 b/gcc/testsuite/gfortran.dg/coarray_13.f90
index bbd1ad4..1c79a07 100644
--- a/gcc/testsuite/gfortran.dg/coarray_13.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_13.f90
@@ -1,19 +1,149 @@
 ! { dg-do run }
-! { dg-options "-fcoarray=single" }
+! { dg-options "-fcoarray=single -fcheck=bounds" }
 !
 ! Coarray support -- allocatable array coarrays
+!                 -- intrinsic procedures
 ! PR fortran/18918
 ! PR fortran/43931
 !
 program test
   implicit none
+  integer,allocatable :: B(:)[:]
+
   call one()
+  call two()
+  allocate(B(3)[-4:*])
+  call three(3,B,1)
+  call three_a(3,B)
+  call three_b(3,B)
+  call four(B)
+  call five()
 contains
   subroutine one()
     integer, allocatable :: a(:)[:,:,:]
     allocate(a(1)[-4:9,8,4:*])
+ 
+    if (this_image(a,dim=1) /= -4_8) call abort()
+    if (lcobound  (a,dim=1) /= -4_8) call abort()
+    if (ucobound  (a,dim=1) /=  9_8) call abort()
+ 
+    if (this_image(a,dim=2) /=  1_8) call abort()
+    if (lcobound  (a,dim=2) /=  1_8) call abort()
+    if (ucobound  (a,dim=2) /=  8_8) call abort()
+ 
+    if (this_image(a,dim=3) /= 4_8) call abort()
+    if (lcobound  (a,dim=3) /= 4_8) call abort()
+    if (ucobound  (a,dim=3) /= 4_8) call abort()
+ 
+    if (any(this_image(a) /= [-4_8, 1_8, 4_8])) call abort()
+    if (any(lcobound  (a) /= [-4_8, 1_8, 4_8])) call abort()
+    if (any(ucobound  (a) /= [9_8, 8_8, 4_8])) call abort()
   end subroutine one
-  subroutine four(C)
-    integer, allocatable :: C(:)[:]
- end subroutine four
+
+  subroutine two()
+    integer, allocatable :: a(:)[:,:,:]
+    allocate(a(1)[-4:9,8,4:*])
+
+    if (this_image(a,dim=1) /= -4) call abort()
+    if (lcobound  (a,dim=1) /= -4) call abort()
+    if (ucobound  (a,dim=1) /=  9) call abort()
+
+    if (this_image(a,dim=2) /=  1) call abort()
+    if (lcobound  (a,dim=2) /=  1) call abort()
+    if (ucobound  (a,dim=2) /=  8) call abort()
+
+    if (this_image(a,dim=3) /= 4) call abort()
+    if (lcobound  (a,dim=3) /= 4) call abort()
+    if (ucobound  (a,dim=3) /= 4) call abort()
+
+    if (any(this_image(a) /= [-4, 1, 4])) call abort()
+    if (any(lcobound  (a) /= [-4, 1, 4])) call abort()
+    if (any(ucobound  (a) /= [9, 8, 4])) call abort()
+  end subroutine two
+
+  subroutine three(n,A, n2)
+    integer :: n, n2
+    integer :: A(3)[n:*]
+
+    A(1) = 42
+    if (A(1) /= 42) call abort()
+    A(1)[n2] = -42
+    if (A(1)[n2] /= -42) call abort()
+
+    if (this_image(A,dim=1) /= n) call abort()
+    if (lcobound  (A,dim=1) /= n) call abort()
+    if (ucobound  (A,dim=1) /= n) call abort()
+
+    if (any(this_image(A) /= n)) call abort()
+    if (any(lcobound  (A) /= n)) call abort()
+    if (any(ucobound  (A) /= n)) call abort()
+  end subroutine three
+
+  subroutine three_a(n,A)
+    integer :: n
+    integer :: A(3)[n+2:n+5,n-1:*]
+
+    A(1) = 42
+    if (A(1) /= 42) call abort()
+    A(1)[4,n] = -42
+    if (A(1)[4,n] /= -42) call abort()
+
+    if (this_image(A,dim=1) /= n+2) call abort()
+    if (lcobound  (A,dim=1) /= n+2) call abort()
+    if (ucobound  (A,dim=1) /= n+5) call abort()
+
+    if (this_image(A,dim=2) /= n-1) call abort()
+    if (lcobound  (A,dim=2) /= n-1) call abort()
+    if (ucobound  (A,dim=2) /= n-1) call abort()
+
+    if (any(this_image(A) /= [n+2,n-1])) call abort()
+    if (any(lcobound  (A) /= [n+2,n-1])) call abort()
+    if (any(ucobound  (A) /= [n+5,n-1])) call abort()
+  end subroutine three_a
+
+  subroutine three_b(n,A)
+    integer :: n
+    integer :: A(-1:3,0:4,-2:5,-4:7)[n+2:n+5,n-1:*]
+
+    A(1,1,1,1) = 42
+    if (A(1,1,1,1) /= 42) call abort()
+    A(1,1,1,1)[4,n] = -42
+    if (A(1,1,1,1)[4,n] /= -42) call abort()
+
+    if (this_image(A,dim=1) /= n+2) call abort()
+    if (lcobound  (A,dim=1) /= n+2) call abort()
+    if (ucobound  (A,dim=1) /= n+5) call abort()
+
+    if (this_image(A,dim=2) /= n-1) call abort()
+    if (lcobound  (A,dim=2) /= n-1) call abort()
+    if (ucobound  (A,dim=2) /= n-1) call abort()
+
+    if (any(this_image(A) /= [n+2,n-1])) call abort()
+    if (any(lcobound  (A) /= [n+2,n-1])) call abort()
+    if (any(ucobound  (A) /= [n+5,n-1])) call abort()
+  end subroutine three_b
+
+  subroutine four(A)
+    integer, allocatable :: A(:)[:]
+    if (this_image(A,dim=1) /= -4_8) call abort()
+    if (lcobound  (A,dim=1) /= -4_8) call abort()
+    if (ucobound  (A,dim=1) /= -4_8) call abort()
+  end subroutine four
+
+  subroutine five()
+    integer, save :: foo(2)[5:7,4:*]
+    integer :: i
+
+    i = 1
+    foo(1)[5,4] = 42
+    if (foo(1)[5,4] /= 42) call abort()
+    if (this_image(foo,dim=i) /= 5) call abort()
+    if (lcobound(foo,dim=i) /= 5) call abort()
+    if (ucobound(foo,dim=i) /= 7) call abort()
+
+    i = 2
+    if (this_image(foo,dim=i) /= 4) call abort()
+    if (lcobound(foo,dim=i) /= 4) call abort()
+    if (ucobound(foo,dim=i) /= 4) call abort()
+  end subroutine five
 end program test
diff --git a/gcc/testsuite/gfortran.dg/coarray_15.f90 b/gcc/testsuite/gfortran.dg/coarray_15.f90
new file mode 100644
index 0000000..91584e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_15.f90
@@ -0,0 +1,112 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Contributed by John Reid.
+!
+program ex2
+      implicit none
+      real, allocatable :: z(:)[:]
+      integer :: image
+      character(len=80) :: str
+
+      allocate(z(3)[*])
+      write(*,*) 'z allocated on image',this_image()
+      sync all
+      if (this_image()==1) then
+          z = 1.2
+          do image = 2, num_images() ! { dg-warning "will be executed zero times" }
+            write(*,*) 'Assigning z(:) on image',image
+            z(:)[image] = z
+         end do
+      end if
+      sync all
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z(:),' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z,' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z(1:3)[this_image()],' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      call ex2a()
+      call ex5()
+end
+
+subroutine ex2a()
+      implicit none
+      real, allocatable :: z(:,:)[:,:]
+      integer :: image
+      character(len=100) :: str
+
+      allocate(z(2,2)[1,*])
+      write(*,*) 'z allocated on image',this_image()
+      sync all
+      if (this_image()==1) then
+          z = 1.2
+          do image = 2, num_images() ! { dg-warning "will be executed zero times" }
+            write(*,*) 'Assigning z(:) on image',image
+            z(:,:)[1,image] = z
+         end do
+      end if
+      sync all
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z(:,:),' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z,' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+end subroutine ex2a
+
+subroutine ex5
+   implicit none
+   integer :: me
+   real, save :: w(4)[*]
+   character(len=100) :: str
+
+   me = this_image()
+   w = me
+
+   str = repeat('X', len(str))
+   write(str,*) 'In main on image',this_image(), 'w= ',w 
+   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
+     call abort ()
+
+   str = repeat('X', len(str))
+   write(str,*) 'In main on image',this_image(), 'w= ',w(1:4) 
+   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
+     call abort ()
+
+   str = repeat('X', len(str))
+   write(str,*) 'In main on image',this_image(), 'w= ',w(:)[1]
+   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
+     call abort ()
+
+   sync all
+   call ex5_sub(me,w)
+end subroutine ex5
+      
+subroutine ex5_sub(n,w)
+   implicit none
+   integer :: n
+   real :: w(n)
+   character(len=50) :: str
+
+   str = repeat('X', len(str))
+   write(str,*) 'In sub on image',this_image(), 'w= ',w 
+   if (str /= " In sub on image           1 w=    1.0000000") &
+     call abort ()
+end subroutine ex5_sub