Merge from trunk revision 99b1021d21e5812ed01221d8fca8e8a32488a934.

32 files changed, 3304 insertions, 679 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b296797..6d0a022 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,279 @@
+2021-10-26  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/102956
+	* symbol.c (gfc_check_conflict): Add conflict check for PDT KIND
+	and LEN type parameters.
+
+2021-10-26  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/102917
+	* decl.c (match_attr_spec): Remove invalid integer kind checks on
+	KIND and LEN attributes of PDTs.
+
+2021-10-26  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/102816
+	* resolve.c (resolve_structure_cons): Reject invalid array spec of
+	a DT component referenced in a structure constructor.
+
+2021-10-26  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/102885
+	* trans-decl.c (gfc_conv_cfi_to_gfc): Properly handle nonconstant
+	character lenghts.
+
+2021-10-25  Andrew MacLeod  <amacleod@redhat.com>
+
+	* trans-decl.c (gfc_conv_cfi_to_gfc): Initialize rank to NULL_TREE.
+
+2021-10-22  Eric Gallager  <egallager@gcc.gnu.org>
+
+	PR other/102663
+	* Make-lang.in: Allow dvi-formatted documentation
+	to be installed.
+
+2021-10-22  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/92621
+	* trans-expr.c (gfc_trans_assignment_1): Add STRIP_NOPS.
+
+2021-10-21  Chung-Lin Tang  <cltang@codesourcery.com>
+
+	* decl.c (gfc_match_end): Add COMP_OMP_STRICTLY_STRUCTURED_BLOCK case
+	together with COMP_BLOCK.
+	* parse.c (parse_omp_structured_block): Change return type to
+	'gfc_statement', add handling for strictly-structured block case, adjust
+	recursive calls to parse_omp_structured_block.
+	(parse_executable): Adjust calls to parse_omp_structured_block.
+	* parse.h (enum gfc_compile_state): Add
+	COMP_OMP_STRICTLY_STRUCTURED_BLOCK.
+	* trans-openmp.c (gfc_trans_omp_workshare): Add EXEC_BLOCK case
+	handling.
+
+2021-10-21  Sandra Loosemore  <sandra@codesourcery.com>
+
+	PR fortran/94070
+	* expr.c (gfc_simplify_expr): Handle GFC_ISYM_SHAPE along with
+	GFC_ISYM_LBOUND and GFC_ISYM_UBOUND.
+	* trans-array.c (gfc_conv_ss_startstride): Likewise.
+	(set_loop_bounds): Likewise.
+	* trans-intrinsic.c (gfc_trans_intrinsic_bound): Extend to
+	handle SHAPE.  Correct logic for zero-size special cases and
+	detecting assumed-rank arrays associated with an assumed-size
+	argument.
+	(gfc_conv_intrinsic_shape): Deleted.
+	(gfc_conv_intrinsic_function): Handle GFC_ISYM_SHAPE like
+	GFC_ISYM_LBOUND and GFC_ISYM_UBOUND.
+	(gfc_add_intrinsic_ss_code): Likewise.
+	(gfc_walk_intrinsic_bound): Likewise.
+
+2021-10-20  Chung-Lin Tang  <cltang@codesourcery.com>
+
+	* openmp.c (gfc_match_omp_clause_reduction): Add 'openmp_target' default
+	false parameter. Add 'always,tofrom' map for OMP_LIST_IN_REDUCTION case.
+	(gfc_match_omp_clauses): Add 'openmp_target' default false parameter,
+	adjust call to gfc_match_omp_clause_reduction.
+	(match_omp): Adjust call to gfc_match_omp_clauses
+	* trans-openmp.c (gfc_trans_omp_taskgroup): Add call to
+	gfc_match_omp_clause, create and return block.
+
+2021-10-19  Tobias Burnus  <tobias@codesourcery.com>
+
+	* trans-types.c (create_fn_spec): For allocatable/pointer
+	character(len=:), use 'w' not 'R' as fn spec for the length dummy
+	argument.
+
+2021-10-19  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/92482
+	* trans-expr.c (gfc_conv_procedure_call): Use TREE_OPERAND not
+	build_fold_indirect_ref_loc to undo an ADDR_EXPR.
+
+2021-10-18  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/102086
+	PR fortran/92189
+	PR fortran/92621
+	PR fortran/101308
+	PR fortran/101309
+	PR fortran/101635
+	PR fortran/92482
+	* decl.c (gfc_verify_c_interop_param): Remove 'sorry' for
+	scalar allocatable/pointer and len=*.
+	* expr.c (is_CFI_desc): Return true for for those.
+	* gfortran.h (CFI_type_kind_shift, CFI_type_mask,
+	CFI_type_from_type_kind, CFI_VERSION, CFI_MAX_RANK,
+	CFI_attribute_pointer, CFI_attribute_allocatable,
+	CFI_attribute_other, CFI_type_Integer, CFI_type_Logical,
+	CFI_type_Real, CFI_type_Complex, CFI_type_Character,
+	CFI_type_ucs4_char, CFI_type_struct, CFI_type_cptr,
+	CFI_type_cfunptr, CFI_type_other): New #define.
+	* trans-array.c (CFI_FIELD_BASE_ADDR, CFI_FIELD_ELEM_LEN,
+	CFI_FIELD_VERSION, CFI_FIELD_RANK, CFI_FIELD_ATTRIBUTE,
+	CFI_FIELD_TYPE, CFI_FIELD_DIM, CFI_DIM_FIELD_LOWER_BOUND,
+	CFI_DIM_FIELD_EXTENT, CFI_DIM_FIELD_SM,
+	gfc_get_cfi_descriptor_field, gfc_get_cfi_desc_base_addr,
+	gfc_get_cfi_desc_elem_len, gfc_get_cfi_desc_version,
+	gfc_get_cfi_desc_rank, gfc_get_cfi_desc_type,
+	gfc_get_cfi_desc_attribute, gfc_get_cfi_dim_item,
+	gfc_get_cfi_dim_lbound, gfc_get_cfi_dim_extent, gfc_get_cfi_dim_sm):
+	New define/functions to access the CFI array descriptor.
+	(gfc_conv_descriptor_type): New function for the GFC descriptor.
+	(gfc_get_array_span): Handle expr of CFI descriptors and
+	assumed-type descriptors.
+	(gfc_trans_array_bounds): Remove 'static'.
+	(gfc_conv_expr_descriptor): For assumed type, use the dtype of
+	the actual argument.
+	(structure_alloc_comps): Remove ' ' inside tabs.
+	* trans-array.h (gfc_trans_array_bounds, gfc_conv_descriptor_type,
+	gfc_get_cfi_desc_base_addr, gfc_get_cfi_desc_elem_len,
+	gfc_get_cfi_desc_version, gfc_get_cfi_desc_rank,
+	gfc_get_cfi_desc_type, gfc_get_cfi_desc_attribute,
+	gfc_get_cfi_dim_lbound, gfc_get_cfi_dim_extent, gfc_get_cfi_dim_sm):
+	New prototypes.
+	* trans-decl.c (gfor_fndecl_cfi_to_gfc, gfor_fndecl_gfc_to_cfi):
+	Remove global vars.
+	(gfc_build_builtin_function_decls): Remove their initialization.
+	(gfc_get_symbol_decl, create_function_arglist,
+	gfc_trans_deferred_vars): Update for CFI.
+	(convert_CFI_desc): Remove and replace by ...
+	(gfc_conv_cfi_to_gfc): ... this function
+	(gfc_generate_function_code): Call it; create local GFC var for CFI.
+	* trans-expr.c (gfc_maybe_dereference_var): Handle CFI.
+	(gfc_conv_subref_array_arg): Handle the if-noncontigous-only copy in
+	when the result should be a descriptor.
+	(gfc_conv_gfc_desc_to_cfi_desc): Completely rewritten.
+	(gfc_conv_procedure_call): CFI fixes.
+	* trans-openmp.c (gfc_omp_is_optional_argument,
+	gfc_omp_check_optional_argument): Handle optional
+	CFI.
+	* trans-stmt.c (gfc_trans_select_rank_cases): Cleanup, avoid invalid
+	code for allocatable/pointer dummies, which cannot be assumed size.
+	* trans-types.c (gfc_cfi_descriptor_base): New global var.
+	(gfc_get_dtype_rank_type): Skip rank init for rank < 0.
+	(gfc_sym_type): Handle CFI dummies.
+	(gfc_get_function_type): Update call.
+	(gfc_get_cfi_dim_type, gfc_get_cfi_type): New.
+	* trans-types.h (gfc_sym_type): Update prototype.
+	(gfc_get_cfi_type): New prototype.
+	* trans.c (gfc_trans_runtime_check): Make conditions more consistent
+	to avoid '<logical> AND_THEN <long int>' in conditions.
+	* trans.h (gfor_fndecl_cfi_to_gfc, gfor_fndecl_gfc_to_cfi): Remove
+	global-var declaration.
+
+2021-10-18  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/102745
+	* intrinsic.c (gfc_convert_type_warn): Fix checks by checking CLASS
+	and do typcheck in correct order for type extension.
+	* misc.c (gfc_typename): Print proper not internal CLASS type name.
+
+2021-10-15  Harald Anlauf  <anlauf@gmx.de>
+	    Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/102685
+	* decl.c (match_clist_expr): Set rank/shape of clist initializer
+	to match LHS.
+	* resolve.c (resolve_structure_cons): In a structure constructor,
+	compare shapes of array components against declared shape.
+
+2021-10-14  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/102717
+	* simplify.c (gfc_simplify_reshape): Replace assert by error
+	message for negative elements in SHAPE array.
+
+2021-10-14  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/102716
+	* check.c (gfc_check_shape): Reorder checks so that invalid KIND
+	arguments can be detected.
+
+2021-10-14  Kwok Cheung Yeung  <kcy@codesourcery.com>
+
+	* gfortran.h (enum gfc_statement): Add ST_OMP_DECLARE_VARIANT.
+	(enum gfc_omp_trait_property_kind): New.
+	(struct gfc_omp_trait_property): New.
+	(gfc_get_omp_trait_property): New macro.
+	(struct gfc_omp_selector): New.
+	(gfc_get_omp_selector): New macro.
+	(struct gfc_omp_set_selector): New.
+	(gfc_get_omp_set_selector): New macro.
+	(struct gfc_omp_declare_variant): New.
+	(gfc_get_omp_declare_variant): New macro.
+	(struct gfc_namespace): Add omp_declare_variant field.
+	(gfc_free_omp_declare_variant_list): New prototype.
+	* match.h (gfc_match_omp_declare_variant): New prototype.
+	* openmp.c (gfc_free_omp_trait_property_list): New.
+	(gfc_free_omp_selector_list): New.
+	(gfc_free_omp_set_selector_list): New.
+	(gfc_free_omp_declare_variant_list): New.
+	(gfc_match_omp_clauses): Add extra optional argument.  Handle end of
+	clauses for context selectors.
+	(omp_construct_selectors, omp_device_selectors,
+	omp_implementation_selectors, omp_user_selectors): New.
+	(gfc_match_omp_context_selector): New.
+	(gfc_match_omp_context_selector_specification): New.
+	(gfc_match_omp_declare_variant): New.
+	* parse.c: Include tree-core.h and omp-general.h.
+	(decode_omp_directive): Handle 'declare variant'.
+	(case_omp_decl): Include ST_OMP_DECLARE_VARIANT.
+	(gfc_ascii_statement): Handle ST_OMP_DECLARE_VARIANT.
+	(gfc_parse_file): Initialize omp_requires_mask.
+	* symbol.c (gfc_free_namespace): Call
+	gfc_free_omp_declare_variant_list.
+	* trans-decl.c (gfc_get_extern_function_decl): Call
+	gfc_trans_omp_declare_variant.
+	(gfc_create_function_decl): Call gfc_trans_omp_declare_variant.
+	* trans-openmp.c (gfc_trans_omp_declare_variant): New.
+	* trans-stmt.h (gfc_trans_omp_declare_variant): New prototype.
+
+2021-10-13  Tobias Burnus  <tobias@codesourcery.com>
+
+	* dump-parse-tree.c (show_omp_clauses): Handle ancestor modifier,
+	avoid ICE for GFC_OMP_ATOMIC_SWAP.
+	* gfortran.h (gfc_omp_clauses): Change 'anecestor' into a bitfield.
+
+2021-10-12  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/102541
+	* check.c (gfc_check_present): Handle optional CLASS.
+	* interface.c (gfc_compare_actual_formal): Likewise.
+	* trans-array.c (gfc_trans_g77_array): Likewise.
+	* trans-decl.c (gfc_build_dummy_array_decl): Likewise.
+	* trans-types.c (gfc_sym_type): Likewise.
+	* primary.c (gfc_variable_attr): Fixes for dummy and
+	pointer when 'class%_data' is passed.
+	* trans-expr.c (set_dtype_for_unallocated, gfc_conv_procedure_call):
+	For assumed-rank dummy, fix setting rank for dealloc/notassoc actual
+	and setting ubound to -1 for assumed-size actuals.
+
+2021-10-10  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/99348
+	PR fortran/102521
+	* decl.c (add_init_expr_to_sym): Extend initialization of
+	parameter arrays from scalars to handle derived types.
+
+2021-10-09  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/65454
+	* module.c (read_module): Handle old and new-style relational
+	operators when used in USE module, ONLY: OPERATOR(op).
+
+2021-10-08  Sandra Loosemore  <sandra@codesourcery.com>
+
+	PR fortran/54753
+	* interface.c (gfc_compare_actual_formal): Add diagnostic
+	for F2018:C839.  Refactor shared code and fix bugs with class
+	array info lookup, and extend similar diagnostic from PR94110
+	to also cover class types.
+
+2021-10-08  Martin Liska  <mliska@suse.cz>
+
+	* options.c (gfc_post_options): Use new macro
+	OPTION_SET_P.
+
 2021-10-06  Tobias Burnus  <tobias@codesourcery.com>
 
 	* resolve.c (resolve_values): Only show
diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in
index 63195a9..58ce589 100644
--- a/gcc/fortran/Make-lang.in
+++ b/gcc/fortran/Make-lang.in
@@ -117,7 +117,20 @@ fortran.tags: force
 	etags --include TAGS.sub --include ../TAGS.sub
 
 fortran.info: doc/gfortran.info doc/gfc-internals.info
-fortran.dvi: doc/gfortran.dvi doc/gfc-internals.dvi
+
+F95_DVIFILES = doc/gfortran.dvi
+
+fortran.dvi: $(F95_DVIFILES) doc/gfc-internals.dvi
+
+fortran.install-dvi: $(F95_DVIFILES)
+	@$(NORMAL_INSTALL)
+	test -z "$(dvidir)/gcc" || $(mkinstalldirs) "$(DESTDIR)$(dvidir)/gcc"
+	@list='$(F95_DVIFILES)'; for p in $$list; do \
+	  if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+	  f=$(dvi__strip_dir) \
+	  echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(dvidir)/gcc/$$f'"; \
+	  $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(dvidir)/gcc/$$f"; \
+	done
 
 F95_HTMLFILES = $(build_htmldir)/gfortran
 
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f31ad68..cfaf9d2 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -4530,7 +4530,9 @@ gfc_check_present (gfc_expr *a)
       return false;
     }
 
-  if (!sym->attr.optional)
+  /* For CLASS, the optional attribute might be set at either location. */
+  if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional)
+      && !sym->attr.optional)
     {
       gfc_error ("%qs argument of %qs intrinsic at %L must be of "
 		 "an OPTIONAL dummy variable",
@@ -5084,6 +5086,13 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
   if (gfc_invalid_null_arg (source))
     return false;
 
+  if (!kind_check (kind, 1, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+			       "with KIND argument at %L",
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
     return true;
 
@@ -5096,13 +5105,6 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
       return false;
     }
 
-  if (!kind_check (kind, 1, BT_INTEGER))
-    return false;
-  if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-			       "with KIND argument at %L",
-			       gfc_current_intrinsic, &kind->where))
-    return false;
-
   return true;
 }
 
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index b3c65b7..ce61e53 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -896,9 +896,6 @@ match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
       expr->ts = *ts;
       expr->value.constructor = array_head;
 
-      expr->rank = as->rank;
-      expr->shape = gfc_get_shape (expr->rank);
-
       /* Validate sizes.  We built expr ourselves, so cons_size will be
 	 constant (we fail above for non-constant expressions).
 	 We still need to verify that the sizes match.  */
@@ -911,6 +908,12 @@ match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
       mpz_clear (cons_size);
       if (cmp)
 	goto cleanup;
+
+      /* Set the rank/shape to match the LHS as auto-reshape is implied. */
+      expr->rank = as->rank;
+      expr->shape = gfc_get_shape (as->rank);
+      for (int i = 0; i < as->rank; ++i)
+	spec_dimen_size (as, i, &expr->shape[i]);
     }
 
   /* Make sure scalar types match. */
@@ -1602,15 +1605,6 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
 					    sym->name, &sym->declared_at,
 					    sym->ns->proc_name->name))
 		    retval = false;
-		  else if (!sym->attr.dimension)
-		    {
-		      /* FIXME: Use CFI array descriptor for scalars.  */
-		      gfc_error ("Sorry, deferred-length scalar character dummy "
-				 "argument %qs at %L of procedure %qs with "
-				 "BIND(C) not yet supported", sym->name,
-				 &sym->declared_at, sym->ns->proc_name->name);
-		      retval = false;
-		    }
 		}
 	      else if (sym->attr.value
 		       && (!cl || !cl->length
@@ -1633,20 +1627,6 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
 				      "attribute", sym->name, &sym->declared_at,
 				      sym->ns->proc_name->name))
 		    retval = false;
-		  else if (!sym->attr.dimension
-			   || sym->as->type == AS_ASSUMED_SIZE
-			   || sym->as->type == AS_EXPLICIT)
-		    {
-		      /* FIXME: Valid - should use the CFI array descriptor, but
-			 not yet handled for scalars and assumed-/explicit-size
-			 arrays.  */
-		      gfc_error ("Sorry, character dummy argument %qs at %L "
-				 "with assumed length is not yet supported for "
-				 "procedure %qs with BIND(C) attribute",
-				 sym->name, &sym->declared_at,
-				 sym->ns->proc_name->name);
-		      retval = false;
-		    }
 		}
 	      else if (cl->length->expr_type != EXPR_CONSTANT
 		       || mpz_cmp_si (cl->length->value.integer, 1) != 0)
@@ -2228,12 +2208,16 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
 	  gfc_expr *array;
 	  int n;
 	  if (sym->attr.flavor == FL_PARAMETER
-		&& init->expr_type == EXPR_CONSTANT
-		&& spec_size (sym->as, &size)
-		&& mpz_cmp_si (size, 0) > 0)
+	      && gfc_is_constant_expr (init)
+	      && (init->expr_type == EXPR_CONSTANT
+		  || init->expr_type == EXPR_STRUCTURE)
+	      && spec_size (sym->as, &size)
+	      && mpz_cmp_si (size, 0) > 0)
 	    {
 	      array = gfc_get_array_expr (init->ts.type, init->ts.kind,
 					  &init->where);
+	      if (init->ts.type == BT_DERIVED)
+		array->ts.u.derived = init->ts.u.derived;
 	      for (n = 0; n < (int)mpz_get_si (size); n++)
 		gfc_constructor_append_expr (&array->value.constructor,
 					     n == 0
@@ -5608,14 +5592,6 @@ match_attr_spec (void)
 		  m = MATCH_ERROR;
 		  goto cleanup;
 		}
-	      if (current_ts.kind != gfc_default_integer_kind)
-		{
-		  gfc_error ("Component with KIND attribute at %C must be "
-			     "default integer kind (%d)",
-			      gfc_default_integer_kind);
-		  m = MATCH_ERROR;
-		  goto cleanup;
-		}
 	    }
 	  else if (d == DECL_LEN)
 	    {
@@ -5635,14 +5611,6 @@ match_attr_spec (void)
 		  m = MATCH_ERROR;
 		  goto cleanup;
 		}
-	      if (current_ts.kind != gfc_default_integer_kind)
-		{
-		  gfc_error ("Component with LEN attribute at %C must be "
-			     "default integer kind (%d)",
-			      gfc_default_integer_kind);
-		  m = MATCH_ERROR;
-		  goto cleanup;
-		}
 	    }
 	  else
 	    {
@@ -8445,6 +8413,7 @@ gfc_match_end (gfc_statement *st)
       break;
 
     case COMP_BLOCK:
+    case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
       *st = ST_END_BLOCK;
       target = " block";
       eos_ok = 0;
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 64e04c0..14a3078 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1750,6 +1750,8 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
   if (omp_clauses->device)
     {
       fputs (" DEVICE(", dumpfile);
+      if (omp_clauses->ancestor)
+	fputs ("ANCESTOR:", dumpfile);
       show_expr (omp_clauses->device);
       fputc (')', dumpfile);
     }
@@ -1894,7 +1896,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
   if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET)
     {
       const char *atomic_op;
-      switch (omp_clauses->atomic_op)
+      switch (omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
 	{
 	case GFC_OMP_ATOMIC_READ: atomic_op = "READ"; break;
 	case GFC_OMP_ATOMIC_WRITE: atomic_op = "WRITE"; break;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 6c38935..b19d3a2 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1110,11 +1110,13 @@ is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
 
   if (sym && sym->attr.dummy
       && sym->ns->proc_name->attr.is_bind_c
-      && sym->attr.dimension
       && (sym->attr.pointer
 	  || sym->attr.allocatable
-	  || sym->as->type == AS_ASSUMED_SHAPE
-	  || sym->as->type == AS_ASSUMED_RANK))
+	  || (sym->attr.dimension
+	      && (sym->as->type == AS_ASSUMED_SHAPE
+		  || sym->as->type == AS_ASSUMED_RANK))
+	  || (sym->ts.type == BT_CHARACTER
+	      && (!sym->ts.u.cl || !sym->ts.u.cl->length))))
     return true;
 
 return false;
@@ -2203,7 +2205,8 @@ gfc_simplify_expr (gfc_expr *p, int type)
 	  (p->value.function.isym->id == GFC_ISYM_LBOUND
 	   || p->value.function.isym->id == GFC_ISYM_UBOUND
 	   || p->value.function.isym->id == GFC_ISYM_LCOBOUND
-	   || p->value.function.isym->id == GFC_ISYM_UCOBOUND))
+	   || p->value.function.isym->id == GFC_ISYM_UCOBOUND
+	   || p->value.function.isym->id == GFC_ISYM_SHAPE))
 	ap = ap->next;
 
       for ( ; ap; ap = ap->next)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c25d1cc..66192c0 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -105,6 +105,40 @@ typedef struct
 }
 mstring;
 
