check.c (check_co_collective): Renamed from

2014-09-25  Tobias Burnus  <burnus@net-b.de>

gcc/fortran
        * check.c (check_co_collective): Renamed from
        * check_co_minmaxsum,
        handle co_reduce.
        (gfc_check_co_minmax, gfc_check_co_sum): Update call.
        (gfc_check_co_broadcast, gfc_check_co_reduce): New.
        * gfortran.h (gfc_isym_id): Add GFC_ISYM_CO_BROADCAST and
        GFC_ISYM_CO_REDUCE.
        * intrinsic.c (add_subroutines): Add co_reduce and co_broadcast.
        * intrinsic.h (gfc_check_co_broadcast, gfc_check_co_reduce): Add
        proto types.
        * intrinsic.texi (CO_BROADCAST): Add.
        * trans.h (gfor_fndecl_co_broadcast): New.
        * trans-decl.c (gfor_fndecl_co_broadcast): Ditto.
        (gfc_build_builtin_function_decls): Add decl for it,
        * trans-intrinsic.c (conv_co_collective): Renamed from
        conv_co_minmaxsum. Handle co_reduce.
        (gfc_conv_intrinsic_subroutine): Handle co_reduce.

gcc/testsuite/
        * gfortran.dg/coarray/collectives_3.f90: New.
        * gfortran.dg/coarray_collectives_9.f90: New.
        * gfortran.dg/coarray_collectives_10.f90: New.
        * gfortran.dg/coarray_collectives_11.f90: New.
        * gfortran.dg/coarray_collectives_12.f90: New.

libgfortran/
        * caf/libcaf.h (_gfortran_caf_co_broadcast): New prototype.
        * caf/single.c (_gfortran_caf_co_broadcast): New.

From-SVN: r215579

gcc/fortran/ChangeLog

@@ -1,3 +1,22 @@
+2014-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (check_co_collective): Renamed from check_co_minmaxsum,
+	handle co_reduce.
+	(gfc_check_co_minmax, gfc_check_co_sum): Update call.
+	(gfc_check_co_broadcast, gfc_check_co_reduce): New.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_CO_BROADCAST and
+	GFC_ISYM_CO_REDUCE.
+	* intrinsic.c (add_subroutines): Add co_reduce and co_broadcast.
+	* intrinsic.h (gfc_check_co_broadcast, gfc_check_co_reduce): Add
+	proto types.
+	* intrinsic.texi (CO_BROADCAST): Add.
+	* trans.h (gfor_fndecl_co_broadcast): New.
+	* trans-decl.c (gfor_fndecl_co_broadcast): Ditto.
+	(gfc_build_builtin_function_decls): Add decl for it,
+	* trans-intrinsic.c (conv_co_collective): Renamed from
+	conv_co_minmaxsum. Handle co_reduce.
+	(gfc_conv_intrinsic_subroutine): Handle co_reduce.
+
 2014-09-23  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/63331

gcc/fortran/check.c

@@ -1414,8 +1414,8 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 
 
 static bool
-check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
+check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
-		    gfc_expr *errmsg)
+		    gfc_expr *errmsg, bool co_reduce)
 {
   if (!variable_check (a, 0, false))
     return false;
@@ -1424,6 +1424,7 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
 				 "INTENT(INOUT)"))
     return false;
 
+  /* Fortran 2008, 12.5.2.4, paragraph 18.  */
   if (gfc_has_vector_subscript (a))
     {
       gfc_error ("Argument 'A' with INTENT(INOUT) at %L of the intrinsic "
@@ -1432,21 +1433,21 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
       return false;
     }
 
-  if (result_image != NULL)
+  if (image_idx != NULL)
     {
-      if (!type_check (result_image, 1, BT_INTEGER))
+      if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
 	return false;
-      if (!scalar_check (result_image, 1))
+      if (!scalar_check (image_idx, co_reduce ? 2 : 1))
 	return false;
     }
 
   if (stat != NULL)
     {
-      if (!type_check (stat, 2, BT_INTEGER))
+      if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER))
 	return false;
-      if (!scalar_check (stat, 2))
+      if (!scalar_check (stat, co_reduce ? 3 : 2))
 	return false;
