func_derived_4.f90

来自「用于进行gcc测试」· F90 代码 · 共 106 行

! { 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" } }