+/* ISO_Fortran_binding.h
+   CAUTION: This has to be kept in sync with libgfortran.  */
+
+#define CFI_type_kind_shift 8
+#define CFI_type_mask 0xFF
+#define CFI_type_from_type_kind(t, k) (t + (k << CFI_type_kind_shift))
+
+/* Constants, defined as macros. */
+#define CFI_VERSION 1
+#define CFI_MAX_RANK 15
+
+/* Attributes. */
+#define CFI_attribute_pointer 0
+#define CFI_attribute_allocatable 1
+#define CFI_attribute_other 2
+
+#define CFI_type_mask 0xFF
+#define CFI_type_kind_shift 8
+
+/* Intrinsic types. Their kind number defines their storage size. */
+#define CFI_type_Integer 1
+#define CFI_type_Logical 2
+#define CFI_type_Real 3
+#define CFI_type_Complex 4
+#define CFI_type_Character 5
+
+/* Combined type (for more, see ISO_Fortran_binding.h).  */
+#define CFI_type_ucs4_char (CFI_type_Character + (4 << CFI_type_kind_shift))
+
+/* Types with no kind. */
+#define CFI_type_struct 6
+#define CFI_type_cptr 7
+#define CFI_type_cfunptr 8
+#define CFI_type_other -1
 
 
 /*************************** Enums *****************************/
@@ -239,7 +273,7 @@ enum gfc_statement
   ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
   ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
   ST_OMP_TARGET, ST_OMP_END_TARGET, ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA,
-  ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET,
+  ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, ST_OMP_DECLARE_VARIANT,
   ST_OMP_TEAMS, ST_OMP_END_TEAMS, ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE,
   ST_OMP_DISTRIBUTE_SIMD, ST_OMP_END_DISTRIBUTE_SIMD,
   ST_OMP_DISTRIBUTE_PARALLEL_DO, ST_OMP_END_DISTRIBUTE_PARALLEL_DO,
@@ -1482,12 +1516,11 @@ typedef struct gfc_omp_clauses
   struct gfc_expr *dist_chunk_size;
   struct gfc_expr *message;
   const char *critical_name;
-  bool ancestor;
   enum gfc_omp_default_sharing default_sharing;
   enum gfc_omp_atomic_op atomic_op;
   enum gfc_omp_defaultmap defaultmap[OMP_DEFAULTMAP_CAT_NUM];
   int collapse, orderedc;
-  unsigned nowait:1, ordered:1, untied:1, mergeable:1;
+  unsigned nowait:1, ordered:1, untied:1, mergeable:1, ancestor:1;
   unsigned inbranch:1, notinbranch:1, nogroup:1;
   unsigned sched_simd:1, sched_monotonic:1, sched_nonmonotonic:1;
   unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1;
@@ -1554,6 +1587,73 @@ typedef struct gfc_omp_declare_simd
 gfc_omp_declare_simd;
 #define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd)
 
+
+enum gfc_omp_trait_property_kind
+{
+  CTX_PROPERTY_NONE,
+  CTX_PROPERTY_USER,
+  CTX_PROPERTY_NAME_LIST,
+  CTX_PROPERTY_ID,
+  CTX_PROPERTY_EXPR,
+  CTX_PROPERTY_SIMD
+};
+
+typedef struct gfc_omp_trait_property
+{
+  struct gfc_omp_trait_property *next;
+  enum gfc_omp_trait_property_kind property_kind;
+  bool is_name : 1;
+
+  union
+    {
+      gfc_expr *expr;
+      gfc_symbol *sym;
+      gfc_omp_clauses *clauses;
+      char *name;
+    };
+} gfc_omp_trait_property;
+#define gfc_get_omp_trait_property() XCNEW (gfc_omp_trait_property)
+
+typedef struct gfc_omp_selector
+{
+  struct gfc_omp_selector *next;
+
+  char *trait_selector_name;
+  gfc_expr *score;
+  struct gfc_omp_trait_property *properties;
+} gfc_omp_selector;
+#define gfc_get_omp_selector() XCNEW (gfc_omp_selector)
+
+typedef struct gfc_omp_set_selector
+{
+  struct gfc_omp_set_selector *next;
+
+  const char *trait_set_selector_name;
+  struct gfc_omp_selector *trait_selectors;
+} gfc_omp_set_selector;
+#define gfc_get_omp_set_selector() XCNEW (gfc_omp_set_selector)
+
+
+/* Node in the linked list used for storing !$omp declare variant
+   constructs.  */
+
+typedef struct gfc_omp_declare_variant
+{
+  struct gfc_omp_declare_variant *next;
+  locus where; /* Where the !$omp declare variant construct occurred.  */
+
+  struct gfc_symtree *base_proc_symtree;
+  struct gfc_symtree *variant_proc_symtree;
+
+  gfc_omp_set_selector *set_selectors;
+
+  bool checked_p : 1; /* Set if previously checked for errors.  */
+  bool error_p : 1; /* Set if error found in directive.  */
+}
+gfc_omp_declare_variant;
+#define gfc_get_omp_declare_variant() XCNEW (gfc_omp_declare_variant)
+
+
 typedef struct gfc_omp_udr
 {
   struct gfc_omp_udr *next;
@@ -2023,6 +2123,9 @@ typedef struct gfc_namespace
   /* Linked list of !$omp declare simd constructs.  */
   struct gfc_omp_declare_simd *omp_declare_simd;
 
+  /* Linked list of !$omp declare variant constructs.  */
+  struct gfc_omp_declare_variant *omp_declare_variant;
+
   /* A hash set for the the gfc expressions that have already
      been finalized in this namespace.  */
 
@@ -3423,6 +3526,7 @@ bool gfc_omp_requires_add_clause (gfc_omp_requires_kind, const char *,
 void gfc_check_omp_requires (gfc_namespace *, int);
 void gfc_free_omp_clauses (gfc_omp_clauses *);
 void gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *);
+void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list);
 void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
 void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
 void gfc_free_omp_udr (gfc_omp_udr *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index a2fea0e..24698be 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3061,6 +3061,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   unsigned long actual_size, formal_size;
   bool full_array = false;
   gfc_array_ref *actual_arr_ref;
+  gfc_array_spec *fas, *aas;
+  bool pointer_dummy, pointer_arg, allocatable_arg;
 
   actual = *ap;
 
@@ -3329,13 +3331,60 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return false;
 	}
 
-      if (f->sym->as
-	  && (f->sym->as->type == AS_ASSUMED_SHAPE
-	      || f->sym->as->type == AS_DEFERRED
-	      || (f->sym->as->type == AS_ASSUMED_RANK && f->sym->attr.pointer))
-	  && a->expr->expr_type == EXPR_VARIABLE
-	  && a->expr->symtree->n.sym->as
-	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
+      /* Class array variables and expressions store array info in a
+	 different place from non-class objects; consolidate the logic
+	 to access it here instead of repeating it below.  Note that
+	 pointer_arg and allocatable_arg are not fully general and are
+	 only used in a specific situation below with an assumed-rank
+	 argument.  */
+      if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym))
+	{
+	  gfc_component *classdata = CLASS_DATA (f->sym);
+	  fas = classdata->as;
+	  pointer_dummy = classdata->attr.class_pointer;
+	}
+      else
+	{
+	  fas = f->sym->as;
+	  pointer_dummy = f->sym->attr.pointer;
+	}
+
+      if (a->expr->expr_type != EXPR_VARIABLE)
+	{
+	  aas = NULL;
+	  pointer_arg = false;
+	  allocatable_arg = false;
+	}
+      else if (a->expr->ts.type == BT_CLASS
+	       && a->expr->symtree->n.sym
+	       && CLASS_DATA (a->expr->symtree->n.sym))
+	{
+	  gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym);
+	  aas = classdata->as;
+	  pointer_arg = classdata->attr.class_pointer;
+	  allocatable_arg = classdata->attr.allocatable;
+	}
+      else
+	{
+	  aas = a->expr->symtree->n.sym->as;
+	  pointer_arg = a->expr->symtree->n.sym->attr.pointer;
+	  allocatable_arg = a->expr->symtree->n.sym->attr.allocatable;
+	}
+
+      /* F2018:9.5.2(2) permits assumed-size whole array expressions as
+	 actual arguments only if the shape is not required; thus it
+	 cannot be passed to an assumed-shape array dummy.
+	 F2018:15.5.2.(2) permits passing a nonpointer actual to an
+	 intent(in) pointer dummy argument and this is accepted by
+	 the compare_pointer check below, but this also requires shape
+	 information.
+	 There's more discussion of this in PR94110.  */
+      if (fas
+	  && (fas->type == AS_ASSUMED_SHAPE
+	      || fas->type == AS_DEFERRED
+	      || (fas->type == AS_ASSUMED_RANK && pointer_dummy))
+	  && aas
+	  && aas->type == AS_ASSUMED_SIZE
 	  && (a->expr->ref == NULL
 	      || (a->expr->ref->type == REF_ARRAY
 		  && a->expr->ref->u.ar.type == AR_FULL)))
@@ -3346,6 +3395,35 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return false;
 	}
 
+      /* Diagnose F2018 C839 (TS29113 C535c).  Here the problem is
+	 passing an assumed-size array to an INTENT(OUT) assumed-rank
+	 dummy when it doesn't have the size information needed to run
+	 initializers and finalizers.  */
+      if (f->sym->attr.intent == INTENT_OUT
+	  && fas
+	  && fas->type == AS_ASSUMED_RANK
+	  && aas
+	  && ((aas->type == AS_ASSUMED_SIZE
+	       && (a->expr->ref == NULL
+		   || (a->expr->ref->type == REF_ARRAY
+		       && a->expr->ref->u.ar.type == AR_FULL)))
+	      || (aas->type == AS_ASSUMED_RANK
+		  && !pointer_arg
+		  && !allocatable_arg))
+	  && (a->expr->ts.type == BT_CLASS
+	      || (a->expr->ts.type == BT_DERIVED
+		  && (gfc_is_finalizable (a->expr->ts.u.derived, NULL)
+		      || gfc_has_ultimate_allocatable (a->expr)
+		      || gfc_has_default_initializer
+			   (a->expr->ts.u.derived)))))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to assumed-rank INTENT(OUT) "
+		       "dummy %qs at %L cannot be of unknown size",
+		       f->sym->name, where);
+	  return false;
+	}
+
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_pointer (f->sym, a->expr) == 0)
 	{
@@ -3479,7 +3557,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && a->expr->symtree->n.sym->as
 	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
-	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	  && !(fas && fas->type == AS_ASSUMED_SHAPE))
 	{
 	  if (where)
 	    gfc_error ("Assumed-shape actual argument at %L is "
@@ -3496,7 +3574,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       if (f->sym->attr.volatile_
 	  && actual_arr_ref && actual_arr_ref->type == AR_SECTION
-	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	  && !(fas && fas->type == AS_ASSUMED_SHAPE))
 	{
 	  if (where)
 	    gfc_error ("Array-section actual argument at %L is "
@@ -3514,8 +3592,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && a->expr->symtree->n.sym->attr.pointer
 	  && a->expr->symtree->n.sym->as
-	  && !(f->sym->as
-	       && (f->sym->as->type == AS_ASSUMED_SHAPE
+	  && !(fas
+	       && (fas->type == AS_ASSUMED_SHAPE
 		   || f->sym->attr.pointer)))
 	{
 	  if (where)
@@ -3546,8 +3624,13 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		       "at %L", where);
 	  return false;
 	}
-      if (!f->sym->attr.optional
-	  || (in_statement_function && f->sym->attr.optional))
+      /* For CLASS, the optional attribute might be set at either location. */
+      if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional)
+	   && !f->sym->attr.optional)
+	  || (in_statement_function
+	      && (f->sym->attr.optional
+		  || (f->sym->ts.type == BT_CLASS
+		      && CLASS_DATA (f->sym)->attr.optional))))
 	{
 	  if (where)
 	    gfc_error ("Missing actual argument for argument %qs at %L",
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 219f04f..f5c88d9 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -5237,12 +5237,13 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag,
   /* In building an array constructor, gfortran can end up here when no
      conversion is required for an intrinsic type.  We need to let derived
      types drop through.  */
-  if (from_ts.type != BT_DERIVED
+  if (from_ts.type != BT_DERIVED && from_ts.type != BT_CLASS
       && (from_ts.type == ts->type && from_ts.kind == ts->kind))
     return true;
 
-  if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
-      && gfc_compare_types (&expr->ts, ts))
+  if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+      && (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+      && gfc_compare_types (ts, &expr->ts))
     return true;
 
   /* If array is true then conversion is in an array constructor where
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 92fd127..21e94f7 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -160,6 +160,7 @@ match gfc_match_omp_critical (void);
 match gfc_match_omp_declare_reduction (void);
 match gfc_match_omp_declare_simd (void);
 match gfc_match_omp_declare_target (void);
+match gfc_match_omp_declare_variant (void);
 match gfc_match_omp_depobj (void);
 match gfc_match_omp_distribute (void);
 match gfc_match_omp_distribute_parallel_do (void);
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 3d449ae1..e6402e8 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -130,7 +130,6 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
   static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
   static int flag = 0;
   char *buffer;
-  gfc_typespec *ts1;
   gfc_charlen_t length = 0;
 
   buffer = flag ? buffer1 : buffer2;
@@ -180,16 +179,17 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
       break;
     case BT_CLASS:
-      if (ts->u.derived == NULL)
+      if (!ts->u.derived || !ts->u.derived->components
+	  || !ts->u.derived->components->ts.u.derived)
 	{
 	  sprintf (buffer, "invalid class");
 	  break;
 	}
-      ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
-      if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
+      if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
 	sprintf (buffer, "CLASS(*)");
       else
-	sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
+	sprintf (buffer, "CLASS(%s)",
+		 ts->u.derived->components->ts.u.derived->name);
       break;
     case BT_ASSUMED:
       sprintf (buffer, "TYPE(*)");
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1804066..7b98ba5 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -5592,6 +5592,9 @@ read_module (void)
 
   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
     {
+      gfc_use_rename *u = NULL, *v = NULL;
+      int j = i;
+
       if (i == INTRINSIC_USER)
 	continue;
 
@@ -5599,18 +5602,73 @@ read_module (void)
 	{
 	  u = find_use_operator ((gfc_intrinsic_op) i);
 
-	  if (u == NULL)
+	  /* F2018:10.1.5.5.1 requires same interpretation of old and new-style
+	     relational operators.  Special handling for USE, ONLY.  */
+	  switch (i)
+	    {
+	    case INTRINSIC_EQ:
+	      j = INTRINSIC_EQ_OS;
+	      break;
+	    case INTRINSIC_EQ_OS:
+	      j = INTRINSIC_EQ;
+	      break;
+	    case INTRINSIC_NE:
+	      j = INTRINSIC_NE_OS;
+	      break;
+	    case INTRINSIC_NE_OS:
+	      j = INTRINSIC_NE;
+	      break;
+	    case INTRINSIC_GT:
+	      j = INTRINSIC_GT_OS;
+	      break;
+	    case INTRINSIC_GT_OS:
+	      j = INTRINSIC_GT;
+	      break;
+	    case INTRINSIC_GE:
+	      j = INTRINSIC_GE_OS;
+	      break;
+	    case INTRINSIC_GE_OS:
+	      j = INTRINSIC_GE;
+	      break;
+	    case INTRINSIC_LT:
+	      j = INTRINSIC_LT_OS;
+	      break;
+	    case INTRINSIC_LT_OS:
+	      j = INTRINSIC_LT;
+	      break;
+	    case INTRINSIC_LE:
+	      j = INTRINSIC_LE_OS;
+	      break;
+	    case INTRINSIC_LE_OS:
+	      j = INTRINSIC_LE;
+	      break;
+	    default:
+	      break;
+	    }
+
+	  if (j != i)
+	    v = find_use_operator ((gfc_intrinsic_op) j);
+
+	  if (u == NULL && v == NULL)
 	    {
 	      skip_list ();
 	      continue;
 	    }
 
-	  u->found = 1;
+	  if (u)
+	    u->found = 1;
+	  if (v)
+	    v->found = 1;
 	}
 
       mio_interface (&gfc_current_ns->op[i]);
-      if (u && !gfc_current_ns->op[i])
-	u->found = 0;
+      if (!gfc_current_ns->op[i] && !gfc_current_ns->op[j])
+	{
+	  if (u)
+	    u->found = 0;
+	  if (v)
+	    v->found = 0;
+	}
     }
 
   mio_rparen ();
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 6a4ca28..dcf22ac 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -168,6 +168,70 @@ gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
     }
 }
 
+static void
+gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
+{
+  while (list)
+    {
+      gfc_omp_trait_property *current = list;
+      list = list->next;
+      switch (current->property_kind)
+	{
+	case CTX_PROPERTY_ID:
+	  free (current->name);
+	  break;
+	case CTX_PROPERTY_NAME_LIST:
+	  if (current->is_name)
+	    free (current->name);
+	  break;
+	case CTX_PROPERTY_SIMD:
+	  gfc_free_omp_clauses (current->clauses);
+	  break;
+	default:
+	  break;
+	}
+      free (current);
+    }
+}
+
+static void
+gfc_free_omp_selector_list (gfc_omp_selector *list)
+{
+  while (list)
+    {
+      gfc_omp_selector *current = list;
+      list = list->next;
+      gfc_free_omp_trait_property_list (current->properties);
+      free (current);
+    }
+}
+
+static void
+gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
+{
+  while (list)
+    {
+      gfc_omp_set_selector *current = list;
+      list = list->next;
+      gfc_free_omp_selector_list (current->trait_selectors);
+      free (current);
+    }
+}
+
+/* Free an !$omp declare variant construct list.  */
+
+void
+gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
+{
+  while (list)
+    {
+      gfc_omp_declare_variant *current = list;
+      list = list->next;
+      gfc_free_omp_set_selector_list (current->set_selectors);
+      free (current);
+    }
+}
+
 /* Free an !$omp declare reduction.  */
 
 void
@@ -1138,7 +1202,7 @@ failed:
 
 static match
 gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
-				bool allow_derived)
+				bool allow_derived, bool openmp_target = false)
 {
   if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
     return MATCH_NO;
@@ -1285,6 +1349,19 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
 	    n->u2.udr = gfc_get_omp_namelist_udr ();
 	    n->u2.udr->udr = udr;
 	  }
+	if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
+	  {
+	    gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
+	    p->sym = n->sym;
+	    p->where = p->where;
+	    p->u.map_op = OMP_MAP_ALWAYS_TOFROM;
+
+	    tl = &c->lists[OMP_LIST_MAP];
+	    while (*tl)
+	      tl = &((*tl)->next);
+	    *tl = p;
+	    p->next = NULL;
+	  }
      }
   return MATCH_YES;
 }
@@ -1353,7 +1430,8 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name)
 static match
 gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		       bool first = true, bool needs_space = true,
-		       bool openacc = false)
+		       bool openacc = false, bool context_selector = false,
+		       bool openmp_target = false)
 {
   bool error = false;
   gfc_omp_clauses *c = gfc_get_omp_clauses ();
@@ -2057,8 +2135,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 	      goto error;
 	    }
 	  if ((mask & OMP_CLAUSE_IN_REDUCTION)
-	      && gfc_match_omp_clause_reduction (pc, c, openacc,
-						 allow_derived) == MATCH_YES)
+	      && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
+						 openmp_target) == MATCH_YES)
 	    continue;
 	  if ((mask & OMP_CLAUSE_INBRANCH)
 	      && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
@@ -2843,7 +2921,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
     }
 
 end:
