Fortran: Update get_team, team_number and image_status to F2018 [PR88154, PR88960, PR97210, PR103001]

Add functions get_team() and team_number() to comply with F2018
standard.

Update image_status() to comply with F2018 standard.

	PR fortran/88154
	PR fortran/88960
	PR fortran/97210
	PR fortran/103001

gcc/fortran/ChangeLog:

	* check.cc (team_type_check): Check a type for being team_type
	from the iso_fortran_env module.
	(gfc_check_image_status): Use team_type check.
	(gfc_check_get_team): Check for level argument.
	(gfc_check_team_number): Use team_type check.
	* expr.cc (gfc_check_assign): Add treatment for returning
	team_type in caf-single mode.
	* gfortran.texi: Add/Update documentation for get_team and
	team_number API functions.
	* intrinsic.cc (add_functions): Update get_team signature.
	* intrinsic.h (gfc_resolve_get_team): Add prototype.
	* intrinsic.texi: Add/Update documentation for get_team and
	team_number Fortran functions.
	* iresolve.cc (gfc_resolve_get_team): Resolve return type to be
	of type team_type.
	* iso-fortran-env.def: Update STAT_LOCK constants.  They have
	nothing to do with files.  Add level constants for get_team.
	* libgfortran.h: Add level and unlock_stat constants.
	* simplify.cc (gfc_simplify_get_team): Simply to correct return
	type team_type.
	* trans-decl.cc (gfc_build_builtin_function_decls): Update
	get_team and image_status API prototypes to correct signatures.
	* trans-intrinsic.cc (conv_intrinsic_image_status): Translate
	second parameter correctly.
	(conv_intrinsic_team_number): Translate optional single team
	argument correctly.
	(gfc_conv_intrinsic_function): Add translation of get_team.

libgfortran/ChangeLog:

	* caf/libcaf.h: Add constants for get_team's level argument and
	update stat values for failed images.
	(_gfortran_caf_team_number): Add prototype.
	(_gfortran_caf_get_team): Same.
	* caf/single.c (_gfortran_caf_team_number): Get the given team's
	team number.
	(_gfortran_caf_get_team): Get the current team or the team given
	by level when the argument is present.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/image_status_1.f08: Correct check for
	team_type.
	* gfortran.dg/pr102458.f90: Adapt to multiple errors.
	* gfortran.dg/coarray/get_team_1.f90: New test.
	* gfortran.dg/team_get_1.f90: New test.
	* gfortran.dg/team_number_1.f90: Correct Fortran syntax.

12 files changed, 268 insertions, 72 deletions

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 0034278..a1c3de3 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -1809,6 +1809,23 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
   return gfc_check_atomic (atom, 1, value, 0, stat, 2);
 }
 
+bool
+team_type_check (gfc_expr *e, int n)
+{
+  if (e->ts.type != BT_DERIVED || !e->ts.u.derived
+      || e->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+      || e->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
+		 "%<team_type%> from the intrinsic module "
+		 "%<ISO_FORTRAN_ENV%>",
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+		 &e->where);
+      return false;
+    }
+
+  return true;
+}
 
 bool
 gfc_check_image_status (gfc_expr *image, gfc_expr *team)
@@ -1818,14 +1835,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team)
       || !positive_check (0, image))
     return false;
 
-  if (team)
-    {
-      gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
-		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
-		 &team->where);
-      return false;
-    }
-  return true;
+  return !team || (scalar_check (team, 0) && team_type_check (team, 0));
 }
 
 
@@ -1905,10 +1915,25 @@ gfc_check_get_team (gfc_expr *level)
 {
   if (level)
     {
-      gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
-		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
-		 &level->where);
-      return false;
+      int l;
+
+      if (!type_check (level, 0, BT_INTEGER) || !scalar_check (level, 0))
+	return false;
+
+      /* When level is a constant, try to extract it.  If not, the runtime has
+	 to check.  */
+      if (gfc_extract_int (level, &l, 0))
+	return true;
+
+      if (l < GFC_CAF_INITIAL_TEAM || l > GFC_CAF_CURRENT_TEAM)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L shall specify one of "
+		     "the INITIAL_TEAM, PARENT_TEAM or CURRENT_TEAM constants "
+		     "from the intrinsic module ISO_FORTRAN_ENV",
+		     gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		     &level->where);
+	  return false;
+	}
     }
   return true;
 }