-      if (!variable_check (stat, 2, false))
+      if (!variable_check (stat, co_reduce ? 3 : 2, false))
 	return false;
       if (stat->ts.kind != 4)
 	{
@@ -1458,11 +1459,11 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
 
   if (errmsg != NULL)
     {
-      if (!type_check (errmsg, 3, BT_CHARACTER))
+      if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER))
 	return false;
-      if (!scalar_check (errmsg, 3))
+      if (!scalar_check (errmsg, co_reduce ? 4 : 3))
 	return false;
-      if (!variable_check (errmsg, 3, false))
+      if (!variable_check (errmsg, co_reduce ? 4 : 3, false))
 	return false;
       if (errmsg->ts.kind != 1)
 	{
@@ -1483,6 +1484,61 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
 }
 
 
+bool
+gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
+			gfc_expr *errmsg)
+{
+  if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
+    {
+       gfc_error ("Support for the A argument at %L which is polymorphic A "
+                  "argument or has allocatable components is not yet "
+		  "implemented", &a->where);
+       return false;
+    }
+  return check_co_collective (a, source_image, stat, errmsg, false);
+}
+
+
+bool
+gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
+		     gfc_expr *stat, gfc_expr *errmsg)
+{
+  symbol_attribute attr;
+
+  if (a->ts.type == BT_CLASS)
+    {
+       gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
+		  &a->where);
+       return false;
+    }
+
+  if (gfc_expr_attr (a).alloc_comp)
+    {
+       gfc_error ("Support for the A argument at %L with allocatable components"
+                  " is not yet implemented", &a->where);
+       return false;
+    }
+
+  attr = gfc_expr_attr (op);
+  if (!attr.pure || !attr.function)
+    {
+       gfc_error ("OPERATOR argument at %L must be a PURE function",
+		  &op->where);
+       return false;
+    }
+
+  if (!check_co_collective (a, result_image, stat, errmsg, true))
+    return false;
+
+  /* FIXME: After J3/WG5 has decided what they actually exactly want, more
+     checks such as same-argument checks have to be added, implemented and
+     intrinsic.texi upated.  */
+
+  gfc_error("CO_REDUCE at %L is not yet implemented", &a->where);
+  return false;
+}
+
+
 bool
 gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
 		     gfc_expr *errmsg)
@@ -1496,7 +1552,7 @@ gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
 		  &a->where);
        return false;
     }
-  return check_co_minmaxsum (a, result_image, stat, errmsg);
+  return check_co_collective (a, result_image, stat, errmsg, false);
 }
 
 
@@ -1506,7 +1562,7 @@ gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
 {
   if (!numeric_check (a, 0))
     return false;
-  return check_co_minmaxsum (a, result_image, stat, errmsg);
+  return check_co_collective (a, result_image, stat, errmsg, false);
 }
 
 

gcc/fortran/gfortran.h

@@ -369,8 +369,10 @@ enum gfc_isym_id
   GFC_ISYM_CHDIR,
   GFC_ISYM_CHMOD,
   GFC_ISYM_CMPLX,
+  GFC_ISYM_CO_BROADCAST,
   GFC_ISYM_CO_MAX,
   GFC_ISYM_CO_MIN,
+  GFC_ISYM_CO_REDUCE,
   GFC_ISYM_CO_SUM,
   GFC_ISYM_COMMAND_ARGUMENT_COUNT,
   GFC_ISYM_COMPILER_OPTIONS,

gcc/fortran/intrinsic.c

@@ -3294,6 +3294,14 @@ add_subroutines (void)
   make_from_module();
 
   /* Coarray collectives.  */
+  add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_co_broadcast, NULL, NULL,
+	      a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
+	      "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
+
   add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE,
 	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
 	      gfc_check_co_minmax, NULL, NULL,
@@ -3318,6 +3326,16 @@ add_subroutines (void)
 	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
 	      errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
 
+  add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_co_reduce, NULL, NULL,
+	      a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
+	      "operator", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+	      errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
+
+
   /* The following subroutine is internally used for coarray libray functions.
      "make_from_module" makes it inaccessible for external users.  */
   add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE,

gcc/fortran/intrinsic.h

