106 lines
2.5 KiB
Fortran
106 lines
2.5 KiB
Fortran
! { dg-do run }
|
|
! PR fortran/30793
|
|
! Check that pointer-returing functions
|
|
! work derived types.
|
|
!
|
|
! Contributed by Salvatore Filippone.
|
|
!
|
|
module class_mesh
|
|
type mesh
|
|
real(kind(1.d0)), allocatable :: area(:)
|
|
end type mesh
|
|
contains
|
|
subroutine create_mesh(msh)
|
|
type(mesh), intent(out) :: msh
|
|
allocate(msh%area(10))
|
|
return
|
|
end subroutine create_mesh
|
|
end module class_mesh
|
|
|
|
module class_field
|
|
use class_mesh
|
|
implicit none
|
|
private ! Default
|
|
public :: create_field, field
|
|
public :: msh_
|
|
|
|
type field
|
|
private
|
|
type(mesh), pointer :: msh => null()
|
|
integer :: isize(2)
|
|
end type field
|
|
|
|
interface msh_
|
|
module procedure msh_
|
|
end interface
|
|
interface create_field
|
|
module procedure create_field
|
|
end interface
|
|
contains
|
|
subroutine create_field(fld,msh)
|
|
type(field), intent(out) :: fld
|
|
type(mesh), intent(in), target :: msh
|
|
fld%msh => msh
|
|
fld%isize = 1
|
|
end subroutine create_field
|
|
|
|
function msh_(fld)
|
|
type(mesh), pointer :: msh_
|
|
type(field), intent(in) :: fld
|
|
msh_ => fld%msh
|
|
end function msh_
|
|
end module class_field
|
|
|
|
module class_scalar_field
|
|
use class_field
|
|
implicit none
|
|
private
|
|
public :: create_field, scalar_field
|
|
public :: msh_
|
|
|
|
type scalar_field
|
|
private
|
|
type(field) :: base
|
|
real(kind(1.d0)), allocatable :: x(:)
|
|
real(kind(1.d0)), allocatable :: bx(:)
|
|
real(kind(1.d0)), allocatable :: x_old(:)
|
|
end type scalar_field
|
|
|
|
interface create_field
|
|
module procedure create_scalar_field
|
|
end interface
|
|
interface msh_
|
|
module procedure get_scalar_field_msh
|
|
end interface
|
|
contains
|
|
subroutine create_scalar_field(fld,msh)
|
|
use class_mesh
|
|
type(scalar_field), intent(out) :: fld
|
|
type(mesh), intent(in), target :: msh
|
|
call create_field(fld%base,msh)
|
|
allocate(fld%x(10),fld%bx(20))
|
|
end subroutine create_scalar_field
|
|
|
|
function get_scalar_field_msh(fld)
|
|
use class_mesh
|
|
type(mesh), pointer :: get_scalar_field_msh
|
|
type(scalar_field), intent(in), target :: fld
|
|
|
|
get_scalar_field_msh => msh_(fld%base)
|
|
end function get_scalar_field_msh
|
|
end module class_scalar_field
|
|
|
|
program test_pnt
|
|
use class_mesh
|
|
use class_scalar_field
|
|
implicit none
|
|
type(mesh) :: msh
|
|
type(mesh), pointer :: mshp
|
|
type(scalar_field) :: quality
|
|
call create_mesh(msh)
|
|
call create_field(quality,msh)
|
|
mshp => msh_(quality)
|
|
end program test_pnt
|
|
|
|
! { dg-final { cleanup-modules "class_mesh class_field class_scalar_field" } }
|