|
1 | | -module object_interface |
2 | | - implicit none |
3 | | - private |
4 | | - public :: object |
5 | | - |
6 | | - type object |
7 | | - private |
8 | | - integer :: foo=0 |
9 | | - logical :: bar=.false. |
10 | | - contains |
11 | | - procedure :: initialize |
12 | | - procedure :: co_broadcast_me |
13 | | - procedure :: not_equal |
14 | | - procedure :: copy |
15 | | - generic :: operator(/=)=>not_equal |
16 | | - generic :: assignment(=)=>copy |
17 | | - end type |
18 | | - |
19 | | - interface |
20 | | - elemental impure module subroutine initialize(this,foo_,bar_) |
21 | | - implicit none |
22 | | - class(object), intent(out) :: this |
23 | | - integer, intent(in) :: foo_ |
24 | | - logical, intent(in) :: bar_ |
25 | | - end subroutine |
26 | | - |
27 | | - elemental impure module subroutine co_broadcast_me(this,source_image) |
28 | | - implicit none |
29 | | - class(object), intent(inout) :: this |
30 | | - integer, intent(in) :: source_image |
31 | | - end subroutine |
32 | | - |
33 | | - elemental module function not_equal(lhs,rhs) result(lhs_ne_rhs) |
34 | | - implicit none |
35 | | - class(object), intent(in) :: lhs,rhs |
36 | | - logical lhs_ne_rhs |
37 | | - end function |
38 | | - |
39 | | - elemental impure module subroutine copy(lhs,rhs) |
40 | | - implicit none |
41 | | - class(object), intent(inout) :: lhs |
42 | | - class(object), intent(in) :: rhs |
43 | | - end subroutine |
44 | | - end interface |
45 | | - |
46 | | -end module |
47 | | - |
48 | | -submodule(object_interface) object_implementation |
49 | | - implicit none |
50 | | -contains |
51 | | - module procedure co_broadcast_me |
52 | | - call co_broadcast(this%foo,source_image) |
53 | | - call co_broadcast(this%bar,source_image) |
54 | | - end procedure |
55 | | - |
56 | | - module procedure initialize |
57 | | - this%foo = foo_ |
58 | | - this%bar = bar_ |
59 | | - end procedure |
60 | | - |
61 | | - module procedure not_equal |
62 | | - lhs_ne_rhs = (lhs%foo /= rhs%foo) .or. (lhs%bar .neqv. rhs%bar) |
63 | | - end procedure |
64 | | - |
65 | | - module procedure copy |
66 | | - lhs%foo = rhs%foo |
67 | | - lhs%bar = rhs%bar |
68 | | - end procedure |
69 | | -end submodule |
70 | | - |
71 | 1 | program main |
72 | | - use object_interface, only : object |
| 2 | + !! author: Damian Rouson |
| 3 | + !! |
| 4 | + !! Test co_broadcast with derived-type actual arguments |
73 | 5 | implicit none |
74 | | - type(object) message |
75 | | - |
76 | | - call message%initialize(foo_=1,bar_=.true.) |
77 | | - |
78 | | - emulate_co_broadcast: block |
79 | | - type(object) foobar |
80 | | - if (this_image()==1) foobar = message |
81 | | - call foobar%co_broadcast_me(source_image=1) |
82 | | - if ( foobar /= message ) error stop "Test failed." |
83 | | - end block emulate_co_broadcast |
84 | | - |
85 | | - desired_co_broadcast: block |
86 | | - type(object) barfoo |
87 | | - if (this_image()==1) barfoo = message |
88 | | - call co_broadcast(barfoo,source_image=1) ! OpenCoarrays terminates here with the message "Unsupported data type" |
89 | | - if ( barfoo /= message ) error stop "Test failed." |
90 | | - end block desired_co_broadcast |
91 | | - |
92 | | - sync all ! Wait for each image to pass the test |
93 | | - if (this_image()==1) print *,"Test passed." |
| 6 | + |
| 7 | + integer, parameter :: sender=1 !! co_broadcast source_image |
| 8 | + character(len=*), parameter :: text="text" !! character message data |
| 9 | + |
| 10 | + associate(me=>this_image()) |
| 11 | + |
| 12 | + test_non_allocatable: block |
| 13 | + type parent |
| 14 | + integer :: heritable=0 |
| 15 | + end type |
| 16 | + |
| 17 | + type component |
| 18 | + integer :: subcomponent=0 |
| 19 | + end type |
| 20 | + |
| 21 | + type, extends(parent) :: child |
| 22 | + type(component) a |
| 23 | + character(len=len(text)) :: c="", z(0) |
| 24 | + complex :: i=(0.,0.), j(1)=(0.,0.) |
| 25 | + integer :: k=0, l(2,3)=0 |
| 26 | + real :: r=0., s(3,2,1)=0. |
| 27 | + logical :: t=.false., u(1,2,3, 1,2,3, 1,2,3, 1,2,3, 1,2,3)=.false. |
| 28 | + end type |
| 29 | + |
| 30 | + type(child) message |
| 31 | + type(child) :: content = child( & |
| 32 | + parent=parent(heritable=-2), a=component(-1), c=text, z=[character(len=len(text))::], & |
| 33 | + i=(0.,1.), j=(2.,3.), k=4, l=5, r=7., s=8., t=.true., u=.true. & |
| 34 | + ) |
| 35 | + if (me==sender) message = content |
| 36 | + |
| 37 | + call co_broadcast(message,source_image=sender) |
| 38 | + |
| 39 | + associate( failures => [ & |
| 40 | + message%parent%heritable /= content%parent%heritable, & |
| 41 | + message%a%subcomponent /= content%a%subcomponent, & |
| 42 | + message%c /= content%c, & |
| 43 | + message%z /= content%z, & |
| 44 | + message%i /= content%i, & |
| 45 | + message%j /= content%j, & |
| 46 | + message%k /= content%k, & |
| 47 | + message%l /= content%l, & |
| 48 | + message%r /= content%r, & |
| 49 | + message%s /= content%s, & |
| 50 | + message%t .neqv. content%t, & |
| 51 | + any( message%u .neqv. content%u ) & |
| 52 | + ] ) |
| 53 | + |
| 54 | + if ( any(failures) ) error stop "Test failed in non-allocatable block." |
| 55 | + |
| 56 | + end associate |
| 57 | + |
| 58 | + end block test_non_allocatable |
| 59 | + |
| 60 | + test_allocatable: block |
| 61 | + type dynamic |
| 62 | + character(len=:), allocatable :: string |
| 63 | + complex, allocatable :: scalar |
| 64 | + integer, allocatable :: vector(:) |
| 65 | + logical, allocatable :: matrix(:,:) |
| 66 | + real, allocatable :: superstring(:,:,:, :,:,:, :,:,:, :,:,:, :,:,: ) |
| 67 | + end type |
| 68 | + |
| 69 | + type(dynamic) alloc_message, alloc_content |
| 70 | + |
| 71 | + alloc_content = dynamic( & |
| 72 | + string=text, & |
| 73 | + scalar=(0.,1.), & |
| 74 | + vector=reshape( [integer::], [0]), & |
| 75 | + matrix=reshape( [.true.], [1,1]), & |
| 76 | + superstring=reshape([1,2,3,4], [2,1,2, 1,1,1, 1,1,1, 1,1,1, 1,1,1 ]) & |
| 77 | + ) |
| 78 | + |
| 79 | + if (me==sender) alloc_message = alloc_content |
| 80 | + |
| 81 | + call co_broadcast(alloc_message,source_image=sender) |
| 82 | + |
| 83 | + associate( failures => [ & |
| 84 | + alloc_message%string /= alloc_content%string, & |
| 85 | + alloc_message%scalar /= alloc_content%scalar, & |
| 86 | + alloc_message%vector /= alloc_content%vector, & |
| 87 | + alloc_message%matrix .neqv. alloc_content%matrix, & |
| 88 | + alloc_message%superstring /= alloc_content%superstring & |
| 89 | + ] ) |
| 90 | + |
| 91 | + if ( any(failures) ) error stop "Test failed in allocatable block." |
| 92 | + |
| 93 | + end associate |
| 94 | + |
| 95 | + end block test_allocatable |
| 96 | + |
| 97 | + sync all ! Wait for each image to pass the test |
| 98 | + if (me==sender) print *,"Test passed." |
| 99 | + |
| 100 | + end associate |
94 | 101 |
|
95 | 102 | end program main |
0 commit comments