-  if (error || gfc_match_omp_eos () != MATCH_YES)
+  if (error
+      || (context_selector && gfc_peek_ascii_char () != ')')
+      || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
     {
       if (!gfc_error_flag_test ())
 	gfc_error ("Failed to match clause at %C");
@@ -3512,7 +3592,8 @@ static match
 match_omp (gfc_exec_op op, const omp_mask mask)
 {
   gfc_omp_clauses *c;
-  if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
+  if (gfc_match_omp_clauses (&c, mask, true, true, false, false,
+			     op == EXEC_OMP_TARGET) != MATCH_YES)
     return MATCH_ERROR;
   new_st.op = op;
   new_st.ext.omp_clauses = c;
@@ -4429,6 +4510,449 @@ cleanup:
 }
 
 
+static const char *const omp_construct_selectors[] = {
+  "simd", "target", "teams", "parallel", "do", NULL };
+static const char *const omp_device_selectors[] = {
+  "kind", "isa", "arch", NULL };
+static const char *const omp_implementation_selectors[] = {
+  "vendor", "extension", "atomic_default_mem_order", "unified_address",
+  "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL };
+static const char *const omp_user_selectors[] = {
+  "condition", NULL };
+
+
+/* OpenMP 5.0:
+
+   trait-selector:
+     trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
+
+   trait-score:
+     score(score-expression)  */
+
+match
+gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
+{
+  do
+    {
+      char selector[GFC_MAX_SYMBOL_LEN + 1];
+
+      if (gfc_match_name (selector) != MATCH_YES)
+	{
+	  gfc_error ("expected trait selector name at %C");
+	  return MATCH_ERROR;
+	}
+
+      gfc_omp_selector *os = gfc_get_omp_selector ();
+      os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1);
+      strcpy (os->trait_selector_name, selector);
+      os->next = oss->trait_selectors;
+      oss->trait_selectors = os;
+
+      const char *const *selectors = NULL;
+      bool allow_score = true;
+      bool allow_user = false;
+      int property_limit = 0;
+      enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE;
+      switch (oss->trait_set_selector_name[0])
+	{
+	case 'c': /* construct */
+	  selectors = omp_construct_selectors;
+	  allow_score = false;
+	  property_limit = 1;
+	  property_kind = CTX_PROPERTY_SIMD;
+	  break;
+	case 'd': /* device */
+	  selectors = omp_device_selectors;
+	  allow_score = false;
+	  allow_user = true;
+	  property_limit = 3;
+	  property_kind = CTX_PROPERTY_NAME_LIST;
+	  break;
+	case 'i': /* implementation */
+	  selectors = omp_implementation_selectors;
+	  allow_user = true;
+	  property_limit = 3;
+	  property_kind = CTX_PROPERTY_NAME_LIST;
+	  break;
+	case 'u': /* user */
+	  selectors = omp_user_selectors;
+	  property_limit = 1;
+	  property_kind = CTX_PROPERTY_EXPR;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      for (int i = 0; ; i++)
+	{
+	  if (selectors[i] == NULL)
+	    {
+	      if (allow_user)
+		{
+		  property_kind = CTX_PROPERTY_USER;
+		  break;
+		}
+	      else
+		{
+		  gfc_error ("selector '%s' not allowed for context selector "
+			     "set '%s' at %C",
+			     selector, oss->trait_set_selector_name);
+		  return MATCH_ERROR;
+		}
+	    }
+	  if (i == property_limit)
+	    property_kind = CTX_PROPERTY_NONE;
+	  if (strcmp (selectors[i], selector) == 0)
+	    break;
+	}
+      if (property_kind == CTX_PROPERTY_NAME_LIST
+	  && oss->trait_set_selector_name[0] == 'i'
+	  && strcmp (selector, "atomic_default_mem_order") == 0)
+	property_kind = CTX_PROPERTY_ID;
+
+      if (gfc_match (" (") == MATCH_YES)
+	{
+	  if (property_kind == CTX_PROPERTY_NONE)
+	    {
+	      gfc_error ("selector '%s' does not accept any properties at %C",
+			 selector);
+	      return MATCH_ERROR;
+	    }
+
+	  if (allow_score && gfc_match (" score") == MATCH_YES)
+	    {
+	      if (gfc_match (" (") != MATCH_YES)
+		{
+		  gfc_error ("expected '(' at %C");
+		  return MATCH_ERROR;
+		}
+	      if (gfc_match_expr (&os->score) != MATCH_YES
+		  || !gfc_resolve_expr (os->score)
+		  || os->score->ts.type != BT_INTEGER
+		  || os->score->rank != 0)
+		{
+		  gfc_error ("score argument must be constant integer "
+			     "expression at %C");
+		  return MATCH_ERROR;
+		}
+
+	      if (os->score->expr_type == EXPR_CONSTANT
+		  && mpz_sgn (os->score->value.integer) < 0)
+		{
+		  gfc_error ("score argument must be non-negative at %C");
+		  return MATCH_ERROR;
+		}
+
+	      if (gfc_match (" )") != MATCH_YES)
+		{
+		  gfc_error ("expected ')' at %C");
+		  return MATCH_ERROR;
+		}
+
+	      if (gfc_match (" :") != MATCH_YES)
+		{
+		  gfc_error ("expected : at %C");
+		  return MATCH_ERROR;
+		}
+	    }
+
+	  gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
+	  otp->property_kind = property_kind;
+	  otp->next = os->properties;
+	  os->properties = otp;
+
+	  switch (property_kind)
+	    {
+	    case CTX_PROPERTY_USER:
+	      do
+		{
+		  if (gfc_match_expr (&otp->expr) != MATCH_YES)
+		    {
+		      gfc_error ("property must be constant integer "
+				 "expression or string literal at %C");
+		      return MATCH_ERROR;
+		    }
+
+		  if (gfc_match (" ,") != MATCH_YES)
+		    break;
+		}
+	      while (1);
+	      break;
+	    case CTX_PROPERTY_ID:
+	      {
+		char buf[GFC_MAX_SYMBOL_LEN + 1];
+		if (gfc_match_name (buf) == MATCH_YES)
+		  {
+		    otp->name = XNEWVEC (char, strlen (buf) + 1);
+		    strcpy (otp->name, buf);
+		  }
+		else
+		  {
+		    gfc_error ("expected identifier at %C");
+		    return MATCH_ERROR;
+		  }
+	      }
+	      break;
+	    case CTX_PROPERTY_NAME_LIST:
+	      do
+		{
+		  char buf[GFC_MAX_SYMBOL_LEN + 1];
+		  if (gfc_match_name (buf) == MATCH_YES)
+		    {
+		      otp->name = XNEWVEC (char, strlen (buf) + 1);
+		      strcpy (otp->name, buf);
+		      otp->is_name = true;
+		    }
+		  else if (gfc_match_literal_constant (&otp->expr, 0)
+			   != MATCH_YES
+			   || otp->expr->ts.type != BT_CHARACTER)
+		    {
+		      gfc_error ("expected identifier or string literal "
+				 "at %C");
+		      return MATCH_ERROR;
+		    }
+
+		  if (gfc_match (" ,") == MATCH_YES)
+		    {
+		      otp = gfc_get_omp_trait_property ();
+		      otp->property_kind = property_kind;
+		      otp->next = os->properties;
+		      os->properties = otp;
+		    }
+		  else
+		    break;
+		}
+	      while (1);
+	      break;
+	    case CTX_PROPERTY_EXPR:
+	      if (gfc_match_expr (&otp->expr) != MATCH_YES)
+		{
+		  gfc_error ("expected expression at %C");
+		  return MATCH_ERROR;
+		}
+	      if (!gfc_resolve_expr (otp->expr)
+		  || (otp->expr->ts.type != BT_LOGICAL
+		      && otp->expr->ts.type != BT_INTEGER)
+		  || otp->expr->rank != 0)
+		{
+		  gfc_error ("property must be constant integer or logical "
+			     "expression at %C");
+		  return MATCH_ERROR;
+		}
+	      break;
+	    case CTX_PROPERTY_SIMD:
+	      {
+		if (gfc_match_omp_clauses (&otp->clauses,
+					   OMP_DECLARE_SIMD_CLAUSES,
+					   true, false, false, true)
+		    != MATCH_YES)
+		  {
+		  gfc_error ("expected simd clause at %C");
+		    return MATCH_ERROR;
+		  }
+		break;
+	      }
+	    default:
+	      gcc_unreachable ();
+	    }
+
+	  if (gfc_match (" )") != MATCH_YES)
+	    {
+	      gfc_error ("expected ')' at %C");
+	      return MATCH_ERROR;
+	    }
+	}
+      else if (property_kind == CTX_PROPERTY_NAME_LIST
+	       || property_kind == CTX_PROPERTY_ID
+	       || property_kind == CTX_PROPERTY_EXPR)
+	{
+	  if (gfc_match (" (") != MATCH_YES)
+	    {
+	      gfc_error ("expected '(' at %C");
+	      return MATCH_ERROR;
+	    }
+	}
+
+      if (gfc_match (" ,") != MATCH_YES)
+	break;
+    }
+  while (1);
+
+  return MATCH_YES;
+}
+
+/* OpenMP 5.0:
+
+   trait-set-selector[,trait-set-selector[,...]]
+
+   trait-set-selector:
+     trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
+
+   trait-set-selector-name:
+     constructor
+     device
+     implementation
+     user  */
+
+match
+gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
+{
+  do
+    {
+      match m;
+      const char *selector_sets[] = { "construct", "device",
+				      "implementation", "user" };
+      const int selector_set_count
+	= sizeof (selector_sets) / sizeof (*selector_sets);
+      int i;
+      char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+      m = gfc_match_name (buf);
+      if (m == MATCH_YES)
+	for (i = 0; i < selector_set_count; i++)
+	  if (strcmp (buf, selector_sets[i]) == 0)
+	    break;
+
+      if (m != MATCH_YES || i == selector_set_count)
+	{
+	  gfc_error ("expected 'construct', 'device', 'implementation' or "
+		     "'user' at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match (" =");
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("expected '=' at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match (" {");
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("expected '{' at %C");
+	  return MATCH_ERROR;
+	}
+
+      gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
+      oss->next = odv->set_selectors;
+      oss->trait_set_selector_name = selector_sets[i];
+      odv->set_selectors = oss;
+
+      if (gfc_match_omp_context_selector (oss) != MATCH_YES)
+	return MATCH_ERROR;
+
+      m = gfc_match (" }");
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("expected '}' at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match (" ,");
+      if (m != MATCH_YES)
+	break;
+    }
+  while (1);
+
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_declare_variant (void)
+{
+  bool first_p = true;
+  char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+  if (gfc_match (" (") != MATCH_YES)
+    {
+      gfc_error ("expected '(' at %C");
+      return MATCH_ERROR;
+    }
+
+  gfc_symtree *base_proc_st, *variant_proc_st;
+  if (gfc_match_name (buf) != MATCH_YES)
+    {
+      gfc_error ("expected name at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_get_ha_sym_tree (buf, &base_proc_st))
+    return MATCH_ERROR;
+
+  if (gfc_match (" :") == MATCH_YES)
+    {
+      if (gfc_match_name (buf) != MATCH_YES)
+	{
+	  gfc_error ("expected variant name at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
+	return MATCH_ERROR;
+    }
+  else
+    {
+      /* Base procedure not specified.  */
+      variant_proc_st = base_proc_st;
+      base_proc_st = NULL;
+    }
+
+  gfc_omp_declare_variant *odv;
+  odv = gfc_get_omp_declare_variant ();
+  odv->where = gfc_current_locus;
+  odv->variant_proc_symtree = variant_proc_st;
+  odv->base_proc_symtree = base_proc_st;
+  odv->next = NULL;
+  odv->error_p = false;
+
+  /* Add the new declare variant to the end of the list.  */
+  gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
+  while (*prev_next)
+    prev_next = &((*prev_next)->next);
+  *prev_next = odv;
+
+  if (gfc_match (" )") != MATCH_YES)
+    {
+      gfc_error ("expected ')' at %C");
+      return MATCH_ERROR;
+    }
+
+  for (;;)
+    {
+      if (gfc_match (" match") != MATCH_YES)
+	{
+	  if (first_p)
+	    {
+	      gfc_error ("expected 'match' at %C");
+	      return MATCH_ERROR;
+	    }
+	  else
+	    break;
+	}
+
+      if (gfc_match (" (") != MATCH_YES)
+	{
+	  gfc_error ("expected '(' at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
+	return MATCH_ERROR;
+
+      if (gfc_match (" )") != MATCH_YES)
+	{
+	  gfc_error ("expected ')' at %C");
+	  return MATCH_ERROR;
+	}
+
+      first_p = false;
+    }
+
+  return MATCH_YES;
+}
+
+
 match
 gfc_match_omp_threadprivate (void)
 {
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 016b704..3499a1c 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -260,7 +260,7 @@ gfc_post_options (const char **pfilename)
      If not enabled explicitly by the user, only warn for -I
      and -J, otherwise warn for all include paths.  */
   verbose_missing_dir_warn
-    = (global_options_set.x_cpp_warn_missing_include_dirs
+    = (OPTION_SET_P (cpp_warn_missing_include_dirs)
        && global_options.x_cpp_warn_missing_include_dirs);
   SET_OPTION_IF_UNSET (&global_options, &global_options_set,
 		       cpp_warn_missing_include_dirs, 1);
@@ -309,7 +309,7 @@ gfc_post_options (const char **pfilename)
     flag_dump_fortran_original = 0;
 
   /* Make -fmax-errors visible to gfortran's diagnostic machinery.  */
-  if (global_options_set.x_flag_max_errors)
+  if (OPTION_SET_P (flag_max_errors))
     gfc_option.max_errors = flag_max_errors;
 
   /* Verify the input file name.  */
@@ -388,7 +388,7 @@ gfc_post_options (const char **pfilename)
 
       /* Enable -Werror=line-truncation when -Werror and -Wno-error have
 	 not been set.  */
-      if (warn_line_truncation && !global_options_set.x_warnings_are_errors
+      if (warn_line_truncation && !OPTION_SET_P (warnings_are_errors)
 	  && (global_dc->classify_diagnostic[OPT_Wline_truncation] ==
 	      DK_UNSPECIFIED))
 	diagnostic_classify_diagnostic (global_dc, OPT_Wline_truncation,
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7d765a0..b1e73ee 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -26,6 +26,8 @@ along with GCC; see the file COPYING3.  If not see
 #include <setjmp.h>
 #include "match.h"
 #include "parse.h"
+#include "tree-core.h"
+#include "omp-general.h"
 
 /* Current statement label.  Zero means no statement label.  Because new_st
    can get wiped during statement matching, we have to keep it separate.  */
@@ -860,6 +862,8 @@ decode_omp_directive (void)
 	       ST_OMP_DECLARE_SIMD);
       matchdo ("declare target", gfc_match_omp_declare_target,
 	       ST_OMP_DECLARE_TARGET);
+      matchdo ("declare variant", gfc_match_omp_declare_variant,
+	       ST_OMP_DECLARE_VARIANT);
       break;
     case 's':
       matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
@@ -1718,6 +1722,7 @@ next_statement (void)
 
 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
   case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
+  case ST_OMP_DECLARE_VARIANT: \
   case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
 
 /* Block end statements.  Errors associated with interchanging these
@@ -2361,6 +2366,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_OMP_DECLARE_TARGET:
       p = "!$OMP DECLARE TARGET";
       break;
+    case ST_OMP_DECLARE_VARIANT:
+      p = "!$OMP DECLARE VARIANT";
+      break;
     case ST_OMP_DEPOBJ:
       p = "!$OMP DEPOBJ";
       break;
@@ -5451,7 +5459,7 @@ parse_oacc_loop (gfc_statement acc_st)
 
 /* Parse the statements of an OpenMP structured block.  */
 
-static void
+static gfc_statement
 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 {
   gfc_statement st, omp_end_st;
@@ -5538,6 +5546,32 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
       gcc_unreachable ();
     }
 
+  bool block_construct = false;
+  gfc_namespace *my_ns = NULL;
+  gfc_namespace *my_parent = NULL;
+
+  st = next_statement ();
+
+  if (st == ST_BLOCK)
+    {
+      /* Adjust state to a strictly-structured block, now that we found that
+	 the body starts with a BLOCK construct.  */
+      s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
+
+      block_construct = true;
+      gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
+
+      my_ns = gfc_build_block_ns (gfc_current_ns);
+      gfc_current_ns = my_ns;
+      my_parent = my_ns->parent;
+
+      new_st.op = EXEC_BLOCK;
+      new_st.ext.block.ns = my_ns;
+      new_st.ext.block.assoc = NULL;
+      accept_statement (ST_BLOCK);
+      st = parse_spec (ST_NONE);
+    }
+
   do
     {
       if (workshare_stmts_only)
@@ -5554,7 +5588,6 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 	     restrictions apply recursively.  */
 	  bool cycle = true;
 
-	  st = next_statement ();
 	  for (;;)
 	    {
 	      switch (st)
@@ -5580,13 +5613,13 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 		case ST_OMP_PARALLEL_MASKED:
 		case ST_OMP_PARALLEL_MASTER:
 		case ST_OMP_PARALLEL_SECTIONS:
-		  parse_omp_structured_block (st, false);
-		  break;
+		  st = parse_omp_structured_block (st, false);
+		  continue;
 
 		case ST_OMP_PARALLEL_WORKSHARE:
 		case ST_OMP_CRITICAL:
-		  parse_omp_structured_block (st, true);
-		  break;
+		  st = parse_omp_structured_block (st, true);
+		  continue;
 
 		case ST_OMP_PARALLEL_DO:
 		case ST_OMP_PARALLEL_DO_SIMD:
@@ -5609,7 +5642,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 	    }
 	}
       else
-	st = parse_executable (ST_NONE);
+	st = parse_executable (st);
       if (st == ST_NONE)
 	unexpected_eof ();
       else if (st == ST_OMP_SECTION
@@ -5619,9 +5652,27 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 	  np = new_level (np);
 	  np->op = cp->op;
 	  np->block = NULL;
+	  st = next_statement ();
+	}
+      else if (block_construct && st == ST_END_BLOCK)
+	{
+	  accept_statement (st);
+	  gfc_current_ns = my_parent;
+	  pop_state ();
+
+	  st = next_statement ();
+	  if (st == omp_end_st)
+	    {
+	      accept_statement (st);
+	      st = next_statement ();
+	    }
+	  return st;
 	}
       else if (st != omp_end_st)
-	unexpected_statement (st);
+	{
+	  unexpected_statement (st);
+	  st = next_statement ();
+	}
     }
   while (st != omp_end_st);
 
@@ -5657,6 +5708,8 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
   gfc_commit_symbols ();
   gfc_warning_check ();
   pop_state ();
+  st = next_statement ();
+  return st;
 }
 
 
@@ -5797,13 +5850,13 @@ parse_executable (gfc_statement st)
 	case ST_OMP_TEAMS:
 	case ST_OMP_TASK:
 	case ST_OMP_TASKGROUP:
-	  parse_omp_structured_block (st, false);
-	  break;
+	  st = parse_omp_structured_block (st, false);
+	  continue;
 
 	case ST_OMP_WORKSHARE:
 	case ST_OMP_PARALLEL_WORKSHARE:
-	  parse_omp_structured_block (st, true);
-	  break;
+	  st = parse_omp_structured_block (st, true);
+	  continue;
 
 	case ST_OMP_DISTRIBUTE:
 	case ST_OMP_DISTRIBUTE_PARALLEL_DO:
@@ -6793,6 +6846,24 @@ done:
        gfc_current_ns = gfc_current_ns->sibling)
     gfc_check_omp_requires (gfc_current_ns, omp_requires);
 
+  /* Populate omp_requires_mask (needed for resolving OpenMP
+     metadirectives and declare variant).  */
+  switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+    {
+    case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
+      omp_requires_mask
+	= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
+      break;
+    case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
+      omp_requires_mask
+	= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
+      break;
+    case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
+      omp_requires_mask
+	= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
+      break;
+    }
+
   /* Do the parse tree dump.  */
   gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
 
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 55f0229..66b275d 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -31,7 +31,7 @@ enum gfc_compile_state
   COMP_STRUCTURE, COMP_UNION, COMP_MAP,
   COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
   COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL,
-  COMP_DO_CONCURRENT
+  COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK
 };
 
 /* Stack element for the current compilation state.  These structures
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 56a78d6..d873264 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2627,7 +2627,7 @@ check_substring:
 symbol_attribute
 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 {
-  int dimension, codimension, pointer, allocatable, target;
+  int dimension, codimension, pointer, allocatable, target, optional;
   symbol_attribute attr;
   gfc_ref *ref;
   gfc_symbol *sym;
@@ -2640,12 +2640,14 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   sym = expr->symtree->n.sym;
   attr = sym->attr;
 
+  optional = attr.optional;
   if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
     {
       dimension = CLASS_DATA (sym)->attr.dimension;
       codimension = CLASS_DATA (sym)->attr.codimension;
       pointer = CLASS_DATA (sym)->attr.class_pointer;
       allocatable = CLASS_DATA (sym)->attr.allocatable;
+      optional |= CLASS_DATA (sym)->attr.optional;
     }
   else
     {
@@ -2667,6 +2669,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
     if (ref->type == REF_INQUIRY)
       {
 	has_inquiry_part = true;
+	optional = false;
 	break;
       }
 
@@ -2684,12 +2687,13 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	  case AR_SECTION:
 	    allocatable = pointer = 0;
 	    dimension = 1;
+	    optional = false;
 	    break;
 
 	  case AR_ELEMENT:
 	    /* Handle coarrays.  */
 	    if (ref->u.ar.dimen > 0)
-	      allocatable = pointer = 0;
+	      allocatable = pointer = optional = false;
 	    break;
 
 	  case AR_UNKNOWN:
@@ -2702,6 +2706,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	break;
 
       case REF_COMPONENT:
+	optional = false;
 	comp = ref->u.c.component;
 	attr = comp->attr;
 	if (ts != NULL && !has_inquiry_part)
@@ -2723,7 +2728,10 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	else
 	  {
 	    codimension = comp->attr.codimension;
-	    pointer = comp->attr.pointer;
+	    if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0)
+	      pointer = comp->attr.class_pointer;
+	    else
+	      pointer = comp->attr.pointer;
 	    allocatable = comp->attr.allocatable;
 	  }
 	if (pointer || attr.proc_pointer)
@@ -2733,7 +2741,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 
       case REF_INQUIRY:
       case REF_SUBSTRING:
-	allocatable = pointer = 0;
+	allocatable = pointer = optional = false;
 	break;
       }
 
@@ -2743,6 +2751,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   attr.allocatable = allocatable;
   attr.target = target;
   attr.save = sym->attr.save;
+  attr.optional = optional;
 
   return attr;
 }
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0d0af39..af71b13 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1454,6 +1454,41 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	    }
 	}
 
+      /* Validate shape, except for dynamic or PDT arrays.  */
+      if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
+	  && comp->as && !comp->attr.allocatable && !comp->attr.pointer
+	  && !comp->attr.pdt_array)
+	{
+	  mpz_t len;
+	  mpz_init (len);
+	  for (int n = 0; n < rank; n++)
+	    {
+	      if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
+		  || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
+		{
+		  gfc_error ("Bad array spec of component %qs referenced in "
+			     "structure constructor at %L",
+			     comp->name, &cons->expr->where);
+		  t = false;
+		  break;
+		};
+	      mpz_set_ui (len, 1);
+	      mpz_add (len, len, comp->as->upper[n]->value.integer);
+	      mpz_sub (len, len, comp->as->lower[n]->value.integer);
+	      if (mpz_cmp (cons->expr->shape[n], len) != 0)
+		{
+		  gfc_error ("The shape of component %qs in the structure "
+			     "constructor at %L differs from the shape of the "
+			     "declared component for dimension %d (%ld/%ld)",
+			     comp->name, &cons->expr->where, n+1,
+			     mpz_get_si (cons->expr->shape[n]),
+			     mpz_get_si (len));
+		  t = false;
+		}
+	    }
+	  mpz_clear (len);
+	}
+
       if (!comp->attr.pointer || comp->attr.proc_pointer
 	  || cons->expr->expr_type == EXPR_NULL)
 	continue;
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index f40e493..d675f2c 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -6840,7 +6840,13 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
       gfc_extract_int (e, &shape[rank]);
 
       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
-      gcc_assert (shape[rank] >= 0);
+      if (shape[rank] < 0)
+	{
+	  gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
+		     "negative value %d for dimension %d",
+		     &shape_exp->where, shape[rank], rank+1);
+	  return &gfc_bad_expr;
+	}
 
       rank++;
     }
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6d61bf4..c77f3f8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -720,6 +720,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (pdt_len, pointer)
   conf (pdt_len, dimension)
   conf (pdt_len, codimension)
+  conf (pdt_len, pdt_kind)
 
   if (attr->access == ACCESS_PRIVATE)
     {
@@ -4046,6 +4047,7 @@ gfc_free_namespace (gfc_namespace *ns)
   free_tb_tree (ns->tb_uop_root);
   gfc_free_finalizer_list (ns->finalizers);
   gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
+  gfc_free_omp_declare_variant_list (ns->omp_declare_variant);
   gfc_free_charlen (ns->cl_list, NULL);
   free_st_labels (ns->st_labels);
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index e2f59e0..bceb8b2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -103,6 +103,111 @@ gfc_array_dataptr_type (tree desc)
   return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
 }
 
+/* Build expressions to access members of the CFI descriptor.  */
+#define CFI_FIELD_BASE_ADDR 0
+#define CFI_FIELD_ELEM_LEN 1
+#define CFI_FIELD_VERSION 2
+#define CFI_FIELD_RANK 3
+#define CFI_FIELD_ATTRIBUTE 4
+#define CFI_FIELD_TYPE 5
+#define CFI_FIELD_DIM 6
+
+#define CFI_DIM_FIELD_LOWER_BOUND 0
+#define CFI_DIM_FIELD_EXTENT 1
+#define CFI_DIM_FIELD_SM 2
+
+static tree
+gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
+{
+  tree type = TREE_TYPE (desc);
+  gcc_assert (TREE_CODE (type) == RECORD_TYPE
+	      && TYPE_FIELDS (type)
+	      && (strcmp ("base_addr",
+			 IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
+		  == 0));
+  tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
+  gcc_assert (field != NULL_TREE);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+tree
+gfc_get_cfi_desc_base_addr (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
+}
+
+tree
+gfc_get_cfi_desc_elem_len (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
+}
+
+tree
+gfc_get_cfi_desc_version (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
+}
+
+tree
+gfc_get_cfi_desc_rank (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
+}
+
+tree
+gfc_get_cfi_desc_type (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
+}
+
+tree
+gfc_get_cfi_desc_attribute (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
+}
+
+static tree
+gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
+{
+  tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
+  tmp = gfc_build_array_ref (tmp, idx, NULL);
+  tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
+  gcc_assert (field != NULL_TREE);
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  tmp, field, NULL_TREE);
+}
+
+tree
+gfc_get_cfi_dim_lbound (tree desc, tree idx)
+{
+  return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
+}
+
+tree
+gfc_get_cfi_dim_extent (tree desc, tree idx)
+{
+  return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
+}
+
+tree
+gfc_get_cfi_dim_sm (tree desc, tree idx)
+{
+  return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
+}
+
+#undef CFI_FIELD_BASE_ADDR
+#undef CFI_FIELD_ELEM_LEN
+#undef CFI_FIELD_VERSION
+#undef CFI_FIELD_RANK
+#undef CFI_FIELD_ATTRIBUTE
+#undef CFI_FIELD_TYPE
+#undef CFI_FIELD_DIM
+
+#undef CFI_DIM_FIELD_LOWER_BOUND
+#undef CFI_DIM_FIELD_EXTENT
+#undef CFI_DIM_FIELD_SM
 
 /* Build expressions to access the members of an array descriptor.
    It's surprisingly easy to mess up here, so never access
@@ -289,6 +394,20 @@ gfc_conv_descriptor_attribute (tree desc)
 }
 
 tree
+gfc_conv_descriptor_type (tree desc)
+{
+  tree tmp;
+  tree dtype;
+
+  dtype = gfc_conv_descriptor_dtype (desc);
+  tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
+  gcc_assert (tmp!= NULL_TREE
+	      && TREE_TYPE (tmp) == signed_char_type_node);
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+			  dtype, tmp, NULL_TREE);
+}
+
+tree
 gfc_get_descriptor_dimension (tree desc)
 {
   tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
@@ -825,7 +944,11 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
 {
   tree tmp;
 
-  if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL))
+  if (is_pointer_array (desc)
+      || (get_CFI_desc (NULL, expr, &desc, NULL)
+	  && (POINTER_TYPE_P (TREE_TYPE (desc))
+	      ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
+	      : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
     {
       if (POINTER_TYPE_P (TREE_TYPE (desc)))
 	desc = build_fold_indirect_ref_loc (input_location, desc);
@@ -833,6 +956,14 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
       /* This will have the span field set.  */
       tmp = gfc_conv_descriptor_span_get (desc);
     }
+  else if (expr->ts.type == BT_ASSUMED)
+    {
+      if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
+	desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
+      if (POINTER_TYPE_P (TREE_TYPE (desc)))
+	desc = build_fold_indirect_ref_loc (input_location, desc);
+      tmp = gfc_conv_descriptor_span_get (desc);
+    }
   else if (TREE_CODE (desc) == COMPONENT_REF
 	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
 	   && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
@@ -4376,6 +4507,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	    case GFC_ISYM_UBOUND:
 	    case GFC_ISYM_LCOBOUND:
 	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_SHAPE:
 	    case GFC_ISYM_THIS_IMAGE:
 	      loop->dimen = ss->dimen;
 	      goto done;
@@ -4427,12 +4559,14 @@ done:
 	    /* Fall through to supply start and stride.  */
 	    case GFC_ISYM_LBOUND:
 	    case GFC_ISYM_UBOUND:
+	      /* This is the variant without DIM=...  */
+	      gcc_assert (expr->value.function.actual->next->expr == NULL);
+	      /* Fall through.  */
+
+	    case GFC_ISYM_SHAPE:
 	      {
 		gfc_expr *arg;
 
-		/* This is the variant without DIM=...  */
-		gcc_assert (expr->value.function.actual->next->expr == NULL);
-
 		arg = expr->value.function.actual->expr;
 		if (arg->rank == -1)
 		  {
@@ -5219,10 +5353,13 @@ set_loop_bounds (gfc_loopinfo *loop)
 		gfc_expr *expr = loopspec[n]->info->expr;
 
 		/* The {l,u}bound of an assumed rank.  */
-		gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
-			     || expr->value.function.isym->id == GFC_ISYM_UBOUND)
-			     && expr->value.function.actual->next->expr == NULL
-			     && expr->value.function.actual->expr->rank == -1);
+		if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
+		  gcc_assert (expr->value.function.actual->expr->rank == -1);
+		else
+		  gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
+			       || expr->value.function.isym->id == GFC_ISYM_UBOUND)
+			      && expr->value.function.actual->next->expr == NULL
+			      && expr->value.function.actual->expr->rank == -1);
 
 		loop->to[n] = info->end[dim];
 		break;
@@ -6286,7 +6423,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
 /* Generate code to evaluate non-constant array bounds.  Sets *poffset and
    returns the size (in elements) of the array.  */
 
-static tree
+tree
 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
                         stmtblock_t * pblock)
 {
@@ -6549,7 +6686,9 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
 
   /* Add the initialization code to the start of the function.  */
 
-  if (sym->attr.optional || sym->attr.not_always_present)
+  if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+      || sym->attr.optional
+      || sym->attr.not_always_present)
     {
       tree nullify;
       if (TREE_CODE (parm) != PARM_DECL)
@@ -7753,6 +7892,15 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       tmp = gfc_conv_descriptor_dtype (parm);
       if (se->unlimited_polymorphic)
 	dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
+      else if (expr->ts.type == BT_ASSUMED)
+	{
+	  tree tmp2 = desc;
+	  if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
+	    tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
+	  if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
+	    tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+	  dtype = gfc_conv_descriptor_dtype (tmp2);
+	}
       else
 	dtype = gfc_get_dtype (parmtype);
       gfc_add_modify (&loop.pre, tmp, dtype);
@@ -9004,7 +9152,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  DECL_ARTIFICIAL (cdesc) = 1;
 
 	  gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
-	  		  gfc_get_dtype_rank_type (1, tmp));
+			  gfc_get_dtype_rank_type (1, tmp));
 	  gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
 					  gfc_index_zero_node,
 					  gfc_index_one_node);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 85ff216..1d3dc48 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -160,7 +160,8 @@ tree gfc_conv_array_stride (tree, int);
 tree gfc_conv_array_lbound (tree, int);
 tree gfc_conv_array_ubound (tree, int);
 
-/* Set cobounds of an array.  */
+/* Set (co)bounds of an array.  */
+tree gfc_trans_array_bounds (tree, gfc_symbol *, tree *, stmtblock_t *);
 void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *);
 
 /* Build expressions for accessing components of an array descriptor.  */
