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