Initial data commit

Task/Polymorphism/Fortran/polymorphism.f

@@ -0,0 +1,129 @@
+module geom
+
+  type point
+     real(8), private  :: x = 0
+     real(8), private  :: y = 0
+   contains
+     procedure, public :: get_x
+     procedure, public :: get_y
+     procedure, public :: set_x
+     procedure, public :: set_y
+     procedure, public :: print => print_point
+     procedure, pass :: copy_point
+     !overloaded assignment operator
+     generic, public :: assignment(=) => copy_point
+  end type point
+
+  type, extends(point) :: circle
+     real(8), private  :: r = 0
+   contains
+     procedure, public :: get_r
+     procedure, public :: set_r
+     procedure, public :: print => print_circle
+     procedure, pass :: copy_circle
+     !overloaded assignment operator
+     generic, public :: assignment(=) => copy_circle
+  end type circle
+
+  ! constructor interface
+  interface circle
+  module procedure circle_constructor
+  end interface circle
+  ! constructor interface
+  interface point
+  module procedure point_constructor
+  end interface point
+
+contains
+
+  real(8) function get_x(this)
+    class(point), intent(in) :: this
+    get_x = this%x
+  end function get_x
+
+  real(8) function get_y(this)
+    class(point), intent(in) :: this
+    get_y = this%y
+  end function get_y
+
+  subroutine set_x(this, val)
+    class(point), intent(inout) :: this
+    real(8), intent(in)         :: val
+    this%x = val
+  end subroutine set_x
+
+  subroutine set_y(this, val)
+    class(point), intent(inout) :: this
+    real(8), intent(in)         :: val
+    this%y = val
+  end subroutine set_y
+
+  subroutine print_point(this)
+    class(point), intent(in) :: this
+    write(*,'(2(a,f0.4),a)') 'Point(',this%x,', ',this%y,')'
+  end subroutine print_point
+
+  real(8) function get_r(this)
+    class(circle), intent(in) :: this
+    get_r = this%r
+  end function get_r
+
+  subroutine set_r(this, val)
+    class(circle), intent(inout) :: this
+    real(8), intent(in)          :: val
+    this%r = val
+  end subroutine set_r
+
+  subroutine print_circle(this)
+    class(circle), intent(in) :: this
+    write(*,'(3(a,f0.4),a)') 'Circle(',this%x,', ',this%y,'; ',this%r,')'
+  end subroutine print_circle
+
+  subroutine copy_point(this, rhs)
+      class(point), intent(inout) :: this
+      type(point), intent(in) :: rhs
+      this%x = rhs%x
+      this%y = rhs%y
+  end subroutine copy_point
+
+  subroutine copy_circle(this, rhs)
+      class(circle), intent(inout) :: this
+      type(circle), intent(in) :: rhs
+      this%x = rhs%x
+      this%y = rhs%y
+      this%r = rhs%r
+  end subroutine copy_circle
+
+! non-default constructor to init private components
+  type(point) function point_constructor(x,y)
+  real(8), intent(in) :: x,y
+  point_constructor%x = x
+  point_constructor%y = y
+  end function point_constructor
+! non-default constructor to init private components
+  type(circle) function circle_constructor(x,y,r)
+  real(8), intent(in) :: x,y,r
+  circle_constructor%x = x
+  circle_constructor%y = y
+  circle_constructor%r = r
+  end function circle_constructor
+
+end module geom
+
+program inh
+  use geom
+
+  type(point)  :: p, p_copy
+  type(circle) :: c, c_copy
+
+  p = point(2.0d0, 3.0d0)
+  call p%print
+  p_copy = p
+  call p_copy%print
+
+  c = circle(3.0d0, 4.0d0, 5.0d0)
+  call c%print
+  c_copy = c
+  call c_copy%print
+
+end program inh