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