@@ -175,6 +176,7 @@ tree gfc_conv_descriptor_dtype (tree);
 tree gfc_conv_descriptor_rank (tree);
 tree gfc_conv_descriptor_elem_len (tree);
 tree gfc_conv_descriptor_attribute (tree);
+tree gfc_conv_descriptor_type (tree);
 tree gfc_get_descriptor_dimension (tree);
 tree gfc_conv_descriptor_stride_get (tree, tree);
 tree gfc_conv_descriptor_lbound_get (tree, tree);
@@ -188,6 +190,18 @@ void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
 void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
 void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
 
+/* CFI descriptor.  */
+tree gfc_get_cfi_desc_base_addr (tree);
+tree gfc_get_cfi_desc_elem_len (tree);
+tree gfc_get_cfi_desc_version (tree);
+tree gfc_get_cfi_desc_rank (tree);
+tree gfc_get_cfi_desc_type (tree);
+tree gfc_get_cfi_desc_attribute (tree);
+tree gfc_get_cfi_dim_lbound (tree, tree);
+tree gfc_get_cfi_dim_extent (tree, tree);
+tree gfc_get_cfi_dim_sm (tree, tree);
+
+
 /* Shift lower bound of descriptor, updating ubound and offset.  */
 void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c758d26..49ba906 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -117,8 +117,6 @@ tree gfor_fndecl_fdate;
 tree gfor_fndecl_ttynam;
 tree gfor_fndecl_in_pack;
 tree gfor_fndecl_in_unpack;
-tree gfor_fndecl_cfi_to_gfc;
-tree gfor_fndecl_gfc_to_cfi;
 tree gfor_fndecl_associated;
 tree gfor_fndecl_system_clock4;
 tree gfor_fndecl_system_clock8;
@@ -1303,7 +1301,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
   DECL_EXTERNAL (decl) = 0;
 
   /* Avoid uninitialized warnings for optional dummy arguments.  */
-  if (sym->attr.optional)
+  if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+      || sym->attr.optional)
     suppress_warning (decl);
 
   /* We should never get deferred shape arrays here.  We used to because of
@@ -1547,6 +1546,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	      || (sym->module && sym->attr.if_source != IFSRC_DECL
 		  && sym->backend_decl));
 
+  if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c
+      && is_CFI_desc (sym, NULL))
+    {
+      gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER
+					|| sym->ts.u.cl->backend_decl));
+      return sym->backend_decl;
+    }
+
   if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
     byref = gfc_return_by_reference (sym->ns->proc_name);
   else
@@ -1594,9 +1601,6 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
     }
 
-  if (is_CFI_desc (sym, NULL))
-    gfc_defer_symbol_init (sym);
-
   fun_or_res = byref && (sym->attr.result
 			 || (sym->attr.function && sym->ts.deferred));
   if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
@@ -2361,9 +2365,13 @@ module_sym:
     pushdecl_top_level (fndecl);
 
   if (sym->formal_ns
-      && sym->formal_ns->proc_name == sym
-      && sym->formal_ns->omp_declare_simd)
-    gfc_trans_omp_declare_simd (sym->formal_ns);
+      && sym->formal_ns->proc_name == sym)
+    {
+      if (sym->formal_ns->omp_declare_simd)
+	gfc_trans_omp_declare_simd (sym->formal_ns);
+      if (flag_openmp)
+	gfc_trans_omp_declare_variant (sym->formal_ns);
+    }
 
   return fndecl;
 }
@@ -2754,9 +2762,19 @@ create_function_arglist (gfc_symbol * sym)
       if (f->sym->attr.volatile_)
 	type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
 
-      /* Build the argument declaration.  */
-      parm = build_decl (input_location,
-			 PARM_DECL, gfc_sym_identifier (f->sym), type);
+      /* Build the argument declaration. For C descriptors, we use a
+	 '_'-prefixed name for the parm_decl and inside the proc the
+	 sym->name. */
+      tree parm_name;
+      if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL))
+	{
+	  strcpy (&name[1], f->sym->name);
+	  name[0] = '_';
+	  parm_name = get_identifier (name);
+	}
+      else
+	parm_name = gfc_sym_identifier (f->sym);
+      parm = build_decl (input_location, PARM_DECL, parm_name, type);
 
       if (f->sym->attr.volatile_)
 	{
@@ -3111,6 +3129,12 @@ gfc_create_function_decl (gfc_namespace * ns, bool global)
 
   if (ns->omp_declare_simd)
     gfc_trans_omp_declare_simd (ns);
+
+  /* Handle 'declare variant' directives.  The applicable directives might
+     be declared in a parent namespace, so this needs to be called even if
+     there are no local directives.  */
+  if (flag_openmp)
+    gfc_trans_omp_declare_variant (ns);
 }
 
 /* Return the decl used to hold the function return value.  If
@@ -3821,19 +3845,6 @@ gfc_build_builtin_function_decls (void)
 	get_identifier (PREFIX("internal_unpack")), ". w R ",
 	void_type_node, 2, pvoid_type_node, pvoid_type_node);
 
-  /* These two builtins write into what the first argument points to and
-     read from what the second argument points to, but we can't use R
-     for that, because the directly pointed structure contains a pointer
-     which is copied into the descriptor pointed by the first argument,
-     effectively escaping that way.  See PR92123.  */
-  gfor_fndecl_cfi_to_gfc = gfc_build_library_function_decl_with_spec (
-	get_identifier (PREFIX("cfi_desc_to_gfc_desc")), ". w . ",
-	void_type_node, 2, pvoid_type_node, ppvoid_type_node);
-
-  gfor_fndecl_gfc_to_cfi = gfc_build_library_function_decl_with_spec (
-	get_identifier (PREFIX("gfc_desc_to_cfi_desc")), ". w . ",
-	void_type_node, 2, ppvoid_type_node, pvoid_type_node);
-
   gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("associated")), ". R R ",
 	integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
@@ -4451,115 +4462,6 @@ gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
 }
 
 
-/* Convert CFI descriptor dummies into gfc types and back again.  */
-static void
-convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
-{
-  tree gfc_desc;
-  tree gfc_desc_ptr;
-  tree CFI_desc;
-  tree CFI_desc_ptr;
-  tree dummy_ptr;
-  tree tmp;
-  tree present;
-  tree incoming;
-  tree outgoing;
-  stmtblock_t outer_block;
-  stmtblock_t tmpblock;
-
-  /* dummy_ptr will be the pointer to the passed array descriptor,
-     while CFI_desc is the descriptor itself.  */
-  if (DECL_LANG_SPECIFIC (sym->backend_decl))
-    CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
-  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (sym->backend_decl))))
-    CFI_desc = sym->backend_decl;
-  else
-    CFI_desc = NULL;
-
-  dummy_ptr = CFI_desc;
-
-  if (CFI_desc)
-    {
-      CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc);
-
-      /* The compiler will have given CFI_desc the correct gfortran
-	 type. Use this new variable to store the converted
-	 descriptor.  */
-      gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc");
-      tmp = build_pointer_type (TREE_TYPE (gfc_desc));
-      gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
-      CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
-
-      /* Fix the condition for the presence of the argument.  */
-      gfc_init_block (&outer_block);
-      present = fold_build2_loc (input_location, NE_EXPR,
-				 logical_type_node, dummy_ptr,
-				 build_int_cst (TREE_TYPE (dummy_ptr), 0));
-
-      gfc_init_block (&tmpblock);
-      /* Pointer to the gfc descriptor.  */
-      gfc_add_modify (&tmpblock, gfc_desc_ptr,
-		      gfc_build_addr_expr (NULL, gfc_desc));
-      /* Store the pointer to the CFI descriptor.  */
-      gfc_add_modify (&tmpblock, CFI_desc_ptr,
-		      fold_convert (pvoid_type_node, dummy_ptr));
-      tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
-      /* Convert the CFI descriptor.  */
-      incoming = build_call_expr_loc (input_location,
-			gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
-      gfc_add_expr_to_block (&tmpblock, incoming);
-      /* Set the dummy pointer to point to the gfc_descriptor.  */
-      gfc_add_modify (&tmpblock, dummy_ptr,
-		      fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
-
-      /* The hidden string length is not passed to bind(C) procedures so set
-	 it from the descriptor element length.  */
-      if (sym->ts.type == BT_CHARACTER
-	  && sym->ts.u.cl->backend_decl
-	  && VAR_P (sym->ts.u.cl->backend_decl))
-	{
-	  tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
-	  tmp = gfc_conv_descriptor_elem_len (tmp);
-	  gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
-			  fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
-				        tmp));
-	}
-
-      /* Check that the argument is present before executing the above.  */
-      incoming = build3_v (COND_EXPR, present,
-			   gfc_finish_block (&tmpblock),
-			   build_empty_stmt (input_location));
-      gfc_add_expr_to_block (&outer_block, incoming);
-      incoming = gfc_finish_block (&outer_block);
-
-      /* Convert the gfc descriptor back to the CFI type before going
-	 out of scope, if the CFI type was present at entry.  */
-      outgoing = NULL_TREE;
-      if ((sym->attr.pointer || sym->attr.allocatable)
-	  && !sym->attr.value
-	  && sym->attr.intent != INTENT_IN)
-	{
-	  gfc_init_block (&outer_block);
-	  gfc_init_block (&tmpblock);
-
-	  tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
-	  outgoing = build_call_expr_loc (input_location,
-					  gfor_fndecl_gfc_to_cfi, 2,
-					  tmp, gfc_desc_ptr);
-	  gfc_add_expr_to_block (&tmpblock, outgoing);
-
-	  outgoing = build3_v (COND_EXPR, present,
-			       gfc_finish_block (&tmpblock),
-			       build_empty_stmt (input_location));
-	  gfc_add_expr_to_block (&outer_block, outgoing);
-	  outgoing = gfc_finish_block (&outer_block);
-	}
-
-      /* Add the lot to the procedure init and finally blocks.  */
-      gfc_add_init_cleanup (block, incoming, outgoing);
-    }
-}
-
 /* Get the result expression for a procedure.  */
 
 static tree
@@ -5136,13 +5038,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	}
       else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
 	gcc_unreachable ();
-
-      /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
-	 as ISO Fortran Interop descriptors. These have to be converted to
-	 gfortran descriptors and back again.  This has to be done here so that
-	 the conversion occurs at the start of the init block.  */
-      if (is_CFI_desc (sym, NULL))
-	convert_CFI_desc (block, sym);
     }
 
   gfc_init_block (&tmpblock);
@@ -6766,6 +6661,795 @@ finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
   return;
 }
 
