|
1 | | -module object_interface |
| 1 | +program main |
| 2 | + !! author: Damian Rouson |
| 3 | + !! |
| 4 | + !! Test co_broadcast with derived-type actual arguments |
2 | 5 | 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 |
| 6 | + |
| 7 | + integer, parameter :: sender=1 !! co_broadcast source_image |
| 8 | + character(len=*), parameter :: text="text" !! character message data |
18 | 9 |
|
19 | 10 | 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 |
| 11 | + function f(x) result(y) |
| 12 | + real x, y |
| 13 | + end function |
44 | 14 | end interface |
45 | 15 |
|
46 | | -end module |
| 16 | + type parent |
| 17 | + integer :: heritable=0 |
| 18 | + end type |
47 | 19 |
|
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 |
| 20 | + type component |
| 21 | + integer :: subcomponent=0 |
| 22 | + end type |
70 | 23 |
|
71 | | -program main |
72 | | - use object_interface, only : object |
73 | | - 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." |
| 24 | + type, extends(parent) :: child |
| 25 | + |
| 26 | + ! Scalar and array derived-type components |
| 27 | + type(component) a, b(1,2,1, 1,1,1, 1) |
| 28 | + |
| 29 | + ! Scalar and array intrinsic-type components |
| 30 | + character(len=len(text)) :: c="", z(0) |
| 31 | + complex :: i=(0.,0.), j(1)=(0.,0.) |
| 32 | + integer :: k=0, l(2,3)=0 |
| 33 | + logical :: r=.false., s(1,2,3, 1,2,3, 1)=.false. |
| 34 | + real :: t=0., u(3,2,1)=0. |
| 35 | + |
| 36 | + ! Scalar and array pointer components |
| 37 | + character(len=len(text)), pointer :: & |
| 38 | + char_ptr=>null(), char_ptr_maxdim(:,:,:, :,:,:, :)=>null() |
| 39 | + complex, pointer :: cplx_ptr=>null(), cplx_ptr_maxdim(:,:,:, :,:,:, :)=>null() |
| 40 | + integer, pointer :: int_ptr =>null(), int_ptr_maxdim (:,:,:, :,:,:, :)=>null() |
| 41 | + logical, pointer :: bool_ptr=>null(), bool_ptr_maxdim(:,:,:, :,:,:, :)=>null() |
| 42 | + real, pointer :: real_ptr=>null(), real_ptr_maxdim(:,:,:, :,:,:, :)=>null() |
| 43 | + procedure(f), pointer :: procedure_pointer=>null() |
| 44 | + end type |
| 45 | + |
| 46 | + type(child) message |
| 47 | + type(child) :: content = child( & ! define content using the insrinsic structure constructor |
| 48 | + parent=parent(heritable=-4), & ! parent |
| 49 | + a=component(-3), b=reshape([component(-2),component(-1)], [1,2,1, 1,1,1, 1]), & ! derived types |
| 50 | + c=text, z=[character(len=len(text))::], i=(0.,1.), j=(2.,3.), k=4, l=5, r=.true., s=.true., t=7., u=8. & ! intrinsic types |
| 51 | + ) |
| 52 | + |
| 53 | + associate(me=>this_image()) |
| 54 | + |
| 55 | + if (me==sender) then |
| 56 | + message = content |
| 57 | + allocate(message%char_ptr, message%char_ptr_maxdim(1,1,2, 1,1,1, 1), source=text ) |
| 58 | + allocate(message%cplx_ptr, message%cplx_ptr_maxdim(1,1,1, 1,1,2, 1), source=(0.,1.)) |
| 59 | + allocate(message%int_ptr , message%int_ptr_maxdim (1,1,1, 1,1,1, 1), source=2 ) |
| 60 | + allocate(message%bool_ptr, message%bool_ptr_maxdim(1,1,1, 1,2,1, 1), source=.true. ) |
| 61 | + allocate(message%real_ptr, message%real_ptr_maxdim(1,1,1, 1,1,1, 1), source=3. ) |
| 62 | + end if |
| 63 | + |
| 64 | + call co_broadcast(message,source_image=sender) |
| 65 | + |
| 66 | + if (me==sender) then |
| 67 | + deallocate(message%char_ptr, message%char_ptr_maxdim) |
| 68 | + deallocate(message%cplx_ptr, message%cplx_ptr_maxdim) |
| 69 | + deallocate(message%int_ptr , message%int_ptr_maxdim ) |
| 70 | + deallocate(message%bool_ptr, message%bool_ptr_maxdim) |
| 71 | + deallocate(message%real_ptr, message%real_ptr_maxdim) |
| 72 | + end if |
| 73 | + |
| 74 | + !! Verify correct broadcast of all non-pointer components (pointers become undefined on the receiving image). |
| 75 | + associate( failures => [ & |
| 76 | + message%parent%heritable /= content%parent%heritable, & |
| 77 | + message%a%subcomponent /= content%a%subcomponent, & |
| 78 | + message%c /= content%c, & |
| 79 | + message%z /= content%z, & |
| 80 | + message%i /= content%i, & |
| 81 | + message%j /= content%j, & |
| 82 | + message%k /= content%k, & |
| 83 | + message%l /= content%l, & |
| 84 | + message%r .neqv. content%r, & |
| 85 | + message%s .neqv. content%s, & |
| 86 | + message%t /= content%t, & |
| 87 | + any( message%u /= content%u ) & |
| 88 | + ] ) |
| 89 | + |
| 90 | + if ( any(failures) ) error stop "Test failed. " |
| 91 | + |
| 92 | + end associate |
| 93 | + |
| 94 | + sync all ! Wait for each image to pass the test |
| 95 | + if (me==sender) print *,"Test passed." |
| 96 | + |
| 97 | + end associate |
94 | 98 |
|
95 | 99 | end program main |
0 commit comments