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