@@ -6635,21 +6660,7 @@ gfc_check_team_number (gfc_expr *team)
       return false;
     }
 
-  if (team)
-    {
-      if (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 at %L to the intrinsic TEAM_NUMBER "
-	   	      "shall be of type TEAM_TYPE", &team->where);
-	   return false;
-	 }
-    }
-  else
-    return true;
-
-  return true;
+  return !team || (scalar_check (team, 0) && team_type_check (team, 0));
 }
 
 
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 0753667..07e9bac 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3836,7 +3836,13 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
       if (has_pointer && (ref == NULL || ref->next == NULL)
 	  && lvalue->symtree->n.sym->attr.data)
         return true;
-      else
+      /* Prevent the following error message for caf-single mode, because there
+	 are no teams in single mode and the simplify returns a null then.  */
+      else if (!(flag_coarray == GFC_FCOARRAY_SINGLE
+		 && rvalue->ts.type == BT_DERIVED
+		 && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+		 && rvalue->ts.u.derived->intmod_sym_id
+		      == ISOFORTRAN_TEAM_TYPE))
 	{
 	  gfc_error ("NULL appears on right-hand side in assignment at %L",
 		     &rvalue->where);
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index ff38567..a809631 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4234,6 +4234,8 @@ future implementation of teams.  It is about to change without further notice.
 * _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
+* _gfortran_caf_get_team:: Get the opaque handle of the specified team
+* _gfortran_caf_team_number:: Get the unique id of the given team
 @end menu
 
 
@@ -5786,6 +5788,54 @@ an error message; may be NULL.
 @end table
 
 
+
+@node _gfortran_caf_get_team
+@subsection @code{_gfortran_caf_get_team} --- Get the opaque handle of the specified team
+@cindex Coarray, _gfortran_caf_get_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{caf_team_t _gfortran_caf_get_team (int32_t *level)}
+
+@item @emph{Description}:
+Get the current team, when @var{level} is null, or the team specified by
+@var{level} set to @code{INITIAL_TEAM}, @code{PARENT_TEAM} or
+@code{CURRENT_TEAM} from the @code{ISO_FORTRAN_ENV} intrinsic module.  When
+being on the @code{INITIAL_TEAM} and requesting its @code{PARENT_TEAM}, then
+the initial team is returned.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{level} @tab intent(in)  If set to one of the levels specified in
+the @code{ISO_FORTRAN_ENV} module, the function returns the handle of the given
+team.  Values different from the allowed ones lead to a runtime error.
+@end multitable
+@end table
+
+
+
+@node _gfortran_caf_team_number
+@subsection @code{_gfortran_caf_team_number} --- Get the unique id of the given team
+@cindex Coarray, _gfortran_caf_team_number
+
+@table @asis
+@item @emph{Synopsis}:
+@code{int _gfortran_caf_team_number (caf_team_t team)}
+
+@item @emph{Description}:
+The team id given when forming the team @ref{_gfortran_caf_form_team} of the
+team specified by @var{team}, if given, or of the current team, if @var{team}
+is absent.  It is a runtime error to specify a non-existing team.
+The team has to be formed, i.e., it is not necessary that it is changed
+into to get the team number.  The initial team has the team number @code{-1}.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team} @tab intent(in)  The team for which the team id is desired.
+@end multitable
+@end table
+
+
 @c Intrinsic Procedures
 @c ---------------------------------------------------------------------
 
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 91f16c7..7d459d0 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -2112,10 +2112,10 @@ add_functions (void)
 
   make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
 
-  add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL,
-	     ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018,
-	     gfc_check_get_team, NULL, gfc_resolve_get_team,
-	     level, BT_INTEGER, di, OPTIONAL);
+  add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
+	     BT_DERIVED, di, GFC_STD_F2018, gfc_check_get_team,
+	     gfc_simplify_get_team, gfc_resolve_get_team, level, BT_INTEGER, di,
+	     OPTIONAL);
 
   add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
 	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 70e14c40..c177fcb 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -479,6 +479,7 @@ void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a);
 void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_c_loc (gfc_expr *, gfc_expr *);
 void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *);
+void gfc_resolve_get_team (gfc_expr *, gfc_expr *);
 void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_chdir (gfc_expr *, gfc_expr *);
@@ -523,7 +524,6 @@ void gfc_resolve_gamma (gfc_expr *, gfc_expr *);
 void gfc_resolve_getcwd (gfc_expr *, gfc_expr *);
 void gfc_resolve_getgid (gfc_expr *);
 void gfc_resolve_getpid (gfc_expr *);
-void gfc_resolve_get_team (gfc_expr *, gfc_expr *);
 void gfc_resolve_getuid (gfc_expr *);
 void gfc_resolve_hostnm (gfc_expr *, gfc_expr *);
 void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index ad89064..cc01a9d 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -170,6 +170,7 @@ Some basic guidelines for editing this document:
 * @code{GETGID}:        GETGID,    Group ID function
 * @code{GETLOG}:        GETLOG,    Get login name
 * @code{GETPID}:        GETPID,    Process ID function
+* @code{GET_TEAM}:      GET_TEAM,  Get the handle of a team
 * @code{GETUID}:        GETUID,    User ID function
 * @code{GMTIME}:        GMTIME,    Convert time to GMT info
 * @code{HOSTNM}:        HOSTNM,    Get system host name
@@ -311,6 +312,7 @@ Some basic guidelines for editing this document:
 * @code{TAN}:           TAN,       Tangent function
 * @code{TAND}:          TAND,      Tangent function, degrees
 * @code{TANH}:          TANH,      Hyperbolic tangent function
+* @code{TEAM_NUMBER}:   TEAM_NUMBER, Retrieve team id of given team
 * @code{THIS_IMAGE}:    THIS_IMAGE, Cosubscript index of this image
 * @code{TIME}:          TIME,      Time function
 * @code{TIME8}:         TIME8,     Time function (64-bit)
@@ -7336,6 +7338,59 @@ GNU extension
 
 
 
+@node GET_TEAM
+@section @code{GET_TEAM} --- Get the handle of a team
+@fnindex GET_TEAM
+@cindex coarray, @code{GET_TEAM}
+@cindex images, get a handle to a team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{RESULT = GET_TEAM([LEVEL])}
+
+@item @emph{Description}:
+Returns the handle of the current team, if @var{LEVEL} is not given.  Or the
+team specified by @var{LEVEL}, where @var{LEVEL} is one of the constants
+@code{INITIAL_TEAM}, @code{PARENT_TEAM} or @code{CURRENT_TEAM} from the
+intrinsic module @code{ISO_FORTRAN_ENV}.  Calling the function with
+@code{PARENT_TEAM} while being on the initial team, returns a handle to the
+initial team.  This ensures that always a valid team is returned, given that
+team handles can neither be checked for validity nor compared with each other
+or null.
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Return value}:
+An opaque handle of @code{TEAM_TYPE} from the intrinsic module
+@code{ISO_FORTRAN_ENV}.
+
+@item @emph{Example}:
+@smallexample
+program info
+  use, intrinsic :: iso_fortran_env
+  type(team_type) :: init, curr, par, nt
+
+  init = get_team()
+  curr = get_team(current_team) ! init equals curr here
+  form team(1, nt)
+  change team(nt)
+    curr = get_team() ! or get_team(current_team)
+    par = get_team(parent_team) ! par equals init here
+  end team
+end program info
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2018 or later
+
+@item @emph{See also}:
+@ref{THIS_IMAGE}, @*
+@ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
 @node GETUID
 @section @code{GETUID} --- User ID function
 @fnindex GETUID
@@ -14467,6 +14522,54 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later
 
 
 
+@node TEAM_NUMBER
+@section @code{TEAM_NUMBER} --- Retrieve team id of given team
+@fnindex TEAM_NUMBER
+@cindex coarray, @code{TEAM_NUMBER}
+@cindex teams, index of given team
+
+@table @asis
+@item @emph{Synopsis}:
+@item @code{RESULT = TEAM_NUMBER([TEAM])}
+
+@item @emph{Description}:
+Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}.
+If @var{TEAM} is absent, returns the team number of the current team.
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which
+the number, aka id, is desired.
+@end multitable
+
+@item @emph{Return value}:
+Default integer.  The id as given in a call @code{FORM TEAM}. Applying
+@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned.
+Returns the id of the current team, if @var{TEAM} is null.
+
+@item @emph{Example}:
+@smallexample
+use, intrinsic :: iso_fortran_env
+type(team_type) :: t
+
+print *, team_number() ! -1
+form team (99, t)
+print *, team_number(t) ! 99
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2018 and later.
+
+@item @emph{See also}:
+@ref{GET_TEAM}, @*
+@ref{TEAM_NUMBER}
+@end table
+
+
+
 @node THIS_IMAGE
 @section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image
 @fnindex THIS_IMAGE
@@ -15354,12 +15457,18 @@ parameters of the @code{CHARACTER} type. (Fortran 2008 or later.)
 @item @code{CHARACTER_STORAGE_SIZE}:
 Size in bits of the character storage unit.
 
+@item @code{CURRENT_TEAM}:
+The argument to @ref{GET_TEAM} to retrieve a handle of the current team.
+
 @item @code{ERROR_UNIT}:
 Identifies the preconnected unit used for error reporting.
 
 @item @code{FILE_STORAGE_SIZE}:
 Size in bits of the file-storage unit.
 
+@item @code{INTIAL_TEAM}:
+Argument to @ref{GET_TEAM} to retrieve a handle of the initial team.
+
 @item @code{INPUT_UNIT}:
 Identifies the preconnected unit identified by the asterisk
 (@code{*}) in @code{READ} statement.
@@ -15397,6 +15506,9 @@ parameters of the @code{LOGICAL} type. (Fortran 2008 or later.)
 Identifies the preconnected unit identified by the asterisk
 (@code{*}) in @code{WRITE} statement.
 
+@item @code{PARENT_TEAM}:
+Argument to @ref{GET_TEAM} to retrieve a handle to the parent team.
+
 @item @code{REAL32}, @code{REAL64}, @code{REAL128}:
 Kind type parameters to specify a REAL type with a storage
 size of 32, 64, and 128 bits. It is negative if a target platform
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 858ffb1..567bf52 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3209,11 +3209,21 @@ gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
 {
   static char get_team[] = "_gfortran_caf_get_team";
   f->rank = 0;
-  f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  f->ts.type = BT_DERIVED;
+  gfc_find_symbol ("team_type", gfc_current_ns, 1, &f->ts.u.derived);
+  if (!f->ts.u.derived
+      || f->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV)
+    {
+      gfc_error (
+	"GET_TEAM at %L needs USE of the intrinsic module ISO_FORTRAN_ENV "
+	"to define its result type TEAM_TYPE",
+	&f->where);
+      f->ts.type = BT_UNKNOWN;
+    }
   f->value.function.name = get_team;
-}
 
+  /* No requirements to resolve for level argument now.  */
+}
 
 /* Resolve image_index (...).  */
 
@@ -3248,15 +3258,17 @@ gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
 /* Resolve team_number (team).  */
 
 void
-gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
+gfc_resolve_team_number (gfc_expr *f, gfc_expr *team)
 {
   static char team_number[] = "_gfortran_caf_team_number";
   f->rank = 0;
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = team_number;
-}
 
+  if (team)
+    gfc_resolve_expr (team);
+}
 
 void
 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index 970f09f..250a730 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -83,17 +83,23 @@ NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \
               gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008)
 NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \
               gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \
+NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED, "stat_locked", \
               GFC_STAT_LOCKED, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \
+NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED_OTHER_IMAGE, \
               "stat_locked_other_image", \
 	      GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \
-              GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \
-              GFC_STAT_FAILED_IMAGE, GFC_STD_F2018)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \
-              GFC_STAT_UNLOCKED, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_STAT_STOPPED_IMAGE, "stat_stopped_image", \
+	      GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_STAT_FAILED_IMAGE, "stat_failed_image", \
+	      GFC_STAT_FAILED_IMAGE, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_STAT_UNLOCKED, "stat_unlocked", \
+	      GFC_STAT_UNLOCKED, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INITIAL_TEAM, "initial_team", \
+	      GFC_CAF_INITIAL_TEAM, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_PARENT_TEAM, "parent_team", \
+	      GFC_CAF_PARENT_TEAM, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_CURRENT_TEAM, "current_team", \
+	      GFC_CAF_CURRENT_TEAM, GFC_STD_F2018)
 
 
 /* The arguments to NAMED_KINDARRAY are:
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 9565365..9de5afb 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -154,12 +154,20 @@ typedef enum
   GFC_STAT_LOCKED,
   GFC_STAT_LOCKED_OTHER_IMAGE,
   GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
-  GFC_STAT_FAILED_IMAGE  = 6001
+  GFC_STAT_FAILED_IMAGE  = 6001,
+  GFC_STAT_UNLOCKED_FAILED_IMAGE = 6002
 }
 libgfortran_stat_codes;
 
 typedef enum
 {
+  GFC_CAF_INITIAL_TEAM = 0,
+  GFC_CAF_PARENT_TEAM,
+  GFC_CAF_CURRENT_TEAM
+} libgfortran_team_levels;
+
+typedef enum
+{
   GFC_CAF_ATOMIC_ADD = 1,
   GFC_CAF_ATOMIC_AND,
   GFC_CAF_ATOMIC_OR,
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 92ab17b..6e773d1 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -3133,8 +3133,10 @@ gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
   if (flag_coarray == GFC_FCOARRAY_SINGLE)
     {
       gfc_expr *result;
-      result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
-      result->rank = 0;
+      result = gfc_get_null_expr (&gfc_current_locus);
+      result->ts.type = BT_DERIVED;
+      gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived);
+
       return result;
     }
 
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index ae996a0..a2905b6 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4215,10 +4215,9 @@ gfc_build_builtin_function_decls (void)
 	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 (
-	    get_identifier (PREFIX("caf_get_team")),
-	    void_type_node, 1, integer_type_node);
+      gfor_fndecl_caf_get_team = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX ("caf_get_team")), ". r ", pvoid_type_node, 1,
+	pint_type);
 
       gfor_fndecl_caf_sync_team = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node,
@@ -4229,10 +4228,9 @@ gfc_build_builtin_function_decls (void)
 	    get_identifier (PREFIX("caf_team_number")), ". r ",
       	    integer_type_node, 1, integer_type_node);
 
-      gfor_fndecl_caf_image_status
-	= gfc_build_library_function_decl_with_spec (
-	    get_identifier (PREFIX("caf_image_status")), ". . r ",
-	    integer_type_node, 2, integer_type_node, ppvoid_type_node);
+      gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX ("caf_image_status")), ". r r ",
+	integer_type_node, 2, integer_type_node, ppvoid_type_node);
 
       gfor_fndecl_caf_stopped_images
 	= gfc_build_library_function_decl_with_spec (
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index cab3ebc..2e31460 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2072,7 +2072,8 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB)
     tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
-			       args[0], build_int_cst (integer_type_node, -1));
+			       args[0],
+			       num_args < 2 ? null_pointer_node : args[1]);
   else
     gcc_unreachable ();
 
@@ -2092,18 +2093,7 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
 
   if (flag_coarray ==
       GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
-    {
-      tree arg;
-
-      arg = gfc_evaluate_now (args[0], &se->pre);
-      tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
-      			     fold_convert (integer_type_node, arg),
-      			     integer_one_node);
-      tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
-      			     tmp, integer_zero_node,
-      			     build_int_cst (integer_type_node,
-      					    GFC_STAT_STOPPED_IMAGE));
-    }
+    tmp = gfc_evaluate_now (args[0], &se->pre);
   else if (flag_coarray == GFC_FCOARRAY_SINGLE)
     {
       // the value -1 represents that no team has been created yet
@@ -2111,10 +2101,10 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
     tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
-			       args[0], build_int_cst (integer_type_node, -1));
+			       args[0]);
   else if (flag_coarray == GFC_FCOARRAY_LIB)
     tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
-		integer_zero_node, build_int_cst (integer_type_node, -1));
+			       null_pointer_node);
   else
     gcc_unreachable ();
 
@@ -11475,6 +11465,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
     case GFC_ISYM_GETGID:
     case GFC_ISYM_GETPID:
     case GFC_ISYM_GETUID:
+    case GFC_ISYM_GET_TEAM:
     case GFC_ISYM_HOSTNM:
     case GFC_ISYM_IERRNO:
     case GFC_ISYM_IRAND: