summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/func_derived_4.f90
blob: 532d821deefbb3f089cf8b899df3b9ae69dc40ea (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
! { 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" } }