Fortran: Improve F2018 TEAM handling [PR87326, PR87556, PR88254, PR103896]

Improve the implementation of F2018 TEAM handling routines. Add
runtime-functions to caf_single to allow testing.

	PR fortran/87326
	PR fortran/87556
	PR fortran/88254
	PR fortran/103796

gcc/fortran/ChangeLog:

	* coarray.cc (split_expr_at_caf_ref): Treat polymorphic types
	correctly.  Ensure resolve of expression after coindex.
	(create_allocated_callback): Fix parameter of allocated function
	for coarrays.
	(coindexed_expr_callback): Improve detection of coarrays in
	allocated function.
	* decl.cc (gfc_match_end): Add team block matching.
	* dump-parse-tree.cc (show_code_node): Dump change team block as
	such.
	* frontend-passes.cc (gfc_code_walker): Recognice team block.
	* gfortran.texi: Add documentation for team api functions.
	* intrinsic.texi: Add documentation about team_type in
	iso_fortran_env module.
	* iso-fortran-env.def (team_type): Use helper to get pointer
	kind.
	* match.cc (gfc_match_associate): Factor out matching of
	association list, because it is used in change team as well.
	(check_coarray_assoc): Ensure, that the association is to a
	coarray.
	(match_association_list): Match a list of association either in
	associate or in change team.
	(gfc_match_form_team): Match form team correctly include
	new_index.
	(gfc_match_change_team): Match change team with association
	list.
	(gfc_match_end_team): Match end team including stat and errmsg.
	(gfc_match_return): Prevent return from team block.
	* parse.cc (decode_statement): Sort team block.
	(next_statement): Same.
	(check_statement_label): Same.
	(accept_statement): Same.
	(verify_st_order): Same.
	(parse_associate): Renamed to move_associates_to_block...
	(move_associates_to_block): ... to enable reuse for change team.
	(parse_change_team): Parse it as block.
	(parse_executable): Same.
	* parse.h (enum gfc_compile_state): Add team block as compiler
	state.
	* resolve.cc (resolve_scalar_argument): New function to resolve
	an argument to a statement as a scalar.
	(resolve_form_team): Resolve its members.
	(resolve_change_team): Same.
	(resolve_branch): Prevent branch from jumping out of team block.
	(check_team): Removed.
	* trans-decl.cc (gfc_build_builtin_function_decls): Add stat and
	errmsg to team API functions and update their arguments.
	* trans-expr.cc (gfc_trans_subcomponent_assign): Also null the
	token when moving memory or an allocated() will not detect a
	free.
	* trans-intrinsic.cc (gfc_conv_intrinsic_caf_is_present_remote):
	Adapt to signature change no longer a pointer-pointer.
	* trans-stmt.cc (gfc_trans_form_team): Translate a form team
	including new_index.
	(gfc_trans_change_team): Translate a change team as a block.

libgfortran/ChangeLog:

	* caf/libcaf.h: Remove commented block.
	(_gfortran_caf_form_team): Allow for all relevant arguments.
	(_gfortran_caf_change_team): Same.
	(_gfortran_caf_end_team): Same.
	(_gfortran_caf_sync_team): Same.
	* caf/single.c (struct caf_single_team): Team handling
	structures.
	(_gfortran_caf_init): Initialize initial team.
	(free_team_list): Free all teams and the memory they hold.
	(_gfortran_caf_finalize): Free initial and sibling teams.
	(_gfortran_caf_register): Add memory registered to current team.
	(_gfortran_caf_deregister): Unregister memory from current team.
	(_gfortran_caf_is_present_on_remote): Check token's memptr for
	llocation.  May have been deallocated by an end team.
	(_gfortran_caf_form_team): Push a new team stub to the list.
	(_gfortran_caf_change_team): Push a formed team on top of the
	ctive teams stack.
	(_gfortran_caf_end_team): End the active team, free all memory
	allocated during its livespan.
	(_gfortran_caf_sync_team): Take stat and errmsg into account.

gcc/testsuite/ChangeLog:

	* gfortran.dg/team_change_2.f90: New test.
	* gfortran.dg/team_change_3.f90: New test.
	* gfortran.dg/team_end_2.f90: New test.
	* gfortran.dg/team_end_3.f90: New test.
	* gfortran.dg/team_form_2.f90: New test.
	* gfortran.dg/team_form_3.f90: New test.
	* gfortran.dg/team_sync_2.f90: New test.

24 files changed, 1116 insertions, 209 deletions

diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc
index 7058325..2f067f8 100644
--- a/gcc/fortran/coarray.cc
+++ b/gcc/fortran/coarray.cc
@@ -357,7 +357,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
 
   gcc_assert (expr->expr_type == EXPR_VARIABLE);
   caf_ts = &expr->symtree->n.sym->ts;
