2 ! { dg-options "-fdump-tree-original" }
4 ! Tests the fix for PR61830.
6 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
9 integer, parameter :: foo_dpk_ = kind(1.d0)
10 type foo_d_base_vect_type
11 real(foo_dpk_), allocatable :: v(:)
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
20 class(foo_d_base_vect_type), allocatable :: v
22 procedure :: free => d_vect_free
23 procedure :: get_vect => d_vect_get_vect
24 end type foo_d_vect_type
28 end type foo_desc_type
32 subroutine foo_cdall(map,nl)
33 type(foo_desc_type) :: map
34 integer, optional :: nl
41 end subroutine foo_cdall
44 subroutine foo_cdasb(map,info)
46 type(foo_desc_type) :: map
47 if (map%nl < 0) map%nl=1
48 end subroutine foo_cdasb
52 subroutine d_base_allocate(this,n)
53 class(foo_d_base_vect_type), intent(out) :: this
55 allocate(this%v(max(1,n)))
57 end subroutine d_base_allocate
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'
65 end subroutine d_base_free
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(:)
71 if (allocated(this%v)) then
76 end function d_base_get_vect
78 subroutine d_vect_free(this)
79 class(foo_d_vect_type) :: this
80 if (allocated(this%v)) then
82 write(0,*) 'Deallocate class() component'
85 end subroutine d_vect_free
87 function d_vect_get_vect(this) result(res)
88 class(foo_d_vect_type) :: this
89 real(foo_dpk_), allocatable :: res(:)
91 if (allocated(this%v)) then
92 res = this%v%get_vect()
96 end function d_vect_get_vect
98 subroutine foo_geall(v,map,info)
99 type(foo_d_vect_type), intent(out) :: v
100 type(foo_Desc_type) :: map
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
107 end module foo_base_mod
110 module foo_scalar_field_mod
115 type(foo_d_vect_type) :: f
116 type(foo_desc_type), pointer :: map => null()
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
129 subroutine initialize_map(NumMyElements)
130 integer :: NumMyElements, info
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
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(:)
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)
148 call foo_geall(this%f,this%map,info)
151 subroutine free(this)
152 class(scalar_field), intent(inout) :: this
157 end module foo_scalar_field_mod
159 module foo_vector_field_mod
161 use foo_scalar_field_mod
164 type(scalar_field) :: u(1)
165 end type vector_field
167 function new_vector_field() result(this)
168 type(vector_field) :: this
171 associate(sf=>this%u(i))
172 sf = new_scalar_field()
177 subroutine free_v_field(this)
178 class(vector_field), intent(inout) :: this
180 associate(vf=>this%u)
185 end subroutine free_v_field
187 end module foo_vector_field_mod
191 use foo_vector_field_mod
192 use foo_scalar_field_mod
194 type(vector_field) :: u
195 type(foo_d_vect_type) :: v
196 real(foo_dpk_), allocatable :: av(:)
197 integer :: iam, np, i,info
199 u = new_vector_field()
200 call foo_geall(v,map,info)
203 u = new_vector_field()
207 ! This gets rid of the "memory leak"
208 if (associated (u%u(1)%map)) deallocate (u%u(1)%map)
213 ! { dg-final { scan-tree-dump-times "__builtin_malloc" 22 "original" } }
214 ! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }