My Project
mod_geometry.f90
Go to the documentation of this file.
1 ! classes_geom.f90 --
2 ! Classes of geometrical objects as an illustration
3 ! of object-oriented programming in Fortran
4 !
5 ! Example belonging to "Modern Fortran in Practice" by Arjen Markus
6 !
7 ! This work is licensed under the Creative Commons Attribution 3.0 Unported License.
8 ! To view a copy of this license, visit http://creativecommons.org/licenses/by/3.0/
9 ! or send a letter to:
10 ! Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.
11 
13 
14  implicit none
15 
16  !
17  ! General shape
18  !
19  type, abstract :: shape
20  ! No data
21  contains
22  procedure(get_shape_area), deferred :: get_area
23  !procedure :: size -- does not work
24  end type shape
25 
26  abstract interface
27  real function get_shape_area( this )
28  import :: shape
29  class(shape), intent(in) :: this
30  end function get_shape_area
31  end interface
32 
33  !
34  ! Rectangle
35  !
36  type, extends(shape) :: rectangle
37  real :: width, height
38  contains
39  procedure :: get_area => get_rectangle_area
40  procedure :: size => rectangle_size
41  end type rectangle
42 
43  !
44  ! Square
45  ! Note:
46  ! square_size must have the same interface as its rectangle parent!
47  !
48  type, extends(rectangle) :: square
49  contains
50  procedure :: get_area => get_square_area
51  procedure :: size => square_size
52  end type square
53 
54 contains
55 
56 !
57 ! The various routines and functions we need
58 !
59 real function get_rectangle_area( this )
60  class(rectangle), intent(in) :: this
61 
62  get_rectangle_area = this%width * this%height
63 
64 end function get_rectangle_area
65 
66 subroutine rectangle_size( this, width, height )
67  class(rectangle), intent(inout) :: this
68  real, intent(in) :: width
69  real, intent(in), optional :: height
70 
71  this%width = width
72  if ( present(height) ) then
73  this%height = height
74  else
75  this%height = width
76  endif
77 
78 end subroutine rectangle_size
79 
80 subroutine square_size( this, width, height )
81  class(square), intent(inout) :: this
82  real, intent(in) :: width
83  real, intent(in), optional :: height ! Ignored
84 
85  this%width = width
86  this%height = 0.0
87 
88 end subroutine square_size
89 
90 real function get_square_area( this )
91  class(square), intent(in) :: this
92 
93  get_square_area = this%width ** 2
94 
95 end function get_square_area
96 
97 end module geometrical_objects
real function get_rectangle_area(this)
subroutine square_size(this, width, height)
real function get_square_area(this)
subroutine rectangle_size(this, width, height)