-  if (!expr->symtree->n.sym->attr.codimension)
+  if (!(expr->symtree->n.sym->ts.type == BT_CLASS
+	  ? CLASS_DATA (expr->symtree->n.sym)->attr.codimension
+	  : expr->symtree->n.sym->attr.codimension))
     {
       /* The coarray is in some component.  Find it.  */
       caf_ref = expr->ref;
@@ -432,6 +434,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
   else if (base->ts.type == BT_CLASS)
     convert_coarray_class_to_derived_type (base, ns);
 
+  memset (&(*post_caf_ref_expr)->ts, 0, sizeof (gfc_typespec));
+  gfc_resolve_expr (*post_caf_ref_expr);
+  (*post_caf_ref_expr)->corank = 0;
   gfc_expression_rank (*post_caf_ref_expr);
   if (for_send)
     gfc_expression_rank (expr);
@@ -1130,8 +1135,8 @@ create_allocated_callback (gfc_expr *expr)
 
   // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
   base = post_caf_ref_expr->symtree->n.sym;
+  base->attr.pointer = !base->attr.dimension;
   gfc_set_sym_referenced (base);
-  gfc_commit_symbol (base);
   *argptr = gfc_get_formal_arglist ();
   (*argptr)->sym = base;
   argptr = &(*argptr)->next;
@@ -1420,7 +1425,8 @@ coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
 	  {
 	  case GFC_ISYM_ALLOCATED:
 	    if ((*e)->value.function.actual->expr
-		&& gfc_is_coindexed ((*e)->value.function.actual->expr))
+		&& (gfc_is_coarray ((*e)->value.function.actual->expr)
+		    || gfc_is_coindexed ((*e)->value.function.actual->expr)))
 	      {
 		rewrite_caf_allocated (e);
 		*walk_subtrees = 0;
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index feb454e..69acd2d 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -8459,6 +8459,7 @@ gfc_match_end (gfc_statement *st)
     {
     case COMP_ASSOCIATE:
     case COMP_BLOCK:
+    case COMP_CHANGE_TEAM:
       if (startswith (block_name, "block@"))
 	block_name = NULL;
       break;
@@ -8515,7 +8516,7 @@ gfc_match_end (gfc_statement *st)
     case COMP_SUBROUTINE:
       *st = ST_END_SUBROUTINE;
       if (!abbreviated_modproc_decl)
-      target = " subroutine";
+	target = " subroutine";
       else
 	target = " procedure";
       eos_ok = !contained_procedure ();
@@ -8524,7 +8525,7 @@ gfc_match_end (gfc_statement *st)
     case COMP_FUNCTION:
       *st = ST_END_FUNCTION;
       if (!abbreviated_modproc_decl)
-      target = " function";
+	target = " function";
       else
 	target = " procedure";
       eos_ok = !contained_procedure ();
@@ -8646,6 +8647,12 @@ gfc_match_end (gfc_statement *st)
       eos_ok = 0;
       break;
 
+    case COMP_CHANGE_TEAM:
+      *st = ST_END_TEAM;
+      target = " team";
+      eos_ok = 0;
+      break;
+
     default:
       gfc_error ("Unexpected END statement at %C");
       goto cleanup;
@@ -8683,14 +8690,19 @@ gfc_match_end (gfc_statement *st)
   else
     got_matching_end = true;
 
+  if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
+    /* Emit errors of stat and errmsg parsing now to finish the block and
+       continue analysis of compilation unit.  */
+    gfc_error_check ();
+
   old_loc = gfc_current_locus;
   /* If we're at the end, make sure a block name wasn't required.  */
   if (gfc_match_eos () == MATCH_YES)
     {
-
       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
 	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
-	  && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
+	  && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
+	  && *st != ST_END_TEAM)
 	return MATCH_YES;
 
       if (!block_name)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 4ace093..dd920f3 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2769,17 +2769,21 @@ show_code_node (int level, gfc_code *c)
       fputs ("FAIL IMAGE ", dumpfile);
       break;
 
-    case EXEC_CHANGE_TEAM:
-      fputs ("CHANGE TEAM", dumpfile);
-      break;
-
     case EXEC_END_TEAM:
       fputs ("END TEAM", dumpfile);
       show_sync_stat (&c->ext.sync_stat);
       break;
 
     case EXEC_FORM_TEAM:
-      fputs ("FORM TEAM", dumpfile);
+      fputs ("FORM TEAM ", dumpfile);
+      show_expr (c->expr1);
+      show_expr (c->expr2);
+      if (c->expr3)
+	{
+	  fputs (" NEW_INDEX", dumpfile);
+	  show_expr (c->expr3);
+	}
+      show_sync_stat (&c->ext.sync_stat);
       break;
 
     case EXEC_SYNC_TEAM:
@@ -2930,6 +2934,7 @@ show_code_node (int level, gfc_code *c)
       fputs ("ENDIF", dumpfile);
       break;
 
+    case EXEC_CHANGE_TEAM:
     case EXEC_BLOCK:
       {
 	const char *blocktype, *sname = NULL;
@@ -2945,17 +2950,23 @@ show_code_node (int level, gfc_code *c)
 	    if (fcn && fcn->expr_type == EXPR_FUNCTION)
 	      sname = fcn->value.function.actual->expr->symtree->n.sym->name;
 	  }
+	else if (c->op == EXEC_CHANGE_TEAM)
+	  blocktype = "CHANGE TEAM";
 	else if (c->ext.block.assoc)
 	  blocktype = "ASSOCIATE";
 	else
 	  blocktype = "BLOCK";
 	show_indent ();
 	fprintf (dumpfile, "%s ", blocktype);
+	if (c->op == EXEC_CHANGE_TEAM)
+	  show_expr (c->expr1);
 	for (alist = c->ext.block.assoc; alist; alist = alist->next)
 	  {
 	    fprintf (dumpfile, " %s = ", sname ? sname : alist->name);
 	    show_expr (alist->target);
 	  }
+	if (c->op == EXEC_CHANGE_TEAM)
+	  show_sync_stat (&c->ext.block.sync_stat);
 
 	++show_level;
 	ns = c->ext.block.ns;
@@ -2965,8 +2976,13 @@ show_code_node (int level, gfc_code *c)
 	gfc_current_ns = saved_ns;
 	show_code (show_level, ns->code);
 	--show_level;
-	show_indent ();
-	fprintf (dumpfile, "END %s ", blocktype);
+	if (c->op != EXEC_CHANGE_TEAM)
+	  {
+	    /* A CHANGE_TEAM is terminated by a END_TEAM, which have its own
+	       stat and errmsg.  Therefore, let it print itself.  */
+	    show_indent ();
+	    fprintf (dumpfile, "END %s ", blocktype);
+	  }
 	break;
       }
 
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index ef9c801..02a0a23 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5340,6 +5340,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 	    {
 
 	    case EXEC_BLOCK:
+	    case EXEC_CHANGE_TEAM:
 	      WALK_SUBCODE (co->ext.block.ns->code);
 	      if (co->ext.block.assoc)
 		{
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 9632161..ff38567 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4230,6 +4230,10 @@ future implementation of teams.  It is about to change without further notice.
 * _gfortran_caf_co_min:: Collective minimum reduction
 * _gfortran_caf_co_sum:: Collective summing reduction
 * _gfortran_caf_co_reduce:: Generic collective reduction
+* _gfortran_caf_form_team:: Team creation function
+* _gfortran_caf_change_team:: Team activation function
+* _gfortran_caf_end_team:: Team termination function
+* _gfortran_caf_sync_team:: Synchronize all images of a given team
 @end menu
 
 
@@ -4705,9 +4709,9 @@ structure.
 operation, i.e., zero on success and non-zero on error.  When @code{NULL} and an
 error occurs, then an error message is printed and the program is terminated.
 @item @var{team} @tab intent(in)  The opaque team handle as returned by
-@code{FORM TEAM}.  Unused at the moment.
+@code{FORM TEAM}.
 @item @var{team_number} @tab intent(in)  The number of the team this access is
-to be part of.  Unused at the moment.
+to be part of.
 @end multitable
 
 @item @emph{Notes}:
@@ -4806,9 +4810,9 @@ structure.
 operation, i.e., zero on success and non-zero on error.  When @code{NULL} and an
 error occurs, then an error message is printed and the program is terminated.
 @item @var{team} @tab intent(in)  The opaque team handle as returned by
-@code{FORM TEAM}.  Unused at the moment.
+@code{FORM TEAM}.
 @item @var{team_number} @tab intent(in)  The number of the team this access is
-to be part of.  Unused at the moment.
+to be part of.
 @end multitable
 
 @item @emph{Notes}:
@@ -4906,13 +4910,13 @@ the operation on the sending side, i.e., zero on success and non-zero on error.
 When @code{NULL} and an error occurs, then an error message is printed and the
 program is terminated.
 @item @var{dst_team} @tab intent(in)  The opaque team handle as returned by
-@code{FORM TEAM}.  Unused at the moment.
+@code{FORM TEAM}.
 @item @var{dst_team_number} @tab intent(in)  The number of the team this access
-is to be part of.  Unused at the moment.
+is to be part of.
 @item @var{src_team} @tab intent(in)  The opaque team handle as returned by
-@code{FORM TEAM}.  Unused at the moment.
+@code{FORM TEAM}.
 @item @var{src_team_number} @tab intent(in)  The number of the team this access
-is to be part of.  Unused at the moment.
+is to be part of.
 @end multitable
 
 @item @emph{Notes}:
@@ -5656,6 +5660,132 @@ or an array descriptor.
 @end table
 
 
+
+@node _gfortran_caf_form_team
+@subsection @code{_gfortran_caf_form_team} --- Team creation function
+@cindex Coarray, _gfortran_caf_form_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_form_team (int team_id, caf_team_t *team,
+int *new_index, int *stat, char *errmsg, size_t errmsg_len)}
+
+@item @emph{Description}:
+Create a team.  All images giving the same @var{team_id} in a call to
+@code{FORM TEAM} will form a new team addressable by the opaque handle
+@var{team} which is of type @code{team_type} from the intrinsic module
+@ref{ISO_FORTRAN_ENV}.  In the team the image gets the image index given by
+@var{new_index} if present.  If @var{new_index} is absent, then an
+implementation specific index is assigned.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team_id} @tab intent(in)  A unique id for each team to form.  Images
+giving the same @var{team_id} in a call to @code{FORM TEAM} belong to the same
+team.
+@item @var{team} @tab intent(out)  The opaque pointer to the newly formed team
+@item @var{new_index} @tab intent(in)  If non-null gives the unique index of
+this image in the newly formed team.  When no @var{new_index} is given, the
+caf-library is free to choose a unique index.
+@item @var{stat} @tab intent(out)  Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out)  When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in)  the buffer size of errmsg
+@end multitable
+
+@item @emph{Notes}:
+The id given in @var{team_id} has to be unique in all subsequent calls to
+@code{FORM TEAM} on the same image.  That id is the same used in
+@code{TEAM_NUMBER=} of coarray indexes, which motivates the uniqueness.
+
+The index given in @var{new_index} needs to be unique among all members of
+team to create.  Failing uniqueness may lead to misbehaviour, which depends
+on the caf-library's implementation.  The library is free to implement
+checks for this, which imposes overhead and therefore may be avoided.
+@end table
+
+
+
+@node _gfortran_caf_change_team
+@subsection @code{_gfortran_caf_change_team} --- Team activation function
+@cindex Coarray, _gfortran_caf_change_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_change_team (caf_team_t team, int *stat, char *errmsg,
+size_t errmsg_len)}
+
+@item @emph{Description}:
+Actives the team given by @var{team}, which must be formed but not active
+yet.  This routine starts a new epoch on the coarray memory pool.  All
+coarrays registered from now on, will be freeed once the team is terminated.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team} @tab intent(inout)  The opaque pointer to an already formed
+team
+@item @var{stat} @tab intent(out)  Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out)  When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in)  the buffer size of errmsg
+@end multitable
+
+@item @emph{Notes}:
+When an error occurs and @var{stat} is non-null, it will be set.  Nevertheless
+will the Fortran program continue with the first statement in the change team
+block.
+@end table
+
+
+
+@node _gfortran_caf_end_team
+@subsection @code{_gfortran_caf_end_team} --- Team termination function
+@cindex Coarray, _gfortran_caf_end_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)}
+
+@item @emph{Description}:
+Terminates the last team changed to.  The coarray memory epoch is
+terminated and all coarrays allocated since the execution of @code{CHANGE TEAM}
+are freeed.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{stat} @tab intent(out)  Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out)  When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in)  the buffer size of errmsg
+@end multitable
+@end table
+
+
+
+@node _gfortran_caf_sync_team
+@subsection @code{_gfortran_caf_sync_team} --- Synchronize all images of a given team
+@cindex Coarray, _gfortran_caf_sync_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg,
+size_t errmsg_len)}
+
+@item @emph{Description}:
+Blocks execution of the image calling @code{SYNC TEAM} until all images of the
+team given by @var{team} have joined the synchronisation call.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team} @tab intent(in)  The opaque pointer to an active team
+@item @var{stat} @tab intent(out)  Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out)  When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in)  the buffer size of errmsg
+@end multitable
+@end table
+
+
 @c Intrinsic Procedures
 @c ---------------------------------------------------------------------
 
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 8c160e5..ad89064 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -15445,6 +15445,10 @@ Derived type with private components to be use with the @code{LOCK} and
 @code{UNLOCK} statement. A variable of its type has to be always declared
 as coarray and may not appear in a variable-definition context.
 (Fortran 2008 or later.)
