@@ -13,83 +13,83 @@ function f(x) result(y)
13
13
end function
14
14
end interface
15
15
16
- type parent
17
- integer :: heritable= 0
18
- end type
19
-
20
- type component
21
- integer :: subcomponent= 0
22
- end type
23
-
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 ,1 ,1 , 1 ,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 ,2 ,3 , 1 ,2 ,3 , 1 ,2 ,3 )= .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 ,1 ,1 , 1 ,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
- )
16
+ type parent
17
+ integer :: heritable= 0
18
+ end type
19
+
20
+ type component
21
+ integer :: subcomponent= 0
22
+ end type
23
+
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 ,1 ,1 , 1 ,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 ,2 ,3 , 1 ,2 ,3 , 1 ,2 ,3 )= .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 ,1 ,1 , 1 ,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
52
53
53
associate(me= >this_image())
54
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 ,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
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
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
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
93
94
94
sync all ! Wait for each image to pass the test
95
95
if (me== sender) print * ," Test passed."
0 commit comments