Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 166976)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1837,1842 ****
--- 1837,1843 ----
    tree offsetvar;
    tree desc;
    tree type;
+   tree tmp;
    bool dynamic;
    bool old_first_len, old_typespec_chararray_ctor;
    tree old_first_len_val;
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1949,1954 ****
--- 1950,1958 ----
  	}
      }
  
+   if (TREE_CODE (loop->to[0]) == VAR_DECL)
+     dynamic = true;
+ 
    gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
  			       type, NULL_TREE, dynamic, true, false, where);
  
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1963,1974 ****
    /* If the array grows dynamically, the upper bound of the loop variable
       is determined by the array's final upper bound.  */
    if (dynamic)
!     loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
  
    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)
--- 1967,1989 ----
    /* 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, &loop->pre);
!       gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
!       if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
! 	gfc_add_modify (&loop->pre, loop->to[0], tmp);
!       else
! 	loop->to[0] = 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)
*************** gfc_conv_ss_descriptor (stmtblock_t * bl
*** 2181,2186 ****
--- 2196,2206 ----
  
        tmp = gfc_conv_array_offset (se.expr);
        ss->data.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.  */
+       ss->data.info.saved_offset = ss->data.info.offset;
      }
  }
  
*************** gfc_conv_ss_startstride (gfc_loopinfo * 
*** 3209,3214 ****
--- 3229,3238 ----
  	  if (ss->type != GFC_SS_SECTION)
  	    continue;
  
+ 	  /* Catch allocatable lhs in f2003.  */
+ 	  if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
+ 	    continue;
+ 
  	  gfc_start_block (&inner);
  
  	  /* TODO: range checking for mapped dimensions.  */
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 3676,3681 ****
--- 3700,3710 ----
  	      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 (ss->type != GFC_SS_SECTION)
  	    continue;
  
*************** gfc_copy_only_alloc_comp (gfc_symbol * d
*** 6457,6462 ****
--- 6486,6883 ----
  }
  
  
+ /* 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;
+   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);
+     }
+   else if (expr->expr_type == EXPR_VARIABLE)
+     {
+       tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+       return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
+     }
+   else if (expr->expr_type == EXPR_FUNCTION)
+     {
+       /* A conversion function, so use the argument.  */
+       expr = expr->value.function.actual->expr;
+       if (expr->expr_type != EXPR_VARIABLE)
+ 	return gfc_index_one_node;
+       desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+       return get_std_lbound (expr, desc, dim, assumed_size);
+     }
+ 
+   return gfc_index_one_node;
+ }
+ 
+ /* 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;
+   tree realloc_expr;
+   tree alloc_expr;
+   tree size1;
+   tree size2;
+   tree array1;
+   tree cond;
+   tree tmp;
+   tree tmp2;
+   tree lbound;
+   tree ubound;
+   tree desc;
+   tree desc2;
+   tree offset;
+   tree jump_label1;
+   tree jump_label2;
+   tree neq_size;
+   tree lbd;
+   int n;
+   int dim;
+   gfc_array_spec * as;
+ 
+   /* 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->expr && lss->expr->expr_type == EXPR_VARIABLE)
+ 	  break;
+       if (lss == gfc_ss_terminator)
+ 	return NULL_TREE;
+       expr1 = lss->expr;
+     }
+ 
+   /* Bail out if this is not a valid allocate on assignment.  */
+   if (!expr1->symtree->n.sym->attr.allocatable
+ 	|| (expr1->ref && expr1->ref->type == REF_ARRAY
+ 	      && expr1->ref->u.ar.type != AR_FULL)
+ 	|| (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->expr == expr1)
+       break;
+ 
+   if (lss == gfc_ss_terminator)
+     return NULL_TREE;
+ 
+   /* 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->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 = lss->data.info.descriptor;
+   gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+   array1 = gfc_conv_descriptor_data_get (desc);
+   size1 = gfc_conv_descriptor_size (desc, expr1->rank);
+ 
+   /* Get the rhs size.  Fix both sizes.  */
+   if (expr2)
+     desc2 = rss->data.info.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);
+     }
+   size1 = gfc_evaluate_now (size1, &fblock);
+   size2 = gfc_evaluate_now (size2, &fblock);
+   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ 			  size1, size2);
+   neq_size = gfc_evaluate_now (cond, &fblock);
+ 
+   /* If the lhs is allocated and the lhs and rhs are equal length, jump
+      past the realloc/malloc.  This allows F95 compliant expressions
+      to escape allocation on assignment.  */
+   jump_label1 = gfc_build_label_decl (NULL_TREE);
+   jump_label2 = gfc_build_label_decl (NULL_TREE);
+ 
+   /* Allocate if data is NULL.  */
+   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ 			 array1, build_int_cst (TREE_TYPE (array1), 0));
+   tmp = build3_v (COND_EXPR, cond,
+ 		  build1_v (GOTO_EXPR, jump_label1),
+ 		  build_empty_stmt (input_location));
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   /* Reallocate if sizes are different.  */
+   tmp = build3_v (COND_EXPR, neq_size,
+ 		  build1_v (GOTO_EXPR, jump_label1),
+ 		  build_empty_stmt (input_location));
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   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;
+ 
+   /* Reset the lhs bounds if any are different from the rhs.  */ 
+   if (as && expr2->expr_type == EXPR_VARIABLE)
+     {
+       for (n = 0; n < expr1->rank; n++)
+ 	{
+ 	  /* First check the lbounds.  */
+ 	  dim = rss->data.info.dim[n];
+ 	  lbd = get_std_lbound (expr2, desc2, dim,
+ 				as->type == AS_ASSUMED_SIZE);
+ 	  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+ 	  cond = fold_build2_loc (input_location, NE_EXPR,
+ 				  boolean_type_node, lbd, lbound);
+ 	  tmp = build3_v (COND_EXPR, cond,
+ 			  build1_v (GOTO_EXPR, jump_label1),
+ 			  build_empty_stmt (input_location));
+ 	  gfc_add_expr_to_block (&fblock, tmp);
+ 
+ 	  /* Now check the shape.  */
+ 	  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);
+ 	  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ 	  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);	  
+ 	}
+     }
+ 
+     /* Otherwise 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);
+ 
+   /* Now modify the lhs descriptor and the associated scalarizer
+      variables.
+      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).  */
+   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 (lss->data.info.saved_offset
+ 	&& TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
+       gfc_add_modify (&fblock, lss->data.info.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->data.info.dim[n];
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type, tmp,
+ 			     loop->from[dim]);
+       if (lss->data.info.delta[dim]
+ 	    && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
+ 	gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
+     }
+ 
+   /* Get the new lhs size in bytes.  */
+   if (expr2->ts.type == BT_CHARACTER && expr2->ts.u.cl->backend_decl)
+     tmp = expr2->ts.u.cl->backend_decl;
+   else
+     tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->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 = gfc_evaluate_now (size2, &fblock);
+ 
+   /* Realloc expression.  Note that the scalarizer uses desc.data
+      in the array reference - (*desc.data)[<element>]. */
+   gfc_init_block (&realloc_block);
+   tmp = build_call_expr_loc (input_location,
+ 			     built_in_decls[BUILT_IN_REALLOC], 2,
+ 			     fold_convert (pvoid_type_node, array1),
+ 			     size2);
+   gfc_conv_descriptor_data_set (&realloc_block,
+ 				desc, tmp);
+   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);
+   tmp = build_call_expr_loc (input_location,
+ 			     built_in_decls[BUILT_IN_MALLOC], 1,
+ 			     size2);
+   gfc_conv_descriptor_data_set (&alloc_block,
+ 				desc, tmp);
+   tmp = gfc_conv_descriptor_dtype (desc);
+   gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+   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 (lss->data.info.data
+ 	&& TREE_CODE (lss->data.info.data) == VAR_DECL)
+     {
+       tmp = gfc_conv_descriptor_data_get (desc);
+       gfc_add_modify (&fblock, lss->data.info.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.  */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 166976)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3355,3362 ****
  	    se->expr = build_fold_indirect_ref_loc (input_location,
  						se->expr);
  
! 	  result = build_fold_indirect_ref_loc (input_location,
! 						se->expr);
  	  VEC_safe_push (tree, gc, retargs, se->expr);
  	}
        else if (comp && comp->attr.dimension)