+@item @code{TEAM_TYPE}:
+An opaque type for handling teams.  Note that a variable of type
+@code{TEAM_TYPE} is not comparable with other variables of the same or other
+types nor with null.
 @end table
 
 The module also provides the following intrinsic procedures:
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index b8926f4..970f09f 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -134,9 +134,7 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \
 		    : gfc_default_integer_kind, GFC_STD_F2018)
 
 NAMED_DERIVED_TYPE (ISOFORTRAN_TEAM_TYPE, "team_type", \
-		    flag_coarray == GFC_FCOARRAY_LIB
-		    ? get_int_kind_from_node (ptr_type_node)
-		    : gfc_default_integer_kind, GFC_STD_F2018)
+		    get_int_kind_from_node (ptr_type_node), GFC_STD_F2018)
 
 NAMED_INTCST (ISOFORTRANENV_LOGICAL8, "logical8", \
               gfc_get_int_kind_from_width_isofortranenv (8), GFC_STD_F2023)
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 4d77e09..0d81b69 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1966,29 +1966,29 @@ gfc_match_block (void)
   return MATCH_YES;
 }
 
-
-/* Match an ASSOCIATE statement.  */
-
-match
-gfc_match_associate (void)
+bool
+check_coarray_assoc (const char *name, gfc_association_list *assoc)
 {
-  if (gfc_match_label () == MATCH_ERROR)
-    return MATCH_ERROR;
-
-  if (gfc_match (" associate") != MATCH_YES)
-    return MATCH_NO;
-
-  /* Match the association list.  */
-  if (gfc_match_char ('(') != MATCH_YES)
+  if (assoc->target->expr_type == EXPR_VARIABLE
+      && !strcmp (assoc->target->symtree->name, name))
     {
-      gfc_error ("Expected association list at %C");
-      return MATCH_ERROR;
+      gfc_error ("Codimension decl name %qs in association at %L "
+		 "must not be the same as a selector",
+		 name, &assoc->where);
+      return false;
     }
+  return true;
+}
+
+match
+match_association_list (bool for_change_team = false)
+{
   new_st.ext.block.assoc = NULL;
   while (true)
     {
-      gfc_association_list* newAssoc = gfc_get_association_list ();
-      gfc_association_list* a;
+      gfc_association_list *newAssoc = gfc_get_association_list ();
+      gfc_association_list *a;
+      locus pre_name = gfc_current_locus;
 
       /* Match the next association.  */
       if (gfc_match (" %n ", newAssoc->name) != MATCH_YES)
@@ -1998,7 +1998,7 @@ gfc_match_associate (void)
 	}
 
       /* Required for an assumed rank target.  */
-      if (gfc_peek_char () == '(')
+      if (!for_change_team && gfc_peek_char () == '(')
 	{
 	  newAssoc->ar = gfc_get_array_ref ();
 	  if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES)
@@ -2012,26 +2012,53 @@ gfc_match_associate (void)
 	gfc_error_now ("The bounds remapping list at %C is an experimental "
 		       "F202y feature. Use std=f202y to enable");
 
+      if (for_change_team && gfc_peek_char () == '[')
+	{
+	  if (!newAssoc->ar)
+	    newAssoc->ar = gfc_get_array_ref ();
+	  if (gfc_match_array_spec (&newAssoc->ar->as, false, true)
+	      == MATCH_ERROR)
+	    goto assocListError;
+	}
+
       /* Match the next association.  */
       if (gfc_match (" =>", newAssoc->name) != MATCH_YES)
 	{
-	  gfc_error ("Expected association at %C");
-	  goto assocListError;
+	  if (for_change_team)
+	    gfc_current_locus = pre_name;
+
+	  free (newAssoc);
+	  return MATCH_NO;
 	}
 
-      if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
+      if (!for_change_team)
 	{
-	  /* Have another go, allowing for procedure pointer selectors.  */
-	  gfc_matching_procptr_assignment = 1;
 	  if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
 	    {
+	      /* Have another go, allowing for procedure pointer selectors.  */
+	      gfc_matching_procptr_assignment = 1;
+	      if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
+		{
+		  gfc_matching_procptr_assignment = 0;
+		  gfc_error ("Invalid association target at %C");
+		  goto assocListError;
+		}
 	      gfc_matching_procptr_assignment = 0;
-	      gfc_error ("Invalid association target at %C");
+	    }
+	  newAssoc->where = gfc_current_locus;
+	}
+      else
+	{
+	  newAssoc->where = gfc_current_locus;
+	  /* F2018, C1116: A selector in a coarray-association shall be a named
+	     coarray.  */
+	  if (gfc_match (" %v", &newAssoc->target) != MATCH_YES)
+	    {
+	      gfc_error ("Selector in coarray association as %C shall be a "
+			 "named coarray");
 	      goto assocListError;
 	    }
-	  gfc_matching_procptr_assignment = 0;
 	}
-      newAssoc->where = gfc_current_locus;
 
       /* Check that the current name is not yet in the list.  */
       for (a = new_st.ext.block.assoc; a; a = a->next)
@@ -2042,6 +2069,35 @@ gfc_match_associate (void)
 	    goto assocListError;
 	  }
 
+      if (for_change_team)
+	{
+	  /* F2018, C1113: In a change-team-stmt, a coarray-name in a
+	     codimension-decl shall not be the same as a selector, or another
+	     coarray-name, in that statement.
+	     The latter is already checked for above.  So check only the
+	     former.
+	   */
+	  if (!check_coarray_assoc (newAssoc->name, newAssoc))
+	    goto assocListError;
+
+	  for (a = new_st.ext.block.assoc; a; a = a->next)
+	    {
+	      if (!check_coarray_assoc (newAssoc->name, a)
+		  || !check_coarray_assoc (a->name, newAssoc))
+		goto assocListError;
+
+	      /* F2018, C1115: No selector shall appear more than once in a
+	       * given change-team-stmt.  */
+	      if (!strcmp (newAssoc->target->symtree->name,
+			   a->target->symtree->name))
+		{
+		  gfc_error ("Selector at %L duplicates selector at %L",
+			     &newAssoc->target->where, &a->target->where);
+		  goto assocListError;
+		}
+	    }
+	}
+
       /* The target expression must not be coindexed.  */
       if (gfc_is_coindexed (newAssoc->target))
 	{
@@ -2108,8 +2164,40 @@ gfc_match_associate (void)
 
 assocListError:
       free (newAssoc);
+      return MATCH_ERROR;
+    }
+
+  return MATCH_YES;
+}
+
+/* Match an ASSOCIATE statement.  */
+
+match
+gfc_match_associate (void)
+{
+  match m;
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" associate") != MATCH_YES)
+    return MATCH_NO;
+
+  /* Match the association list.  */
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      gfc_error ("Expected association list at %C");
+      return MATCH_ERROR;
+    }
+
+  m = match_association_list ();
+  if (m == MATCH_ERROR)
+    goto error;
+  else if (m == MATCH_NO)
+    {
+      gfc_error ("Expected association at %C");
       goto error;
     }