+static void
+gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
+		     tree cfi_desc, tree gfc_desc, gfc_symbol *sym)
+{
+  stmtblock_t block;
+  gfc_init_block (&block);
+  tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
+  tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
+  bool do_copy_inout = false;
+
+  /* When allocatable + intent out, free the cfi descriptor.  */
+  if (sym->attr.allocatable && sym->attr.intent == INTENT_OUT)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tree call = builtin_decl_explicit (BUILT_IN_FREE);
+      call = build_call_expr_loc (input_location, call, 1, tmp);
+      gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+      gfc_add_modify (&block, tmp,
+		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
+    }
+
+  /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      char *msg;
+      tree tmp3;
+      msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor "
+		       "passed to dummy argument %s", CFI_VERSION, sym->name);
+      tmp2 = gfc_get_cfi_desc_version (cfi);
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
+			     build_int_cst (TREE_TYPE (tmp2), CFI_VERSION));
+      gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+			       msg, tmp2);
+      free (msg);
+
+      /* Rank check; however, for character(len=*), assumed/explicit-size arrays
+	 are permitted to differ in rank according to the Fortran rules.  */
+      if (sym->as && sym->as->type != AS_ASSUMED_SIZE
+	  && sym->as->type != AS_EXPLICIT)
+	{
+	  if (sym->as->rank != -1)
+	    msg = xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor "
+			     "passed to dummy argument %s", sym->as->rank,
+			     sym->name);
+	  else
+	    msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI "
+			     "descriptor passed to dummy argument %s",
+			     CFI_MAX_RANK, sym->name);
+
+	  tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi);
+	  if (sym->as->rank != -1)
+	    tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   tmp, build_int_cst (signed_char_type_node,
+						       sym->as->rank));
+	  else
+	    {
+	      tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				     tmp, build_zero_cst (TREE_TYPE (tmp)));
+	      tmp2 = fold_build2_loc (input_location, GT_EXPR,
+				      boolean_type_node, tmp2,
+				      build_int_cst (TREE_TYPE (tmp2),
+						     CFI_MAX_RANK));
+	      tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				     boolean_type_node, tmp, tmp2);
+	    }
+	  gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+				   msg, tmp3);
+	  free (msg);
+	}
+
+      tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi);
+      if (sym->attr.allocatable || sym->attr.pointer)
+	{
+	  int attr = (sym->attr.pointer ? CFI_attribute_pointer
+					: CFI_attribute_allocatable);
+	  msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI "
+			   "descriptor passed to dummy argument %s with %s "
+			   "attribute", attr, sym->name,
+			   sym->attr.pointer ? "pointer" : "allocatable");
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 tmp, build_int_cst (TREE_TYPE (tmp), attr));
+	}
+      else
+	{
+	  int amin = MIN (CFI_attribute_pointer,
+			  MIN (CFI_attribute_allocatable, CFI_attribute_other));
+	  int amax = MAX (CFI_attribute_pointer,
+			  MAX (CFI_attribute_allocatable, CFI_attribute_other));
+	  msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI "
+			   "descriptor passed to nonallocatable, nonpointer "
+			   "dummy argument %s", amin, amax, sym->name);
+	  tmp2 = tmp;
+	  tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp,
+			     build_int_cst (TREE_TYPE (tmp), amin));
+	  tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2,
+			     build_int_cst (TREE_TYPE (tmp2), amax));
+	  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				 boolean_type_node, tmp, tmp2);
+	  gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+				   msg, tmp3);
+	  free (msg);
+	  msg = xasprintf ("Invalid unallocatated/unassociated CFI "
+			   "descriptor passed to nonallocatable, nonpointer "
+			   "dummy argument %s", sym->name);
+	  tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi),
+	  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				 tmp, null_pointer_node);
+	}
+      gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+			       msg, tmp3);
+      free (msg);
+
+      if (sym->ts.type != BT_ASSUMED)
+	{
+	  int type = CFI_type_other;
+	  if (sym->ts.f90_type == BT_VOID)
+	    {
+	      type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+		      ? CFI_type_cfunptr : CFI_type_cptr);
+	    }
+	  else
+	    switch (sym->ts.type)
+	      {
+		case BT_INTEGER:
+		case BT_LOGICAL:
+		case BT_REAL:
+		case BT_COMPLEX:
+		  type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind);
+		  break;
+		case BT_CHARACTER:
+		  type = CFI_type_from_type_kind (CFI_type_Character,
+						  sym->ts.kind);
+		  break;
+		case BT_DERIVED:
+		  type = CFI_type_struct;
+		  break;
+		case BT_VOID:
+		  type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+			? CFI_type_cfunptr : CFI_type_cptr);
+		  break;
+		case BT_ASSUMED:
+		case BT_CLASS:
+		case BT_PROCEDURE:
+		case BT_HOLLERITH:
+		case BT_UNION:
+		case BT_BOZ:
+		case BT_UNKNOWN:
+		  gcc_unreachable ();
+	    }
+	  msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor"
+			   " passed to dummy argument %s", type, sym->name);
+	  tmp2 = tmp = gfc_get_cfi_desc_type (cfi);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 tmp, build_int_cst (TREE_TYPE (tmp), type));
+	  gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+			       msg, tmp2);
+	  free (msg);
+	}
+    }
+
+  if (!sym->attr.referenced)
+    goto done;
+
+  /* Set string length for len=* and len=:, otherwise, it is already set.  */
+  if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
+    {
+      tmp = fold_convert (gfc_array_index_type,
+			  gfc_get_cfi_desc_elem_len (cfi));
+      if (sym->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			       gfc_array_index_type, tmp,
+			       build_int_cst (gfc_charlen_type_node,
+					      sym->ts.kind));
+      gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp);
+    }
+
+  if (sym->ts.type == BT_CHARACTER
+      && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+    {
+      gfc_conv_string_length (sym->ts.u.cl, NULL, init);
+      gfc_trans_vla_type_sizes (sym, init);
+    }
+
+  /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr.
+     assumed-size/explicit-size arrays end up here for character(len=*)
+     only. */
+  if (!sym->attr.dimension || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, gfc_desc,
+		      fold_convert (TREE_TYPE (gfc_desc), tmp));
+      if (!sym->attr.dimension)
+	goto done;
+    }
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+    {
+      /* gfc->dtype = ... (from declaration, not from cfi).  */
+      etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
+      gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
+		      gfc_get_dtype_rank_type (sym->as->rank, etype));
+      /* gfc->data = cfi->base_addr. */
+      gfc_conv_descriptor_data_set (&block, gfc_desc,
+				    gfc_get_cfi_desc_base_addr (cfi));
+    }
+
+  if (sym->ts.type == BT_ASSUMED)
+    {
+      /* For type(*), take elem_len + dtype.type from the actual argument.  */
+      gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
+		      gfc_get_cfi_desc_elem_len (cfi));
+      tree cond;
+      tree ctype = gfc_get_cfi_desc_type (cfi);
+      ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
+			       ctype, build_int_cst (TREE_TYPE (ctype),
+						     CFI_type_mask));
+      tree type = gfc_conv_descriptor_type (gfc_desc);
+
+      /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN  */
+      /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+			      build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+			     build_int_cst (TREE_TYPE (type), BT_VOID));
+      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			      type,
+			      build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (CFI_type_struct) BT_DERIVED else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+			      build_int_cst (TREE_TYPE (ctype),
+					     CFI_type_struct));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+			     build_int_cst (TREE_TYPE (type), BT_DERIVED));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (CFI_type_Character) BT_CHARACTER else  < tmp2 >  */
+      /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
+	 before (see below, as generated bottom up).  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+			      build_int_cst (TREE_TYPE (ctype),
+			      CFI_type_Character));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+			     build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (CFI_type_ucs4_char) BT_CHARACTER else  < tmp2 >  */
+      /* Note: gfc->elem_len = cfi->elem_len/4.  */
+      /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
+	 gfc->elem_len == cfi->elem_len, which helps with operations which use
+	 sizeof() in Fortran and cfi->elem_len in C.  */
+      tmp = gfc_get_cfi_desc_type (cfi);
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+			      build_int_cst (TREE_TYPE (tmp),
+					     CFI_type_ucs4_char));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+			     build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+			      build_int_cst (TREE_TYPE (ctype),
+			      CFI_type_Complex));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+			     build_int_cst (TREE_TYPE (type), BT_COMPLEX));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
+	   ctype else  <tmp2>  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+			      build_int_cst (TREE_TYPE (ctype),
+					     CFI_type_Integer));
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+			      build_int_cst (TREE_TYPE (ctype),
+					     CFI_type_Logical));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+			      build_int_cst (TREE_TYPE (ctype),
+					     CFI_type_Real));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     type, fold_convert (TREE_TYPE (type), ctype));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      gfc_add_expr_to_block (&block, tmp2);
+    }
+
+  if (sym->as->rank < 0)
+    {
+      /* Set gfc->dtype.rank, if assumed-rank.  */
+      rank = gfc_get_cfi_desc_rank (cfi);
+      gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank);
+    }
+  else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+    /* In that case, the CFI rank and the declared rank can differ.  */
+    rank = gfc_get_cfi_desc_rank (cfi);
+  else
+    rank = build_int_cst (signed_char_type_node, sym->as->rank);
+
+  /* With bind(C), the standard requires that both Fortran callers and callees
+     handle noncontiguous arrays passed to an dummy with 'contiguous' attribute
+     and with character(len=*) + assumed-size/explicit-size arrays.
+     cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */
+  if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length
+       && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT))
+      || sym->attr.contiguous)
+    {
+      do_copy_inout = true;
+      gcc_assert (!sym->attr.pointer);
+      stmtblock_t block2;
+      tree data;
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+	data = gfc_conv_descriptor_data_get (gfc_desc);
+      else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
+	data = gfc_build_addr_expr (NULL, gfc_desc);
+      else
+	data = gfc_desc;
+
+      /* Is copy-in/out needed? */
+      /* do_copyin = rank != 0 && !assumed-size */
+      tree cond_var = gfc_create_var (boolean_type_node, "do_copyin");
+      tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   rank, build_zero_cst (TREE_TYPE (rank)));
+      /* dim[rank-1].extent != -1 -> assumed size*/
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (rank),
+			     rank, build_int_cst (TREE_TYPE (rank), 1));
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      gfc_get_cfi_dim_extent (cfi, tmp),
+			      build_int_cst (gfc_array_index_type, -1));
+      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			      boolean_type_node, cond, tmp);
+      gfc_add_modify (&block, cond_var, cond);
+      /* if (do_copyin) do_copyin = ... || ... || ... */
+      gfc_init_block (&block2);
+      /* dim[0].sm != elem_len */
+      tmp = fold_convert (gfc_array_index_type,
+			  gfc_get_cfi_desc_elem_len (cfi));
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      gfc_get_cfi_dim_sm (cfi, gfc_index_zero_node),
+			      tmp);
+      gfc_add_modify (&block2, cond_var, cond);
+
+      /* for (i = 1; i < rank; ++i)
+	   cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */
+      idx = gfc_create_var (TREE_TYPE (rank), "idx");
+      stmtblock_t loop_body;
+      gfc_init_block (&loop_body);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
+			     idx, build_int_cst (TREE_TYPE (idx), 1));
+      tree tmp2 = gfc_get_cfi_dim_sm (cfi, tmp);
+      tmp = gfc_get_cfi_dim_extent (cfi, tmp);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+			     tmp2, tmp);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     gfc_get_cfi_dim_sm (cfi, idx), tmp);
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond_var, cond);
+      gfc_add_modify (&loop_body, cond_var, cond);
+      gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
+			  rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+			  gfc_finish_block (&loop_body));
+      tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* Copy-in body.  */
+      gfc_init_block (&block2);
+      /* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */
+      size_var = gfc_create_var (size_type_node, "size");
+      tmp = fold_convert (size_type_node,
+			  gfc_get_cfi_dim_extent (cfi, gfc_index_zero_node));
+      gfc_add_modify (&block2, size_var, tmp);
+
+      gfc_init_block (&loop_body);
+      tmp = fold_convert (size_type_node,
+			  gfc_get_cfi_dim_extent (cfi, idx));
+      tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			     size_var, fold_convert (size_type_node, tmp));
+      gfc_add_modify (&loop_body, size_var, tmp);
+      gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
+			  rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+			  gfc_finish_block (&loop_body));
+      /* data = malloc (size * elem_len) */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			     size_var, gfc_get_cfi_desc_elem_len (cfi));
+      tree call = builtin_decl_explicit (BUILT_IN_MALLOC);
+      call = build_call_expr_loc (input_location, call, 1, tmp);
+      gfc_add_modify (&block2, data, fold_convert (TREE_TYPE (data), call));
+
+      /* Copy the data:
+	 for (idx = 0; idx < size; ++idx)
+	   {
+	     shift = 0;
+	     tmpidx = idx
+	     for (dim = 0; dim < rank; ++dim)
+		{
+		  shift += (tmpidx % extent[d]) * sm[d]
+		  tmpidx = tmpidx / extend[d]
+		}
+	     memcpy (lhs + idx*elem_len, rhs + shift, elem_len)
+	   } .*/
+      idx = gfc_create_var (size_type_node, "arrayidx");
+      gfc_init_block (&loop_body);
+      tree shift = gfc_create_var (size_type_node, "shift");
+      tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
+      gfc_add_modify (&loop_body, shift, build_zero_cst (TREE_TYPE (shift)));
+      gfc_add_modify (&loop_body, tmpidx, idx);
+      stmtblock_t inner_loop;
+      gfc_init_block (&inner_loop);
+      tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
+      /* shift += (tmpidx % extent[d]) * sm[d] */
+      tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+			     size_type_node, tmpidx,
+			     fold_convert (size_type_node,
+					   gfc_get_cfi_dim_extent (cfi, dim)));
+      tmp = fold_build2_loc (input_location, MULT_EXPR,
+			     size_type_node, tmp,
+			     fold_convert (size_type_node,
+					   gfc_get_cfi_dim_sm (cfi, dim)));
+      gfc_add_modify (&inner_loop, shift,
+		      fold_build2_loc (input_location, PLUS_EXPR,
+				       size_type_node, shift, tmp));
+      /* tmpidx = tmpidx / extend[d] */
+      tmp = fold_convert (size_type_node, gfc_get_cfi_dim_extent (cfi, dim));
+      gfc_add_modify (&inner_loop, tmpidx,
+		      fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+				       size_type_node, tmpidx, tmp));
+      gfc_simple_for_loop (&loop_body, dim, build_zero_cst (TREE_TYPE (rank)),
+			   rank, LT_EXPR, build_int_cst (TREE_TYPE (dim), 1),
+			   gfc_finish_block (&inner_loop));
+      /* Assign.  */
+      tmp = fold_convert (pchar_type_node, gfc_get_cfi_desc_base_addr (cfi));
+      tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
+      tree lhs;
+      /* memcpy (lhs + idx*elem_len, rhs + shift, elem_len)  */
+      tree elem_len;
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+	elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
+      else
+	elem_len = gfc_get_cfi_desc_elem_len (cfi);
+      lhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			     elem_len, idx);
+      lhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pchar_type_node,
+			     fold_convert (pchar_type_node, data), lhs);
+      tmp = fold_convert (pvoid_type_node, tmp);
+      lhs = fold_convert (pvoid_type_node, lhs);
+      call = builtin_decl_explicit (BUILT_IN_MEMCPY);
+      call = build_call_expr_loc (input_location, call, 3, lhs, tmp, elem_len);
+      gfc_add_expr_to_block (&loop_body, fold_convert (void_type_node, call));
+      gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+			   size_var, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+			   gfc_finish_block (&loop_body));
+      /* if (cond) { block2 }  */
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     data, fold_convert (TREE_TYPE (data),
+						 null_pointer_node));
+      tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+    {
+      tree offset, type;
+      type = TREE_TYPE (gfc_desc);
+      gfc_trans_array_bounds (type, sym, &offset, &block);
+      if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
+	gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+      goto done;
+    }
+
+  /* If cfi->data != NULL. */
+  stmtblock_t block2;
+  gfc_init_block (&block2);
+
+  /* if do_copy_inout:  gfc->dspan = gfc->dtype.elem_len
+     We use gfc instead of cfi on the RHS as this might be a constant.  */
+  tmp = fold_convert (gfc_array_index_type,
+		      gfc_conv_descriptor_elem_len (gfc_desc));
+  if (!do_copy_inout)
+    {
+      /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len)
+		       ? cfi->dim[0].sm : gfc->elem_len).  */
+      tree cond;
+      tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+      cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+			      gfc_array_index_type, tmp2, tmp);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      cond, gfc_index_zero_node);
+      tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+			tmp2, tmp);
+    }
+  gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp);
+
+  /* Calculate offset + set lbound, ubound and stride.  */
+  gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node);
+  if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable)
+    for (int i = 0; i < sym->as->rank; ++i)
+      {
+	gfc_se se;
+	gfc_init_se (&se, NULL );
+	if (sym->as->lower[i])
+	  {
+	    gfc_conv_expr (&se, sym->as->lower[i]);
+	    tmp = se.expr;
+	  }
+	else
+	  tmp = gfc_index_one_node;
+	gfc_add_block_to_block (&block2, &se.pre);
+	gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i],
+					tmp);
+	gfc_add_block_to_block (&block2, &se.post);
+      }
+
+  /* Loop: for (i = 0; i < rank; ++i).  */
+  idx = gfc_create_var (TREE_TYPE (rank), "idx");
+
+  /* Loop body.  */
+  stmtblock_t loop_body;
+  gfc_init_block (&loop_body);
+  /* gfc->dim[i].lbound = ... */
+  if (sym->attr.pointer || sym->attr.allocatable)
+    {
+      tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+      gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp);
+    }
+  else if (sym->as->rank < 0)
+    gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx,
+				    gfc_index_one_node);
+
+  /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_lbound_get (gfc_desc, idx),
+			     gfc_index_one_node);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     gfc_get_cfi_dim_extent (cfi, idx), tmp);
+  gfc_conv_descriptor_ubound_set (&loop_body, gfc_desc, idx, tmp);
+
+  if (do_copy_inout)
+    {
+      /* gfc->dim[i].stride
+	   = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
+      tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				   idx, build_zero_cst (TREE_TYPE (idx)));
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
+			     idx, build_int_cst (TREE_TYPE (idx), 1));
+      tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp);
+      tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2),
+			     tmp2, tmp);
+      tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+			gfc_index_one_node, tmp);
+    }
+  else
+    {
+      /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+      tmp = gfc_get_cfi_dim_sm (cfi, idx);
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type, tmp,
+			     fold_convert (gfc_array_index_type,
+					   gfc_get_cfi_desc_elem_len (cfi)));
+     }
+  gfc_conv_descriptor_stride_set (&loop_body, gfc_desc, idx, tmp);
+  /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc_desc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_offset_get (gfc_desc), tmp);
+  gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp);
+
+  /* Generate loop.  */
+  gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+		       rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+		       gfc_finish_block (&loop_body));
+  if (sym->attr.allocatable || sym->attr.pointer)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi),
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, null_pointer_node);
+      tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  else
+    gfc_add_block_to_block (&block, &block2);
+
+done:
+  /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'.  */
+  if (sym->attr.optional)
+    {
+      tree present = fold_build2_loc (input_location, NE_EXPR,
+				      boolean_type_node, cfi_desc,
+				      null_pointer_node);
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     sym->backend_decl,
+			     fold_convert (TREE_TYPE (sym->backend_decl),
+					   null_pointer_node));
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp);
+      gfc_add_expr_to_block (init, tmp);
+    }
+  else
+    gfc_add_block_to_block (init, &block);
+
+  if (!sym->attr.referenced)
+    return;
+
+  /* If pointer not changed, nothing to be done (except copy out)  */
+  if (!do_copy_inout && ((!sym->attr.pointer && !sym->attr.allocatable)
+			 || sym->attr.intent == INTENT_IN))
+    return;
+
+  gfc_init_block (&block);
+
+  /* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or
+     len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain
+     unchanged.  */
+  if (do_copy_inout)
+    {
+      tree data, call;
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+	data = gfc_conv_descriptor_data_get (gfc_desc);
+      else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
+	data = gfc_build_addr_expr (NULL, gfc_desc);
+      else
+	data = gfc_desc;
+      gfc_init_block (&block2);
+      if (sym->attr.intent != INTENT_IN)
+	{
+	 /* First, create the inner copy-out loop.
+	  for (idx = 0; idx < size; ++idx)
+	   {
+	     shift = 0;
+	     tmpidx = idx
+	     for (dim = 0; dim < rank; ++dim)
+		{
+		  shift += (tmpidx % extent[d]) * sm[d]
+		  tmpidx = tmpidx / extend[d]
+		}
+	     memcpy (lhs + shift, rhs + idx*elem_len, elem_len)
+	   } .*/
+	  stmtblock_t loop_body;
+	  idx = gfc_create_var (size_type_node, "arrayidx");
+	  gfc_init_block (&loop_body);
+	  tree shift = gfc_create_var (size_type_node, "shift");
+	  tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
+	  gfc_add_modify (&loop_body, shift,
+			  build_zero_cst (TREE_TYPE (shift)));
+	  gfc_add_modify (&loop_body, tmpidx, idx);
+	  stmtblock_t inner_loop;
+	  gfc_init_block (&inner_loop);
+	  tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
+	  /* shift += (tmpidx % extent[d]) * sm[d] */
+	  tmp = fold_convert (size_type_node,
+			      gfc_get_cfi_dim_extent (cfi, dim));
+	  tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+				 size_type_node, tmpidx, tmp);
+	  tmp = fold_build2_loc (input_location, MULT_EXPR,
+				 size_type_node, tmp,
+				 fold_convert (size_type_node,
+					       gfc_get_cfi_dim_sm (cfi, dim)));
+	  gfc_add_modify (&inner_loop, shift,
+		      fold_build2_loc (input_location, PLUS_EXPR,
+				       size_type_node, shift, tmp));
+	  /* tmpidx = tmpidx / extend[d] */
+	  tmp = fold_convert (size_type_node,
+			      gfc_get_cfi_dim_extent (cfi, dim));
+	  gfc_add_modify (&inner_loop, tmpidx,
+			  fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+					   size_type_node, tmpidx, tmp));
+	  gfc_simple_for_loop (&loop_body, dim,
+			       build_zero_cst (TREE_TYPE (rank)), rank, LT_EXPR,
+			       build_int_cst (TREE_TYPE (dim), 1),
+			       gfc_finish_block (&inner_loop));
+	  /* Assign.  */
+	  tree rhs;
+	  tmp = fold_convert (pchar_type_node,
+			      gfc_get_cfi_desc_base_addr (cfi));
+	  tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
+	  /* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */
+	  tree elem_len;
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+	    elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
+	  else
+	    elem_len = gfc_get_cfi_desc_elem_len (cfi);
+	  rhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+				 elem_len, idx);
+	  rhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
+				 pchar_type_node,
+				 fold_convert (pchar_type_node, data), rhs);
+	  tmp = fold_convert (pvoid_type_node, tmp);
+	  rhs = fold_convert (pvoid_type_node, rhs);
+	  call = builtin_decl_explicit (BUILT_IN_MEMCPY);
+	  call = build_call_expr_loc (input_location, call, 3, tmp, rhs,
+				      elem_len);
+	  gfc_add_expr_to_block (&loop_body,
+				 fold_convert (void_type_node, call));
+	  gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+			       size_var, LT_EXPR,
+			       build_int_cst (TREE_TYPE (idx), 1),
+			       gfc_finish_block (&loop_body));
+	}
+      call = builtin_decl_explicit (BUILT_IN_FREE);
+      call = build_call_expr_loc (input_location, call, 1, data);
+      gfc_add_expr_to_block (&block2, call);
+
+      /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return  */
+      tree tmp2 = gfc_get_cfi_desc_base_addr (cfi);
+      tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      tmp2, fold_convert (TREE_TYPE (tmp2), data));
+      tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+      goto done_finally;
+    }
+
+  /* Update pointer + array data data on exit.  */
+  tmp = gfc_get_cfi_desc_base_addr (cfi);
+  tmp2 = (!sym->attr.dimension
+	       ? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc));
+  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+
+  /* Set string length for len=:, only.  */
+  if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
+    {
+      tmp = sym->ts.u.cl->backend_decl;
+      if (sym->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_array_index_type,
+			       sym->ts.u.cl->backend_decl, tmp);
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
+
+  if (!sym->attr.dimension)
+    goto done_finally;
+
+  gfc_init_block (&block2);
+
+  /* Loop: for (i = 0; i < rank; ++i).  */
+  idx = gfc_create_var (TREE_TYPE (rank), "idx");
+
+  /* Loop body.  */
+  gfc_init_block (&loop_body);
+  /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
+  gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx),
+		  gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+  /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1.  */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_ubound_get (gfc_desc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp,
+			 gfc_index_one_node);
+  gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
+  /* d->dim[n].sm = gfc->dim[i].stride  * gfc->span); */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc_desc, idx),
+			     gfc_conv_descriptor_span_get (gfc_desc));
+  gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
+
+  /* Generate loop.  */
+  gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+		       rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+		       gfc_finish_block (&loop_body));
+  /* if (gfc->data != NULL) { block2 }.  */
+  tmp = gfc_get_cfi_desc_base_addr (cfi),
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			 tmp, null_pointer_node);
+  tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block, tmp);
+
+done_finally:
+  /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'.  */
+  if (sym->attr.optional)
+    {
+      tree present = fold_build2_loc (input_location, NE_EXPR,
+				      boolean_type_node, cfi_desc,
+				      null_pointer_node);
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (finally, tmp);
+     }
+   else
+     gfc_add_block_to_block (finally, &block);
+}
 
 /* Generate code for a function.  */
 
