diff mbox

[Fortran] Add CO_BROADCAST

Message ID 541D8AA1.8010303@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Sept. 20, 2014, 2:09 p.m. UTC 
This patch adds a CO_BROADCAST and prepares a bit for CO_REDUCE.

Both functions permit arguments with allocatable components 
(nonpolymophic or polymorphic), CO_BROADCAST also permits polymorphic 
arguments. This patch doesn't support allocatable/polymorphic arguments 
but otherwise CO_BROADCAST should work. For CO_REDUCE only some 
parsing/argument checking is done but no actual implementation.

The allocatables make life harder for general coarray communication, 
broadcast and reduction and have to be implemented at some point in a 
clever way. I am thinking of some call-back-able function - which could 
also be used for OpenMP 4.x/5.0 to handle copying to threadprivate 
variables and for copyin/out to accelerators; the current spec handles 
allocatable components by creating the copying code in the middle end, 
but that won't work for polymorphic allocatables.

For CO_REDUCE, it becomes even harder as currently any pure function 
works (elemental or not, passing arguments with array descriptor, as 
pointer or as value, having a hidden string length argument or [with C 
binding] not etc. Requiring packed array arguments or not, whether 
gfortran returns the result as value or as argument - and possibly 
more). There is some J3 discussion if one could narrow down the 
possibilities a bit. In any case, implementing co_reduce requires some 
thinking.

The attached patch was build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

Comments

Paul Richard Thomas Sept. 25, 2014, 4:42 a.m. UTC | #1 
Hi Tobias,

In the check.c error messages, you use 'A argument'.  Should you not
use 'SOURCE argument', following CO BROADCAST (SOURCE, SOURCE IMAGE [,
STAT, ERRMSG]) ? I am looking at WG5/N1983 - is there some more recent
proposal?

When do you intend to implement a _gfortran_caf_co_broadcast that does
something?

Anway, the patch is OK for trunk.

Thanks

Paul

On 20 September 2014 16:09, Tobias Burnus <burnus@net-b.de> wrote:
> This patch adds a CO_BROADCAST and prepares a bit for CO_REDUCE.
>
> Both functions permit arguments with allocatable components (nonpolymophic
> or polymorphic), CO_BROADCAST also permits polymorphic arguments. This patch
> doesn't support allocatable/polymorphic arguments but otherwise CO_BROADCAST
> should work. For CO_REDUCE only some parsing/argument checking is done but
> no actual implementation.
>
> The allocatables make life harder for general coarray communication,
> broadcast and reduction and have to be implemented at some point in a clever
> way. I am thinking of some call-back-able function - which could also be
> used for OpenMP 4.x/5.0 to handle copying to threadprivate variables and for
> copyin/out to accelerators; the current spec handles allocatable components
> by creating the copying code in the middle end, but that won't work for
> polymorphic allocatables.
>
> For CO_REDUCE, it becomes even harder as currently any pure function works
> (elemental or not, passing arguments with array descriptor, as pointer or as
> value, having a hidden string length argument or [with C binding] not etc.
> Requiring packed array arguments or not, whether gfortran returns the result
> as value or as argument - and possibly more). There is some J3 discussion if
> one could narrow down the possibilities a bit. In any case, implementing
> co_reduce requires some thinking.
>
> The attached patch was build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
Tobias Burnus Sept. 25, 2014, 6:08 a.m. UTC | #2 
Hi Paul,

Paul Richard Thomas wrote:
> In the check.c error messages, you use 'A argument'.  Should you not
> use 'SOURCE argument', following CO BROADCAST (SOURCE, SOURCE IMAGE [,
> STAT, ERRMSG]) ? I am looking at WG5/N1983 - is there some more recent
> proposal?

Looking at N2027, I see "A, SOURCE_IMAGE [, STAT, ERRMSG]". It might be 
that J3/WG5 decided that SOURCE= is a bad name on all but one image as 
it would for all other images a DESTINATION.

Regarding the references: I try to keep 
https://gcc.gnu.org/wiki/GFortranStandards up to date; I think the 
latest draft is N2027: 
http://isotc.iso.org/livelink/livelink?func=ll&objId=16769292&objAction=Open

Thanks for cross checking!

> When do you intend to implement a _gfortran_caf_co_broadcast that does
> something?

Well, the current libgfortran/caf/single.c is fully compliant - for a 
single image. (Ignoring allocatable components and the lacking 
finalization.)

I intend to leave the MPI and GASNet implementation to Alessandro, 
unless I feel really tempted to do it.

