1! { dg-do compile }
2! { dg-options "-fcoarray=single -fmax-errors=80" }
3!
4!
5! CO_REDUCE (plus CO_MIN/MAX/SUM/BROADCAST)
6!
7program test
8  implicit none (external, type)
9  intrinsic co_reduce
10  intrinsic co_broadcast
11  intrinsic co_min
12  intrinsic co_max
13  intrinsic co_sum
14  intrinsic dprod
15  external ext
16
17  type t
18    procedure(), pointer, nopass :: ext
19    procedure(valid), pointer, nopass :: valid
20    procedure(sub), pointer, nopass :: sub
21    procedure(nonpure), pointer, nopass :: nonpure
22    procedure(arg1), pointer, nopass :: arg1
23    procedure(arg3), pointer, nopass :: arg3
24    procedure(elem), pointer, nopass :: elem
25    procedure(realo), pointer, nopass :: realo
26    procedure(int8), pointer, nopass :: int8
27    procedure(arr), pointer, nopass :: arr
28    procedure(ptr), pointer, nopass :: ptr
29    procedure(alloc), pointer, nopass :: alloc
30    procedure(opt), pointer, nopass :: opt
31    procedure(val), pointer, nopass :: val
32    procedure(async), pointer, nopass :: async
33    procedure(tgt), pointer, nopass :: tgt
34    procedure(char44), pointer, nopass :: char44
35    procedure(char34), pointer, nopass :: char34
36  end type t
37
38  type(t) :: dt
39  integer :: caf[*]
40  character(len=3) :: c3
41  character(len=4) :: c4
42
43
44
45  call co_min(caf[1]) ! { dg-error "shall not be coindexed" }
46  call co_max(caf[1]) ! { dg-error "shall not be coindexed" }
47  call co_sum(caf[1]) ! { dg-error "shall not be coindexed" }
48  call co_broadcast(caf[1], source_image=1) ! { dg-error "shall not be coindexed" }
49  call co_reduce(caf[1], valid) ! { dg-error "shall not be coindexed" }
50
51  call co_reduce(caf, valid) ! OK
52  call co_reduce(caf, dt%valid) ! OK
53  call co_reduce(caf, dprod) ! { dg-error "is not permitted for CO_REDUCE" }
54  call co_reduce(caf, ext) ! { dg-error "must be a PURE function" }
55  call co_reduce(caf, dt%ext) ! { dg-error "must be a PURE function" }
56  call co_reduce(caf, sub) ! { dg-error "must be a PURE function" }
57  call co_reduce(caf, dt%sub) ! { dg-error "must be a PURE function" }
58  call co_reduce(caf, nonpure) ! { dg-error "must be a PURE function" }
59  call co_reduce(caf, dt%nonpure) ! { dg-error "must be a PURE function" }
60  call co_reduce(caf, arg1) ! { dg-error "shall have two arguments" }
61  call co_reduce(caf, dt%arg1) ! { dg-error "shall have two arguments" }
62  call co_reduce(caf, arg3) ! { dg-error "shall have two arguments" }
63  call co_reduce(caf, dt%arg3) ! { dg-error "shall have two arguments" }
64  call co_reduce(caf, elem) ! { dg-error "ELEMENTAL non-INTRINSIC procedure 'elem' is not allowed as an actual argument" }
65  call co_reduce(caf, dt%elem) ! { dg-error "ELEMENTAL procedure pointer component 'elem' is not allowed as an actual argument" }
66  call co_reduce(caf, realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
67  call co_reduce(caf, dt%realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
68  call co_reduce(caf, int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
69  call co_reduce(caf, dt%int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
70  call co_reduce(caf, arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
71  call co_reduce(caf, dt%arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
72  call co_reduce(caf, ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
73  call co_reduce(caf, dt%ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
74  call co_reduce(caf, alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
75  call co_reduce(caf, dt%alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
76  call co_reduce(caf, opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" }
77  call co_reduce(caf, dt%opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" }
78  call co_reduce(caf, val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" }
79  call co_reduce(caf, dt%val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" }
80  call co_reduce(caf, async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" }
81  call co_reduce(caf, dt%async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" }
82  call co_reduce(caf, tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" }
83  call co_reduce(caf, dt%tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" }
84  call co_reduce(c4, char44) ! OK
85  call co_reduce(c4, dt%char44) ! OK
86  call co_reduce(c3, char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
87  call co_reduce(c3, dt%char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
88  call co_reduce(c4, char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
89  call co_reduce(c4, dt%char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
90
91contains
92  pure integer function valid(x,y)
93    integer, value :: x, y
94  end function valid
95  impure integer function nonpure(x,y)
96    integer, value :: x, y
97  end function nonpure
98  pure subroutine sub()
99  end subroutine sub
100  pure integer function arg3(x, y, z)
101    integer, value :: x, y, z
102  end function arg3
103  pure integer function arg1(x)
104    integer, value :: x
105  end function arg1
106  pure elemental integer function elem(x,y)
107    integer, value :: x, y
108  end function elem
109  pure real function realo(x,y)
110    integer, value :: x, y
111  end function realo
112  pure integer(8) function int8(x,y)
113    integer, value :: x, y
114  end function int8
115  pure integer function arr(x,y)
116    integer, intent(in) :: x(:), y
117  end function arr
118  pure integer function ptr(x,y)
119    integer, intent(in), pointer :: x, y
120  end function ptr
121  pure integer function alloc(x,y)
122    integer, intent(in), allocatable :: x, y
123  end function alloc
124  pure integer function opt(x,y)
125    integer, intent(in) :: x, y
126    optional :: x, y
127  end function opt
128  pure integer function val(x,y)
129    integer, value :: x
130    integer, intent(in) :: y
131  end function val
132  pure integer function tgt(x,y)
133    integer, intent(in) :: x, y
134    target :: x
135  end function tgt
136  pure integer function async(x,y)
137    integer, intent(in) :: x, y
138    asynchronous :: y
139  end function async
140  pure character(4) function char44(x,y)
141    character(len=4), value :: x, y
142  end function char44
143  pure character(3) function char34(x,y)
144    character(len=4), value :: x, y
145  end function char34
146end program test
147