Skip to content

Commit b4dab08

Browse files
author
Damian Rouson
committed
Expand co_broadcast_derived_type test: add pointrs
1 parent 6d1671d commit b4dab08

File tree

1 file changed

+77
-38
lines changed

1 file changed

+77
-38
lines changed

‎src/tests/unit/collectives/co_broadcast_derived_type.f90

Lines changed: 77 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,12 @@ program main
77
integer, parameter :: sender=1 !! co_broadcast source_image
88
character(len=*), parameter :: text="text" !! character message data
99

10+
interface
11+
function f(x) result(y)
12+
real x, y
13+
end function
14+
end interface
15+
1016
associate(me=>this_image())
1117

1218
test_non_allocatable: block
@@ -19,23 +25,53 @@ program main
1925
end type
2026

2127
type, extends(parent) :: child
22-
type(component) a
28+
29+
! Scalar and array derived-type components
30+
type(component) a, b(1,2,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1)
31+
32+
! Scalar and array intrinsic-type components
2333
character(len=len(text)) :: c="", z(0)
2434
complex :: i=(0.,0.), j(1)=(0.,0.)
2535
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.
36+
logical :: r=.false., s(1,2,3, 1,2,3, 1,2,3, 1,2,3, 1,2,3)=.false.
37+
real :: t=0., u(3,2,1)=0.
38+
39+
! Scalar and array pointer components
40+
character(len=len(text)), pointer :: &
41+
char_ptr=>null(), char_ptr_maxdim(:,:,:, :,:,:, :,:,:, :,:,:, :,:,:)=>null()
42+
complex, pointer :: cplx_ptr=>null(), cplx_ptr_maxdim(:,:,:, :,:,:, :,:,:, :,:,:, :,:,:)=>null()
43+
integer, pointer :: int_ptr =>null(), int_ptr_maxdim (:,:,:, :,:,:, :,:,:, :,:,:, :,:,:)=>null()
44+
logical, pointer :: bool_ptr=>null(), bool_ptr_maxdim(:,:,:, :,:,:, :,:,:, :,:,:, :,:,:)=>null()
45+
real, pointer :: real_ptr=>null(), real_ptr_maxdim(:,:,:, :,:,:, :,:,:, :,:,:, :,:,:)=>null()
46+
procedure(f), pointer :: procedure_pointer=>null()
2847
end type
2948

3049
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. &
50+
type(child) :: content = child( & ! define content using the insrinsic structure constructor
51+
parent=parent(heritable=-4), & ! parent
52+
a=component(-3), b=reshape([component(-2),component(-1)], [1,2,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1]), & ! derived types
53+
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
3454
)
35-
if (me==sender) message = content
55+
if (me==sender) then
56+
message = content
57+
allocate(message%char_ptr, message%char_ptr_maxdim(1,1,2, 1,1,1, 1,1,1, 1,1,1, 1,1,1), source=text )
58+
allocate(message%cplx_ptr, message%cplx_ptr_maxdim(1,1,1, 1,1,2, 1,1,1, 1,1,1, 1,1,1), source=(0.,1.))
59+
allocate(message%int_ptr , message%int_ptr_maxdim (1,1,1, 1,1,1, 1,1,2, 1,1,1, 1,1,1), source=2 )
60+
allocate(message%bool_ptr, message%bool_ptr_maxdim(1,1,1, 1,2,1, 1,1,1, 1,1,2, 1,1,1), source=.true. )
61+
allocate(message%real_ptr, message%real_ptr_maxdim(1,1,1, 1,1,1, 1,1,1, 1,1,1, 1,1,2), source=3. )
62+
end if
3663

3764
call co_broadcast(message,source_image=sender)
3865

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).
3975
associate( failures => [ &
4076
message%parent%heritable /= content%parent%heritable, &
4177
message%a%subcomponent /= content%a%subcomponent, &
@@ -45,10 +81,10 @@ program main
4581
message%j /= content%j, &
4682
message%k /= content%k, &
4783
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 ) &
84+
message%r .neqv. content%r, &
85+
message%s .neqv. content%s, &
86+
message%t /= content%t, &
87+
any( message%u /= content%u ) &
5288
] )
5389

5490
if ( any(failures) ) error stop "Test failed in non-allocatable block."
@@ -57,40 +93,43 @@ program main
5793

5894
end block test_non_allocatable
5995

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
96+
test_allocatable: block
97+
type dynamic
98+
character(len=:), allocatable :: string
99+
character(len=len(text)), allocatable :: string_array(:)
100+
complex, allocatable :: scalar
101+
integer, allocatable :: vector(:)
102+
logical, allocatable :: matrix(:,:)
103+
real, allocatable :: superstring(:,:,:, :,:,:, :,:,:, :,:,:, :,:,: )
104+
end type
68105

69-
type(dynamic) alloc_message, alloc_content
106+
type(dynamic) alloc_message, alloc_content
70107

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-
)
108+
alloc_content = dynamic( &
109+
string=text, &
110+
string_array=[text], &
111+
scalar=(0.,1.), &
112+
vector=reshape( [integer::], [0]), &
113+
matrix=reshape( [.true.], [1,1]), &
114+
superstring=reshape([1,2,3,4], [2,1,2, 1,1,1, 1,1,1, 1,1,1, 1,1,1 ]) &
115+
)
78116

79-
if (me==sender) alloc_message = alloc_content
117+
if (me==sender) alloc_message = alloc_content
80118

81-
call co_broadcast(alloc_message,source_image=sender)
119+
call co_broadcast(alloc_message,source_image=sender)
82120

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-
] )
121+
associate( failures => [ &
122+
alloc_message%string /= alloc_content%string, &
123+
alloc_message%string_array /= alloc_content%string_array, &
124+
alloc_message%scalar /= alloc_content%scalar, &
125+
alloc_message%vector /= alloc_content%vector, &
126+
alloc_message%matrix .neqv. alloc_content%matrix, &
127+
alloc_message%superstring /= alloc_content%superstring &
128+
] )
90129

91-
if ( any(failures) ) error stop "Test failed in allocatable block."
130+
if ( any(failures) ) error stop "Test failed in allocatable block."
92131

93-
end associate
132+
end associate
94133

95134
end block test_allocatable
96135

0 commit comments

Comments
 (0)