--- 3355,3384 ----
  	    se->expr = build_fold_indirect_ref_loc (input_location,
  						se->expr);
  
! 	  /* If the lhs of an assignment x = f(..) is allocatable and
! 	     f2003 is allowed, we must do the automatic reallocation.
! 	     TODO - deal with instrinsics, without using a temporary.  */
! 	  if (gfc_option.flag_realloc_lhs
! 		&& se->ss && se->ss->loop_chain
! 		&& se->ss->loop_chain->is_alloc_lhs
! 		&& !expr->value.function.isym
! 		&& sym->result->as != NULL)
! 	    {
! 	      /* Evaluate the bounds of the result, if known.  */
! 	      gfc_set_loop_bounds_from_array_spec (&mapping, se,
! 						   sym->result->as);
! 
! 	      /* Perform the automatic reallocation.  */
! 	      tmp = gfc_alloc_allocatable_for_assignment (se->loop,
! 							  expr, NULL);
! 	      gfc_add_expr_to_block (&se->pre, tmp);
! 
! 	      /* Pass the temporary as the first argument.  */
! 	      result = info->descriptor;
! 	    }
! 	  else
! 	    result = build_fold_indirect_ref_loc (input_location,
! 						  se->expr);
  	  VEC_safe_push (tree, gc, retargs, se->expr);
  	}
        else if (comp && comp->attr.dimension)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3370,3375 ****
