gcc/testsuite/gfortran.dg/coarray_collectives_9.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fcoarray=single -fmax-errors=40" }
   3 !
   4 !
   5 ! CO_BROADCAST/CO_REDUCE
   6 !
   7 program test
   8   implicit none
   9   intrinsic co_broadcast
  10   intrinsic co_reduce
  11   integer :: val, i
  12   integer :: vec(3), idx(3)
  13   character(len=30) :: errmsg
  14   integer(8) :: i8
  15   character(len=19, kind=4) :: msg4
  16
  17   interface
  18     pure function red_f(a, b)
  19       integer :: a, b, red_f
  20       intent(in) :: a, b
  21     end function red_f
  22     impure function red_f2(a, b)
  23       integer :: a, b, red_f
  24       intent(in) :: a, b
  25     end function red_f2
  26   end interface
  27
  28   call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" }
  29   call co_reduce("abc") ! { dg-error "Missing actual argument 'operation' in call to 'co_reduce'" }
  30   call co_broadcast(1, source_image=1) ! { dg-error "'a' argument of 'co_broadcast' intrinsic at .1. must be a variable" }
  31   call co_reduce(a=1, operation=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" }
  32   call co_reduce(a=val, operation=red_f2) ! { dg-error "OPERATION argument at \\(1\\) must be a PURE function" }
  33
  34   call co_broadcast(val, source_image=[1,2]) ! { dg-error "must be a scalar" }
  35   call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" }
  36   call co_broadcast(val, 1, stat=[1,2]) ! { dg-error "must be a scalar" }
  37   call co_broadcast(val, 1, stat=1.0) ! { dg-error "must be INTEGER" }
  38   call co_broadcast(val, 1, stat=1) ! { dg-error "must be a variable" }
  39   call co_broadcast(val, stat=i, source_image=1) ! OK
  40   call co_broadcast(val, stat=i, errmsg=errmsg, source_image=1) ! OK
  41   call co_broadcast(val, stat=i, errmsg=[errmsg], source_image=1) ! { dg-error "must be a scalar" }
  42   call co_broadcast(val, stat=i, errmsg=5, source_image=1) ! { dg-error "must be CHARACTER" }
  43   call co_broadcast(val, 1, errmsg="abc") ! { dg-error "must be a variable" }
  44   call co_broadcast(val, 1, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" }
  45   call co_broadcast(val, 1, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" }
  46
  47   call co_reduce(val, red_f, result_image=[1,2]) ! { dg-error "must be a scalar" }
  48   call co_reduce(val, red_f, result_image=1.0) ! { dg-error "must be INTEGER" }
  49   call co_reduce(val, red_f, stat=[1,2]) ! { dg-error "must be a scalar" }
  50   call co_reduce(val, red_f, stat=1.0) ! { dg-error "must be INTEGER" }
  51   call co_reduce(val, red_f, stat=1) ! { dg-error "must be a variable" }
  52   call co_reduce(val, red_f, stat=i, result_image=1) ! OK
  53   call co_reduce(val, red_f, stat=i, errmsg=errmsg, result_image=1) ! OK
  54   call co_reduce(val, red_f, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" }
  55   call co_reduce(val, red_f, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" }
  56   call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" }
  57   call co_reduce(val, red_f, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" }
  58   call co_reduce(val, red_f, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" }
  59
  60   call co_broadcast(vec(idx), 1) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_broadcast shall not have a vector subscript" }
  61   call co_reduce(vec([1,3,2]), red_f) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_reduce shall not have a vector subscript" }
  62 end program test