Fortran: Add team-support to this_image [PR87326]

This_image() no longer has a distance formal argument, but a team one.
The source of the distance argument could not be identified, i.e.
whether it came from a TS or standard draft.  To implement only the
standard it is removed.  Besides being defined, it was not used anyway.

	PR fortran/87326

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_this_image): Check the three different
	parameter lists possible for this_image and sort them correctly.
	* gfortran.texi: Update documentation on this_image's API.
	* intrinsic.cc (add_functions): Update this_image's signature.
	(check_specific): Add specific check for this_image.
	* intrinsic.h (gfc_check_this_image): Change to flexible
	argument list.
	* intrinsic.texi: Update documentation on this_image().
	* iresolve.cc (gfc_resolve_this_image): Resolve the different
	arguments.
	* simplify.cc (gfc_simplify_this_image): Simplify the simplify
	routine.
	* trans-decl.cc (gfc_build_builtin_function_decls): Update
	signature of this_image.
	* trans-expr.cc (gfc_caf_get_image_index): Use correct signature
	of this_image.
	* trans-intrinsic.cc (trans_this_image): Adapt to correct
	signature.

libgfortran/ChangeLog:

	* caf/libcaf.h (_gfortran_caf_this_image): Correct prototype.
	* caf/single.c (struct caf_single_team): Add new_index of image.
	(_gfortran_caf_this_image): Return the image index in the given team.
	(_gfortran_caf_form_team): Set new_index in team structure.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray_10.f90: Update error messages.
	* gfortran.dg/coarray_lib_this_image_1.f90: Same.
	* gfortran.dg/coarray_lib_this_image_2.f90: Same.
	* gfortran.dg/coarray_this_image_1.f90: Add more tests and
	remove incorrect ones.
	* gfortran.dg/coarray_this_image_2.f90: Test more features.
	* gfortran.dg/coarray_this_image_3.f90: New test.

16 files changed, 283 insertions, 121 deletions

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index a1c3de3..c27f653 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -6665,75 +6665,115 @@ gfc_check_team_number (gfc_expr *team)
 
 
 bool
-gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
+gfc_check_this_image (gfc_actual_arglist *args)
 {
+  gfc_expr *coarray, *dim, *team, *cur;
+
+  coarray = dim = team = NULL;
+
   if (flag_coarray == GFC_FCOARRAY_NONE)
     {
       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
       return false;
     }
 
-  if (coarray == NULL && dim == NULL && distance == NULL)
+  /* Shortcut when no arguments are given.  */
+  if (!args->expr && !args->next->expr && !args->next->next->expr)
     return true;
 
-  if (dim != NULL && coarray == NULL)
-    {
-      gfc_error ("DIM argument without COARRAY argument not allowed for "
-		 "THIS_IMAGE intrinsic at %L", &dim->where);
-      return false;
-    }
+  cur = args->expr;
 
-  if (distance && (coarray || dim))
+  if (cur)
     {
-      gfc_error ("The DISTANCE argument may not be specified together with the "
-		 "COARRAY or DIM argument in intrinsic at %L",
-		 &distance->where);
-      return false;
+      gfc_push_suppress_errors ();
+      if (coarray_check (cur, 0))
+	coarray = cur;
+      else if (scalar_check (cur, 2) && team_type_check (cur, 2))
+	team = cur;
+      else
+	{
+	  gfc_pop_suppress_errors ();
+	  gfc_error ("First argument of %<this_image%> intrinsic at %L must be "
+		     "a coarray "
+		     "variable or an object of type %<team_type%> from the "
+		     "intrinsic module "
+		     "%<ISO_FORTRAN_ENV%>",
+		     &cur->where);
+	  return false;
+	}
+      gfc_pop_suppress_errors ();
     }
 
-  /* Assume that we have "this_image (distance)".  */
-  if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
+  cur = args->next->expr;
+  if (cur)
     {
-      if (dim)
+      gfc_push_suppress_errors ();
+      if (dim_check (cur, 1, true) && cur->corank == 0)
+	dim = cur;
+      else if (scalar_check (cur, 2) && team_type_check (cur, 2))
 	{
-	  gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
-		     &coarray->where);
+	  if (team)
+	    {
+	      gfc_pop_suppress_errors ();
+	      goto team_type_error;
+	    }
+	  team = cur;
+	}
+      else
+	{
+	  gfc_pop_suppress_errors ();
+	  gfc_error ("Second argument of %<this_image%> intrinsic at %L must "
+		     "be an %<INTEGER%> "
+		     "typed scalar or an object of type %<team_type%> from the "
+		     "intrinsic "
+		     "module %<ISO_FORTRAN_ENV%>",
+		     &cur->where);
 	  return false;
 	}
-      distance = coarray;
+      gfc_pop_suppress_errors ();
     }
 