@@ -53,8 +53,11 @@ bool gfc_check_chdir (gfc_expr *);
 bool gfc_check_chmod (gfc_expr *, gfc_expr *);
 bool gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_complex (gfc_expr *, gfc_expr *);
+bool gfc_check_co_broadcast (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_co_minmax (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_co_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_co_reduce (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			  gfc_expr *);
 bool gfc_check_count (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_ctime (gfc_expr *);

gcc/fortran/intrinsic.texi

@@ -95,6 +95,7 @@ Some basic guidelines for editing this document:
 * @code{CHDIR}:         CHDIR,     Change working directory
 * @code{CHMOD}:         CHMOD,     Change access permissions of files
 * @code{CMPLX}:         CMPLX,     Complex conversion function
+* @code{CO_BROADCAST}:  CO_BROADCAST, Copy a value to all images the current set of images
 * @code{CO_MAX}:        CO_MAX,    Maximal value on the current set of images
 * @code{CO_MIN}:        CO_MIN,    Minimal value on the current set of images
 * @code{CO_SUM}:        CO_SUM,    Sum of values on the current set of images
@@ -3291,6 +3292,59 @@ end program test_cmplx
 
 
 
+@node CO_BROADCAST
+@section @code{CO_BROADCAST} --- Copy a value to all images the current set of images
+@fnindex CO_BROADCAST
+@cindex Collectives, value broadcasting
+
+@table @asis
+@item @emph{Description}:
+@code{CO_BROADCAST} copies the value of argument @var{A} on the image with
+image index @code{SOURCE_IMAGE} to all images in the current team.  @var{A}
+becomes defined as if by intrinsic assignment.  If the execution was
+successful and @var{STAT} is present, it is assigned the value zero.  If the
+execution failed, @var{STAT} gets assigned a nonzero value and, if present,
+@var{ERRMSG} gets assigned a value describing the occurred error.
+
+@item @emph{Standard}:
+Technical Specification (TS) 18508 or later
+
+@item @emph{Class}:
+Collective subroutine
+
+@item @emph{Syntax}:
+@code{CALL CO_BROADCAST(A, SOURCE_IMAGE [, STAT, ERRMSG])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A}            @tab INTENT(INOUT) argument; shall have the same
+dynamic type and type paramters on all images of the current team. If it
+is an array, it shall have the same shape on all images.
+@item @var{SOURCE_IMAGE} @tab (optional) a scalar integer expression.
+It shall have the same the same value on all images and refer to an
+image of the current team.
+@item @var{STAT}         @tab (optional) a scalar integer variable
+@item @var{ERRMSG}       @tab (optional) a scalar character variable
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program test
+  integer :: val(3)
+  if (this_image() == 1) then
+    val = [1, 5, 3]
+  end if
+  call co_broadcast (val, source_image=1)
+  print *, this_image, ":", val
+end program test
+@end smallexample
+
+@item @emph{See also}:
+@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_SUM}
+@end table
+
+
+
 @node CO_MAX
 @section @code{CO_MAX} --- Maximal value on the current set of images
 @fnindex CO_MAX
@@ -3340,7 +3394,7 @@ end program test
 @end smallexample
 
 @item @emph{See also}:
-@ref{CO_MIN}, @ref{CO_SUM}
+@ref{CO_MIN}, @ref{CO_SUM}, @ref{CO_BROADCAST}
 @end table
 
 
@@ -3394,7 +3448,7 @@ end program test
 @end smallexample
 
 @item @emph{See also}:
-@ref{CO_MAX}, @ref{CO_SUM}
+@ref{CO_MAX}, @ref{CO_SUM}, @ref{CO_BROADCAST}
 @end table
 
 
@@ -3448,7 +3502,7 @@ end program test
 @end smallexample
 
 @item @emph{See also}:
-@ref{CO_MAX}, @ref{CO_MIN}
+@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_BROADCAST}
 @end table
 
 

gcc/fortran/trans-decl.c

@@ -145,6 +145,7 @@ tree gfor_fndecl_caf_atomic_cas;
 tree gfor_fndecl_caf_atomic_op;
 tree gfor_fndecl_caf_lock;
 tree gfor_fndecl_caf_unlock;
+tree gfor_fndecl_co_broadcast;
 tree gfor_fndecl_co_max;
 tree gfor_fndecl_co_min;
 tree gfor_fndecl_co_sum;
@@ -3424,6 +3425,11 @@ gfc_build_builtin_function_decls (void)
 	void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
 	pint_type, pchar_type_node, integer_type_node);
 
