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