> Anway, the patch is OK for trunk.

Thanks for the review! I committed the unmodified patch as Rev. 215579.

Tobias

> On 20 September 2014 16:09, Tobias Burnus <burnus@net-b.de> wrote:
>> This patch adds a CO_BROADCAST and prepares a bit for CO_REDUCE.
>>
>> Both functions permit arguments with allocatable components (nonpolymophic
>> or polymorphic), CO_BROADCAST also permits polymorphic arguments. This patch
>> doesn't support allocatable/polymorphic arguments but otherwise CO_BROADCAST
>> should work. For CO_REDUCE only some parsing/argument checking is done but
>> no actual implementation.
>>
>> The allocatables make life harder for general coarray communication,
>> broadcast and reduction and have to be implemented at some point in a clever
>> way. I am thinking of some call-back-able function - which could also be
>> used for OpenMP 4.x/5.0 to handle copying to threadprivate variables and for
>> copyin/out to accelerators; the current spec handles allocatable components
>> by creating the copying code in the middle end, but that won't work for
>> polymorphic allocatables.
>>
>> For CO_REDUCE, it becomes even harder as currently any pure function works
>> (elemental or not, passing arguments with array descriptor, as pointer or as
>> value, having a hidden string length argument or [with C binding] not etc.
>> Requiring packed array arguments or not, whether gfortran returns the result
>> as value or as argument - and possibly more). There is some J3 discussion if
>> one could narrow down the possibilities a bit. In any case, implementing
>> co_reduce requires some thinking.
>>
>> The attached patch was build and regtested on x86-64-gnu-linux.
>> OK for the trunk?
>>
>> Tobias
Alessandro Fanfarillo Sept. 25, 2014, 4:46 p.m. UTC | #3 
Hi, I'm implementing the co_broadcast on libcafmpi right now.

2014-09-25 8:08 GMT+02:00 Tobias Burnus <burnus@net-b.de>:
> Hi Paul,
>
> Paul Richard Thomas wrote:
>>
>> In the check.c error messages, you use 'A argument'.  Should you not
>> use 'SOURCE argument', following CO BROADCAST (SOURCE, SOURCE IMAGE [,
>> STAT, ERRMSG]) ? I am looking at WG5/N1983 - is there some more recent
>> proposal?
>
>
> Looking at N2027, I see "A, SOURCE_IMAGE [, STAT, ERRMSG]". It might be that
> J3/WG5 decided that SOURCE= is a bad name on all but one image as it would
> for all other images a DESTINATION.
>
> Regarding the references: I try to keep
> https://gcc.gnu.org/wiki/GFortranStandards up to date; I think the latest
> draft is N2027:
> http://isotc.iso.org/livelink/livelink?func=ll&objId=16769292&objAction=Open
>
> Thanks for cross checking!
>
>> When do you intend to implement a _gfortran_caf_co_broadcast that does
>> something?
>
>
> Well, the current libgfortran/caf/single.c is fully compliant - for a single
> image. (Ignoring allocatable components and the lacking finalization.)
>
> I intend to leave the MPI and GASNet implementation to Alessandro, unless I
> feel really tempted to do it.
>
>> Anway, the patch is OK for trunk.
>
>
> Thanks for the review! I committed the unmodified patch as Rev. 215579.
>
> Tobias
>
>
>> On 20 September 2014 16:09, Tobias Burnus <burnus@net-b.de> wrote:
>>>
>>> This patch adds a CO_BROADCAST and prepares a bit for CO_REDUCE.
>>>
>>> Both functions permit arguments with allocatable components
>>> (nonpolymophic
>>> or polymorphic), CO_BROADCAST also permits polymorphic arguments. This
>>> patch
>>> doesn't support allocatable/polymorphic arguments but otherwise
>>> CO_BROADCAST
>>> should work. For CO_REDUCE only some parsing/argument checking is done
>>> but
>>> no actual implementation.
>>>
>>> The allocatables make life harder for general coarray communication,
>>> broadcast and reduction and have to be implemented at some point in a
>>> clever
>>> way. I am thinking of some call-back-able function - which could also be
>>> used for OpenMP 4.x/5.0 to handle copying to threadprivate variables and
>>> for
>>> copyin/out to accelerators; the current spec handles allocatable
>>> components
>>> by creating the copying code in the middle end, but that won't work for
>>> polymorphic allocatables.
>>>
>>> For CO_REDUCE, it becomes even harder as currently any pure function
>>> works
>>> (elemental or not, passing arguments with array descriptor, as pointer or
>>> as
>>> value, having a hidden string length argument or [with C binding] not
>>> etc.
>>> Requiring packed array arguments or not, whether gfortran returns the
>>> result
>>> as value or as argument - and possibly more). There is some J3 discussion
>>> if
>>> one could narrow down the possibilities a bit. In any case, implementing
>>> co_reduce requires some thinking.
>>>
>>> The attached patch was build and regtested on x86-64-gnu-linux.
>>> OK for the trunk?
>>>
>>> Tobias
>
>
Andreas Schwab Sept. 26, 2014, 8:18 p.m. UTC | #4 
Tobias Burnus <burnus@net-b.de> writes:

> diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90
> new file mode 100644
> index 0000000..90c09c5
> --- /dev/null
> +++ b/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

FAIL: gfortran.dg/coarray_collectives_9.f90   -O   (test for errors, line 32)
FAIL: gfortran.dg/coarray_collectives_9.f90   -O   (test for errors, line 57)
FAIL: gfortran.dg/coarray_collectives_9.f90   -O   (test for errors, line 58)
FAIL: gfortran.dg/coarray_collectives_9.f90   -O   (test for errors, line 60)
FAIL: gfortran.dg/coarray_collectives_9.f90   -O   (test for errors, line 61)
FAIL: gfortran.dg/coarray_collectives_9.f90   -O  (test for excess errors)
Excess errors:
/usr/local/gcc/gcc-20140926/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90:32:33: Error: OPERATOR argument at (1) must be a PURE function
/usr/local/gcc/gcc-20140926/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90:52:17: Error: CO_REDUCE at (1) is not yet implemented
/usr/local/gcc/gcc-20140926/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90:53:17: Error: CO_REDUCE at (1) is not yet implemented
Fatal Error: Error count reached limit of 25.

Andreas.
diff mbox

Patch

2014-09-20  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                           |  10 +-
	* caf/single.c                           |  14 ++-

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 531fe86..0a08c73 100644
--- a/gcc/fortran/check.c
+++ b/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,
-		    gfc_expr *errmsg)
+check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
+		    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)
 	{
@@ -1484,6 +1485,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);
 }
 
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b208a89..f1c78cc 100644
--- a/gcc/fortran/gfortran.h
+++ b/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,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 1ad1e69..9bc9b3c 100644
--- a/gcc/fortran/intrinsic.c
+++ b/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,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 9437171..a6342e7 100644
--- a/gcc/fortran/intrinsic.h
+++ b/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 *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 48713a6..4d884d7 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/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
 
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 10dfc9f..7184504 100644
--- a/gcc/fortran/trans-decl.c
+++ b/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,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 0a83ad0..0a3315d 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/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)
-    fndecl = gfor_fndecl_co_max;
-  else if (code->resolved_isym->id == GFC_ISYM_CO_MIN)
-    fndecl = gfor_fndecl_co_min;
-  else if (code->resolved_isym->id == GFC_ISYM_CO_SUM)
-    fndecl = gfor_fndecl_co_sum;
-  else
-    gcc_unreachable ();
+  switch (code->resolved_isym->id)
+    {
+    case GFC_ISYM_CO_BROADCAST:
+      fndecl = gfor_fndecl_co_broadcast;
+      break;
+    case GFC_ISYM_CO_MAX:
+      fndecl = gfor_fndecl_co_max;
+      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:
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 70c794b..03136e6 100644
--- a/gcc/fortran/trans.h
+++ b/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;
diff --git a/gcc/testsuite/gfortran.dg/coarray/collectives_3.f90 b/gcc/testsuite/gfortran.dg/coarray/collectives_3.f90
new file mode 100644
index 0000000..123a857
--- /dev/null
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_10.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_10.f90
new file mode 100644
index 0000000..906785c
--- /dev/null
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_11.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_11.f90
new file mode 100644
index 0000000..b10ba62
--- /dev/null
+++ b/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" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90
new file mode 100644
index 0000000..e3ba9d8
--- /dev/null
+++ b/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" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90
new file mode 100644
index 0000000..90c09c5
--- /dev/null
+++ b/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
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 0f3398a..ffd0980 100644
--- a/libgfortran/caf/libcaf.h
+++ b/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 *,
-			   char *, int);
-void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *,
-			   int, int);
-void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *,
-			   int, int);
+void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, 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 *, 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);
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 773941b..e264fc5 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -211,6 +211,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)),
 		      int *stat, char *errmsg __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)