+
   if (gfc_match_char (')') != MATCH_YES)
     {
       /* This should never happen as we peek above.  */
@@ -3914,7 +4002,9 @@ match
 gfc_match_form_team (void)
 {
   match m;
-  gfc_expr *teamid,*team;
+  gfc_expr *teamid, *team, *new_index;
+
+  teamid = team = new_index = NULL;
 
   if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C"))
     return MATCH_ERROR;
@@ -3932,18 +4022,61 @@ gfc_match_form_team (void)
   if (gfc_match ("%e", &team) != MATCH_YES)
     goto syntax;
 
-  m = gfc_match_char (')');
+  m = gfc_match_char (',');
+  if (m == MATCH_ERROR)
+    goto syntax;
   if (m == MATCH_NO)
+    {
+      m = gfc_match_char (')');
+      if (m == MATCH_YES)
+	goto done;
+      goto syntax;
+    }
+
+  for (;;)
+    {
+      m = match_stat_errmsg (&new_st.ext.sync_stat, ST_FORM_TEAM);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      m = match_named_arg (" new_index = %e", "NEW_INDEX", &new_index,
+			   ST_FORM_TEAM);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      m = gfc_match_char (',');
+      if (m == MATCH_YES)
+	continue;
+
+      break;
+    }
+
+  if (m == MATCH_ERROR)
     goto syntax;
 
+  if (gfc_match (" )%t") != MATCH_YES)
+    goto syntax;
+
+done:
+
   new_st.expr1 = teamid;
   new_st.expr2 = team;
+  new_st.expr3 = new_index;
 
   return MATCH_YES;
 
 syntax:
   gfc_syntax_error (ST_FORM_TEAM);
 
+cleanup:
+  gfc_free_expr (new_index);
+  gfc_free_expr (new_st.ext.sync_stat.stat);
+  gfc_free_expr (new_st.ext.sync_stat.errmsg);
+  new_st.ext.sync_stat = {NULL, NULL};
+
+  gfc_free_expr (team);
+  gfc_free_expr (teamid);
+
   return MATCH_ERROR;
 }
 
@@ -3953,7 +4086,13 @@ match
 gfc_match_change_team (void)
 {
   match m;
-  gfc_expr *team;
+  gfc_expr *team = NULL;
+
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" change% team") != MATCH_YES)
+    return MATCH_NO;
 
   if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C"))
     return MATCH_ERROR;
@@ -3961,15 +4100,41 @@ gfc_match_change_team (void)
   if (gfc_match_char ('(') == MATCH_NO)
     goto syntax;
 
-  new_st.op = EXEC_CHANGE_TEAM;
-
   if (gfc_match ("%e", &team) != MATCH_YES)
     goto syntax;
 
-  m = gfc_match_char (')');
+  m = gfc_match_char (',');
+  if (m == MATCH_ERROR)
+    goto syntax;
   if (m == MATCH_NO)
+    {
+      m = gfc_match_char (')');
+      if (m == MATCH_YES)
+	goto done;
+      goto syntax;
+    }
+
+  m = match_association_list (true);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  else if (m == MATCH_NO)
+    for (;;)
+      {
+	m = match_stat_errmsg (&new_st.ext.block.sync_stat, ST_CHANGE_TEAM);
+	if (m == MATCH_ERROR)
+	  goto cleanup;
+
+	if (gfc_match_char (',') == MATCH_YES)
+	  continue;
+
+	break;
+      }
+
+  if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 
+done:
+
   new_st.expr1 = team;
 
   return MATCH_YES;
@@ -3977,20 +4142,46 @@ gfc_match_change_team (void)
 syntax:
   gfc_syntax_error (ST_CHANGE_TEAM);
 
+cleanup:
+  gfc_free_expr (new_st.ext.block.sync_stat.stat);
+  gfc_free_expr (new_st.ext.block.sync_stat.errmsg);
+  new_st.ext.block.sync_stat = {NULL, NULL};
+  gfc_free_association_list (new_st.ext.block.assoc);
+  new_st.ext.block.assoc = NULL;
+  gfc_free_expr (team);
+
   return MATCH_ERROR;
 }
 
-/* Match a END TEAM statement.  */
+/* Match an END TEAM statement.  */
 
 match
 gfc_match_end_team (void)
 {
-  if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C"))
-    return MATCH_ERROR;
+  if (gfc_match_eos () == MATCH_YES)
+    goto done;
 
-  if (gfc_match_char ('(') == MATCH_YES)
+  if (gfc_match_char ('(') != MATCH_YES)
+    /* There could be a team-construct-name following.  Let caller decide
+       about error.  */
+    return MATCH_NO;
+
+  for (;;)
+    {
+      if (match_stat_errmsg (&new_st.ext.sync_stat, ST_END_TEAM) == MATCH_ERROR)
+	goto cleanup;
+
+      if (gfc_match_char (',') == MATCH_YES)
+	continue;
+
+      break;
+    }
+
+  if (gfc_match_char (')') != MATCH_YES)
     goto syntax;
 
+done:
+
   new_st.op = EXEC_END_TEAM;
 
   return MATCH_YES;
@@ -3998,6 +4189,14 @@ gfc_match_end_team (void)
 syntax:
   gfc_syntax_error (ST_END_TEAM);
 
+cleanup:
+  gfc_free_expr (new_st.ext.sync_stat.stat);
+  gfc_free_expr (new_st.ext.sync_stat.errmsg);
+  new_st.ext.sync_stat = {NULL, NULL};
+
+  /* Try to match the closing bracket to allow error recovery.  */
+  gfc_match_char (')');
+
   return MATCH_ERROR;
 }
 
@@ -5358,6 +5557,15 @@ gfc_match_return (void)
       return MATCH_ERROR;
     }
 
+  if (gfc_find_state (COMP_CHANGE_TEAM))
+    {
+      /* F2018, C1111: A RETURN statement shall not appear within a CHANGE TEAM
+	 construct.  */
+      gfc_error (
+	"Image control statement RETURN at %C in CHANGE TEAM-END TEAM block");
+      return MATCH_ERROR;
+    }
+
   if (gfc_match_eos () == MATCH_YES)
     goto done;
 
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index a95bb62..538eb65 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -488,6 +488,7 @@ decode_statement (void)
   match (NULL, gfc_match_do, ST_DO);
   match (NULL, gfc_match_block, ST_BLOCK);
   match (NULL, gfc_match_associate, ST_ASSOCIATE);
+  match (NULL, gfc_match_change_team, ST_CHANGE_TEAM);
   match (NULL, gfc_match_critical, ST_CRITICAL);
   match (NULL, gfc_match_select, ST_SELECT_CASE);
   match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
@@ -517,7 +518,6 @@ decode_statement (void)
 
     case 'c':
       match ("call", gfc_match_call, ST_CALL);
-      match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM);
       match ("close", gfc_match_close, ST_CLOSE);
       match ("continue", gfc_match_continue, ST_CONTINUE);
       match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
@@ -537,7 +537,6 @@ decode_statement (void)
 
     case 'e':
       match ("end file", gfc_match_endfile, ST_END_FILE);
-      match ("end team", gfc_match_end_team, ST_END_TEAM);
       match ("exit", gfc_match_exit, ST_EXIT);
       match ("else", gfc_match_else, ST_ELSE);
       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
@@ -1927,8 +1926,7 @@ next_statement (void)
   case ST_OMP_INTEROP: \
   case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
   case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
-  case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
-  case ST_END_TEAM: case ST_SYNC_TEAM: \
+  case ST_FORM_TEAM: case ST_SYNC_TEAM: \
   case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
   case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
   case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@@ -2032,7 +2030,8 @@ next_statement (void)
 
 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
 		 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
-		 case ST_END_BLOCK: case ST_END_ASSOCIATE
+		 case ST_END_BLOCK: case ST_END_ASSOCIATE: \
+		 case ST_END_TEAM
 
 
 /* Push a new state onto the stack.  */
@@ -2164,6 +2163,7 @@ check_statement_label (gfc_statement st)
     case ST_END_CRITICAL:
     case ST_END_BLOCK:
     case ST_END_ASSOCIATE:
+    case ST_END_TEAM:
     case_executable:
     case_exec_markers:
       if (st == ST_ENDDO || st == ST_CONTINUE)
@@ -3199,6 +3199,8 @@ accept_statement (gfc_statement st)
     case ST_ENTRY:
     case ST_OMP_METADIRECTIVE:
     case ST_OMP_BEGIN_METADIRECTIVE:
+    case ST_CHANGE_TEAM:
+    case ST_END_TEAM:
     case_executable:
     case_exec_markers:
       add_statement ();
@@ -3383,6 +3385,8 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
 	goto order;
       break;
 
+    case ST_CHANGE_TEAM:
+    case ST_END_TEAM:
     case_executable:
     case_exec_markers:
       if (p->state < ORDER_EXEC)