@@ -6777,7 +7461,7 @@ gfc_generate_function_code (gfc_namespace * ns)
   tree decl;
   tree tmp;
   tree fpstate = NULL_TREE;
-  stmtblock_t init, cleanup;
+  stmtblock_t init, cleanup, outer_block;
   stmtblock_t body;
   gfc_wrapped_block try_block;
   tree recurcheckvar = NULL_TREE;
@@ -6811,6 +7495,8 @@ gfc_generate_function_code (gfc_namespace * ns)
   trans_function_start (sym);
 
   gfc_init_block (&init);
+  gfc_init_block (&cleanup);
+  gfc_init_block (&outer_block);
 
   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
     {
@@ -6834,6 +7520,81 @@ gfc_generate_function_code (gfc_namespace * ns)
 	|| ns->parent == NULL)
     parent_fake_result_decl = NULL_TREE;
 
+  /* For BIND(C):
+     - deallocate intent-out allocatable dummy arguments.
+     - Create GFC variable which will later be populated by convert_CFI_desc  */
+  if (sym->attr.is_bind_c)
+    for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym);
+	 formal; formal = formal->next)
+      {
+	gfc_symbol *fsym = formal->sym;
+	if (!is_CFI_desc (fsym, NULL))
+	  continue;
+	if (!fsym->attr.referenced)
+	  {
+	    gfc_conv_cfi_to_gfc (&init, &cleanup, fsym->backend_decl,
+				 NULL_TREE, fsym);
+	    continue;
+	  }
+	/* Let's now create a local GFI descriptor. Afterwards:
+	   desc is the local descriptor,
+	   desc_p is a pointer to it
+	     and stored in sym->backend_decl
+	   GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor
+	     -> PARM_DECL and before sym->backend_decl.
+	   For scalars, decl == decl_p is a pointer variable.  */
+	tree desc_p, desc;
+	location_t loc = gfc_get_location (&sym->declared_at);
+	if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length)
+	  fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type,
+							fsym->name);
+	else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl)
+	  {
+	    gfc_se se;
+	    gfc_init_se (&se, NULL );
+	    gfc_conv_expr (&se, fsym->ts.u.cl->length);
+	    gfc_add_block_to_block (&init, &se.pre);
+	    fsym->ts.u.cl->backend_decl = se.expr;
+	    gcc_assert(se.post.head == NULL_TREE);
+	  }
+	/* Nullify, otherwise gfc_sym_type will return the CFI type.  */
+	tree tmp = fsym->backend_decl;
+	fsym->backend_decl = NULL;
+	tree type = gfc_sym_type (fsym);
+	gcc_assert (POINTER_TYPE_P (type));
+	if (POINTER_TYPE_P (TREE_TYPE (type)))
+	  /* For instance, allocatable scalars.  */
+	  type = TREE_TYPE (type);
+	if (TREE_CODE (type) == REFERENCE_TYPE)
+	  type = build_pointer_type (TREE_TYPE (type));
+	desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type);
+	if (!fsym->attr.dimension)
+	  desc = desc_p;
+	else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p))))
+	  {
+	    /* Character(len=*) explict-size/assumed-size array. */
+	    desc = desc_p;
+	    gfc_build_qualified_array (desc, fsym);
+	  }
+	else
+	  {
+	    tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p)));
+	    tree call = builtin_decl_explicit (BUILT_IN_ALLOCA);
+	    call = build_call_expr_loc (input_location, call, 1, size);
+	    gfc_add_modify (&outer_block, desc_p,
+			    fold_convert (TREE_TYPE(desc_p), call));
+	    desc = build_fold_indirect_ref_loc (input_location, desc_p);
+	  }
+	pushdecl (desc_p);
+	if (fsym->attr.optional)
+	  {
+	    gfc_allocate_lang_decl (desc_p);
+	    GFC_DECL_OPTIONAL_ARGUMENT (desc_p) = 1;
+	  }
+	fsym->backend_decl = desc_p;
+	gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
+      }
+
   gfc_generate_contained_functions (ns);
 
   has_coarray_vars = false;
@@ -6957,7 +7718,7 @@ gfc_generate_function_code (gfc_namespace * ns)
 	      /* Arrays are not initialized using the default initializer of
 		 their elements.  Therefore only check if a default
 		 initializer is available when the result is scalar.  */
-              init_exp = rsym->as ? NULL
+	      init_exp = rsym->as ? NULL
                                   : gfc_generate_initializer (&rsym->ts, true);
 	      if (init_exp)
 		{
@@ -6989,8 +7750,6 @@ gfc_generate_function_code (gfc_namespace * ns)
 	gfc_add_expr_to_block (&body, gfc_generate_return ());
     }
 
-  gfc_init_block (&cleanup);
-
   /* Reset recursion-check variable.  */
   if (recurcheckvar != NULL_TREE)
     {
@@ -7004,8 +7763,8 @@ gfc_generate_function_code (gfc_namespace * ns)
 
   /* Finish the function body and add init and cleanup code.  */
   tmp = gfc_finish_block (&body);
-  gfc_start_wrapped_block (&try_block, tmp);
   /* Add code to create and cleanup arrays.  */
+  gfc_start_wrapped_block (&try_block, tmp);
   gfc_trans_deferred_vars (sym, &try_block);
   gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
 			gfc_finish_block (&cleanup));
@@ -7023,7 +7782,8 @@ gfc_generate_function_code (gfc_namespace * ns)
     }
   saved_function_decls = NULL_TREE;
 
-  DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
+  gfc_add_expr_to_block (&outer_block, gfc_finish_wrapped_block (&try_block));
+  DECL_SAVED_TREE (fndecl) = gfc_finish_block (&outer_block);
   decl = getdecls ();
 
   /* Finish off this function and send it for code generation.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1c24556..2d7f9e0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2866,6 +2866,9 @@ tree
 gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
 			   bool is_classarray)
 {
+  if (is_CFI_desc (sym, NULL))
+    return build_fold_indirect_ref_loc (input_location, var);
+
   /* Characters are entirely different from other types, they are treated
      separately.  */
   if (sym->ts.type == BT_CHARACTER)
@@ -4922,7 +4925,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
 
       if (fsym && proc_name)
 	msg = xasprintf ("An array temporary was created for argument "
-			     "'%s' of procedure '%s'", fsym->name, proc_name);
+			 "'%s' of procedure '%s'", fsym->name, proc_name);
       else
 	msg = xasprintf ("An array temporary was created");
 
@@ -5220,6 +5223,8 @@ class_array_fcn:
       tree post_cond;
 
       type = TREE_TYPE (parmse->expr);
+      if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
+	type = TREE_TYPE (type);
       pointer = gfc_create_var (type, "arg_ptr");
 
       if (check_contiguous)
@@ -5263,17 +5268,25 @@ class_array_fcn:
 	  gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
 	  gfc_add_block_to_block (&se->pre, &(&array_se)->post);
 
-	  /* if_stmt = { pointer = &a[0]; } .  */
+	  /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } .  */
 	  gfc_init_block (&if_block);
-	  tmp = gfc_conv_array_data (array_se.expr);
-	  tmp = fold_convert (type, tmp);
-	  gfc_add_modify (&if_block, pointer, tmp);
+	  if (GFC_DESCRIPTOR_TYPE_P (type))
+	    gfc_add_modify (&if_block, pointer, array_se.expr);
+	  else
+	    {
+	      tmp = gfc_conv_array_data (array_se.expr);
+	      tmp = fold_convert (type, tmp);
+	      gfc_add_modify (&if_block, pointer, tmp);
+	    }
 	  if_stmt = gfc_finish_block (&if_block);
 
 	  /* else_stmt = { parmse->pre(); pointer = parmse->expr; } .  */
 	  gfc_init_block (&else_block);
 	  gfc_add_block_to_block (&else_block, &parmse->pre);
-	  gfc_add_modify (&else_block, pointer, parmse->expr);
+	  tmp = (GFC_DESCRIPTOR_TYPE_P (type)
+		 ? build_fold_indirect_ref_loc (input_location, parmse->expr)
+		 : parmse->expr);
+	  gfc_add_modify (&else_block, pointer, tmp);
 	  else_stmt = gfc_finish_block (&else_block);
 
 	  /* And put the above into an if statement.  */
@@ -5300,7 +5313,11 @@ class_array_fcn:
 
 	  /* else_stmt = { pointer = NULL; } .  */
 	  gfc_init_block (&else_block);
-	  gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
+	  if (GFC_DESCRIPTOR_TYPE_P (type))
+	    gfc_conv_descriptor_data_set (&else_block, pointer,
+					  null_pointer_node);
+	  else
+	    gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
 	  else_stmt = gfc_finish_block (&else_block);
 
 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
@@ -5344,6 +5361,24 @@ class_array_fcn:
       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
 			     post_stmts, build_empty_stmt (input_location));
       gfc_add_expr_to_block (&se->post, tmp);
+      if (GFC_DESCRIPTOR_TYPE_P (type))
+	{
+	  type = TREE_TYPE (parmse->expr);
+	  if (POINTER_TYPE_P (type))
+	    {
+	      pointer = gfc_build_addr_expr (type, pointer);
+	      if (pass_optional)
+		{
+		  tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
+		  pointer = fold_build3_loc (input_location, COND_EXPR, type,
+					     tmp, pointer,
+					     fold_convert (type,
+							   null_pointer_node));
+		}
+	    }
+	  else
+	    gcc_assert (!pass_optional);
+	}
       se->expr = pointer;
     }
 
@@ -5454,7 +5489,8 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
 
   if (POINTER_TYPE_P (TREE_TYPE (desc)))
     desc = build_fold_indirect_ref_loc (input_location, desc);
-
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
+    desc = gfc_class_data_get (desc);
   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
     return;
 
@@ -5483,168 +5519,457 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
 static void
 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 {
-  tree tmp;
-  tree cfi_desc_ptr;
-  tree gfc_desc_ptr;
-  tree type;
-  tree cond;
-  tree desc_attr;
-  int attribute;
-  int cfi_attribute;
-  symbol_attribute attr = gfc_expr_attr (e);
+  stmtblock_t block, block2;
+  tree cfi, gfc, tmp, tmp2;
+  tree present = NULL;
+  tree gfc_strlen = NULL;
+  tree rank;
+  gfc_se se;
 
-  /* If this is a full array or a scalar, the allocatable and pointer
-     attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
-  attribute = 2;
-  if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
+  if (fsym->attr.optional
+      && e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->attr.optional)
+    present = gfc_conv_expr_present (e->symtree->n.sym);
+
+  gfc_init_block (&block);
+
+  /* Convert original argument to a tree. */
+  gfc_init_se (&se, NULL);
+  if (e->rank == 0)
     {
-      if (attr.pointer)
-	attribute = 0;
-      else if (attr.allocatable)
-	attribute = 1;
+      se.want_pointer = 1;
+      gfc_conv_expr (&se, e);
+      gfc = se.expr;
+      /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst.  */
+      if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
+	gfc = gfc_build_addr_expr (NULL, gfc);
     }
+  else
+    {
+      /* If the actual argument can be noncontiguous, copy-in/out is required,
+	 if the dummy has either the CONTIGUOUS attribute or is an assumed-
+	 length assumed-length/assumed-size CHARACTER array.  */
+      se.force_no_tmp = 1;
+      if ((fsym->attr.contiguous
+	   || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
+	       && (fsym->as->type == AS_ASSUMED_SIZE
+		   || fsym->as->type == AS_EXPLICIT)))
+	  && !gfc_is_simply_contiguous (e, false, true))
+	{
+	  bool optional = fsym->attr.optional;
+	  fsym->attr.optional = 0;
+	  gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
+				     fsym->attr.pointer, fsym,
+				     fsym->ns->proc_name->name, NULL,
+				     /* check_contiguous= */ true);
+	  fsym->attr.optional = optional;
+	}
+      else
+	gfc_conv_expr_descriptor (&se, e);
+      gfc = se.expr;
+      /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
+	 elem_len = sizeof(dt) and base_addr = dt(lb) instead.
+	 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
+	 While sm is fine as it uses span*stride and not elem_len.  */
+      if (POINTER_TYPE_P (TREE_TYPE (gfc)))
+	gfc = build_fold_indirect_ref_loc (input_location, gfc);
+      else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
+	 gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
+    }
+  if (e->ts.type == BT_CHARACTER)
+    {
+      if (se.string_length)
+	gfc_strlen = se.string_length;
+      else if (e->ts.u.cl->backend_decl)
+	gfc_strlen = e->ts.u.cl->backend_decl;
+      else
+	gcc_unreachable ();
+    }
+  gfc_add_block_to_block (&block, &se.pre);
 
+  /* Create array decriptor and set version, rank, attribute, type. */
+  cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
+					  ? GFC_MAX_DIMENSIONS : e->rank,
+					  false), "cfi");
+  /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
+  if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
+    {
+      tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
+      tmp = build_pointer_type (tmp);
+      parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
+      cfi = build_fold_indirect_ref_loc (input_location, cfi);
+    }
+  else
+    parmse->expr = gfc_build_addr_expr (NULL, cfi);
+
+  tmp = gfc_get_cfi_desc_version (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
+  if (e->rank < 0)
+    rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
+  else
+    rank = build_int_cst (signed_char_type_node, e->rank);
+  tmp = gfc_get_cfi_desc_rank (cfi);
+  gfc_add_modify (&block, tmp, rank);
+  int itype = CFI_type_other;
+  if (e->ts.f90_type == BT_VOID)
+    itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+	     ? CFI_type_cfunptr : CFI_type_cptr);
+  else
+    switch (e->ts.type)
+      {
+	case BT_INTEGER:
+	case BT_LOGICAL:
+	case BT_REAL:
+	case BT_COMPLEX:
+	  itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
+	  break;
+	case BT_CHARACTER:
+	  itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
+	  break;
+	case BT_DERIVED:
+	  itype = CFI_type_struct;
+	  break;
+	case BT_VOID:
+	  itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+		   ? CFI_type_cfunptr : CFI_type_cptr);
+	  break;
+	case BT_ASSUMED:
+	  itype = CFI_type_other;  // FIXME: Or CFI_type_cptr ?
+	  break;
+	case BT_CLASS:
+	case BT_PROCEDURE:
+	case BT_HOLLERITH:
+	case BT_UNION:
+	case BT_BOZ:
+	case BT_UNKNOWN:
+	  // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
+	  gcc_unreachable ();
+      }
+
+  tmp = gfc_get_cfi_desc_type (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), itype));
+
+  int attr = CFI_attribute_other;
   if (fsym->attr.pointer)
-    cfi_attribute = 0;
+    attr = CFI_attribute_pointer;
   else if (fsym->attr.allocatable)
-    cfi_attribute = 1;
-  else
-    cfi_attribute = 2;
+    attr = CFI_attribute_allocatable;
+  tmp = gfc_get_cfi_desc_attribute (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), attr));
 
-  if (e->rank != 0)
+  if (e->rank == 0)
     {
-      parmse->force_no_tmp = 1;
-      if (fsym->attr.contiguous
-	  && !gfc_is_simply_contiguous (e, false, true))
-	gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
-				   fsym->attr.pointer);
-      else
-	gfc_conv_expr_descriptor (parmse, e);
-
-      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
-	parmse->expr = build_fold_indirect_ref_loc (input_location,
-						    parmse->expr);
-      bool is_artificial = (INDIRECT_REF_P (parmse->expr)
-			    ? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
-			    : DECL_ARTIFICIAL (parmse->expr));
-
-      /* Unallocated allocatable arrays and unassociated pointer arrays
-	 need their dtype setting if they are argument associated with
-	 assumed rank dummies.  */
-      if (fsym && fsym->as
-	  && (gfc_expr_attr (e).pointer
-	      || gfc_expr_attr (e).allocatable))
-	set_dtype_for_unallocated (parmse, e);
-
-      /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
-	 the expression type is different from the descriptor type, then
-	 the offset must be found (eg. to a component ref or substring)
-	 and the dtype updated.  Assumed type entities are only allowed
-	 to be dummies in Fortran. They therefore lack the decl specific
-	 appendiges and so must be treated differently from other fortran
-	 entities passed to CFI descriptors in the interface decl.  */
-      type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
-					NULL_TREE;
-
-      if (type && is_artificial
-	  && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
-	{
-	  /* Obtain the offset to the data.  */
-	  gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
-				  gfc_index_zero_node, true, e);
-
-	  /* Update the dtype.  */
-	  gfc_add_modify (&parmse->pre,
-			  gfc_conv_descriptor_dtype (parmse->expr),
-			  gfc_get_dtype_rank_type (e->rank, type));
-	}
-      else if (type == NULL_TREE
-	       || (!is_subref_array (e) && !is_artificial))
-	{
-	  /* Make sure that the span is set for expressions where it
-	     might not have been done already.  */
-	  tmp = gfc_conv_descriptor_elem_len (parmse->expr);
-	  tmp = fold_convert (gfc_array_index_type, tmp);
-	  gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
-	}
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
     }
   else
     {
-      gfc_conv_expr (parmse, e);
-
-      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
-	parmse->expr = build_fold_indirect_ref_loc (input_location,
-						    parmse->expr);
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tmp2 = gfc_conv_descriptor_data_get (gfc);
+      gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+    }
 
-      parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
-						    parmse->expr, attr);
+  /* Set elem_len if known - must be before the next if block.
+     Note that allocatable implies 'len=:'.  */
+  if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
+    {
+      /* Length is known at compile time; use use 'block' for it.  */
+      tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
     }
 
-  /* Set the CFI attribute field through a temporary value for the
-     gfc attribute.  */
-  desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-			 void_type_node, desc_attr,
-			 build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  /* When allocatable + intent out, free the cfi descriptor.  */
+  if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tree call = builtin_decl_explicit (BUILT_IN_FREE);
+      call = build_call_expr_loc (input_location, call, 1, tmp);
+      gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+      gfc_add_modify (&block, tmp,
+		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
+      goto done;
+    }
 
-  /* Now pass the gfc_descriptor by reference.  */
-  parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+  /* If not unallocated/unassociated. */
+  gfc_init_block (&block2);
 
-  /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
-     that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call.  */
-  gfc_desc_ptr = parmse->expr;
-  cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
-  gfc_add_modify (&parmse->pre, cfi_desc_ptr, null_pointer_node);
+  /* Set elem_len, which may be only known at run time. */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      gcc_assert (gfc_strlen);
+      tmp = gfc_strlen;
+      if (e->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_charlen_type_node, tmp,
+			       build_int_cst (gfc_charlen_type_node,
+					      e->ts.kind));
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
+  else if (e->ts.type == BT_ASSUMED)
+    {
+      tmp = gfc_conv_descriptor_elem_len (gfc);
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
 
-  /* Allocate the CFI descriptor itself and fill the fields.  */
-  tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
-  tmp = build_call_expr_loc (input_location,
-			     gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  if (e->ts.type == BT_ASSUMED)
+    {
+      /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
+	 an CFI descriptor.  Use the type in the descritor as it provide
+	 mode information. (Quality of implementation feature.)  */
+      tree cond;
+      tree ctype = gfc_get_cfi_desc_type (cfi);
+      tree type = fold_convert (TREE_TYPE (ctype),
+				gfc_conv_descriptor_type (gfc));
+      tree kind = fold_convert (TREE_TYPE (ctype),
+				gfc_conv_descriptor_elem_len (gfc));
+      kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
+			      kind, build_int_cst (TREE_TYPE (type),
+						   CFI_type_kind_shift));
+
+      /* if (BT_VOID) CFI_type_cptr else CFI_type_other  */
+      /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_VOID));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+			     build_int_cst (TREE_TYPE (type), CFI_type_cptr));
+      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			      ctype,
+			      build_int_cst (TREE_TYPE (type), CFI_type_other));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_DERIVED) CFI_type_struct else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_DERIVED));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+			     build_int_cst (TREE_TYPE (type), CFI_type_struct));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_CHARACTER) CFI_type_Character + kind=1 else  < tmp2 >  */
+      /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+      tmp = build_int_cst (TREE_TYPE (type),
+			   CFI_type_from_type_kind (CFI_type_Character, 1));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_COMPLEX));
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
+			     kind, build_int_cst (TREE_TYPE (type), 2));
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
+			     build_int_cst (TREE_TYPE (type),
+					    CFI_type_Complex));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else  <tmp2>  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_INTEGER));
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_LOGICAL));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_REAL));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
+			     type, kind);
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      gfc_add_expr_to_block (&block2, tmp2);
+    }
 
