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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
! { dg-do run }
!
! Example in F2008 C.8.4 to demonstrate submodules
!
module color_points
type color_point
private
real :: x, y
integer :: color
end type color_point
interface
! Interfaces for procedures with separate
! bodies in the submodule color_points_a
module subroutine color_point_del ( p ) ! Destroy a color_point object
type(color_point), allocatable :: p
end subroutine color_point_del
! Distance between two color_point objects
real module function color_point_dist ( a, b )
type(color_point), intent(in) :: a, b
end function color_point_dist
module subroutine color_point_draw ( p ) ! Draw a color_point object
type(color_point), intent(in) :: p
end subroutine color_point_draw
module subroutine color_point_new ( p ) ! Create a color_point object
type(color_point), allocatable :: p
end subroutine color_point_new
module subroutine verify_cleanup ( p1, p2 ) ! Check cleanup of color_point objects
type(color_point), allocatable :: p1, p2
end subroutine verify_cleanup
end interface
end module color_points
module palette_stuff
type :: palette ;
!...
end type palette
contains
subroutine test_palette ( p )
! Draw a color wheel using procedures from the color_points module
use color_points ! This does not cause a circular dependency because
! the "use palette_stuff" that is logically within
! color_points is in the color_points_a submodule.
type(palette), intent(in) :: p
end subroutine test_palette
end module palette_stuff
submodule ( color_points ) color_points_a ! Submodule of color_points
integer :: instance_count = 0
interface
! Interface for a procedure with a separate
! body in submodule color_points_b
module subroutine inquire_palette ( pt, pal )
use palette_stuff
! palette_stuff, especially submodules
! thereof, can reference color_points by use
! association without causing a circular
! dependence during translation because this
! use is not in the module. Furthermore,
! changes in the module palette_stuff do not
! affect the translation of color_points.
type(color_point), intent(in) :: pt
type(palette), intent(out) :: pal
end subroutine inquire_palette
end interface
contains
! Invisible bodies for public separate module procedures
! declared in the module
module subroutine color_point_del ( p )
type(color_point), allocatable :: p
instance_count = instance_count - 1
deallocate ( p )
end subroutine color_point_del
real module function color_point_dist ( a, b ) result ( dist )
type(color_point), intent(in) :: a, b
dist = sqrt( (b%x - a%x)**2 + (b%y - a%y)**2 )
end function color_point_dist
module subroutine color_point_new ( p )
type(color_point), allocatable :: p
instance_count = instance_count + 1
allocate ( p )
! Added to example so that it does something.
p%x = real (instance_count) * 1.0
p%y = real (instance_count) * 2.0
p%color = instance_count
end subroutine color_point_new
end submodule color_points_a
submodule ( color_points:color_points_a ) color_points_b ! Subsidiary**2 submodule
contains
! Invisible body for interface declared in the ancestor module
module subroutine color_point_draw ( p )
use palette_stuff, only: palette
type(color_point), intent(in) :: p
type(palette) :: MyPalette
call inquire_palette ( p, MyPalette )
! Added to example so that it does something.
if (abs (p%x - real (p%color) * 1.0) .gt. 1.0e-6) STOP 1
if (abs (p%y - real (p%color) * 2.0) .gt. 1.0e-6) STOP 2
end subroutine color_point_draw
! Invisible body for interface declared in the parent submodule
module procedure inquire_palette
!... implementation of inquire_palette
end procedure inquire_palette
module procedure verify_cleanup
if (allocated (p1) .or. allocated (p2)) STOP 3
if (instance_count .ne. 0) STOP 4
end procedure
subroutine private_stuff ! not accessible from color_points_a
!...
end subroutine private_stuff
end submodule color_points_b
program main
use color_points
! "instance_count" and "inquire_palette" are not accessible here
! because they are not declared in the "color_points" module.
! "color_points_a" and "color_points_b" cannot be referenced by
! use association.
interface draw
! just to demonstrate it’s possible
module procedure color_point_draw
end interface
type(color_point), allocatable :: C_1, C_2
real :: RC
!...
call color_point_new (c_1)
call color_point_new (c_2)
! body in color_points_a, interface in color_points
!...
call draw (c_1)
! body in color_points_b, specific interface
! in color_points, generic interface here.
!...
rc = color_point_dist (c_1, c_2) ! body in color_points_a, interface in color_points
if (abs (rc - 2.23606801) .gt. 1.0e-6) STOP 5
!...
call color_point_del (c_1)
call color_point_del (c_2)
! body in color_points_a, interface in color_points
call verify_cleanup (c_1, c_2)
!...
end program main
|