@@ -5238,30 +5242,12 @@ parse_block_construct (void)
   pop_state ();
 }
 
-
-/* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
-   behind the scenes with compiler-generated variables.  */
-
 static void
-parse_associate (void)
+move_associates_to_block ()
 {
-  gfc_namespace* my_ns;
-  gfc_state_data s;
-  gfc_statement st;
-  gfc_association_list* a;
+  gfc_association_list *a;
   gfc_array_spec *as;
 
-  gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
-
-  my_ns = gfc_build_block_ns (gfc_current_ns);
-
-  new_st.op = EXEC_BLOCK;
-  new_st.ext.block.ns = my_ns;
-  gcc_assert (new_st.ext.block.assoc);
-
-  /* Add all associate-names as BLOCK variables.  Creating them is enough
-     for now, they'll get their values during trans-* phase.  */
-  gfc_current_ns = my_ns;
   for (a = new_st.ext.block.assoc; a; a = a->next)
     {
       gfc_symbol *sym, *tsym;
@@ -5298,26 +5284,23 @@ parse_associate (void)
 
       /* Don’t share the character length information between associate
 	 variable and target if the length is not a compile-time constant,
-	 as we don’t want to touch some other character length variable when
-	 we try to initialize the associate variable’s character length
-	 variable.
-	 We do it here rather than later so that expressions referencing the
-	 associate variable will automatically have the correctly setup length
-	 information.  If we did it at resolution stage the expressions would
-	 use the original length information, and the variable a new different
-	 one, but only the latter one would be correctly initialized at
-	 translation stage, and the former one would need some additional setup
-	 there.  */
-      if (sym->ts.type == BT_CHARACTER
-	  && sym->ts.u.cl
+	 as we don’t want to touch some other character length variable
+	 when we try to initialize the associate variable’s character
+	 length variable.  We do it here rather than later so that expressions
+	 referencing the associate variable will automatically have the
+	 correctly setup length information.  If we did it at resolution stage
+	 the expressions would use the original length information, and the
+	 variable a new different one, but only the latter one would be
+	 correctly initialized at translation stage, and the former one would
+	 need some additional setup there.  */
+      if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
 	  && !(sym->ts.u.cl->length
 	       && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
 	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 
       /* If the function has been parsed, go straight to the result to
 	 obtain the expression rank.  */
-      if (target->expr_type == EXPR_FUNCTION
-	  && target->symtree
+      if (target->expr_type == EXPR_FUNCTION && target->symtree
 	  && target->symtree->n.sym)
 	{
 	  tsym = target->symtree->n.sym;
@@ -5344,8 +5327,7 @@ parse_associate (void)
 	 by calling gfc_resolve_expr because the context is unavailable.
 	 However, the references can be resolved and the rank of the target
 	 expression set.  */
-      if (!sym->assoc->inferred_type
-	  && target->ref && gfc_resolve_ref (target)
+      if (!sym->assoc->inferred_type && target->ref && gfc_resolve_ref (target)
 	  && target->expr_type != EXPR_ARRAY
 	  && target->expr_type != EXPR_COMPCALL)
 	gfc_expression_rank (target);
@@ -5353,13 +5335,12 @@ parse_associate (void)
       /* Determine whether or not function expressions with unknown type are
 	 structure constructors. If so, the function result can be converted
 	 to be a derived type.  */
-      if (target->expr_type == EXPR_FUNCTION
-	  && target->ts.type == BT_UNKNOWN)
+      if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
 	{
 	  gfc_symbol *derived;
 	  /* The derived type has a leading uppercase character.  */
 	  gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
-			   my_ns->parent, 1, &derived);
+			   gfc_current_ns->parent, 1, &derived);
 	  if (derived && derived->attr.flavor == FL_DERIVED)
 	    {
 	      sym->ts.type = BT_DERIVED;
@@ -5394,7 +5375,7 @@ parse_associate (void)
 		  attr.codimension = as->corank ? 1 : 0;
 		  sym->assoc->variable = true;
 		}
-	       else if (rank || corank)
+	      else if (rank || corank)
 		{
 		  as = gfc_get_array_spec ();
 		  as->type = AS_DEFERRED;
@@ -5449,6 +5430,30 @@ parse_associate (void)
 	}
       gfc_commit_symbols ();
     }
+}
+
+/* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
+   behind the scenes with compiler-generated variables.  */
+
+static void
+parse_associate (void)
+{
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+  gfc_statement st;
+
+  gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
+  new_st.op = EXEC_BLOCK;
+  new_st.ext.block.ns = my_ns;
+  gcc_assert (new_st.ext.block.assoc);
+
+  /* Add all associate-names as BLOCK variables.  Creating them is enough
+     for now, they'll get their values during trans-* phase.  */
+  gfc_current_ns = my_ns;
+  move_associates_to_block ();
 
   accept_statement (ST_ASSOCIATE);
   push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
@@ -5474,6 +5479,49 @@ loop:
   pop_state ();
 }
 
+static void
+parse_change_team (void)
+{
+  gfc_namespace *my_ns;
+  gfc_state_data s;
+  gfc_statement st;
+
+  gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
+  new_st.op = EXEC_CHANGE_TEAM;
+  new_st.ext.block.ns = my_ns;
+
+  /* Add all associate-names as BLOCK variables.  Creating them is enough
+     for now, they'll get their values during trans-* phase.  */
+  gfc_current_ns = my_ns;
+  if (new_st.ext.block.assoc)
+    move_associates_to_block ();
+
+  accept_statement (ST_CHANGE_TEAM);
+  push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name);
+
+loop:
+  st = parse_executable (ST_NONE);
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case_end:
+      accept_statement (st);
+      my_ns->code = gfc_state_stack->head;
+      break;
+
+    default:
+      unexpected_statement (st);
+      goto loop;
+    }
+
+  gfc_current_ns = gfc_current_ns->parent;
+  pop_state ();
+}
 
 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
    handled inside of parse_executable(), because they aren't really
@@ -6576,6 +6624,7 @@ parse_executable (gfc_statement st)
 	  case ST_STOP:
 	  case ST_ERROR_STOP:
 	  case ST_END_SUBROUTINE:
+	  case ST_END_TEAM:
 
 	  case ST_DO:
 	  case ST_FORALL:
@@ -6615,6 +6664,10 @@ parse_executable (gfc_statement st)
 	  parse_associate ();
 	  break;
 
+	case ST_CHANGE_TEAM:
+	  parse_change_team ();
+	  break;
+
 	case ST_IF_BLOCK:
 	  parse_if_block ();
 	  break;
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 722e94c..7bf0fa4 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -32,7 +32,7 @@ enum gfc_compile_state
   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_OMP_STRICTLY_STRUCTURED_BLOCK,
-  COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE
+  COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE, COMP_CHANGE_TEAM
 };
 
 /* Stack element for the current compilation state.  These structures
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e9053b4..e51f83b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11519,6 +11519,62 @@ gfc_resolve_sync_stat (struct sync_stat *sync_stat)
 				  gfc_default_character_kind,
 				  sync_stat->errmsg);
 }
+
+static void
+resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
+			 gfc_expr *e)
+{
+  gfc_resolve_expr (e);
+  if (e
+      && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
+    gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
+	       name, &e->where, gfc_basic_typename (exp_type), exp_kind);
+}
+
+static void
+resolve_form_team (gfc_code *code)
+{
+  resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
+			   code->expr1);
+  resolve_team_argument (code->expr2);
+  resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
+			   code->expr3);
+  gfc_resolve_sync_stat (&code->ext.sync_stat);
+}
+
+static void resolve_block_construct (gfc_code *);
+
+static void
+resolve_change_team (gfc_code *code)
+{
+  resolve_team_argument (code->expr1);
+  gfc_resolve_sync_stat (&code->ext.block.sync_stat);
+  resolve_block_construct (code);
+  /* Map the coarray bounds as selected.  */
+  for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
+    if (a->ar)
+      {
+	gfc_array_spec *src = a->ar->as, *dst;
+	if (a->st->n.sym->ts.type == BT_CLASS)
+	  dst = CLASS_DATA (a->st->n.sym)->as;
+	else
+	  dst = a->st->n.sym->as;
+	dst->corank = src->corank;
+	dst->cotype = src->cotype;
+	for (int i = 0; i < src->corank; ++i)
+	  {
+	    dst->lower[dst->rank + i] = src->lower[i];
+	    dst->upper[dst->rank + i] = src->upper[i];
+	    src->lower[i] = src->upper[i] = nullptr;
+	  }
+	gfc_free_array_spec (src);
+	free (a->ar);
+	a->ar = nullptr;
+	dst->resolved = false;
+	gfc_resolve_array_spec (dst, 0);
+      }
+}
+
 static void
 resolve_sync_team (gfc_code *code)
 {
@@ -11665,8 +11721,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 
   if (code->here == label)
     {
-      gfc_warning (0,
-		   "Branch at %L may result in an infinite loop", &code->loc);
+      gfc_warning (0, "Branch at %L may result in an infinite loop",
+		   &code->loc);
       return;
     }
 
@@ -11689,6 +11745,10 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 		   && bitmap_bit_p (stack->reachable_labels, label->value))
 	    gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
 		      "for label at %L", &code->loc, &label->where);
