3 ! Example in F2008 C.8.4 to demonstrate submodules
13 ! Interfaces for procedures with separate
14 ! bodies in the submodule color_points_a
15 module subroutine color_point_del ( p ) ! Destroy a color_point object
16 type(color_point), allocatable :: p
17 end subroutine color_point_del
18 ! Distance between two color_point objects
19 real module function color_point_dist ( a, b )
20 type(color_point), intent(in) :: a, b
21 end function color_point_dist
22 module subroutine color_point_draw ( p ) ! Draw a color_point object
23 type(color_point), intent(in) :: p
24 end subroutine color_point_draw
25 module subroutine color_point_new ( p ) ! Create a color_point object
26 type(color_point), allocatable :: p
27 end subroutine color_point_new
28 module subroutine verify_cleanup ( p1, p2 ) ! Check cleanup of color_point objects
29 type(color_point), allocatable :: p1, p2
30 end subroutine verify_cleanup
32 end module color_points
39 subroutine test_palette ( p )
40 ! Draw a color wheel using procedures from the color_points module
41 use color_points ! This does not cause a circular dependency because
42 ! the "use palette_stuff" that is logically within
43 ! color_points is in the color_points_a submodule.
44 type(palette), intent(in) :: p
45 end subroutine test_palette
46 end module palette_stuff
49 submodule ( color_points ) color_points_a ! Submodule of color_points
50 integer :: instance_count = 0
52 ! Interface for a procedure with a separate
53 ! body in submodule color_points_b
54 module subroutine inquire_palette ( pt, pal )
56 ! palette_stuff, especially submodules
57 ! thereof, can reference color_points by use
58 ! association without causing a circular
59 ! dependence during translation because this
60 ! use is not in the module. Furthermore,
61 ! changes in the module palette_stuff do not
62 ! affect the translation of color_points.
63 type(color_point), intent(in) :: pt
64 type(palette), intent(out) :: pal
65 end subroutine inquire_palette
68 ! Invisible bodies for public separate module procedures
69 ! declared in the module
70 module subroutine color_point_del ( p )
71 type(color_point), allocatable :: p
72 instance_count = instance_count - 1
74 end subroutine color_point_del
75 real module function color_point_dist ( a, b ) result ( dist )
76 type(color_point), intent(in) :: a, b
77 dist = sqrt( (b%x - a%x)**2 + (b%y - a%y)**2 )
78 end function color_point_dist
79 module subroutine color_point_new ( p )
80 type(color_point), allocatable :: p
81 instance_count = instance_count + 1
83 ! Added to example so that it does something.
84 p%x = real (instance_count) * 1.0
85 p%y = real (instance_count) * 2.0
86 p%color = instance_count
87 end subroutine color_point_new
88 end submodule color_points_a
91 submodule ( color_points:color_points_a ) color_points_b ! Subsidiary**2 submodule
94 ! Invisible body for interface declared in the ancestor module
95 module subroutine color_point_draw ( p )
96 use palette_stuff, only: palette
97 type(color_point), intent(in) :: p
98 type(palette) :: MyPalette
99 call inquire_palette ( p, MyPalette )
100 ! Added to example so that it does something.
101 if (abs (p%x - real (p%color) * 1.0) .gt. 1.0e-6) call abort
102 if (abs (p%y - real (p%color) * 2.0) .gt. 1.0e-6) call abort
103 end subroutine color_point_draw
104 ! Invisible body for interface declared in the parent submodule
105 module procedure inquire_palette
106 !... implementation of inquire_palette
107 end procedure inquire_palette
108 module procedure verify_cleanup
109 if (allocated (p1) .or. allocated (p2)) call abort
110 if (instance_count .ne. 0) call abort
112 subroutine private_stuff ! not accessible from color_points_a
114 end subroutine private_stuff
115 end submodule color_points_b
120 ! "instance_count" and "inquire_palette" are not accessible here
121 ! because they are not declared in the "color_points" module.
122 ! "color_points_a" and "color_points_b" cannot be referenced by
125 ! just to demonstrate it’s possible
126 module procedure color_point_draw
128 type(color_point), allocatable :: C_1, C_2
131 call color_point_new (c_1)
132 call color_point_new (c_2)
133 ! body in color_points_a, interface in color_points
136 ! body in color_points_b, specific interface
137 ! in color_points, generic interface here.
139 rc = color_point_dist (c_1, c_2) ! body in color_points_a, interface in color_points
140 if (abs (rc - 2.23606801) .gt. 1.0e-6) call abort
142 call color_point_del (c_1)
143 call color_point_del (c_2)
144 ! body in color_points_a, interface in color_points
145 call verify_cleanup (c_1, c_2)