--- 3392,3408 ----
  	  /* Evaluate the bounds of the result, if known.  */
  	  gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
  
+ 	  /* If the lhs of an assignment x = f(..) is allocatable and
+ 	     f2003 is allowed, we must not generate the function call
+ 	     here but should just send back the results of the mapping.
+ 	     This is signalled by the function ss being flagged.  */
+ 	  if (gfc_option.flag_realloc_lhs
+ 		&& se->ss && se->ss->is_alloc_lhs)
+ 	    {
+ 	      gfc_free_interface_mapping (&mapping);
+ 	      return has_alternate_specifier;
+ 	    }
+ 
  	  /* Create a temporary to store the result.  In case the function
  	     returns a pointer, the temporary will be a shallow copy and
  	     mustn't be deallocated.  */
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3394,3399 ****
--- 3427,3443 ----
  	  /* Evaluate the bounds of the result, if known.  */
  	  gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
  
+ 	  /* If the lhs of an assignment x = f(..) is allocatable and
+ 	     f2003 is allowed, we must not generate the function call
+ 	     here but should just send back the results of the mapping.
+ 	     This is signalled by the function ss being flagged.  */
+ 	  if (gfc_option.flag_realloc_lhs
+ 		&& se->ss && se->ss->is_alloc_lhs)
+ 	    {
+ 	      gfc_free_interface_mapping (&mapping);
+ 	      return has_alternate_specifier;
+ 	    }
+ 
  	  /* Create a temporary to store the result.  In case the function
  	     returns a pointer, the temporary will be a shallow copy and
  	     mustn't be deallocated.  */
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 4899,4905 ****
  	  /* Assign to a temporary descriptor and then copy that
  	     temporary to the pointer.  */
  	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
- 
  	  lse.expr = tmp;
  	  lse.direct_byref = 1;
  	  gfc_conv_expr_descriptor (&lse, expr2, rss);
--- 4943,4948 ----
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 5331,5336 ****
--- 5374,5454 ----
  }
  
  
+ /* Provide the loop info so that the lhs descriptor can be built for
+    reallocatable assignments from extrinsic function calls.  */
+ 
+ static void
+ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
+ {
+   gfc_loopinfo loop;
+   /* Signal that the function call should not be made by
+      gfc_conv_loop_setup. */
+   se->ss->is_alloc_lhs = 1;
+   gfc_init_loopinfo (&loop);
+   gfc_add_ss_to_loop (&loop, *ss);
+   gfc_add_ss_to_loop (&loop, se->ss);
+   gfc_conv_ss_startstride (&loop);
+   gfc_conv_loop_setup (&loop, where);
+   gfc_copy_loopinfo_to_se (se, &loop);
+   gfc_add_block_to_block (&se->pre, &loop.pre);
+   gfc_add_block_to_block (&se->pre, &loop.post);
+   se->ss->is_alloc_lhs = 0;
+ }
+ 
+ 
+ static void
+ realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+ {
+   tree desc;
+   tree tmp;
+   tree offset;
+   int n;
+ 
+   /* Use the allocation done by the library.  */
+   desc = build_fold_indirect_ref_loc (input_location, se->expr);
+   tmp = gfc_conv_descriptor_data_get (desc);
+   tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+   gfc_add_expr_to_block (&se->pre, tmp);
+   gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
+   /* Unallocated, the descriptor does not have a dtype.  */
+   tmp = gfc_conv_descriptor_dtype (desc);
+   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ 
+   offset = gfc_index_zero_node;
+   tmp = gfc_index_one_node;
+   /* Now reset the bounds from zero based to unity based.  */
+   for (n = 0 ; n < rank; n++)
+     {
+       /* Accumulate the offset.  */
+       offset = fold_build2_loc (input_location, MINUS_EXPR,
+ 				gfc_array_index_type,
+ 				offset, tmp);
+       /* Now do the bounds.  */
+       gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
+       tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+       tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+       gfc_conv_descriptor_lbound_set (&se->post, desc,
+ 				      gfc_rank_cst[n],
+ 				      gfc_index_one_node);
+       gfc_conv_descriptor_ubound_set (&se->post, desc,
+ 				      gfc_rank_cst[n], tmp);
+ 
+       /* The extent for the next contribution to offset.  */
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
+ 			     gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+       tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+     }
+   gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+ }
+ 
+ 
+ 
  /* Try to translate array(:) = func (...), where func is a transformational
     array function, without using a temporary.  Returns NULL if this isn't the
     case.  */
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 5373,5378 ****
--- 5491,5516 ----
    se.direct_byref = 1;
    se.ss = gfc_walk_expr (expr2);
    gcc_assert (se.ss != gfc_ss_terminator);
+ 
+   /* Reallocate on assignment needs the loopinfo for extrinsic functions.
+      This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
+      For intrinsic calls, the array data is freed and the library takes care
+      of allocation.  TODO: Add the logic of trans-array.c: 
+      gfc_alloc_allocatable_for_assignment to the library.  */    
+   if (gfc_option.flag_realloc_lhs
+ 	&& expr1->symtree->n.sym->attr.allocatable
+ 	&& !expr1->symtree->n.sym->attr.codimension
+ 	&& !gfc_is_coindexed (expr1))
+     {
+       if (!expr2->value.function.isym)
+ 	{
+ 	  realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
+ 	  ss->is_alloc_lhs = 1;
+ 	}
+       else
+ 	realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+     }
+ 
    gfc_conv_function_expr (&se, expr2);
    gfc_add_block_to_block (&se.pre, &se.post);
  
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5603,5608 ****
--- 5741,5750 ----
  
    /* Walk the lhs.  */
    lss = gfc_walk_expr (expr1);
+   if (expr1->symtree->n.sym->attr.allocatable
+ 	&& !(expr2->expr_type == EXPR_FUNCTION
+ 	     && expr2->value.function.isym != NULL))
+     lss->is_alloc_lhs = 1;
    rss = NULL;
    if (lss != gfc_ss_terminator)
      {
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5748,5753 ****
--- 5890,5906 ----
  	  gfc_add_expr_to_block (&body, tmp);
  	}
  
+       /* Allocate or reallocate lhs of allocatable array.  */
+       if (gfc_option.flag_realloc_lhs
+ 	    && expr1->symtree->n.sym->attr.allocatable
+ 	    && !expr1->symtree->n.sym->attr.codimension
+ 	    && !gfc_is_coindexed (expr1))
+ 	{
+ 	  tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ 	  if (tmp != NULL_TREE)
+ 	    gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
+ 	}
+ 
        /* Generate the copying loops.  */
        gfc_trans_scalarizing_loops (&loop, &body);
  
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 166976)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_copy_alloc_comp (gfc_symbol *, 
*** 57,62 ****
--- 57,64 ----
  
  tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
  
+ tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
+ 
  /* Add initialization for deferred arrays.  */
  void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
  /* Generate an initializer for a static pointer or allocatable array.  */
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 166976)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 2238,2243 ****
--- 2238,2244 ----
    int flag_align_commons;
    int flag_whole_file;
    int flag_protect_parens;
+   int flag_realloc_lhs;
  
    int fpe;
    int rtcheck;
Index: gcc/fortran/lang.opt
===================================================================
*** gcc/fortran/lang.opt	(revision 166976)
--- gcc/fortran/lang.opt	(working copy)
*************** frange-check
*** 474,479 ****
--- 474,483 ----
  Fortran
  Enable range checking during compilation
  