+	  else if (stack->current->op == EXEC_CHANGE_TEAM
+		   && bitmap_bit_p (stack->reachable_labels, label->value))
+	    gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
+		      "for label at %L", &code->loc, &label->where);
 	}
 
       return;
@@ -13325,23 +13385,6 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
 }
 
 
-static bool
-check_team (gfc_expr *team, const char *intrinsic)
-{
-  if (team->rank != 0
-      || team->ts.type != BT_DERIVED
-      || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
-      || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
-    {
-      gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
-		 "of type TEAM_TYPE", intrinsic, &team->where);
-      return false;
-    }
-
-  return true;
-}
-
-
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -13530,15 +13573,11 @@ start:
 	  break;
 
 	case EXEC_FORM_TEAM:
-	  if (code->expr1 != NULL
-	      && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
-	    gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
-		       "a scalar INTEGER", &code->expr1->where);
-	  check_team (code->expr2, "FORM TEAM");
+	  resolve_form_team (code);
 	  break;
 
 	case EXEC_CHANGE_TEAM:
-	  check_team (code->expr1, "CHANGE TEAM");
+	  resolve_change_team (code);
 	  break;
 
 	case EXEC_END_TEAM:
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 5e5311e..ae996a0 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4201,21 +4201,19 @@ gfc_build_builtin_function_decls (void)
 	    void_type_node, 3, pvoid_type_node, ppvoid_type_node,
 	    integer_type_node);
 
-      gfor_fndecl_caf_form_team
-	= gfc_build_library_function_decl_with_spec (
-	    get_identifier (PREFIX("caf_form_team")), ". . W . ",
-	    void_type_node, 3, integer_type_node, ppvoid_type_node,
-	    integer_type_node);
+      gfor_fndecl_caf_form_team = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX ("caf_form_team")), ". r w r w w w ",
+	void_type_node, 6, integer_type_node, ppvoid_type_node, pint_type,
+	pint_type, pchar_type_node, size_type_node);
 
-      gfor_fndecl_caf_change_team
-	= gfc_build_library_function_decl_with_spec (
-	    get_identifier (PREFIX("caf_change_team")), ". w . ",
-	    void_type_node, 2, ppvoid_type_node,
-	    integer_type_node);
+      gfor_fndecl_caf_change_team = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX ("caf_change_team")), ". r w w w ",
+	void_type_node, 4, pvoid_type_node, pint_type, pchar_type_node,
+	size_type_node);
 
-      gfor_fndecl_caf_end_team
-	= gfc_build_library_function_decl (
-	    get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
+      gfor_fndecl_caf_end_team = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX ("caf_end_team")), ". w w w ", void_type_node, 3,
+	pint_type, pchar_type_node, size_type_node);
 
       gfor_fndecl_caf_get_team
 	= gfc_build_library_function_decl (
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 62dd38d..276f325 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9836,7 +9836,12 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
 	   && !cm->attr.proc_pointer)
     {
       if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
- 	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+	{
+	  gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+	  if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
+	    gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
+			    null_pointer_node);
+	}
       else if (cm->attr.allocatable || cm->attr.pdt_array)
 	{
 	  tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 16ade8d..cab3ebc 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1379,9 +1379,9 @@ gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
   present_fn = e->value.function.actual->next->next->expr;
   add_data_sym = present_fn->symtree->n.sym->formal->sym;
 
-  fn_index = conv_caf_func_index (&se->pre, gfc_current_ns,
+  fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
 				  "__caf_present_on_remote_fn_index_%d", hash);
-  add_data_tree = conv_caf_add_call_data (&se->pre, gfc_current_ns,
+  add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns,
 					  "__caf_present_on_remote_add_data_%d",
 					  add_data_sym, &add_data_size);
   ++caf_call_cnt;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index e79209e..f128b4c 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -792,38 +792,42 @@ gfc_trans_form_team (gfc_code *code)
 {
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      gfc_se se;
-      gfc_se argse1, argse2;
-      tree team_id, team_type, tmp;
+      gfc_se se, argse;
+      tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp;
 
       gfc_init_se (&se, NULL);
-      gfc_init_se (&argse1, NULL);
-      gfc_init_se (&argse2, NULL);
-      gfc_start_block (&se.pre);
+      gfc_init_se (&argse, NULL);
 
-      gfc_conv_expr_val (&argse1, code->expr1);
-      gfc_conv_expr_val (&argse2, code->expr2);
-      team_id = fold_convert (integer_type_node, argse1.expr);
-      team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr);
+      gfc_conv_expr_val (&argse, code->expr1);
+      team_id = fold_convert (integer_type_node, argse.expr);
+      gfc_conv_expr_reference (&argse, code->expr2);
+      team_type = argse.expr;
 
-      gfc_add_block_to_block (&se.pre, &argse1.pre);
-      gfc_add_block_to_block (&se.pre, &argse2.pre);
-      tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_caf_form_team, 3,
-				 team_id, team_type,
-				 integer_zero_node);
+      /* NEW_INDEX=.  */
+      if (code->expr3)
+	{
+	  gfc_conv_expr_reference (&argse, code->expr3);
+	  new_index = argse.expr;
+	}
+      else
+	new_index = null_pointer_node;
+
+      gfc_add_block_to_block (&se.post, &argse.post);
+
+      gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+			   &errmsg_len);
+
+      gfc_add_block_to_block (&se.pre, &argse.pre);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6,
+				 team_id, team_type, new_index, stat, errmsg,
+				 errmsg_len);
       gfc_add_expr_to_block (&se.pre, tmp);
-      gfc_add_block_to_block (&se.pre, &argse1.post);
-      gfc_add_block_to_block (&se.pre, &argse2.post);
+      gfc_add_block_to_block (&se.pre, &se.post);
       return gfc_finish_block (&se.pre);
-    }
+     }
   else
-    {
-      const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
-      gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
-      tree tmp = gfc_get_symbol_decl (exsym);
-      return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
-    }
+    return trans_exit ();
 }
 
 /* Translate the CHANGE TEAM statement.  */
@@ -833,27 +837,30 @@ gfc_trans_change_team (gfc_code *code)
 {
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      gfc_se argse;
-      tree team_type, tmp;
+      stmtblock_t block;
+      gfc_se se;
+      tree team_type, stat, errmsg, errmsg_len, tmp;
 
-      gfc_init_se (&argse, NULL);
-      gfc_conv_expr_val (&argse, code->expr1);
-      team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+      gfc_init_se (&se, NULL);
+      gfc_start_block (&block);
 
-      tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_caf_change_team, 2, team_type,
-				 integer_zero_node);
-      gfc_add_expr_to_block (&argse.pre, tmp);
-      gfc_add_block_to_block (&argse.pre, &argse.post);
-      return gfc_finish_block (&argse.pre);
+      gfc_conv_expr_val (&se, code->expr1);
+      team_type = se.expr;
+
+      gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg,
+			   &errmsg_len);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4,
+				 team_type, stat, errmsg, errmsg_len);
+
+      gfc_add_expr_to_block (&se.pre, tmp);
+      gfc_add_block_to_block (&se.pre, &se.post);
+      gfc_add_block_to_block (&block, &se.pre);
+      gfc_add_expr_to_block (&block, gfc_trans_block_construct (code));
+      return gfc_finish_block (&block);
     }
   else
-    {
-      const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
-      gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
-      tree tmp = gfc_get_symbol_decl (exsym);
-      return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
-    }
+    return trans_exit ();
 }
 
 /* Translate the END TEAM statement.  */