-  /* Now set the gfc descriptor attribute.  */
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-			 void_type_node, desc_attr,
-			 build_int_cst (TREE_TYPE (desc_attr), attribute));
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  if (e->rank != 0)
+    {
+      /* Loop: for (i = 0; i < rank; ++i).  */
+      tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+      /* Loop body.  */
+      stmtblock_t loop_body;
+      gfc_init_block (&loop_body);
+      /* cfi->dim[i].lower_bound = (allocatable/pointer)
+				   ? gfc->dim[i].lbound : 0 */
+      if (fsym->attr.pointer || fsym->attr.allocatable)
+	tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
+      else
+	tmp = gfc_index_zero_node;
+      gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
+      /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_ubound_get (gfc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc, idx));
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+      gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
+      /* d->dim[n].sm = gfc->dim[i].stride  * gfc->span); */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc, idx),
+			     gfc_conv_descriptor_span_get (gfc));
+      gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
 
-  /* The CFI descriptor is passed to the bind_C procedure.  */
-  parmse->expr = cfi_desc_ptr;
+      /* Generate loop.  */
+      gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
+			   rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+			   gfc_finish_block (&loop_body));
 
-  /* Free the CFI descriptor.  */
-  tmp = gfc_call_free (cfi_desc_ptr);
-  gfc_prepend_expr_to_block (&parmse->post, tmp);
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->ref
+	  && e->ref->u.ar.type == AR_FULL
+	  && e->symtree->n.sym->attr.dummy
+	  && e->symtree->n.sym->as
+	  && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+	{
+	  tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
+	  gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
+	}
+    }
 
-  /* Transfer values back to gfc descriptor.  */
-  if (cfi_attribute != 2  /* CFI_attribute_other.  */
-      && !fsym->attr.value
-      && fsym->attr.intent != INTENT_IN)
+  if (fsym->attr.allocatable || fsym->attr.pointer)
     {
-      tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
-      tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
-      gfc_prepend_expr_to_block (&parmse->post, tmp);
+      tmp = gfc_get_cfi_desc_base_addr (cfi),
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, null_pointer_node);
+      tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
     }
+  else
+    gfc_add_block_to_block (&block, &block2);
 
-  /* Deal with an optional dummy being passed to an optional formal arg
-     by finishing the pre and post blocks and making their execution
-     conditional on the dummy being present.  */
-  if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
-      && e->symtree->n.sym->attr.optional)
+
+done:
+  if (present)
     {
-      cond = gfc_conv_expr_present (e->symtree->n.sym);
-      tmp = fold_build2 (MODIFY_EXPR, void_type_node,
-			 cfi_desc_ptr,
-			 build_int_cst (pvoid_type_node, 0));
-      tmp = build3_v (COND_EXPR, cond,
-		      gfc_finish_block (&parmse->pre), tmp);
+      parmse->expr = build3_loc (input_location, COND_EXPR,
+				 TREE_TYPE (parmse->expr),
+				 present, parmse->expr, null_pointer_node);
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+		      build_empty_stmt (input_location));
       gfc_add_expr_to_block (&parmse->pre, tmp);
-      tmp = build3_v (COND_EXPR, cond,
-		      gfc_finish_block (&parmse->post),
+    }
+  else
+    gfc_add_block_to_block (&parmse->pre, &block);
+
+  gfc_init_block (&block);
+
+  if ((!fsym->attr.allocatable && !fsym->attr.pointer)
+      || fsym->attr.intent == INTENT_IN)
+    goto post_call;
+
+  gfc_init_block (&block2);
+  if (e->rank == 0)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
+    }
+  else
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_conv_descriptor_data_set (&block, gfc, tmp);
+
+      if (fsym->attr.allocatable)
+	{
+	  /* gfc->span = cfi->elem_len.  */
+	  tmp = fold_convert (gfc_array_index_type,
+			      gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+	}
+      else
+	{
+	  /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+			  ? cfi->dim[0].sm : cfi->elem_len).  */
+	  tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+	  tmp2 = fold_convert (gfc_array_index_type,
+			       gfc_get_cfi_desc_elem_len (cfi));
+	  tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+				 gfc_array_index_type, tmp, tmp2);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, gfc_index_zero_node);
+	  tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+			    gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
+	}
+      gfc_conv_descriptor_span_set (&block2, gfc, tmp);
+
+      /* Calculate offset + set lbound, ubound and stride.  */
+      gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
+      /* Loop: for (i = 0; i < rank; ++i).  */
+      tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+      /* Loop body.  */
+      stmtblock_t loop_body;
+      gfc_init_block (&loop_body);
+      /* gfc->dim[i].lbound = ... */
+      tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+      gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+
+      /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_lbound_get (gfc, idx),
+			     gfc_index_one_node);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     gfc_get_cfi_dim_extent (cfi, idx), tmp);
+      gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+      /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+      tmp = gfc_get_cfi_dim_sm (cfi, idx);
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type, tmp,
+			     fold_convert (gfc_array_index_type,
+					   gfc_get_cfi_desc_elem_len (cfi)));
+      gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
+
+      /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc, idx));
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_offset_get (gfc), tmp);
+      gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+      /* Generate loop.  */
+      gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
+			   rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+			   gfc_finish_block (&loop_body));
+    }
+
+  if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
+    {
+      tmp = fold_convert (gfc_charlen_type_node,
+			  gfc_get_cfi_desc_elem_len (cfi));
+      if (e->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			       gfc_charlen_type_node, tmp,
+			       build_int_cst (gfc_charlen_type_node,
+					      e->ts.kind));
+      gfc_add_modify (&block2, gfc_strlen, tmp);
+    }
+
+  tmp = gfc_get_cfi_desc_base_addr (cfi),
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			 tmp, null_pointer_node);
+  tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block, tmp);
+
+post_call:
+  gfc_add_block_to_block (&block, &se.post);
+  if (present && block.head)
+    {
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
 		      build_empty_stmt (input_location));
       gfc_add_expr_to_block (&parmse->post, tmp);
     }
+  else if (block.head)
+    gfc_add_block_to_block (&parmse->post, &block);
 }
 
 
@@ -5763,17 +6088,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       bool finalized = false;
-      bool assumed_length_string = false;
       tree derived_array = NULL_TREE;
 
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
 
-      if (fsym && fsym->ts.type == BT_CHARACTER
-	  && (!fsym->ts.u.cl || !fsym->ts.u.cl->length))
-	assumed_length_string = true;
-
       /* If the procedure requires an explicit interface, the actual
 	 argument is passed according to the corresponding formal
 	 argument.  If the corresponding formal argument is a POINTER,
@@ -6004,9 +6324,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    parmse.expr = convert (type, tmp);
 		}
 
-	      else if (sym->attr.is_bind_c && e
-		       && (is_CFI_desc (fsym, NULL)
-			   || assumed_length_string))
+	      else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
 		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
@@ -6216,7 +6534,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  if (fsym && fsym->attr.intent == INTENT_OUT
 		      && (fsym->attr.allocatable
 			  || (fsym->ts.type == BT_CLASS
-			      && CLASS_DATA (fsym)->attr.allocatable)))
+			      && CLASS_DATA (fsym)->attr.allocatable))
+		      && !is_CFI_desc (fsym, NULL))
 		    {
 		      stmtblock_t block;
 		      tree ptr;
@@ -6321,7 +6640,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    {
 		      tmp = parmse.expr;
 		      if (TREE_CODE (tmp) == ADDR_EXPR)
-			tmp = build_fold_indirect_ref_loc (input_location, tmp);
+			tmp = TREE_OPERAND (tmp, 0);
 		      parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
 								   fsym->attr);
 		      parmse.expr = gfc_build_addr_expr (NULL_TREE,
@@ -6473,8 +6792,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    ref->u.ar.type = AR_SECTION;
 		}
 
-	      if (sym->attr.is_bind_c && e
-		  && (is_CFI_desc (fsym, NULL) || assumed_length_string))
+	      if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
 		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
@@ -6533,47 +6851,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
 					  sym->name, NULL);
 
-	      /* Special case for assumed-rank arrays. */
-	      if (!sym->attr.is_bind_c && e && fsym && fsym->as
-		  && fsym->as->type == AS_ASSUMED_RANK
-		  && e->rank != -1)
-		{
-		  if ((gfc_expr_attr (e).pointer
-		      || gfc_expr_attr (e).allocatable)
-		      && ((fsym->ts.type == BT_CLASS
-			   && (CLASS_DATA (fsym)->attr.class_pointer
-			       || CLASS_DATA (fsym)->attr.allocatable))
-			  || (fsym->ts.type != BT_CLASS
-			      && (fsym->attr.pointer || fsym->attr.allocatable))))
-		    {
-		      /* Unallocated allocatable arrays and unassociated pointer
-			 arrays need their dtype setting if they are argument
-			 associated with assumed rank dummies. However, if the
-			 dummy is nonallocate/nonpointer, the user may not
-			 pass those. Hence, it can be skipped.  */
-		      set_dtype_for_unallocated (&parmse, e);
-		    }
-		  else if (e->expr_type == EXPR_VARIABLE
-			   && e->ref
-			   && e->ref->u.ar.type == AR_FULL
-			   && e->symtree->n.sym->attr.dummy
-			   && e->symtree->n.sym->as
-			   && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
-		    {
-		      tree minus_one;
-		      tmp = build_fold_indirect_ref_loc (input_location,
-							 parmse.expr);
-		      minus_one = build_int_cst (gfc_array_index_type, -1);
-		      gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
-						      gfc_rank_cst[e->rank - 1],
-						      minus_one);
- 		    }
-		}
-
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
-		 allocated on entry, it must be deallocated.  */
+		 allocated on entry, it must be deallocated.
+		 CFI descriptors are handled elsewhere.  */
 	      if (fsym && fsym->attr.allocatable
-		  && fsym->attr.intent == INTENT_OUT)
+		  && fsym->attr.intent == INTENT_OUT
+		  && !is_CFI_desc (fsym, NULL))
 		{
 		  if (fsym->ts.type == BT_DERIVED
 		      && fsym->ts.u.derived->attr.alloc_comp)
@@ -6621,6 +6904,46 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 	    }
 	}
+      /* Special case for an assumed-rank dummy argument. */
+      if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
+	  && (fsym->ts.type == BT_CLASS
+	      ? (CLASS_DATA (fsym)->as
+		 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+	      : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
+	{
+	  if (fsym->ts.type == BT_CLASS
+	      ? (CLASS_DATA (fsym)->attr.class_pointer
+		 || CLASS_DATA (fsym)->attr.allocatable)
+	      : (fsym->attr.pointer || fsym->attr.allocatable))
+	    {
+	      /* Unallocated allocatable arrays and unassociated pointer
+		 arrays need their dtype setting if they are argument
+		 associated with assumed rank dummies to set the rank.  */
+	      set_dtype_for_unallocated (&parmse, e);
+	    }
+	  else if (e->expr_type == EXPR_VARIABLE
+		   && e->symtree->n.sym->attr.dummy
+		   && (e->ts.type == BT_CLASS
+		       ? (e->ref && e->ref->next
+			  && e->ref->next->type == REF_ARRAY
+			  && e->ref->next->u.ar.type == AR_FULL
+			  && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
+		       : (e->ref && e->ref->type == REF_ARRAY
+			  && e->ref->u.ar.type == AR_FULL
+			  && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
+	    {
+	      /* Assumed-size actual to assumed-rank dummy requires
+		 dim[rank-1].ubound = -1. */
+	      tree minus_one;
+	      tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	      if (fsym->ts.type == BT_CLASS)
+		tmp = gfc_class_data_get (tmp);
+	      minus_one = build_int_cst (gfc_array_index_type, -1);
+	      gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+					      gfc_rank_cst[e->rank - 1],
+					      minus_one);
+	    }
+	}
 
       /* The case with fsym->attr.optional is that of a user subroutine
 	 with an interface indicating an optional argument.  When we call
@@ -11404,6 +11727,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 
 	  tmp = INDIRECT_REF_P (lse.expr)
 	      ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
+	  STRIP_NOPS (tmp);
 
 	  /* We should only get array references here.  */
 	  gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 2a2829c..0d91958 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2922,7 +2922,7 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 
 static void
-gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
+gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
 {
   gfc_actual_arglist *arg;
   gfc_actual_arglist *arg2;
@@ -2930,9 +2930,10 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   tree type;
   tree bound;
   tree tmp;
-  tree cond, cond1, cond3, cond4, size;
+  tree cond, cond1;
   tree ubound;
   tree lbound;
+  tree size;
   gfc_se argse;
   gfc_array_spec * as;
   bool assumed_rank_lb_one;
@@ -2943,7 +2944,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   if (se->ss)
     {
       /* Create an implicit second parameter from the loop variable.  */
-      gcc_assert (!arg2->expr);
+      gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
       gcc_assert (se->loop->dimen == 1);
       gcc_assert (se->ss->info->expr == expr);
       gfc_advance_se_ss_chain (se);
@@ -2979,12 +2980,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   if (INTEGER_CST_P (bound))
     {
+      gcc_assert (op != GFC_ISYM_SHAPE);
       if (((!as || as->type != AS_ASSUMED_RANK)
 	   && wi::geu_p (wi::to_wide (bound),
 			 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
 	  || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
 	gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
-		   "dimension index", upper ? "UBOUND" : "LBOUND",
+		   "dimension index",
+		   (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
 		   &expr->where);
     }
 
@@ -3008,8 +3011,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
         }
     }
 
-  /* Take care of the lbound shift for assumed-rank arrays, which are
-     nonallocatable and nonpointers. Those has a lbound of 1.  */
+  /* Take care of the lbound shift for assumed-rank arrays that are
+     nonallocatable and nonpointers. Those have a lbound of 1.  */
   assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
 			&& ((arg->expr->ts.type != BT_CLASS
 			     && !arg->expr->symtree->n.sym->attr.allocatable
@@ -3020,6 +3023,10 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
+  size = fold_build2_loc (input_location, MINUS_EXPR,
+			  gfc_array_index_type, ubound, lbound);
+  size = fold_build2_loc (input_location, PLUS_EXPR,
+			  gfc_array_index_type, size, gfc_index_one_node);
 
   /* 13.14.53: Result value for LBOUND
 
@@ -3042,106 +3049,82 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
                not have size zero and has value zero if dimension DIM has
                size zero.  */
 
-  if (!upper && assumed_rank_lb_one)
+  if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
     se->expr = gfc_index_one_node;
   else if (as)
     {
-      tree stride = gfc_conv_descriptor_stride_get (desc, bound);
-
-      cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
-			       ubound, lbound);
-      cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
-			       stride, gfc_index_zero_node);
-      cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-			       logical_type_node, cond3, cond1);
-      cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
-			       stride, gfc_index_zero_node);
-
-      if (upper)
+      if (op == GFC_ISYM_UBOUND)
 	{
-	  tree cond5;
-	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				  logical_type_node, cond3, cond4);
-	  cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
-				   gfc_index_one_node, lbound);
-	  cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-				   logical_type_node, cond4, cond5);
-
-	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				  logical_type_node, cond, cond5);
-
-	  if (assumed_rank_lb_one)
+	  cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+				  size, gfc_index_zero_node);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR,
+				      gfc_array_index_type, cond,
+				      (assumed_rank_lb_one ? size : ubound),
+				      gfc_index_zero_node);
+	}
+      else if (op == GFC_ISYM_LBOUND)
+	{
+	  cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+				  size, gfc_index_zero_node);
+	  if (as->type == AS_ASSUMED_SIZE)
 	    {
-	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-			       gfc_array_index_type, ubound, lbound);
-	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
-			       gfc_array_index_type, tmp, gfc_index_one_node);
+	      cond1 = fold_build2_loc (input_location, EQ_EXPR,
+				       logical_type_node, bound,
+				       build_int_cst (TREE_TYPE (bound),
+						      arg->expr->rank - 1));
+	      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				      logical_type_node, cond, cond1);
 	    }
-          else
-            tmp = ubound;
-
 	  se->expr = fold_build3_loc (input_location, COND_EXPR,
 				      gfc_array_index_type, cond,
-				      tmp, gfc_index_zero_node);
+				      lbound, gfc_index_one_node);
 	}
+      else if (op == GFC_ISYM_SHAPE)
+	se->expr = size;
       else
-	{
-	  if (as->type == AS_ASSUMED_SIZE)
-	    cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
-				    bound, build_int_cst (TREE_TYPE (bound),
-							  arg->expr->rank - 1));
-	  else
-	    cond = logical_false_node;
+	gcc_unreachable ();
 
-	  cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				   logical_type_node, cond3, cond4);
-	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+      /* According to F2018 16.9.172, para 5, an assumed rank object,
+	 argument associated with and assumed size array, has the ubound
+	 of the final dimension set to -1 and UBOUND must return this.
+	 Similarly for the SHAPE intrinsic.  */
+      if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
+	{
+	  tree minus_one = build_int_cst (gfc_array_index_type, -1);
+	  tree rank = fold_convert (gfc_array_index_type,
+				    gfc_conv_descriptor_rank (desc));
+	  rank = fold_build2_loc (input_location, PLUS_EXPR,
+				  gfc_array_index_type, rank, minus_one);
+
+	  /* Fix the expression to stop it from becoming even more
+	     complicated.  */
+	  se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+	  /* Descriptors for assumed-size arrays have ubound = -1
+	     in the last dimension.  */
+	  cond1 = fold_build2_loc (input_location, EQ_EXPR,
+				   logical_type_node, ubound, minus_one);
+	  cond = fold_build2_loc (input_location, EQ_EXPR,
+				  logical_type_node, bound, rank);
+	  cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
 				  logical_type_node, cond, cond1);
-
 	  se->expr = fold_build3_loc (input_location, COND_EXPR,
 				      gfc_array_index_type, cond,
-				      lbound, gfc_index_one_node);
+				      minus_one, se->expr);
 	}
     }
-  else
+  else   /* as is null; this is an old-fashioned 1-based array.  */
     {
-      if (upper)
+      if (op != GFC_ISYM_LBOUND)
         {
-	  size = fold_build2_loc (input_location, MINUS_EXPR,
-				  gfc_array_index_type, ubound, lbound);
-	  se->expr = fold_build2_loc (input_location, PLUS_EXPR,
-				      gfc_array_index_type, size,
-				  gfc_index_one_node);
 	  se->expr = fold_build2_loc (input_location, MAX_EXPR,
-				      gfc_array_index_type, se->expr,
+				      gfc_array_index_type, size,
 				      gfc_index_zero_node);
 	}
       else
 	se->expr = gfc_index_one_node;
     }
 
-  /* According to F2018 16.9.172, para 5, an assumed rank object, argument
-     associated with and assumed size array, has the ubound of the final
-     dimension set to -1 and UBOUND must return this.  */
-  if (upper && as && as->type == AS_ASSUMED_RANK)
-    {
-      tree minus_one = build_int_cst (gfc_array_index_type, -1);
-      tree rank = fold_convert (gfc_array_index_type,
-				gfc_conv_descriptor_rank (desc));
-      rank = fold_build2_loc (input_location, PLUS_EXPR,
-			      gfc_array_index_type, rank, minus_one);
-      /* Fix the expression to stop it from becoming even more complicated.  */
-      se->expr = gfc_evaluate_now (se->expr, &se->pre);
-      cond = fold_build2_loc (input_location, NE_EXPR,
-			     logical_type_node, bound, rank);
-      cond1 = fold_build2_loc (input_location, NE_EXPR,
-			       logical_type_node, ubound, minus_one);
-      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-			      logical_type_node, cond, cond1);
-      se->expr = fold_build3_loc (input_location, COND_EXPR,
-				  gfc_array_index_type, cond,
-				  se->expr, minus_one);
-    }
 
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);
@@ -6691,85 +6674,6 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
 }
 
 static void
-gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
-{
-  gfc_actual_arglist *s, *k;
-  gfc_expr *e;
-  gfc_array_spec *as;
-  gfc_ss *ss;
-  symbol_attribute attr;
-  tree result_desc = se->expr;
-
-  /* Remove the KIND argument, if present. */
-  s = expr->value.function.actual;
-  k = s->next;
-  e = k->expr;
-  gfc_free_expr (e);
-  k->expr = NULL;
-
-  gfc_conv_intrinsic_funcall (se, expr);
-
-  /* According to F2018 16.9.172, para 5, an assumed rank entity, argument
-     associated with an assumed size array, has the ubound of the final
-     dimension set to -1 and SHAPE must return this.  */
-
-  as = gfc_get_full_arrayspec_from_expr (s->expr);
-  if (!as || as->type != AS_ASSUMED_RANK)
-    return;
-  attr = gfc_expr_attr (s->expr);
-  ss = gfc_walk_expr (s->expr);
-  if (attr.pointer || attr.allocatable
-      || !ss || ss->info->type != GFC_SS_SECTION)
-    return;
-  if (se->expr)
-    result_desc = se->expr;
-  if (POINTER_TYPE_P (TREE_TYPE (result_desc)))
-    result_desc = build_fold_indirect_ref_loc (input_location, result_desc);
-  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (result_desc)))
-    {
-      tree rank, minus_one, cond, ubound, tmp;
-      stmtblock_t block;
-      gfc_se ase;
-
-      minus_one = build_int_cst (gfc_array_index_type, -1);
-
-      /* Recover the descriptor for the array.  */
-      gfc_init_se (&ase, NULL);
-      ase.descriptor_only = 1;
-      gfc_conv_expr_lhs (&ase, ss->info->expr);
-
-      /* Obtain rank-1 so that we can address both descriptors.  */
-      rank = gfc_conv_descriptor_rank (ase.expr);
-      rank = fold_convert (gfc_array_index_type, rank);
-      rank = fold_build2_loc (input_location, PLUS_EXPR,
-			      gfc_array_index_type,
-			      rank, minus_one);
-      rank = gfc_evaluate_now (rank, &se->pre);
-
-      /* The ubound for the final dimension will be tested for being -1.  */
-      ubound = gfc_conv_descriptor_ubound_get (ase.expr, rank);
-      ubound = gfc_evaluate_now (ubound, &se->pre);
-      cond = fold_build2_loc (input_location, EQ_EXPR,
-			     logical_type_node,
-			     ubound, minus_one);
-
-      /* Obtain the last element of the result from the library shape
-	 intrinsic and set it to -1 if that is the value of ubound.  */
-      tmp = gfc_conv_array_data (result_desc);
-      tmp = build_fold_indirect_ref_loc (input_location, tmp);
-      tmp = gfc_build_array_ref (tmp, rank, NULL, NULL);
-
-      gfc_init_block (&block);
-      gfc_add_modify (&block, tmp, build_int_cst (TREE_TYPE (tmp), -1));
-
-      cond = build3_v (COND_EXPR, cond,
-		       gfc_finish_block (&block),
-		       build_empty_stmt (input_location));
-      gfc_add_expr_to_block (&se->pre, cond);
-    }
-}
-
-static void
 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
 			  bool arithmetic)
 {
@@ -10178,10 +10082,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 	      gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
 	      break;
 
-	    case GFC_ISYM_SHAPE:
-	      gfc_conv_intrinsic_shape (se, expr);
-	      break;
-
 	    default:
 	      gfc_conv_intrinsic_funcall (se, expr);
 	      break;
@@ -10575,7 +10475,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_LBOUND:
-      gfc_conv_intrinsic_bound (se, expr, 0);
+      gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
       break;
 
     case GFC_ISYM_LCOBOUND:
@@ -10710,6 +10610,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_scale (se, expr);
       break;
 
+    case GFC_ISYM_SHAPE:
+      gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
+      break;
+
     case GFC_ISYM_SIGN:
       gfc_conv_intrinsic_sign (se, expr);
       break;
@@ -10756,7 +10660,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_UBOUND:
-      gfc_conv_intrinsic_bound (se, expr, 1);
+      gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
       break;
 
     case GFC_ISYM_UCOBOUND:
@@ -11030,6 +10934,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
     case GFC_ISYM_UCOBOUND:
     case GFC_ISYM_LCOBOUND:
     case GFC_ISYM_THIS_IMAGE:
+    case GFC_ISYM_SHAPE:
       break;
 
     default:
@@ -11038,8 +10943,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 }
 
 
-/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
-   are expanded into code inside the scalarization loop.  */
+/* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE 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)
@@ -11048,7 +10953,8 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
     gfc_add_class_array_ref (expr->value.function.actual->expr);
 
   /* The two argument version returns a scalar.  */
