blob: 4a8e54ced6bf46847f56bf187e0241fe4ba5b3c4 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
!{ dg-do run }
! Check gimplify with checking works. [PR86468]
! This rather complicated code is needed to produce two "different"
! types in the move_alloc.
! Contributed by Juergen Reuter <juergen.reuter@desy.de>
module classes
implicit none
private
public :: wrapped_coarray
type :: wrapped_point
integer, allocatable :: point(:)
contains
procedure :: add => wrapped_point_add
end type wrapped_point
type :: wrapped_coarray
type(wrapped_point), allocatable :: caf(:)[:]
end type wrapped_coarray
contains
subroutine wrapped_point_add(self, to_add)
class(wrapped_point), intent(inout) :: self
integer, intent(in) :: to_add
integer, allocatable :: point(:)
integer :: points_number
if (allocated(self%point)) then
points_number = size(self%point, dim=1)
allocate(point(1:points_number+1))
point(1:points_number) = self%point
point(points_number+1) = to_add
call move_alloc(from=point, to=self%point)
else
allocate(self%point(1))
self%point(1) = to_add
end if
end subroutine wrapped_point_add
end module classes
program test
use classes
implicit none
type(wrapped_coarray) :: foo
allocate(foo%caf(99)[*])
call foo%caf(32)%add(this_image())
call foo%caf(32)%add(this_image())
if (any (foo%caf(32)%point /= [this_image(), this_image()])) stop 1
end program test
|
