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