-  if (expr->value.function.actual->next->expr)
+  if (expr->value.function.isym->id != GFC_ISYM_SHAPE
+      && expr->value.function.actual->next->expr)
     return ss;
 
   return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
@@ -11148,7 +11054,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
     case GFC_ISYM_PARITY:
     case GFC_ISYM_PRODUCT:
     case GFC_ISYM_SUM:
-    case GFC_ISYM_SHAPE:
     case GFC_ISYM_SPREAD:
     case GFC_ISYM_YN2:
       /* Ignore absent optional parameters.  */
@@ -11198,6 +11103,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
     case GFC_ISYM_UBOUND:
     case GFC_ISYM_UCOBOUND:
     case GFC_ISYM_THIS_IMAGE:
+    case GFC_ISYM_SHAPE:
       return gfc_walk_intrinsic_bound (ss, expr);
 
     case GFC_ISYM_TRANSFER:
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index d234d1b..e81c558 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -72,7 +72,8 @@ gfc_omp_is_allocatable_or_ptr (const_tree decl)
 static bool
 gfc_omp_is_optional_argument (const_tree decl)
 {
-  return (TREE_CODE (decl) == PARM_DECL
+  /* Note: VAR_DECL can occur with BIND(C) and array descriptors.  */
+  return ((TREE_CODE (decl) == PARM_DECL || TREE_CODE (decl) == VAR_DECL)
 	  && DECL_LANG_SPECIFIC (decl)
 	  && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
 	  && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
@@ -105,8 +106,9 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check)
 	  || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))))
     decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
 
+  /* Note: With BIND(C), array descriptors are converted to a VAR_DECL.  */
   if (decl == NULL_TREE
-      || TREE_CODE (decl) != PARM_DECL
+      || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL)
       || !DECL_LANG_SPECIFIC (decl)
       || !GFC_DECL_OPTIONAL_ARGUMENT (decl))
     return NULL_TREE;
@@ -6405,12 +6407,17 @@ gfc_trans_omp_task (gfc_code *code)
 static tree
 gfc_trans_omp_taskgroup (gfc_code *code)
 {
+  stmtblock_t block;
+  gfc_start_block (&block);
   tree body = gfc_trans_code (code->block->next);
   tree stmt = make_node (OMP_TASKGROUP);
   TREE_TYPE (stmt) = void_type_node;
   OMP_TASKGROUP_BODY (stmt) = body;
-  OMP_TASKGROUP_CLAUSES (stmt) = NULL_TREE;
-  return stmt;
+  OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
+							code->ext.omp_clauses,
+							code->loc);
+  gfc_add_expr_to_block (&block, stmt);
+  return gfc_finish_block (&block);
 }
 
 static tree
@@ -6993,7 +7000,11 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
 	  res = gfc_trans_omp_directive (code);
 	  ompws_flags = saved_ompws_flags;
 	  break;
-	
+
+	case EXEC_BLOCK:
+	  res = gfc_trans_block_construct (code);
+	  break;
+
 	default:
 	  gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
 	}
@@ -7258,3 +7269,207 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns)
       DECL_ATTRIBUTES (fndecl) = c;
     }
 }
+
+void
+gfc_trans_omp_declare_variant (gfc_namespace *ns)
+{
+  tree base_fn_decl = ns->proc_name->backend_decl;
+  gfc_namespace *search_ns = ns;
+  gfc_omp_declare_variant *next;
+
+  for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
+       search_ns; odv = next)
+    {
+      /* Look in the parent namespace if there are no more directives in the
+	 current namespace.  */
+      if (!odv)
+	{
+	  search_ns = search_ns->parent;
+	  if (search_ns)
+	    next = search_ns->omp_declare_variant;
+	  continue;
+	}
+
+      next = odv->next;
+
+      if (odv->error_p)
+	continue;
+
+      /* Check directive the first time it is encountered.  */
+      bool error_found = true;
+
+      if (odv->checked_p)
+	error_found = false;
+      if (odv->base_proc_symtree == NULL)
+	{
+	  if (!search_ns->proc_name->attr.function
+	      && !search_ns->proc_name->attr.subroutine)
+	    gfc_error ("The base name for 'declare variant' must be "
+		       "specified at %L ", &odv->where);
+	  else
+	    error_found = false;
+	}
+      else
+	{
+	  if (!search_ns->contained
+	      && strcmp (odv->base_proc_symtree->name,
+			 ns->proc_name->name))
+	    gfc_error ("The base name at %L does not match the name of the "
+		       "current procedure", &odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.entry)
+	    gfc_error ("The base name at %L must not be an entry name",
+			&odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.generic)
+	    gfc_error ("The base name at %L must not be a generic name",
+			&odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
+	    gfc_error ("The base name at %L must not be a procedure pointer",
+			&odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
+	    gfc_error ("The base procedure at %L must have an explicit "
+			"interface", &odv->where);
+	  else
+	    error_found = false;
+	}
+
+      odv->checked_p = true;
+      if (error_found)
+	{
+	  odv->error_p = true;
+	  continue;
+	}
+
+      /* Ignore directives that do not apply to the current procedure.  */
+      if ((odv->base_proc_symtree == NULL && search_ns != ns)
+	  || (odv->base_proc_symtree != NULL
+	      && strcmp (odv->base_proc_symtree->name, ns->proc_name->name)))
+	continue;
+
+      tree set_selectors = NULL_TREE;
+      gfc_omp_set_selector *oss;
+
+      for (oss = odv->set_selectors; oss; oss = oss->next)
+	{
+	  tree selectors = NULL_TREE;
+	  gfc_omp_selector *os;
+	  for (os = oss->trait_selectors; os; os = os->next)
+	    {
+	      tree properties = NULL_TREE;
+	      gfc_omp_trait_property *otp;
+
+	      for (otp = os->properties; otp; otp = otp->next)
+		{
+		  switch (otp->property_kind)
+		    {
+		    case CTX_PROPERTY_USER:
+		    case CTX_PROPERTY_EXPR:
+		      {
+			gfc_se se;
+			gfc_init_se (&se, NULL);
+			gfc_conv_expr (&se, otp->expr);
+			properties = tree_cons (NULL_TREE, se.expr,
+						properties);
+		      }
+		      break;
+		    case CTX_PROPERTY_ID:
+		      properties = tree_cons (get_identifier (otp->name),
+					      NULL_TREE, properties);
+		      break;
+		    case CTX_PROPERTY_NAME_LIST:
+		      {
+			tree prop = NULL_TREE, value = NULL_TREE;
+			if (otp->is_name)
+			  prop = get_identifier (otp->name);
+			else
+			  value = gfc_conv_constant_to_tree (otp->expr);
+
+			properties = tree_cons (prop, value, properties);
+		      }
+		      break;
+		    case CTX_PROPERTY_SIMD:
+		      properties = gfc_trans_omp_clauses (NULL, otp->clauses,
+							  odv->where, true);
+		      break;
+		    default:
+		      gcc_unreachable ();
+		    }
+		}
+
+	      if (os->score)
+		{
+		  gfc_se se;
+		  gfc_init_se (&se, NULL);
+		  gfc_conv_expr (&se, os->score);
+		  properties = tree_cons (get_identifier (" score"),
+					  se.expr, properties);
+		}
+
+	      selectors = tree_cons (get_identifier (os->trait_selector_name),
+				     properties, selectors);
+	    }
+
+	  set_selectors
+	    = tree_cons (get_identifier (oss->trait_set_selector_name),
+			 selectors, set_selectors);
+	}
+
+      const char *variant_proc_name = odv->variant_proc_symtree->name;
+      gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
+      if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
+	{
+	  gfc_symtree *proc_st;
+	  gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
+	  variant_proc_sym = proc_st->n.sym;
+	}
+      if (variant_proc_sym == NULL)
+	{
+	  gfc_error ("Cannot find symbol %qs", variant_proc_name);
+	  continue;
+	}
+      set_selectors = omp_check_context_selector
+	  (gfc_get_location (&odv->where), set_selectors);
+      if (set_selectors != error_mark_node)
+	{
+	  if (!variant_proc_sym->attr.implicit_type
+	      && !variant_proc_sym->attr.subroutine
+	      && !variant_proc_sym->attr.function)
+	    {
+	      gfc_error ("variant %qs at %L is not a function or subroutine",
+			 variant_proc_name, &odv->where);
+	      variant_proc_sym = NULL;
+	    }
+	  else if (omp_get_context_selector (set_selectors, "construct",
+					     "simd") == NULL_TREE)
+	    {
+	      char err[256];
+	      if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
+					   variant_proc_sym->name, 0, 1,
+					   err, sizeof (err), NULL, NULL))
+		{
+		  gfc_error ("variant %qs and base %qs at %L have "
+			     "incompatible types: %s",
+			     variant_proc_name, ns->proc_name->name,
+			     &odv->where, err);
+		  variant_proc_sym = NULL;
+		}
+	    }
+	  if (variant_proc_sym != NULL)
+	    {
+	      gfc_set_sym_referenced (variant_proc_sym);
+	      tree construct = omp_get_context_selector (set_selectors,
+							 "construct", NULL);
+	      omp_mark_declare_variant (gfc_get_location (&odv->where),
+					gfc_get_symbol_decl (variant_proc_sym),
+					construct);
+	      if (omp_context_selector_matches (set_selectors))
+		{
+		  tree id = get_identifier ("omp declare variant base");
+		  tree variant = gfc_get_symbol_decl (variant_proc_sym);
+		  DECL_ATTRIBUTES (base_fn_decl)
+		    = tree_cons (id, build_tree_list (variant, set_selectors),
+				 DECL_ATTRIBUTES (base_fn_decl));
+		}
+	    }
+	}
+    }
+}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a8ff473..eaf2cc2 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3670,10 +3670,7 @@ gfc_trans_select_rank_cases (gfc_code * code)
   tree tmp;
   tree cond;
   tree low;
-  tree sexpr;
   tree rank;
-  tree rank_minus_one;
-  tree minus_one;
   gfc_se se;
   gfc_se cse;
   stmtblock_t block;
@@ -3687,24 +3684,25 @@ gfc_trans_select_rank_cases (gfc_code * code)
   gfc_conv_expr_descriptor (&se, code->expr1);
   rank = gfc_conv_descriptor_rank (se.expr);
   rank = gfc_evaluate_now (rank, &block);
-  minus_one = build_int_cst (TREE_TYPE (rank), -1);
-  tmp = fold_build2_loc (input_location, MINUS_EXPR,
-			 gfc_array_index_type,
-			 fold_convert (gfc_array_index_type, rank),
-			 build_int_cst (gfc_array_index_type, 1));
-  rank_minus_one = gfc_evaluate_now (tmp, &block);
-  tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one);
-  cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
-			  tmp, build_int_cst (TREE_TYPE (tmp), -1));
-  tmp = fold_build3_loc (input_location, COND_EXPR,
-			 TREE_TYPE (rank), cond,
-			 rank, minus_one);
-  cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
-			  rank, build_int_cst (TREE_TYPE (rank), 0));
-  sexpr = fold_build3_loc (input_location, COND_EXPR,
-			   TREE_TYPE (rank), cond,
-			   rank, tmp);
-  sexpr = gfc_evaluate_now (sexpr, &block);
+  symbol_attribute attr = gfc_expr_attr (code->expr1);
+  if (!attr.pointer && !attr.allocatable)
+    {
+      /* Special case for assumed-rank ('rank(*)', internally -1):
+	 rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+			      rank, build_int_cst (TREE_TYPE (rank), 0));
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     fold_convert (gfc_array_index_type, rank),
+			     gfc_index_one_node);
+      tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			     tmp, build_int_cst (TREE_TYPE (tmp), -1));
+      cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+			      logical_type_node, cond, tmp);
+      tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank),
+			     cond, rank, build_int_cst (TREE_TYPE (rank), -1));
+      rank = gfc_evaluate_now (tmp, &block);
+    }
   TREE_USED (code->exit_label) = 0;
 
 repeat:
@@ -3748,8 +3746,8 @@ repeat:
       if (low != NULL_TREE)
 	{
 	  cond = fold_build2_loc (input_location, EQ_EXPR,
-				  TREE_TYPE (sexpr), sexpr,
-				  fold_convert (TREE_TYPE (sexpr), low));
+				  TREE_TYPE (rank), rank,
+				  fold_convert (TREE_TYPE (rank), low));
 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 				 cond, tmp,
 				 build_empty_stmt (input_location));
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 763f894..1a24d9b 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -71,6 +71,7 @@ tree gfc_trans_deallocate_array (tree);
 /* trans-openmp.c */
 tree gfc_trans_omp_directive (gfc_code *);
 void gfc_trans_omp_declare_simd (gfc_namespace *);
+void gfc_trans_omp_declare_variant (gfc_namespace *);
 tree gfc_trans_oacc_directive (gfc_code *);
 tree gfc_trans_oacc_declare (gfc_namespace *);
 
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 1c78a90..4277806 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -77,6 +77,7 @@ static GTY(()) tree gfc_desc_dim_type;
 static GTY(()) tree gfc_max_array_element_size;
 static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
 static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
+static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];
 
 /* Arrays for all integral and real kinds.  We'll fill this in at runtime
    after the target has a chance to process command-line options.  */
@@ -1575,8 +1576,9 @@ gfc_get_dtype_rank_type (int rank, tree etype)
 
   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
 			     GFC_DTYPE_RANK);
-  CONSTRUCTOR_APPEND_ELT (v, field,
-			  build_int_cst (TREE_TYPE (field), rank));
+  if (rank >= 0)
+    CONSTRUCTOR_APPEND_ELT (v, field,
+			    build_int_cst (TREE_TYPE (field), rank));
 
   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
 			     GFC_DTYPE_TYPE);
@@ -2244,7 +2246,7 @@ gfc_nonrestricted_type (tree t)
    especially for character and array types.  */
 
 tree
-gfc_sym_type (gfc_symbol * sym)
+gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
 {
   tree type;
   int byref;
@@ -2299,7 +2301,11 @@ gfc_sym_type (gfc_symbol * sym)
   if (!restricted)
     type = gfc_nonrestricted_type (type);
 
-  if (sym->attr.dimension || sym->attr.codimension)
+  /* Dummy argument to a bind(C) procedure.  */
+  if (is_bind_c && is_CFI_desc (sym, NULL))
+    type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0,
+			     /* restricted = */ false);
+  else if (sym->attr.dimension || sym->attr.codimension)
     {
       if (gfc_is_nodesc_array (sym))
         {
@@ -2342,7 +2348,8 @@ gfc_sym_type (gfc_symbol * sym)
     {
       /* We must use pointer types for potentially absent variables.  The
 	 optimizers assume a reference type argument is never NULL.  */
-      if (sym->attr.optional
+      if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+	  || sym->attr.optional
 	  || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
 	type = build_pointer_type (type);
       else
@@ -3007,7 +3014,11 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
 	}
       if (sym->ts.type == BT_CHARACTER)
 	{
-	  spec[spec_len++] = 'R';
+	  if (!sym->ts.u.cl->length
+	      && (sym->attr.allocatable || sym->attr.pointer))
+	    spec[spec_len++] = 'w';
+	  else
+	    spec[spec_len++] = 'R';
 	  spec[spec_len++] = ' ';
 	}
     }
@@ -3131,7 +3142,7 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
 	      type = build_pointer_type (type);
 	    }
 	  else
-	    type = gfc_sym_type (arg);
+	    type = gfc_sym_type (arg, sym->attr.is_bind_c);
 
 	  /* Parameter Passing Convention
 
@@ -3722,4 +3733,95 @@ gfc_get_caf_reference_type ()
   return reference_type;
 }
 
+static tree
+gfc_get_cfi_dim_type ()
+{
+  static tree CFI_dim_t = NULL;
+
+  if (CFI_dim_t)
+    return CFI_dim_t;
+
+  CFI_dim_t = make_node (RECORD_TYPE);
+  TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t");
+  TYPE_NAMELESS (CFI_dim_t) = 1;
+  tree field;
+  tree *chain = NULL;
+  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"),
+				     gfc_array_index_type, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"),
+				     gfc_array_index_type, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"),
+				     gfc_array_index_type, &chain);
+  suppress_warning (field);
+  gfc_finish_type (CFI_dim_t);
+  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1;
+  return CFI_dim_t;
+}
+
+
+/* Return the CFI type; use dimen == -1 for dim[] (only for pointers);
+   otherwise dim[dimen] is used.  */
+
+tree
+gfc_get_cfi_type (int dimen, bool restricted)
+{
+  gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK);
+
+  int idx = 2*(dimen + 1) + restricted;
+
+  if (gfc_cfi_descriptor_base[idx])
+    return gfc_cfi_descriptor_base[idx];
+
+  /* Build the type node.  */
+  tree CFI_cdesc_t = make_node (RECORD_TYPE);
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  if (dimen != -1)
+    sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen);
+  TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name);
+  TYPE_NAMELESS (CFI_cdesc_t) = 1;
+
+  tree field;
+  tree *chain = NULL;
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"),
+				     (restricted ? prvoid_type_node
+						 : ptr_type_node), &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"),
+				     size_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"),
+				     integer_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"),
+				     signed_char_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"),
+				     signed_char_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"),
+				     get_typenode_from_name (INT16_TYPE),
+				     &chain);
+  suppress_warning (field);
+
+  if (dimen != 0)
+    {
+      tree range = NULL_TREE;
+      if (dimen > 0)
+	range = gfc_rank_cst[dimen - 1];
+      range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+				range);
+      tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range);
+      field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"),
+					 CFI_dim_t, &chain);
+      suppress_warning (field);
+    }
+
+  TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1;
+  gfc_finish_type (CFI_cdesc_t);
+  gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
+  return CFI_cdesc_t;
+}
+
 #include "gt-fortran-trans-types.h"
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 6804bfe..15d206b 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -84,7 +84,8 @@ tree gfc_get_character_type (int, gfc_charlen *);
 tree gfc_get_character_type_len (int, tree);
 tree gfc_get_character_type_len_for_eltype (tree, tree);
 
-tree gfc_sym_type (gfc_symbol *);
+tree gfc_sym_type (gfc_symbol *, bool is_bind_c_arg = false);
+tree gfc_get_cfi_type (int dimen, bool restricted);
 tree gfc_typenode_for_spec (gfc_typespec *, int c = 0);
 int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
 
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index eb5682a..22f2676 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -608,9 +608,9 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 
   if (once)
     {
-       tmpvar = gfc_create_var (logical_type_node, "print_warning");
+       tmpvar = gfc_create_var (boolean_type_node, "print_warning");
        TREE_STATIC (tmpvar) = 1;
-       DECL_INITIAL (tmpvar) = logical_true_node;
+       DECL_INITIAL (tmpvar) = boolean_true_node;
        gfc_add_expr_to_block (pblock, tmpvar);
     }
 
@@ -631,7 +631,7 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
   va_end (ap);
 
   if (once)
-    gfc_add_modify (&block, tmpvar, logical_false_node);
+    gfc_add_modify (&block, tmpvar, boolean_false_node);
 
   body = gfc_finish_block (&block);
 
@@ -643,9 +643,8 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
     {
       if (once)
 	cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR,
-				long_integer_type_node, tmpvar, cond);
-      else
-	cond = fold_convert (long_integer_type_node, cond);
+				boolean_type_node, tmpvar,
+				fold_convert (boolean_type_node, cond));
 
       tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node,
 			     cond, body,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index fa3e865..7ec4ca53 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -857,8 +857,6 @@ extern GTY(()) tree gfor_fndecl_ctime;
 extern GTY(()) tree gfor_fndecl_fdate;
 extern GTY(()) tree gfor_fndecl_in_pack;
 extern GTY(()) tree gfor_fndecl_in_unpack;
-extern GTY(()) tree gfor_fndecl_cfi_to_gfc;
-extern GTY(()) tree gfor_fndecl_gfc_to_cfi;
 extern GTY(()) tree gfor_fndecl_associated;
 extern GTY(()) tree gfor_fndecl_system_clock4;
 extern GTY(()) tree gfor_fndecl_system_clock8;