gcc/testsuite/gfortran.dg/allocate_with_source_13.f03

   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