Fortran Shape类结构（面向对象写法）

左志华（在读硕士）
哈尔滨工程大学 船舶工程学院
2020/10/20 星期二 晚 哈尔滨工程大学青岛科技园
ThinkPad E485 Windows 10 Home Edition；VS 2019；Intel Fortran 2020
欢迎留言 1325686572@qq.com

父类：Shape

module shape_class
    implicit none
    !> Abtract type
    type, public :: shape
        !> None
    contains
    procedure, public :: area => calc_area_fn
    procedure, public :: perimeter => calc_perimeter_fn
    procedure, public :: to_string => to_string_fn
    end type
    
    private :: calc_area_fn, calc_perimeter_fn, to_string_fn
    contains
    real function calc_area_fn(this)
    implicit none
    class(shape) :: this
    calc_area_fn = 0.0
    end function
    
    real function calc_perimeter_fn(this)
    implicit none
    class(shape) :: this
    calc_perimeter_fn = 0.0
    end function
    
    character(50) function to_string_fn(this)
    implicit none
    class(shape) :: this
    to_string_fn = ""
    end function
    
    end module

子类：Circle

module circle_class
    use shape_class
    implicit none
    type, public, extends(shape) :: circle
        real :: r = 0 !> Radius
    contains
    procedure, public :: inintialize => inintialize_sub
    procedure, public :: area => get_area_fn
    procedure, public :: perimeter => get_perimeter_fn
    procedure, public :: to_string => to_string_fn
    end type
    
    real, parameter :: PI = 3.1415926
    private :: inintialize_sub, get_area_fn, get_perimeter_fn
    contains
    subroutine inintialize_sub(this, r)
    implicit none
    class(circle) :: this
    real, intent(in) :: r
    this % r = r
    end subroutine
    
    real function get_area_fn(this)
    implicit none
    class(circle) :: this
    get_area_fn = PI * this % r**2
    end function
    
    real function get_perimeter_fn(this)
    implicit none
    class(circle) :: this
    get_perimeter_fn = 2.0 * PI * this % r
    end function
    
    character(50) function to_string_fn(this)
    implicit none
    class(circle) :: this
    write(to_string_fn, "(A,F6.2)") "Circle of radius", this % r
    end function
    
    end module

主程序：Console

program console
    use circle_class !> Import circle class
    implicit none
    type(circle), pointer :: cir !> Circle object
    integer :: i
    character(50) :: id_string
    integer :: istat
    type :: shape_ptr
        class(shape), pointer :: p
    end type
    
    type(shape_ptr),dimension(1) :: shapes
    allocate(cir, stat = istat)
    call cir % inintialize(2.0)
    !> Create the array of shape pointers
    shapes(1) % p => cir
    do i = 1, 1
        id_string = shapes(i) % p % to_string()
        write(6, "(/A)") id_string
        write(6, "(A, F8.4)") "Area = ", shapes(i) % p % area()
        write(6, "(A, F8.4)") "Perimeter = ", shapes(i) % p % perimeter()
    end do
    read(5, *)
    end program
    

运行结果

参考书目
[1] Stephen J. Chapman. Fortran 95/2003 程序设计. 第三版. 中国电力出版社. P671.