1! { dg-do compile }
2!
3! Tests the fix for PR61819.
4!
5! Contributed by Salvatore Filippone  <sfilippone@uniroma2.it>
6!
7module foo_base_mod
8  integer, parameter :: foo_ipk_ = kind(1)
9  integer, parameter :: foo_dpk_ = kind(1.d0)
10  type foo_d_base_vect_type
11    real(foo_dpk_), allocatable :: v(:)
12  contains
13    procedure :: free     => d_base_free
14    procedure :: get_vect => d_base_get_vect
15    procedure :: allocate => d_base_allocate
16  end type foo_d_base_vect_type
17
18
19  type foo_d_vect_type
20    class(foo_d_base_vect_type), allocatable :: v
21  contains
22    procedure :: free     => d_vect_free
23    procedure :: get_vect => d_vect_get_vect
24  end type foo_d_vect_type
25
26  type foo_desc_type
27    integer(foo_ipk_) :: nl=-1
28  end type foo_desc_type
29
30
31contains
32
33  subroutine foo_init(ictxt)
34    integer :: ictxt
35  end subroutine foo_init
36
37
38  subroutine foo_exit(ictxt)
39    integer :: ictxt
40  end subroutine foo_exit
41
42  subroutine foo_info(ictxt,iam,np)
43    integer(foo_ipk_) :: ictxt,iam,np
44    iam = 0
45    np = 1
46  end subroutine foo_info
47
48  subroutine  foo_cdall(ictxt,map,info,nl)
49    integer(foo_ipk_) :: ictxt, info
50    type(foo_desc_type) :: map
51    integer(foo_ipk_), optional  :: nl
52
53    if (present(nl)) then
54      map%nl = nl
55    else
56      map%nl = 1
57    end if
58  end subroutine foo_cdall
59
60  subroutine  foo_cdasb(map,info)
61    integer(foo_ipk_) :: info
62    type(foo_desc_type) :: map
63    if (map%nl < 0) map%nl=1
64  end subroutine foo_cdasb
65
66
67  subroutine d_base_allocate(this,n)
68    class(foo_d_base_vect_type), intent(out) :: this
69
70    allocate(this%v(max(1,n)))
71
72  end subroutine d_base_allocate
73
74  subroutine d_base_free(this)
75    class(foo_d_base_vect_type), intent(inout) :: this
76    if (allocated(this%v)) &
77         & deallocate(this%v)
78  end subroutine d_base_free
79
80  function d_base_get_vect(this) result(res)
81    class(foo_d_base_vect_type), intent(inout) :: this
82    real(foo_dpk_), allocatable :: res(:)
83
84    if (allocated(this%v)) then
85      res = this%v
86    else
87      allocate(res(1))
88    end if
89  end function d_base_get_vect
90
91  subroutine d_vect_free(this)
92    class(foo_d_vect_type) :: this
93    if (allocated(this%v)) then
94      call this%v%free()
95      deallocate(this%v)
96    end if
97  end subroutine d_vect_free
98
99  function d_vect_get_vect(this) result(res)
100    class(foo_d_vect_type) :: this
101    real(foo_dpk_), allocatable :: res(:)
102
103    if (allocated(this%v)) then
104      res = this%v%get_vect()
105    else
106      allocate(res(1))
107    end if
108  end function d_vect_get_vect
109
110  subroutine foo_geall(v,map,info)
111    type(foo_d_vect_type), intent(out) :: v
112    type(foo_Desc_type) :: map
113    integer(foo_ipk_) :: info
114
115    allocate(foo_d_base_vect_type :: v%v,stat=info)
116    if (info == 0) call v%v%allocate(map%nl)
117  end subroutine foo_geall
118
119end module foo_base_mod
120
121
122module foo_scalar_field_mod
123  use foo_base_mod
124  implicit none
125
126  type scalar_field
127    type(foo_d_vect_type)        :: f
128    type(foo_desc_type), pointer :: map => null()
129  contains
130    procedure :: free
131  end type
132
133  integer(foo_ipk_), parameter :: nx=4,ny=nx, nz=nx
134  type(foo_desc_type), allocatable, save, target :: map
135  integer(foo_ipk_) ,save :: NumMy_xy_planes
136  integer(foo_ipk_) ,parameter :: NumGlobalElements = nx*ny*nz
137  integer(foo_ipk_) ,parameter :: NumGlobal_xy_planes = nz, Num_xy_points_per_plane = nx*ny
138
139contains
140  subroutine initialize_map(ictxt,NumMyElements,info)
141    integer(foo_ipk_) :: ictxt, NumMyElements, info
142    info = 0
143    if (allocated(map)) deallocate(map,stat=info)
144    if (info == 0) allocate(map,stat=info)
145    if (info == 0) call foo_cdall(ictxt,map,info,nl=NumMyElements)
146    if (info == 0) call foo_cdasb(map,info)
147  end subroutine initialize_map
148
149  function new_scalar_field(comm) result(this)
150    type(scalar_field)                          :: this
151    integer(foo_ipk_)              ,intent(in) :: comm
152    real(foo_dpk_) ,allocatable   :: f_v(:)
153    integer(foo_ipk_) :: i,j,k,NumMyElements, iam, np, info,ip
154    integer(foo_ipk_), allocatable :: idxs(:)
155    call foo_info(comm,iam,np)
156    NumMy_xy_planes = NumGlobal_xy_planes/np
157    NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane
158    if (.not. allocated(map)) call initialize_map(comm,NumMyElements,info)
159    this%map => map
160    call foo_geall(this%f,this%map,info)
161  end function
162
163  subroutine free(this)
164    class(scalar_field), intent(inout) :: this
165    integer(foo_ipk_) ::info
166    write(0,*) 'Freeing scalar_this%f'
167    call this%f%free()
168  end subroutine free
169
170end module foo_scalar_field_mod
171
172module foo_vector_field_mod
173  use foo_base_mod
174  use foo_scalar_field_mod, only : scalar_field,new_scalar_field
175  implicit none
176  type vector_field
177    type(scalar_field) :: u(1)
178  contains
179    procedure :: free
180  end type
181contains
182  function new_vector_field(comm_in) result(this)
183    type(vector_field) :: this
184    integer(foo_ipk_), intent(in) :: comm_in
185    this%u = [new_scalar_field(comm_in)] ! Removing this line eliminates the memory leak
186  end function
187
188  subroutine free(this)
189    class(vector_field), intent(inout) :: this
190    integer :: i
191    associate(vf=>this%u)
192      do i=1, size(vf)
193        write(0,*) 'Freeing vector_this%u(',i,')'
194        call vf(i)%free()
195      end do
196    end associate
197  end subroutine free
198
199end module foo_vector_field_mod
200
201program main
202  use foo_base_mod
203  use foo_vector_field_mod,only: vector_field,new_vector_field
204  use foo_scalar_field_mod,only: map
205  implicit none
206  type(vector_field) :: u
207  type(foo_d_vect_type) :: v
208  real(foo_dpk_), allocatable :: av(:)
209  integer(foo_ipk_) :: ictxt, iam, np, i,info
210  call foo_init(ictxt)
211  call foo_info(ictxt,iam,np)
212  u = new_vector_field(ictxt)
213  call u%free()
214  do i=1,10
215    u = new_vector_field(ictxt)
216    call u%free()
217  end do
218  call u%free()
219  call foo_exit(ictxt)
220end program
221