diff --git a/gcc/testsuite/gfortran.dg/team_change_2.f90 b/gcc/testsuite/gfortran.dg/team_change_2.f90
new file mode 100644
index 0000000..00cc489
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_change_2.f90
@@ -0,0 +1,86 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Tests change team syntax
+
+  use iso_fortran_env, only : team_type
+  implicit none
+  type(team_type) :: team
+  integer :: new_team, istat
+  character(len=30) :: err
+  integer :: caf[*], caf2[*]
+
+  new_team = mod(this_image(),2)+1
+
+  form team (new_team,team)
+
+  change team !{ dg-error "Syntax error in CHANGE TEAM statement" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+  change team (err) !{ dg-error "must be a scalar expression of type TEAM_TYPE" }
+    continue
+  end team
+
+  change team (team, stat=err) !{ dg-error "must be a scalar INTEGER" }
+    continue
+  end team
+
+  change team (team, stat=istat, stat=istat) !{ dg-error "Duplicate STAT" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+  change team (team, stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER variable" }
+    continue
+  end team
+
+  change team (team, stat=istat, errmsg=str, errmsg=str) !{ dg-error "Duplicate ERRMSG" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+1234 if (istat /= 0) stop 1 !{ dg-error "leaves CHANGE TEAM" }
+
+  change team (team)
+    go to 1234 !{ dg-error "leaves CHANGE TEAM" }
+  end team
+
+  call foo(team)
+
+  ! F2018, C1113
+  change team (team, caf[3,*] => caf) !{ dg-error "Codimension decl name" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+  change team (team, c[3,*] => caf, c => caf2) !{ dg-error "Duplicate name" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+  change team (team, c[3,*] => caf, caf => caf2) !{ dg-error "Codimension decl name" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+  change team (team, caf2[3,*] => caf, c => caf2) !{ dg-error "Codimension decl name" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+  ! F2018, C1114
+  change team (team, c => [caf, caf2]) !{ dg-error "a named coarray" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+  ! F2018, C1115
+  change team (team, c => caf, c2 => caf) !{ dg-error "duplicates selector at" }
+    continue
+  end team !{ dg-error "Expecting END PROGRAM statement" }
+
+contains
+  subroutine foo(team)
+    type(team_type) :: team
+
+    change team (team)
+      return !{ dg-error "Image control statement" }
+    end team
+  end subroutine
+end
+
diff --git a/gcc/testsuite/gfortran.dg/team_change_3.f90 b/gcc/testsuite/gfortran.dg/team_change_3.f90
new file mode 100644
index 0000000..bc30c40
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_change_3.f90
@@ -0,0 +1,29 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Tests change team stat= and errmsg= specifiers
+
+  use iso_fortran_env, only : team_type
+  implicit none
+  type(team_type) :: team
+  integer :: new_team, istat = 42
+  character(len=30) :: err = 'unchanged'
+
+  new_team = mod(this_image(),2)+1
+
+  form team (new_team,team)
+
+  change team (team, stat=istat)
+    if (istat /= 0) stop 1
+  end team
+
+  change team (team, stat=istat, errmsg=err)
+    if (trim(err) /= 'unchanged') stop 2
+  end team
+
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, &err, 30\\)" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/team_end_2.f90 b/gcc/testsuite/gfortran.dg/team_end_2.f90
new file mode 100644
index 0000000..64f072a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_end_2.f90
@@ -0,0 +1,33 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Tests change team syntax
+
+  use iso_fortran_env, only : team_type
+  implicit none
+  type(team_type) :: team
+  integer :: new_team, istat
+  character(len=30) :: err
+
+  new_team = mod(this_image(),2)+1
+
+  form team (new_team,team)
+
+  change team (team)
+    continue
+  end team (stat=err) ! { dg-error "must be a scalar INTEGER" }
+
+  change team (team)
+    continue
+  end team (stat=istat, stat=istat) ! { dg-error "Duplicate STAT" }
+
+  change team (team)
+    continue
+  end team (stat=istat, errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" }
+
+  change team (team)
+    continue
+  end team (stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" }
+end
+
diff --git a/gcc/testsuite/gfortran.dg/team_end_3.f90 b/gcc/testsuite/gfortran.dg/team_end_3.f90
new file mode 100644
index 0000000..5e004ad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_end_3.f90
@@ -0,0 +1,39 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Tests end team stat= and errmsg= specifiers
+
+  use iso_fortran_env, only : team_type
+  implicit none
+  type(team_type) :: team
+  integer :: new_team, istat = 42
+  character(len=30) :: err = 'unchanged'
+  integer, allocatable :: sample(:)[:]
+  integer, allocatable :: scal_caf[:]
+
+  new_team = mod(this_image(),2)+1
+
+  form team (new_team,team)
+
+  change team (team)
+    allocate(sample(5)[*], scal_caf[*])
+    if (.NOT. allocated(sample)) stop 1
+    if (.NOT. allocated(scal_caf)) stop 2
+  end team (stat=istat)
+  if (istat /= 0) stop 3
+  if (allocated(sample)) stop 4
+  if (allocated(scal_caf)) stop 5
+
+  deallocate(sample, stat=istat)
+  if (istat == 0) stop 6
+
+  change team (team)
+    continue
+  end team (stat=istat, errmsg=err)
+  if (trim(err) /= 'unchanged') stop 7
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, &err, 30\\)" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/team_form_2.f90 b/gcc/testsuite/gfortran.dg/team_form_2.f90
new file mode 100644
index 0000000..5c6d81f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_form_2.f90
@@ -0,0 +1,27 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Tests form team syntax errors
+
+  use iso_fortran_env, only : team_type
+  implicit none
+  integer :: istat, new_team
+  character(len=30) :: err
+  type(team_type) :: team
+
+   new_team = mod(this_image(),2)+1
+
+  form team ! { dg-error "Syntax error in FORM TEAM statement" }
+  form team (new_team) ! { dg-error "Syntax error in FORM TEAM statement" }
+  form team (new_team,err) ! { dg-error "must be a scalar expression of type TEAM_TYPE" }
+  form team (new_team,team,istat) ! { dg-error "Syntax error in FORM TEAM statement" }
+  form team (new_team,team,stat=istat,stat=istat) ! { dg-error "Duplicate STAT" }
+  form team (new_team,team,stat=istat,errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" }
+  form team (new_team,team,stat=istat,errmsg=err,errmsg=err) ! { dg-error "Duplicate ERRMSG" }
+  form team (new_team,team,new_index=1,new_index=1) ! { dg-error "Duplicate NEW_INDEX" }
+  form team (new_team,team,new_index=err) ! { dg-error "must be a scalar INTEGER" }
+  form team (new_team,team,new_index=1,new_index=1,stat=istat,errmsg=err) ! { dg-error "Duplicate NEW_INDEX" }
+  form team (new_team,team,new_index=1,stat=istat,errmsg=err,new_index=9) ! { dg-error "Duplicate NEW_INDEX" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/team_form_3.f90 b/gcc/testsuite/gfortran.dg/team_form_3.f90
new file mode 100644
index 0000000..d9aae33
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_form_3.f90
@@ -0,0 +1,34 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Tests form team with stat= and errmsg=
+
+  use iso_fortran_env, only : team_type
+  implicit none
+  integer :: istat = 42, new_team
+  character(len=30) :: err = "unchanged"
+  type(team_type) :: team
+
+  new_team = mod(this_image(),2)+1
+
+  form team (new_team,team)
+  form team (new_team,team,stat=istat)
+  if (istat /= 0) stop 1
+  form team (new_team,team,stat=istat, errmsg=err)
+  if (trim(err) /= 'unchanged') stop 2
+  form team (new_team,team,new_index=1)
+  istat = 42
+  form team (new_team,team,new_index=1,stat=istat)
+  if (istat /= 0) stop 3
+  form team (new_team,team,new_index=1,stat=istat,errmsg=err)
+  if (trim(err) /= 'unchanged') stop 4
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, 0B, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, &err, 30\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, 0B, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, &err, 30\\)" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/team_sync_2.f90 b/gcc/testsuite/gfortran.dg/team_sync_2.f90
new file mode 100644
index 0000000..947f65d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_sync_2.f90
@@ -0,0 +1,27 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Test sync team statement
+!
+  use iso_fortran_env, only : team_type
+  implicit none
+  integer :: istat = 42
+  type(team_type) :: team
+  character(len=30) :: err = "unchanged"
+
+  form team (mod(this_image(),2)+1, team)
+
+  change team (team)
+    sync team (team)
+    sync team (team, stat=istat)
+    if (istat /= 0) stop 1
+    sync team (team, stat=istat, errmsg=err)
+    if (trim(err) /= 'unchanged') stop 2
+  end team
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, 0B, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, &err, 30\\)" "original" } }
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 0b371d0..a674a19 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -31,17 +31,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 
 #include "libgfortran.h"
 
-#if 0
-#ifndef __GNUC__
-#define __attribute__(x)
-#define likely(x)       (x)
-#define unlikely(x)     (x)
-#else
-#define likely(x)       __builtin_expect(!!(x), 1)
-#define unlikely(x)     __builtin_expect(!!(x), 0)
-#endif
-#endif
-
 /* Definitions of the Fortran 2008 standard; need to kept in sync with
    ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h.  */
 typedef enum
@@ -78,8 +67,8 @@ typedef enum caf_deregister_t {
 }
 caf_deregister_t;
 
-typedef void* caf_token_t;
-typedef void * caf_team_t;
+typedef void *caf_token_t;
+typedef void *caf_team_t;
 typedef gfc_array_void gfc_descriptor_t;
 
 /* Linked list of static coarrays registered.  */
@@ -185,4 +174,9 @@ void _gfortran_caf_stopped_images (gfc_descriptor_t *,
 
 void _gfortran_caf_random_init (bool, bool);
 
+void _gfortran_caf_form_team (int, caf_team_t *, int *, int *, char *, size_t);
+void _gfortran_caf_change_team (caf_team_t, int *, char *, size_t);
+void _gfortran_caf_end_team (int *, char *, size_t);
+void _gfortran_caf_sync_team (caf_team_t, int *, char *, size_t);
+
 #endif  /* LIBCAF_H  */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 1d7af6b..a705699 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -50,6 +50,21 @@ typedef struct caf_single_token *caf_single_token_t;
 #define TOKEN(X) ((caf_single_token_t) (X))
 #define MEMTOK(X) ((caf_single_token_t) (X))->memptr
 
+struct caf_single_team
+{
+  struct caf_single_team *parent;
+  int team_no;
+  struct coarray_allocated
+  {
+    struct coarray_allocated *next;
+    caf_single_token_t token;
+  } *allocated;
+};
+typedef struct caf_single_team *caf_single_team_t;
+/* This points to the most current team.  */
+static caf_single_team_t caf_team_stack = NULL, caf_initial_team;
+static caf_single_team_t caf_teams_formed = NULL;
+
 /* Single-image implementation of the CAF library.
    Note: For performance reasons -fcoarry=single should be used
    rather than this library.  */
@@ -125,13 +140,39 @@ caf_internal_error (const char *msg, int *stat, char *errmsg,
   va_end (args);
 }
 
+static void
+init_caf_team_stack (void)
+{
+  caf_initial_team = caf_team_stack
+    = (caf_single_team_t) calloc (1, sizeof (struct caf_single_team));
+  caf_initial_team->team_no = -1;
+}
 
 void
 _gfortran_caf_init (int *argc __attribute__ ((unused)),
 		    char ***argv __attribute__ ((unused)))
 {
+  if (likely (!caf_team_stack))
+    init_caf_team_stack ();
 }
 
+static void
+free_team_list (caf_single_team_t l)
+{
+  while (l != NULL)
+    {
+      caf_single_team_t p = l->parent;
+      struct coarray_allocated *ca = l->allocated;
+      while (ca)
+	{
+	  struct coarray_allocated *nca = ca->next;
+	  free (ca);
+	  ca = nca;
+	}
+      free (l);
+      l = p;
+    }
+}
 
 void
 _gfortran_caf_finalize (void)
@@ -146,6 +187,11 @@ _gfortran_caf_finalize (void)
       free (caf_static_list);
       caf_static_list = tmp;
     }
+
+  free_team_list (caf_team_stack);
+  caf_initial_team = caf_team_stack = NULL;
+  free_team_list (caf_teams_formed);
+  caf_teams_formed = NULL;
 }
 
 
@@ -206,6 +252,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
   single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
   single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
 
+  if (unlikely (!caf_team_stack))
+    init_caf_team_stack ();
 
   if (stat)
     *stat = 0;
@@ -219,6 +267,20 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
       tmp->token = *token;
       caf_static_list = tmp;
     }
+  else
+    {
+      struct coarray_allocated *ca = caf_team_stack->allocated;
+      for (; ca && ca->token != single_token; ca = ca->next)
+	;
+      if (!ca)
+	{
+	  ca = (struct coarray_allocated *) malloc (
+	    sizeof (struct coarray_allocated));
+	  *ca = (struct coarray_allocated) {caf_team_stack->allocated,
+					    single_token};
+	  caf_team_stack->allocated = ca;
+	}
+    }
   GFC_DESCRIPTOR_DATA (data) = local;
 }
 
@@ -231,10 +293,30 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
   caf_single_token_t single_token = TOKEN (*token);
 
   if (single_token->owning_memory && single_token->memptr)
-    free (single_token->memptr);
+    {
+      free (single_token->memptr);
+      if (single_token->desc)
+	GFC_DESCRIPTOR_DATA (single_token->desc) = NULL;
+    }
 
   if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
     {
+      struct coarray_allocated *ca = caf_team_stack->allocated;
+      if (ca && caf_team_stack->allocated->token == single_token)
+	caf_team_stack->allocated = ca->next;
+      else
+	{
+	  struct coarray_allocated *pca = NULL;
+	  for (; ca && ca->token != single_token; pca = ca, ca = ca->next)
+	    ;
+	  if (!ca)
+	    caf_runtime_error (
+	      "Coarray token to be freeed is not in current team %d", type);
+	  /* Unhook found coarray_allocated node from list...  */
+	  pca->next = ca->next;
+	}
+      /* ... and free.  */
+      free (ca);
       free (TOKEN (*token));
       *token = NULL;
     }
@@ -599,11 +681,10 @@ _gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index,
   int32_t result;
   struct caf_single_token cb_token = {add_data, NULL, false};
 
-
-  accessor_hash_table[present_index].u.is_present (add_data, &image_index,
-						   &result,
-						   single_token->memptr,
-						   &cb_token, 0);
+  accessor_hash_table[present_index].u.is_present (
+    add_data, &image_index, &result,
+    single_token->desc ? single_token->desc : (void *) &single_token->memptr,
+    &cb_token, 0);
 
   return result;
 }
@@ -923,3 +1004,83 @@ void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
      routine.  */
   _gfortran_random_init (repeatable, image_distinct, 1);
 }
+
+void
+_gfortran_caf_form_team (int team_no, caf_team_t *team,
+			 int *new_index __attribute__ ((unused)), int *stat,
+			 char *errmsg __attribute__ ((unused)),
+			 size_t errmsg_len __attribute__ ((unused)))
+{
+  const char alloc_fail_msg[] = "Failed to allocate team";
+  caf_single_team_t t;
+  if (stat)
+    *stat = 0;
+
+  *team = malloc (sizeof (struct caf_single_team));
+  if (unlikely (*team == NULL))
+    {
+      caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
+      return;
+    }
+  t = *((caf_single_team_t *) team);
+  t->parent = caf_teams_formed;
+  t->team_no = team_no;
+  t->allocated = NULL;
+  caf_teams_formed = t;
+}
+
+void
+_gfortran_caf_change_team (caf_team_t team, int *stat,
+			   char *errmsg __attribute__ ((unused)),
+			   size_t errmsg_len __attribute__ ((unused)))
+{
+  caf_single_team_t t = (caf_single_team_t) team;
+
+  if (stat)
+    *stat = 0;
+
+  if (t == caf_teams_formed)
+    caf_teams_formed = t->parent;
+  else
+    for (caf_single_team_t p = caf_teams_formed; p; p = p->parent)
+      if (p->parent == t)
+	{
+	  p->parent = t->parent;
+	  break;
+	}
+
+  t->parent = caf_team_stack;
+  caf_team_stack = t;
+}
+
+void
+_gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)
+{
+  caf_single_team_t t = caf_team_stack;
+
+  if (stat)
+    *stat = 0;
+
+  caf_team_stack = caf_team_stack->parent;
+  for (struct coarray_allocated *ca = t->allocated; ca;)
+    {
+      struct coarray_allocated *nca = ca->next;
+      _gfortran_caf_deregister ((caf_token_t *) &ca->token,
+				CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat,
+				errmsg, errmsg_len);
+      free (ca);
+      ca = nca;
+    }
+  t->allocated = NULL;
+  t->parent = caf_teams_formed;
+  caf_teams_formed = t;
+}
+
+void
+_gfortran_caf_sync_team (caf_team_t team __attribute__ ((unused)), int *stat,
+			 char *errmsg __attribute__ ((unused)),
+			 size_t errmsg_len __attribute__ ((unused)))
+{
+  if (stat)
+    *stat = 0;
+}