1! { dg-do run }
2! PR fortran/30793
3! Check that pointer-returing functions
4! work derived types.
5!
6! Contributed by Salvatore Filippone.
7!
8module class_mesh
9  type mesh
10    real(kind(1.d0)), allocatable :: area(:)
11  end type mesh
12contains
13  subroutine create_mesh(msh)
14    type(mesh), intent(out) :: msh
15    allocate(msh%area(10))
16    return
17  end subroutine create_mesh
18end module class_mesh
19
20module class_field
21  use class_mesh
22  implicit none
23  private ! Default
24  public :: create_field, field
25  public :: msh_
26
27  type field
28     private
29     type(mesh),     pointer :: msh   => null()
30     integer                 :: isize(2)
31  end type field
32
33  interface msh_
34    module procedure msh_
35  end interface
36  interface create_field
37    module procedure create_field
38  end interface
39contains
40  subroutine create_field(fld,msh)
41    type(field),      intent(out)        :: fld
42    type(mesh),       intent(in), target :: msh
43    fld%msh => msh
44    fld%isize = 1
45  end subroutine create_field
46
47  function msh_(fld)
48    type(mesh), pointer :: msh_
49    type(field), intent(in) :: fld
50    msh_ => fld%msh
51  end function msh_
52end module class_field
53
54module class_scalar_field
55  use class_field
56  implicit none
57  private
58  public :: create_field, scalar_field
59  public :: msh_
60
61  type scalar_field
62    private
63    type(field) :: base
64    real(kind(1.d0)), allocatable :: x(:)
65    real(kind(1.d0)), allocatable :: bx(:)
66    real(kind(1.d0)), allocatable :: x_old(:)
67  end type scalar_field
68
69  interface create_field
70    module procedure create_scalar_field
71  end interface
72  interface msh_
73    module procedure get_scalar_field_msh
74  end interface
75contains
76  subroutine create_scalar_field(fld,msh)
77    use class_mesh
78    type(scalar_field), intent(out)          :: fld
79    type(mesh),         intent(in), target   :: msh
80    call create_field(fld%base,msh)
81    allocate(fld%x(10),fld%bx(20))
82  end subroutine create_scalar_field
83
84  function get_scalar_field_msh(fld)
85    use class_mesh
86    type(mesh), pointer :: get_scalar_field_msh
87    type(scalar_field), intent(in), target  :: fld
88
89    get_scalar_field_msh => msh_(fld%base)
90  end function get_scalar_field_msh
91end module class_scalar_field
92
93program test_pnt
94  use class_mesh
95  use class_scalar_field
96  implicit none
97  type(mesh) :: msh
98  type(mesh), pointer  :: mshp
99  type(scalar_field) :: quality
100  call create_mesh(msh)
101  call create_field(quality,msh)
102  mshp => msh_(quality)
103end program test_pnt
104