+      gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
+	void_type_node, 5, pvoid_type_node, integer_type_node,
+	pint_type, pchar_type_node, integer_type_node);
+
       gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("caf_co_max")), "W.WW",
 	void_type_node, 6, pvoid_type_node, integer_type_node,

gcc/fortran/trans-intrinsic.c

@@ -8173,7 +8173,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
 
 
 static tree
-conv_co_minmaxsum (gfc_code *code)
+conv_co_collective (gfc_code *code)
 {
   gfc_se argse;
   stmtblock_t block, post_block;
@@ -8263,16 +8263,26 @@ conv_co_minmaxsum (gfc_code *code)
     }
 
   /* Generate the function call.  */
-  if (code->resolved_isym->id == GFC_ISYM_CO_MAX)
+  switch (code->resolved_isym->id)
-    fndecl = gfor_fndecl_co_max;
+    {
-  else if (code->resolved_isym->id == GFC_ISYM_CO_MIN)
+    case GFC_ISYM_CO_BROADCAST:
-    fndecl = gfor_fndecl_co_min;
+      fndecl = gfor_fndecl_co_broadcast;
-  else if (code->resolved_isym->id == GFC_ISYM_CO_SUM)
+      break;
-    fndecl = gfor_fndecl_co_sum;
+    case GFC_ISYM_CO_MAX:
-  else
+      fndecl = gfor_fndecl_co_max;
-    gcc_unreachable ();
+      break;
+    case GFC_ISYM_CO_MIN:
+      fndecl = gfor_fndecl_co_min;
+      break;
+    case GFC_ISYM_CO_SUM:
+      fndecl = gfor_fndecl_co_sum;
+      break;
+    default: 
+      gcc_unreachable ();
+    }
 
-  if (code->resolved_isym->id == GFC_ISYM_CO_SUM)
+  if (code->resolved_isym->id == GFC_ISYM_CO_SUM
+      || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
     fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
 				  image_index, stat, errmsg, errmsg_len);
   else
@@ -8281,7 +8291,6 @@ conv_co_minmaxsum (gfc_code *code)
   gfc_add_expr_to_block (&block, fndecl);
   gfc_add_block_to_block (&block, &post_block);
 
-  /* Add CALL to CO_SUM/MIN/MAX: array descriptor, vector descriptor, stat, errmsg, strlen, errmsglen */
   return gfc_finish_block (&block);
 }
 
@@ -8992,10 +9001,14 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
       res = conv_caf_send (code);
       break;
 
+    case GFC_ISYM_CO_REDUCE:
+      gcc_unreachable ();
+      break;
+    case GFC_ISYM_CO_BROADCAST:
     case GFC_ISYM_CO_MIN:
     case GFC_ISYM_CO_MAX:
     case GFC_ISYM_CO_SUM:
-      res = conv_co_minmaxsum (code);
+      res = conv_co_collective (code);
       break;
 
     case GFC_ISYM_SYSTEM_CLOCK:

gcc/fortran/trans.h

@@ -727,6 +727,7 @@ extern GTY(()) tree gfor_fndecl_caf_atomic_cas;
 extern GTY(()) tree gfor_fndecl_caf_atomic_op;
 extern GTY(()) tree gfor_fndecl_caf_lock;
 extern GTY(()) tree gfor_fndecl_caf_unlock;
+extern GTY(()) tree gfor_fndecl_co_broadcast;
 extern GTY(()) tree gfor_fndecl_co_max;
 extern GTY(()) tree gfor_fndecl_co_min;
 extern GTY(()) tree gfor_fndecl_co_sum;

gcc/testsuite/ChangeLog

@@ -1,3 +1,11 @@
+2014-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.dg/coarray/collectives_3.f90: New.
+	* gfortran.dg/coarray_collectives_9.f90: New.
+	* gfortran.dg/coarray_collectives_10.f90: New.
+	* gfortran.dg/coarray_collectives_11.f90: New.
+	* gfortran.dg/coarray_collectives_12.f90: New.
+
 2014-09-24  Bill Schmidt  <wschmidt@linux.vnet.ibm.com>
 
 	* gcc.target/powerpc/swaps-p8-17.c: New test.

