|
111
|
1 ! { dg-do compile }
|
|
|
2 !
|
|
|
3 ! Tests the fix for PR61819.
|
|
|
4 !
|
|
|
5 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
|
|
|
6 !
|
|
|
7 module 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
|
|
|
31 contains
|
|
|
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
|
|
|
119 end module foo_base_mod
|
|
|
120
|
|
|
121
|
|
|
122 module 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
|
|
|
139 contains
|
|
|
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
|
|
|
170 end module foo_scalar_field_mod
|
|
|
171
|
|
|
172 module 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
|
|
|
181 contains
|
|
|
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
|
|
|
199 end module foo_vector_field_mod
|
|
|
200
|
|
|
201 program 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)
|
|
|
220 end program
|