-  if (distance)
+  cur = args->next->next->expr;
+  if (cur)
     {
-      if (!type_check (distance, 2, BT_INTEGER))
-	return false;
-
-      if (!nonnegative_check ("DISTANCE", distance))
-	return false;
-
-      if (!scalar_check (distance, 2))
-	return false;
-
-      if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
-			   "THIS_IMAGE at %L", &distance->where))
+      if (team_type_check (cur, 2) && scalar_check (cur, 2))
+	{
+	  if (team)
+	    goto team_type_error;
+	  team = cur;
+	}
+      else
 	return false;
+    }
 
-      return true;
+  if (dim != NULL && coarray == NULL)
+    {
+      gfc_error ("%<dim%> argument without %<coarray%> argument not allowed "
+		 "for %<this_image%> intrinsic at %L",
+		 &dim->where);
+      return false;
     }
 
-  if (!coarray_check (coarray, 0))
+  if (dim && !dim_corank_check (dim, coarray))
     return false;
 
-  if (dim != NULL)
-    {
-      if (!dim_check (dim, 1, false))
-       return false;
-
-      if (!dim_corank_check (dim, coarray))
-       return false;
-    }
+  if (team
+      && !gfc_notify_std (GFC_STD_F2018,
+			  "%<team%> argument to %<this_image%> at %L",
+			  &team->where))
+    return false;
 
+  args->expr = coarray;
+  args->next->expr = dim;
+  args->next->next->expr = team;
   return true;
+
+team_type_error:
+  gfc_error (
+    "At most one argument of type %<team_type%> from the intrinsic module "
+    "%<ISO_FORTRAN_ENV%> to %<this_image%> at %L allowed",
+    &cur->where);
+  return false;
 }
 
 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index a809631..33ac6d4 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4300,21 +4300,23 @@ using the STOP and ERROR STOP statements; those use different library calls.
 
 @table @asis
 @item @emph{Synopsis}:
-@code{int _gfortran_caf_this_image (int distance)}
+@code{int _gfortran_caf_this_image (caf_team_t team)}
 
 @item @emph{Description}:
-This function returns the current image number, which is a positive number.
+Return the current image number in the @var{team}, or in the current team, if
+no @var{team} is given.
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{distance} @tab As specified for the @code{this_image} intrinsic
-in TS18508.  Shall be a nonnegative number.
+@item @var{team} @tab intent(in), optional; The team this image's number is
+requested for.  If null, the image number in the current team is returned.
 @end multitable
 
 @item @emph{Notes}:
-If the Fortran intrinsic @code{this_image} is invoked without an argument, which
-is the only permitted form in Fortran 2008, GCC passes @code{0} as
-first argument.
+Available since Fortran 2008 without argument; Since Fortran 2018 with optional
+team argument.  Fortran 2008 uses 0 as argument for team, which is permissible,
+because a team handle is always an opaque pointer, which as a special case can
+be null here.
 @end table
 
 
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 7d459d0..ce586a2 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3338,10 +3338,11 @@ add_functions (void)
 	     gfc_check_team_number, NULL, gfc_resolve_team_number,
 	     team, BT_DERIVED, di, OPTIONAL);
 
-  add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
-	     gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
-	     ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL,
-	     dist, BT_INTEGER, di, OPTIONAL);
+  add_sym_3red ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO,
+		BT_INTEGER, di, GFC_STD_F2008, gfc_check_this_image,
+		gfc_simplify_this_image, gfc_resolve_this_image, ca, BT_REAL,
+		dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, team, BT_DERIVED,
+		di, OPTIONAL);
 
   add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
 	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);
@@ -4956,6 +4957,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
   else if (specific->check.f3red == gfc_check_transf_bit_intrins)
     /* Same as for PRODUCT and SUM, but different checks.  */
     t = gfc_check_transf_bit_intrins (*ap);
+  else if (specific->check.f3red == gfc_check_this_image)
+    /* May need to reassign arguments.  */
+    t = gfc_check_this_image (*ap);
   else
      {
        if (specific->check.f1 == NULL)
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index c177fcb..3a702b3 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -234,7 +234,7 @@ bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_sleep_sub (gfc_expr *);
 bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_system_sub (gfc_expr *, gfc_expr *);
-bool gfc_check_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_this_image (gfc_actual_arglist *);
 bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
 bool gfc_check_umask_sub (gfc_expr *, gfc_expr *);
 bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index cc01a9d..365e61b 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -14579,9 +14579,8 @@ Fortran 2018 and later.
 @table @asis
 @item @emph{Synopsis}:
 @multitable @columnfractions .80
-@item @code{RESULT = THIS_IMAGE()}
-@item @code{RESULT = THIS_IMAGE(DISTANCE)}
-@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])}
+@item @code{RESULT = THIS_IMAGE([TEAM])}
+@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM][, TEAM])}
 @end multitable
 
 @item @emph{Description}:
@@ -14592,8 +14591,8 @@ Transformational function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer
-(not permitted together with @var{COARRAY}).
+@item @var{TEAM} @tab (optional, intent(in)) The team for which the index of
+this image is desired.  The current team is used, when no team is given.
 @item @var{COARRAY} @tab Coarray of any type  (optional; if @var{DIM}
 present, required).
 @item @var{DIM}     @tab default integer scalar (optional). If present,
@@ -14602,16 +14601,16 @@ present, required).
 
 @item @emph{Return value}:
 Default integer. If @var{COARRAY} is not present, it is scalar; if
-@var{DISTANCE} is not present or has value 0, its value is the image index on
-the invoking image for the current team, for values smaller or equal
-distance to the initial team, it returns the image index on the ancestor team
-that has a distance of @var{DISTANCE} from the invoking team. If
-@var{DISTANCE} is larger than the distance to the initial team, the image
-index of the initial team is returned. Otherwise when the @var{COARRAY} is
+@var{TEAM} is not present, its value is the image index on the invoking image
+for the current team; if @var{TEAM} is present, returns the image index of
+the invoking image as given to the @code{FORM TEAM (..., NEW_INDEX=..)} call,
+or a implementation specific unique number, when @code{NEW_INDEX=} was absent
+from @code{FORM TEAM}.  Otherwise when the @var{COARRAY} is
 present, if @var{DIM} is not present, a rank-1 array with corank elements is
 returned, containing the cosubscripts for @var{COARRAY} specifying the invoking
-image. If @var{DIM} is present, a scalar is returned, with the value of
-the @var{DIM} element of @code{THIS_IMAGE(COARRAY)}.
+image (in the team when @var{TEAM} is present).  If @var{DIM} is present, a
+scalar is returned, with the value of the @var{DIM} element of
+@code{THIS_IMAGE(COARRAY)}.
 
 @item @emph{Example}:
 @smallexample
@@ -14626,13 +14625,12 @@ IF (THIS_IMAGE() == 1) THEN
 END IF
 
 ! Check whether the current image is the initial image
-IF (THIS_IMAGE(HUGE(1)) /= THIS_IMAGE())
+IF (THIS_IMAGE(GET_TEAM(INITIAL_TEAM)) /= THIS_IMAGE())
   error stop "something is rotten here"
 @end smallexample
 
 @item @emph{Standard}:
-Fortran 2008 and later. With @var{DISTANCE} argument, 
-Technical Specification (TS) 18508 or later
+Fortran 2008 and later.  With @var{TEAM} argument, Fortran 2018 or later
 
 @item @emph{See also}:
 @ref{NUM_IMAGES}, @*
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 567bf52..c286c2a 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3271,20 +3271,33 @@ gfc_resolve_team_number (gfc_expr *f, gfc_expr *team)
 }
 
 void
-gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
-			gfc_expr *distance ATTRIBUTE_UNUSED)
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *coarray, gfc_expr *dim,
+			gfc_expr *team)
 {
   static char this_image[] = "__this_image";
-  if (array && gfc_is_coarray (array))
-    resolve_bound (f, array, dim, NULL, "__this_image", true);
+  if (coarray && dim)
+    resolve_bound (f, coarray, dim, NULL, this_image, true);
+  else if (coarray)
+    {
+      f->ts.type = BT_INTEGER;
+      f->ts.kind = gfc_default_integer_kind;
+      f->value.function.name = this_image;
+      if (f->shape && f->rank != 1)
+	gfc_free_shape (&f->shape, f->rank);
+      f->rank = 1;
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_ui (f->shape[0], coarray->corank);
+    }
   else
     {
       f->ts.type = BT_INTEGER;
       f->ts.kind = gfc_default_integer_kind;
       f->value.function.name = this_image;
     }
-}
 
+  if (team)
+    gfc_resolve_expr (team);
+}
 
 void
 gfc_resolve_time (gfc_expr *f)
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6e773d1..b94eb43 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -9069,14 +9069,13 @@ gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
 
 gfc_expr *
 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
-			 gfc_expr *distance ATTRIBUTE_UNUSED)
+			 gfc_expr *team ATTRIBUTE_UNUSED)
 {
   if (flag_coarray != GFC_FCOARRAY_SINGLE)
     return NULL;
 
-  /* If no coarray argument has been passed or when the first argument
-     is actually a distance argument.  */
-  if (coarray == NULL || !gfc_is_coarray (coarray))
+  /* If no coarray argument has been passed.  */
+  if (coarray == NULL)
     {
       gfc_expr *result;
       /* FIXME: gfc_current_locus is wrong.  */
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index a2905b6..ee48a82 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4043,9 +4043,9 @@ gfc_build_builtin_function_decls (void)
       gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
 	get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
 
-      gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
-	get_identifier (PREFIX("caf_this_image")), integer_type_node,
-	1, integer_type_node);
+      gfor_fndecl_caf_this_image = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX ("caf_this_image")), ". r ", integer_type_node,
+	1, pvoid_type_node);
 
       gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
 	get_identifier (PREFIX("caf_num_images")), integer_type_node,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 276f325..19e5669b 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2579,10 +2579,8 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
   gcc_assert (ref != NULL);
 
   if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
-    {
-      return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
-				  integer_zero_node);
-    }
+    return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
+				null_pointer_node);
 
   img_idx = build_zero_cst (gfc_array_index_type);
   extent = build_one_cst (gfc_array_index_type);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 2e31460..01c1995 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1818,34 +1818,31 @@ static void
 trans_this_image (gfc_se * se, gfc_expr *expr)
 {
   stmtblock_t loop;
-  tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
-       lbound, ubound, extent, ml;
+  tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
+    ubound, extent, ml, team;
   gfc_se argse;
   int rank, corank;
-  gfc_expr *distance = expr->value.function.actual->next->next->expr;
-
-  if (expr->value.function.actual->expr
-      && !gfc_is_coarray (expr->value.function.actual->expr))
-    distance = expr->value.function.actual->expr;
 
   /* The case -fcoarray=single is handled elsewhere.  */
   gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
 
+  /* Translate team, if present.  */
+  if (expr->value.function.actual->next->next->expr)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      team = fold_convert (pvoid_type_node, argse.expr);
+    }
+  else
+    team = null_pointer_node;
+
   /* Argument-free version: THIS_IMAGE().  */
-  if (distance || expr->value.function.actual->expr == NULL)
+  if (expr->value.function.actual->expr == NULL)
     {
-      if (distance)
-	{
-	  gfc_init_se (&argse, NULL);
-	  gfc_conv_expr_val (&argse, distance);
-	  gfc_add_block_to_block (&se->pre, &argse.pre);
-	  gfc_add_block_to_block (&se->post, &argse.post);
-	  tmp = fold_convert (integer_type_node, argse.expr);
-	}
-      else
-	tmp = integer_zero_node;
       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
-				 tmp);
+				 team);
       se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
 			       tmp);
       return;
@@ -1940,8 +1937,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
   */
 
   /* this_image () - 1.  */
-  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
-			     integer_zero_node);
+  tmp
+    = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team);
   tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
 			 fold_convert (type, tmp), build_int_cst (type, 1));
   if (corank == 1)
diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90
index 53917b5..6f453d5 100644
--- a/gcc/testsuite/gfortran.dg/coarray_10.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_10.f90
@@ -21,7 +21,7 @@ subroutine this_image_check()
   integer,save :: z(4)[*], i
 
   j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" }
-  j = this_image(dim=3) ! { dg-error "DIM argument without COARRAY argument" }
+  j = this_image(dim=3) ! { dg-error "'dim' argument without 'coarray' argument" }
   i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" }
   i = image_index(z, 2) ! { dg-error "must be a rank one array" }
 end subroutine this_image_check
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
index 63cca3e..a38c230 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
@@ -21,6 +21,6 @@ end
 ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "bar \\(x, caf_token.., 0\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
index a27d740..3b504f5 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
@@ -21,6 +21,6 @@ end
 ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
index 1fe2318..779b056 100644
--- a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
@@ -1,8 +1,45 @@
-! { dg-do compile }
-! { dg-options "-fdump-tree-original -fcoarray=single" }
+!{ dg-do run }
+!{ dg-options "-fdump-tree-original -fcoarray=single" }
 !
-j1 = this_image(distance=4)
-j2 = this_image(5)
+
+use, intrinsic :: iso_fortran_env, only: team_type 
+integer :: caf[2,*]
+integer, allocatable :: res(:)
+type(team_type) :: team
+
+form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1)
+j1 = this_image()
+if (j1 /= 1) then
+        print *, me, ":", j1
+        stop 1
+endif
+res = this_image(caf)
+if (any (res /= [1, 1])) then
+        print *, me, ":", res
+        stop 2
+endif
+j2 = this_image(caf, 1)
+if (j2 /= 1) then
+        print *, me, ":", j2
+        stop 3
+endif
+j3 = this_image(team)
+if (j3 /= MOD(this_image() + 43, num_images()) +1) then
+        print *, me, ":", j3
+        stop 4
+endif
+res = this_image(caf, team)
+if (any(res /= [1, 1])) then
+        print *, me, ":", res
+        stop 5
+endif
+j4 = this_image(caf, 1, team)
+if (j4 /= 1) then
+        print *, me, ":", j4
+        stop 6
+endif
+associate(me => this_image())
+end associate
 k1 = num_images()
 k2 = num_images(6)
 k3 = num_images(distance=7)
@@ -10,8 +47,8 @@ k4 = num_images(distance=8, failed=.true.)
 k5 = num_images(failed=.false.)
 end
 
-! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "j2 = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "j\[1-4\] = 1;" 4 "original" } }
+! { dg-final { scan-tree-dump-times "A\\.\[0-9\]+\\\[2\\\] = \\\{1, 1\\\};" 4 "original" } }
 ! { dg-final { scan-tree-dump-times "k1 = 1;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "k2 = 1;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "k3 = 1;" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
index 002c897..d977e21 100644
--- a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
@@ -1,8 +1,46 @@
-! { dg-do compile }
-! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!{ dg-do run }
+!{ dg-additional-options "-fdump-tree-original -fcoarray=lib -lcaf_single" }
 !
-j1 = this_image(distance=4)
-j2 = this_image(5)
+
+use, intrinsic :: iso_fortran_env, only: team_type 
+integer :: caf[2,*]
+integer, allocatable :: res(:)
+type(team_type) :: team
+
+form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1)
+
+associate(me => this_image())
+j1 = this_image()
+if (j1 /= 1) then
+        print *, me, ":", j1
+        stop 1
+endif
+res = this_image(caf)
+if (any (res /= [1, 1])) then
+        print *, me, ":", res
+        stop 2
+endif
+j2 = this_image(caf, 1)
+if (j2 /= 1) then
+        print *, me, ":", j2
+        stop 3
+endif
+j3 = this_image(team)
+if (j3 /= MOD(this_image() + 43, num_images()) +1) then
+        print *, me, ":", j3
+        stop 4
+endif
+res = this_image(caf, team)
+if (any(res /= [1, 1])) then
+        print *, me, ":", res
+        stop 5
+endif
+j4 = this_image(caf, 1, team)
+if (j4 /= 1) then
+        print *, me, ":", j4
+        stop 6
+endif
+end associate
 k1 = num_images()
 k2 = num_images(6)
 k3 = num_images(distance=7)
@@ -10,8 +48,10 @@ k4 = num_images(distance=8, failed=.true.)
 k5 = num_images(failed=.false.)
 end
 
-! { dg-final { scan-tree-dump-times "j1 = _gfortran_caf_this_image \\(4\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "j2 = _gfortran_caf_this_image \\(5\\);" 1 "original" } }
+! { dg-final { scan-tree-dump "j1 = _gfortran_caf_this_image \\(0B\\);" "original" } }
+! { dg-final { scan-tree-dump "j3 = _gfortran_caf_this_image \\(team\\);" "original" } }
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(team\\) \\+ -1;" 2 "original" } }
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(0B\\) \\+ -1;" 2 "original" } }
 ! { dg-final { scan-tree-dump-times "k1 = _gfortran_caf_num_images \\(0, -1\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "k2 = _gfortran_caf_num_images \\(6, -1\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "k3 = _gfortran_caf_num_images \\(7, -1\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
new file mode 100644
index 0000000..d346481
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+
+
+use, intrinsic :: iso_fortran_env, only: team_type 
+integer :: caf[*]
+integer, allocatable :: res(:)
+type(team_type) :: team
+
+j1 = this_image()  ! ok
+j1 = this_image('bar') !{ dg-error "First argument of 'this_image'" }
+res = this_image(caf) ! ok
+res = this_image(caf, caf) !{ dg-error "Second argument of 'this_image'" }
+j2 = this_image(caf, 1) ! ok
+j3 = this_image(caf, 'foo') !{ dg-error "Second argument of 'this_image'" }
+j4 = this_image(caf, [1, 2]) !{ dg-error "Second argument of 'this_image'" }
+j5 = this_image(team) ! ok
+j6 = this_image(team, caf) !{ dg-error "Second argument of 'this_image'" }
+res = this_image(caf, team) ! ok
+res = this_image(caf, team, 'foo') !{ dg-error "shall be of type 'team_type'" }
+j4 = this_image(caf, 1, team) ! ok
+j5 = this_image(caf, 1, team, 'baz') !{ dg-error "Too many arguments in call" }
+j6 = this_image(dim=1, team=team, coarray=caf)
+
+!k1 = num_images()
+
+!k2 = num_images(6)
+
+!k3 = num_images(distance=7)
+
+!k4 = num_images(distance=8, failed=.true.)
+
+!k5 = num_images(failed=.false.)
+end