gcc/testsuite/gfortran.dg/coarray/collectives_3.f90

@@ -0,0 +1,136 @@
+! { dg-do run }
+!
+! CO_BROADCAST
+!
+program test
+  implicit none
+  intrinsic co_broadcast
+
+  type t
+    integer :: i
+    character(len=1) :: c
+    real(8) :: x(3), y(3)
+  end type t
+
+  integer :: i, j(10), stat
+  complex :: a(5,5)
+  character(kind=1, len=5) :: str1, errstr
+  character(kind=4, len=8) :: str2(2)
+  type(t) :: dt(4)
+
+  i = 1
+  j = 55
+  a = 99.0
+  str1 = 1_"XXXXX"
+  str2 = 4_"YYYYYYYY"
+  dt = t(1, 'C', [1.,2.,3.], [3,3,3])
+  errstr = "ZZZZZ"
+
+  if (this_image() == num_images()) then
+    i = 2
+    j = 66
+    a = -99.0
+    str1 = 1_"abcd"
+    str2 = 4_"12 3 4 5"
+    dt = t(-1, 'a', [3.,1.,8.], [99,24,5])
+  end if
+  sync all
+
+  call co_broadcast(i, source_image=num_images(), stat=stat, errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (i /= 2) call abort()
+
+  call co_broadcast(j, source_image=num_images(), stat=stat, errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (any (j /= 66)) call abort
+
+  call co_broadcast(a, source_image=num_images(), stat=stat, errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (any (a /= -99.0)) call abort
+
+  call co_broadcast(str1, source_image=num_images(), stat=stat, errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (str1 /= "abcd") call abort()
+
+  call co_broadcast(str2, source_image=num_images(), stat=stat, errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (any (str2 /= 4_"12 3 4 5")) call abort
+
+  call co_broadcast(dt, source_image=num_images(), stat=stat, errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (any (dt(:)%i /= -1)) call abort()
+  if (any (dt(:)%c /= 'a')) call abort()
+  if (any (dt(:)%x(1) /= 3.)) call abort()
+  if (any (dt(:)%x(2) /= 1.)) call abort()
+  if (any (dt(:)%x(3) /= 8.)) call abort()
+  if (any (dt(:)%y(1) /= 99.)) call abort()
+  if (any (dt(:)%y(2) /= 24.)) call abort()
+  if (any (dt(:)%y(3) /= 5.)) call abort()
+
+  sync all
+  dt = t(1, 'C', [1.,2.,3.], [3,3,3])
+  sync all
+  if (this_image() == num_images()) then
+    str2 = 4_"001122"
+    dt(2:4) = t(-2, 'i', [9.,2.,3.], [4,44,321])
+  end if
+
+  call co_broadcast(str2(::2), source_image=num_images(), stat=stat, &
+                    errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (str2(1) /= 4_"001122") call abort()
+  if (this_image() == num_images()) then
+    if (str2(1) /= 4_"001122") call abort()
+  else
+    if (str2(2) /= 4_"12 3 4 5") call abort()
+  end if
+
+  call co_broadcast(dt(2::2), source_image=num_images(), stat=stat, &
+                    errmsg=errstr)
+  if (stat /= 0) call abort()
+  if (errstr /= "ZZZZZ") call abort()
+  if (this_image() == num_images()) then
+    if (any (dt(1:1)%i /= 1)) call abort()
+    if (any (dt(1:1)%c /= 'C')) call abort()
+    if (any (dt(1:1)%x(1) /= 1.)) call abort()
+    if (any (dt(1:1)%x(2) /= 2.)) call abort()
+    if (any (dt(1:1)%x(3) /= 3.)) call abort()
+    if (any (dt(1:1)%y(1) /= 3.)) call abort()
+    if (any (dt(1:1)%y(2) /= 3.)) call abort()
+    if (any (dt(1:1)%y(3) /= 3.)) call abort()
+
+    if (any (dt(2:)%i /= -2)) call abort()
+    if (any (dt(2:)%c /= 'i')) call abort()
+    if (any (dt(2:)%x(1) /= 9.)) call abort()
+    if (any (dt(2:)%x(2) /= 2.)) call abort()
+    if (any (dt(2:)%x(3) /= 3.)) call abort()
+    if (any (dt(2:)%y(1) /= 4.)) call abort()
+    if (any (dt(2:)%y(2) /= 44.)) call abort()
+    if (any (dt(2:)%y(3) /= 321.)) call abort()
+  else
+    if (any (dt(1::2)%i /= 1)) call abort()
+    if (any (dt(1::2)%c /= 'C')) call abort()
+    if (any (dt(1::2)%x(1) /= 1.)) call abort()
+    if (any (dt(1::2)%x(2) /= 2.)) call abort()
+    if (any (dt(1::2)%x(3) /= 3.)) call abort()
+    if (any (dt(1::2)%y(1) /= 3.)) call abort()
+    if (any (dt(1::2)%y(2) /= 3.)) call abort()
+    if (any (dt(1::2)%y(3) /= 3.)) call abort()
+
+    if (any (dt(2::2)%i /= -2)) call abort()
+    if (any (dt(2::2)%c /= 'i')) call abort()
+    if (any (dt(2::2)%x(1) /= 9.)) call abort()
+    if (any (dt(2::2)%x(2) /= 2.)) call abort()
+    if (any (dt(2::2)%x(3) /= 3.)) call abort()
+    if (any (dt(2::2)%y(1) /= 4.)) call abort()
+    if (any (dt(2::2)%y(2) /= 44.)) call abort()
+    if (any (dt(2::2)%y(3) /= 321.)) call abort()
+  endif
+end program test

gcc/testsuite/gfortran.dg/coarray_collectives_10.f90

@@ -0,0 +1,11 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2008" }
+!
+!
+! CO_REDUCE/CO_BROADCAST
+!
+program test
+  implicit none
+  intrinsic co_reduce ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
+  intrinsic co_broadcast ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
+end program test

gcc/testsuite/gfortran.dg/coarray_collectives_11.f90

@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=single" }
+!
+! CO_BROADCAST
+!
+program test
+  implicit none
+  intrinsic co_reduce
+  integer :: stat1
+  real :: val
+  call co_broadcast(val, source_image=1, stat=stat1)
+end program test
+
+! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/coarray_collectives_12.f90

@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+! CO_SUM/CO_MIN/CO_MAX
+!
+program test
+  implicit none
+  intrinsic co_max
+  integer :: stat1, stat2, stat3
+  character(len=6) :: errmesg1
+  character(len=7) :: errmesg2
+  character(len=8) :: errmesg3
+  real :: val1
+  complex, allocatable :: val2(:)
+  character(len=99) :: val3
+  integer :: res
+
+  call co_broadcast(val1, source_image=num_images(), stat=stat1, errmsg=errmesg1)
+  call co_broadcast(val2, source_image=4, stat=stat2, errmsg=errmesg2)
+  call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3)
+end program test
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., res, &stat3, errmesg3, 8\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/coarray_collectives_9.f90

@@ -0,0 +1,62 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+!
+! CO_BROADCAST/CO_REDUCE
+!
+program test
+  implicit none
+  intrinsic co_broadcast
+  intrinsic co_reduce
+  integer :: val, i
+  integer :: vec(3), idx(3)
+  character(len=30) :: errmsg
+  integer(8) :: i8
+  character(len=19, kind=4) :: msg4
+
+  interface
+    pure function red_f(a, b)
+      integer :: a, b, red_f
+      intent(in) :: a, b
+    end function red_f
+    impure function red_f2(a, b)
+      integer :: a, b, red_f
+      intent(in) :: a, b
+    end function red_f2
+  end interface
+
+  call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" }
+  call co_reduce("abc") ! { dg-error "Missing actual argument 'operator' in call to 'co_reduce'" }
+  call co_broadcast(1, source_image=1) ! { dg-error "'a' argument of 'co_broadcast' intrinsic at .1. must be a variable" }
+  call co_reduce(a=1, operator=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" }
+  call co_reduce(a=val, operator=red_f2) ! { dg-error "OPERATOR argument at (1) must be a PURE function" }
+
+  call co_broadcast(val, source_image=[1,2]) ! { dg-error "must be a scalar" }
+  call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" }
+  call co_broadcast(val, 1, stat=[1,2]) ! { dg-error "must be a scalar" }
+  call co_broadcast(val, 1, stat=1.0) ! { dg-error "must be INTEGER" }
+  call co_broadcast(val, 1, stat=1) ! { dg-error "must be a variable" }
+  call co_broadcast(val, stat=i, source_image=1) ! OK
+  call co_broadcast(val, stat=i, errmsg=errmsg, source_image=1) ! OK
+  call co_broadcast(val, stat=i, errmsg=[errmsg], source_image=1) ! { dg-error "must be a scalar" }
+  call co_broadcast(val, stat=i, errmsg=5, source_image=1) ! { dg-error "must be CHARACTER" }
+  call co_broadcast(val, 1, errmsg="abc") ! { dg-error "must be a variable" }
+  call co_broadcast(val, 1, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" }
+  call co_broadcast(val, 1, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" }
+
+  call co_reduce(val, red_f, result_image=[1,2]) ! { dg-error "must be a scalar" }
+  call co_reduce(val, red_f, result_image=1.0) ! { dg-error "must be INTEGER" }
+  call co_reduce(val, red_f, stat=[1,2]) ! { dg-error "must be a scalar" }
+  call co_reduce(val, red_f, stat=1.0) ! { dg-error "must be INTEGER" }
+  call co_reduce(val, red_f, stat=1) ! { dg-error "must be a variable" }
+  call co_reduce(val, red_f, stat=i, result_image=1) ! OK
+  call co_reduce(val, red_f, stat=i, errmsg=errmsg, result_image=1) ! OK
+  call co_reduce(val, red_f, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" }
+  call co_reduce(val, red_f, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" }
+  call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" }
+  call co_reduce(val, red_f, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" }
+  call co_reduce(val, red_f, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" }
+
+  call co_broadcasr(vec(idx), 1) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_sum shall not have a vector subscript" }
+  call co_reduce(vec([1,3,2]), red_f) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_min shall not have a vector subscript" }
+end program test

libgfortran/ChangeLog

@@ -1,3 +1,8 @@
+2014-09-25  Tobias Burnus  <burnus@net-b.de>
+
+	* caf/libcaf.h (_gfortran_caf_co_broadcast): New prototype.
+	* caf/single.c (_gfortran_caf_co_broadcast): New.
+
 2014-09-18  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	PR libfortran/62768

libgfortran/caf/libcaf.h

@@ -106,12 +106,10 @@ void _gfortran_caf_error_stop_str (const char *, int32_t)
      __attribute__ ((noreturn));
 void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
 
-void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *,
+void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, int);
-			   char *, int);
+void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, int);
-void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *,
+void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *, int, int);
-			   int, int);
+void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, int);
-void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *,
-			   int, int);
 
 void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *,
                         caf_vector_t *, gfc_descriptor_t *, int, int, bool);

libgfortran/caf/single.c

@@ -210,6 +210,16 @@ _gfortran_caf_error_stop (int32_t error)
 }
 
 
+void
+_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
+			    int source_image __attribute__ ((unused)),
+			    int *stat, char *errmsg __attribute__ ((unused)),
+			    int errmsg_len __attribute__ ((unused)))
+{
+  if (stat)
+    *stat = 0;
+}
+
 void
 _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
 		      int result_image __attribute__ ((unused)),
@@ -224,7 +234,7 @@ void
 _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
 		      int result_image __attribute__ ((unused)),
 		      int *stat, char *errmsg __attribute__ ((unused)),
-		      int src_len __attribute__ ((unused)),
+		      int a_len __attribute__ ((unused)),
 		      int errmsg_len __attribute__ ((unused)))
 {
   if (stat)
@@ -235,7 +245,7 @@ void
 _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
 		      int result_image __attribute__ ((unused)),
 		      int *stat, char *errmsg __attribute__ ((unused)),
-		      int src_len __attribute__ ((unused)),
+		      int a_len __attribute__ ((unused)),
 		      int errmsg_len __attribute__ ((unused)))
 {
   if (stat)