module shape_module type shape_type integer, private :: x_ = 0 integer, private :: y_ = 0 contains procedure, pass(this) :: getx procedure, pass(this) :: gety procedure, pass(this) :: setx procedure, pass(this) :: sety procedure, pass(this) :: moveto procedure, pass(this) :: draw end type shape_type interface shape_type module procedure shape_type_constructor end interface contains type (shape_type) function shape_type_constructor(x,y) implicit none integer, intent (in) :: x integer, intent (in) :: y shape_type_constructor%x_ = x shape_type_constructor%y_ = y end function shape_type_constructor !include "shape_module_common_code.f90" !text for shape_module_common_code integer function getx(this) implicit none class (shape_type), intent (in) :: this getx = this%x_ end function getx integer function gety(this) implicit none class (shape_type), intent (in) :: this gety = this%y_ end function gety subroutine setx(this,x) implicit none class (shape_type), intent (inout) :: this integer, intent (in) :: x this%x_ = x end subroutine setx subroutine sety(this,y) implicit none class (shape_type), intent (inout) :: this integer, intent (in) :: y this%y_ = y end subroutine sety subroutine moveto(this,newx,newy) implicit none class (shape_type), intent (inout) :: this integer, intent (in) :: newx integer, intent (in) :: newy this%x_ = newx this%y_ = newy end subroutine moveto subroutine draw(this) implicit none class (shape_type), intent (in) :: this print *, ' x = ', this%x_ print *, ' y = ', this%y_ end subroutine draw !end of text for shape_module_common_code end module shape_module module circle_module use shape_module type, extends(shape_type) :: circle_type integer, private :: radius_ contains procedure, pass(this) :: getradius procedure, pass(this) :: setradius procedure, pass(this) :: draw => draw_circle end type circle_type interface circle_type module procedure circle_type_constructor end interface contains type (circle_type) function circle_type_constructor(x,y,radius) implicit none integer, intent (in) :: x integer, intent (in) :: y integer, intent (in) :: radius call circle_type_constructor%setx(x) call circle_type_constructor%sety(y) circle_type_constructor%radius_ = radius end function circle_type_constructor integer function getradius(this) implicit none class (circle_type), intent (in) :: this getradius = this%radius_ end function getradius subroutine setradius(this,radius) implicit none class (circle_type), intent (inout) :: this integer, intent (in) :: radius this%radius_ = radius end subroutine setradius subroutine draw_circle(this) implicit none class (circle_type), intent (in) :: this print *, ' x = ', this%getx() print *, ' y = ', this%gety() print *, ' radius = ', this%radius_ end subroutine draw_circle end module circle_module module rectangle_module use shape_module type, extends(shape_type) :: rectangle_type integer, private :: width_ integer, private :: height_ contains procedure, pass(this) :: getwidth procedure, pass(this) :: setwidth procedure, pass(this) :: getheight procedure, pass(this) :: setheight procedure, pass(this) :: draw => draw_rectangle end type rectangle_type interface rectangle_type module procedure rectangle_type_constructor end interface contains type (rectangle_type) function rectangle_type_constructor(x,y,width,height) implicit none integer, intent (in) :: x integer, intent (in) :: y integer, intent (in) :: width integer, intent (in) :: height call rectangle_type_constructor%setx(x) call rectangle_type_constructor%sety(y) rectangle_type_constructor%width_ = width rectangle_type_constructor%height_ = height end function rectangle_type_constructor integer function getwidth(this) implicit none class (rectangle_type), intent (in) :: this getwidth = this%width_ end function getwidth subroutine setwidth(this,width) implicit none class (rectangle_type), intent (inout) :: this integer, intent (in) :: width this%width_ = width end subroutine setwidth integer function getheight(this) implicit none class (rectangle_type), intent (in) :: this getheight = this%height_ end function getheight subroutine setheight(this,height) implicit none class (rectangle_type), intent (inout) :: this integer, intent (in) :: height this%height_ = height end subroutine setheight subroutine draw_rectangle(this) implicit none class (rectangle_type), intent (in) :: this print *, ' x = ', this%getx() print *, ' y = ', this%gety() print *, ' width = ', this%width_ print *, ' height = ', this%height_ end subroutine draw_rectangle end module rectangle_module program ch2604 use shape_module use circle_module use rectangle_module implicit none type (shape_type) :: vs type (circle_type) :: vc type (rectangle_type) :: vr vs = shape_type(10,20) vc = circle_type(100,200,300) vr = rectangle_type(1000,2000,3000,4000) print *, ' get ' print *, ' shape ', vs%getx(), ' ', vs%gety() print *, ' circle ', vc%getx(), ' ', vc%gety(), 'radius = ',vc%getradius() print *, ' rectangle ', vr%getx(), ' ', vr%gety(), 'width = ',vr%getwidth(),'height ',vr%getheight() print *, ' draw ' call vs%draw() call vc%draw() call vr%draw() print *, ' set ' call vs%setx(19) call vs%sety(19) call vc%setx(199) call vc%sety(199) call vc%setradius(199) call vr%setx(1999) call vr%sety(1999) call vr%setwidth(1999) call vr%setheight(1999) print *, ' draw ' call vs%draw() call vc%draw() call vr%draw() end program ch2604