+ frealloc-lhs
+ Fortran
+ Reallocate the LHS in assignments
+ 
  frecord-marker=4
  Fortran RejectNegative
  Use a 4-byte record marker for unformatted files
Index: gcc/fortran/invoke.texi
===================================================================
*** gcc/fortran/invoke.texi	(revision 166976)
--- gcc/fortran/invoke.texi	(working copy)
*************** and warnings}.
*** 171,177 ****
  -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
  -finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
  -finit-logical=@var{<true|false>} -finit-character=@var{n} @gol
! -fno-align-commons -fno-protect-parens}
  @end table
  
  @menu
--- 171,177 ----
  -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
  -finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
  -finit-logical=@var{<true|false>} -finit-character=@var{n} @gol
! -fno-align-commons -fno-protect-parens -frealloc-lhs}
  @end table
  
  @menu
*************** levels such that the compiler does not d
*** 1458,1463 ****
--- 1458,1470 ----
  @code{COMPLEX} expressions to produce faster code. Note that for the re-association
  optimization @option{-fno-signed-zeros} and @option{-fno-trapping-math}
  need to be in effect.
+ 
+ @item -frealloc-lhs
+ @opindex @code{frealloc-lhs}
+ @cindex Reallocate the LHS in assignments
+ An allocatable left-hand side of an intrinsic assignment is automatically
+ (re)allocated if it is either unallocated or has a different shape. The
+ option is enabled by default except when @option{-std=f95} is given.
  @end table
  
  @xref{Code Gen Options,,Options for Code Generation Conventions,
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 166976)
--- gcc/fortran/trans.h	(working copy)
*************** typedef struct gfc_ss
*** 216,222 ****
       loops the terms appear in.  This will be 1 for the RHS expressions,
       2 for the LHS expressions, and 3(=1|2) for the temporary.  The bit
       'where' suppresses precalculation of scalars in WHERE assignments.  */
!   unsigned useflags:2, where:1;
  }
  gfc_ss;
  #define gfc_get_ss() XCNEW (gfc_ss)
--- 216,222 ----
       loops the terms appear in.  This will be 1 for the RHS expressions,
       2 for the LHS expressions, and 3(=1|2) for the temporary.  The bit
       'where' suppresses precalculation of scalars in WHERE assignments.  */
!   unsigned useflags:2, where:1, is_alloc_lhs:1;
  }
  gfc_ss;
  #define gfc_get_ss() XCNEW (gfc_ss)
Index: gcc/fortran/options.c
===================================================================
*** gcc/fortran/options.c	(revision 166976)
--- gcc/fortran/options.c	(working copy)
*************** gfc_init_options (unsigned int decoded_o
*** 149,154 ****
--- 149,155 ----
    gfc_option.flag_init_character_value = (char)0;
    gfc_option.flag_align_commons = 1;
    gfc_option.flag_protect_parens = 1;
+   gfc_option.flag_realloc_lhs = -1;
    
    gfc_option.fpe = 0;
    gfc_option.rtcheck = 0;
*************** gfc_post_options (const char **pfilename
*** 266,271 ****
--- 267,282 ----
    if (flag_associative_math == -1)
      flag_associative_math = (!flag_trapping_math && !flag_signed_zeros);
  
+   /* By default, disable (re)allocation during assignment for -std=f95,
+      and enable it for F2003/F2008/GNU/Legacy. */
+   if (gfc_option.flag_realloc_lhs == -1)
+     {
+       if (gfc_option.allow_std & GFC_STD_F2003)
+ 	gfc_option.flag_realloc_lhs = 1;
+       else
+ 	gfc_option.flag_realloc_lhs = 0;
+     }
+ 
    /* -fbounds-check is equivalent to -fcheck=bounds */
    if (flag_bounds_check)
      gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS;
*************** gfc_handle_option (size_t scode, const c
*** 964,969 ****
--- 975,984 ----
        gfc_option.flag_protect_parens = value;
        break;
  
+     case OPT_frealloc_lhs:
+       gfc_option.flag_realloc_lhs = value;
+       break;
+ 
      case OPT_fcheck_:
        gfc_handle_runtime_check_option (arg);
        break;
Index: gcc/testsuite/gfortran.dg/transpose_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transpose_2.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/transpose_2.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" }
  program main
    implicit none
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" }
  program main
    implicit none
Index: gcc/testsuite/gfortran.dg/unpack_bounds_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unpack_bounds_1.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/unpack_bounds_1.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
  program main
    integer, allocatable, dimension(:) :: vector
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
  program main
    integer, allocatable, dimension(:) :: vector
Index: gcc/testsuite/gfortran.dg/cshift_bounds_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/cshift_bounds_2.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/cshift_bounds_2.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" }
  program main
    integer, dimension(:,:), allocatable :: a, b
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" }
  program main
    integer, dimension(:,:), allocatable :: a, b
Index: gcc/testsuite/gfortran.dg/matmul_bounds_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_3.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_3.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03	(revision 0)
***************
*** 0 ****
--- 1,80 ----
+ ! { dg-do run }
+ ! Tests the patch that implements F2003 automatic allocation and
+ ! reallocation of allocatable arrays on assignment.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+   integer(4), allocatable :: a(:), b(:), c(:,:)
+   integer(4) :: j
+   integer(4) :: src(2:5) = [11,12,13,14]
+   integer(4) :: mat(2:3,5:6)
+   character(4), allocatable :: chr1(:)
+   character(4) :: chr2(2) = ["abcd", "wxyz"]
+ 
+   allocate(a(1))
+   mat = reshape (src, [2,2])
+ 
+   a = [4,3,2,1]
+   if (size(a, 1) .ne. 4) call abort
+   if (any (a .ne. [4,3,2,1])) call abort
+ 
+   a = [((42 - i), i = 1, 10)]
+   if (size(a, 1) .ne. 10) call abort
+   if (any (a .ne. [((42 - i), i = 1, 10)])) call abort
+ 
+   b = a
+   if (size(b, 1) .ne. 10) call abort
+   if (any (b .ne. a)) call abort
+ 
+   a = [4,3,2,1]
+   if (size(a, 1) .ne. 4) call abort
+   if (any (a .ne. [4,3,2,1])) call abort
+ 
+   a = b
+   if (size(a, 1) .ne. 10) call abort
+   if (any (a .ne. [((42 - i), i = 1, 10)])) call abort
+ 
+   j = 20
+   a = [(i, i = 1, j)]
+   if (size(a, 1) .ne. j) call abort
+   if (any (a .ne. [(i, i = 1, j)])) call abort
+ 
+   a = foo (15)
+   if (size(a, 1) .ne. 15) call abort
+   if (any (a .ne. [((i + 15), i = 1, 15)])) call abort
+ 
+   a = src
+   if (lbound(a, 1) .ne. lbound(src, 1)) call abort
+   if (ubound(a, 1) .ne. ubound(src, 1)) call abort
+   if (any (a .ne. [11,12,13,14])) call abort
+ 
+   k = 7
+   a = b(k:8)
+   if (lbound(a, 1) .ne. lbound (b(k:8), 1)) call abort
+   if (ubound(a, 1) .ne. ubound (b(k:8), 1)) call abort
+   if (any (a .ne. [35,34])) call abort
+ 
+   c = mat
+   if (any (lbound (c) .ne. lbound (mat))) call abort
+   if (any (ubound (c) .ne. ubound (mat))) call abort
+   if (any (c .ne. mat)) call abort
+ 
+   deallocate (c)
+   c = mat(2:,:)
+   if (any (lbound (c) .ne. lbound (mat(2:,:)))) call abort
+ 
+   chr1 = chr2(2:1:-1)
+   if (lbound(chr1, 1) .ne. 1) call abort
+   if (any (chr1 .ne. chr2(2:1:-1))) call abort
+ 
+   b = c(1, :) + c(2, :)
+   if (lbound(b, 1) .ne. lbound (c(1, :) + c(2, :), 1)) call abort
+   if (any (b .ne. c(1, :) + c(2, :))) call abort
+ contains
+   function foo (n) result(res)
+     integer(4), allocatable, dimension(:) :: res
+     integer(4) :: n
+     allocate (res(n))
+     res = [((i + 15), i = 1, n)]
+   end function foo
+ end
Index: gcc/testsuite/gfortran.dg/matmul_bounds_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_5.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_5.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(2,3) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(2,3) :: a
Index: gcc/testsuite/gfortran.dg/matmul_bounds_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_2.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_2.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
Index: gcc/testsuite/gfortran.dg/matmul_bounds_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_4.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_4.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(3) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(3) :: a
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03	(revision 0)
***************
*** 0 ****
--- 1,118 ----
+ ! { dg-do run }
+ ! Tests the patch that implements F2003 automatic allocation and
+ ! reallocation of allocatable arrays on assignment.  The tests
+ ! below were generated in the final stages of the development of
+ ! this patch.
+ !
+ ! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
+ !            and Tobias Burnus <burnus@gcc.gnu.org>
+ !
+   integer :: nglobal
+   call test1
+   call test2
+   call test3
+   call test4
+   call test5
+ contains
+   subroutine test1
+ !
+ ! Check that the bounds are set correctly, when assigning
+ ! to an array that already has the correct shape.
+ !
+     real :: a(10) = 1, b(51:60) = 2
+     real, allocatable :: c(:), d(:)
+     c=a
+     if (lbound (c, 1) .ne. lbound(a, 1)) call abort
+     if (ubound (c, 1) .ne. ubound(a, 1)) call abort
+     c=b
+     if (lbound (c, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (c, 1) .ne. ubound(b, 1)) call abort
+     d=b
+     if (lbound (d, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (d, 1) .ne. ubound(b, 1)) call abort
+     d=a
+     if (lbound (d, 1) .ne. lbound(a, 1)) call abort
+     if (ubound (d, 1) .ne. ubound(a, 1)) call abort
+   end subroutine
+   subroutine test2
+ !
+ ! Check that the bounds are set correctly, when making an
+ ! assignment with an implicit conversion.  First with a
+ ! non-descriptor variable....
+ !
+     integer(4), allocatable :: a(:)
+     integer(8) :: b(5:6)
+     a = b
+     if (lbound (a, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (a, 1) .ne. ubound(b, 1)) call abort
+   end subroutine
+   subroutine test3
+ !
+ ! ...and now a descriptor variable.
+ !
+     integer(4), allocatable :: a(:)
+     integer(8), allocatable :: b(:)
+     allocate (b(7:11))
+     a = b
+     if (lbound (a, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (a, 1) .ne. ubound(b, 1)) call abort
+   end subroutine
+   subroutine test4
+ !
+ ! Check assignments of the kind a = f(...)
+ !
+     integer, allocatable :: a(:)
+     integer, allocatable :: c(:)
+     a = f()
+     if (any (a .ne. [1, 2, 3, 4])) call abort
+     c = a + 8
+     a = f (c)
+     if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort
+     deallocate (c)
+     a = f (c)
+     if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort
+   end subroutine
+   function f(b)
+     integer, allocatable, optional :: b(:)
+     integer :: f(4)
+     if (.not.present (b)) then
+       f = [1,2,3,4]
+     elseif (.not.allocated (b)) then
+       f = [5,6,7,8]
+     else
+       f = b
+     end if
+   end function f
+   
+   subroutine test5
+ !
+ ! Extracted from rnflow.f90, Polyhedron benchmark suite,
+ ! http://www.polyhedron.com
+ !
+     integer, parameter :: ncls = 233, ival = 16, ipic = 17
+     real, allocatable, dimension (:,:) :: utrsft
+     real, allocatable, dimension (:,:) :: dtrsft
+     real, allocatable, dimension (:,:) :: xwrkt
+     allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls))
+     nglobal = 0
+     xwrkt = trs2a2 (ival, ipic, ncls)
+     if (any (shape (xwrkt) .ne. [ncls, ncls])) call abort
+     xwrkt = invima (xwrkt, ival, ipic, ncls)
+     if (nglobal .ne. 1) call abort
+     if (sum(xwrkt) .ne. xwrkt(ival, ival)) call abort
+   end subroutine
+   function trs2a2 (j, k, m)
+     real, dimension (1:m,1:m) :: trs2a2
+     integer, intent (in)      :: j, k, m
+     nglobal = nglobal + 1
+     trs2a2 = 0.0
+   end function trs2a2
+   function invima (a, j, k, m)
+     real, dimension (1:m,1:m)              :: invima
+     real, dimension (1:m,1:m), intent (in) :: a
+     integer, intent (in)            :: j, k
+     invima (j, j) = 1.0 / (1.0 - a (j, j))
+   end function invima
+ 
+ end
+ 
