Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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 'operator' 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, operator=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" }
32 call co_reduce(a=val, operator=red_f2) ! { dg-error "OPERATOR 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