Fortran实现多态
2018-06-07 本文已影响0人
忆霜晨
前言
Fortran是世界上最早出现的计算机高级程序设计语言，主要用于科学与工程计算领域。Fortran的几个重要的版本是：
- FORTRAN 77，现在仍然可以看到很多使用该版本写的代码，比如Lapack里面的代码。
- Fortran 90，最重要的改进是引入了自由格式代码。
- Fortran 2003，该版本改进了衍生类型，支持面向对象编程。
Fortran语言的特点是比较严谨，语法和Matlab有相似之处。但是和Python、Java等高级语言相比，如果要使用其面向对象的特性，仍然有不少限制。
使用Fortran实现面向对象编程一个很重要的关键字就是 class，该关键字只能用于可分配数据项（allocatable）、指针（pointer）或者虚元。class 关键字和 type 关键字的不同之处在于，前者可以实现参数的动态绑定，即面向对象一个很重要的特性——多态。
以下代码实现了一个使用参数动态绑定的过程。抽象类 BaseSolver 包含了：抽象类 BaseTimeSolver、抽象类 BaseSpaceSolver，MySolver 是 BaseSolver 的子类，给 MySolver 传入的是 BaseTimeSolver 的子类 MyTimeSolver 和 BaseSpaceSolver 的子类 MySpaceSolver。
代码中涉及到了很多Fortran语言的关键字，一方面可以看出该语言确实十分严谨，另一方面也让人觉得较为繁琐。关于Fortran语言更多的知识可以参考后面列出的资料[1][2][3]，另外可以参考官方给出的语法规范。
（注：《Fortran95/2003程序设计(第3版)》这本书介绍了不少这部分的内容，书本上源码的个别地方有误需要注意。《Modern Fortran Explained》这部分内容讲解比较详细，推荐。《Modern Fortran: Style and Usage》这本书源码字体排版对阅读来说显得很不友好。）
一、主函数
输出结果
PROGRAM MAIN
use mod_MySolver
use mod_MyTimeSolver
use mod_MySpaceSolver
implicit none
type(MySolver), pointer :: me_solver
type(MyTimeSolver), pointer :: me_time_solver
type(MySpaceSolver), pointer :: me_space_solver
type(MyTimeSolver) :: test_time_solver
call test_time_solver % set_class_msg('Hello World!')
write(*, *) TRIM(ADJUSTL(test_time_solver % get_class_msg()))
write(*, *)
allocate( me_solver )
allocate( me_time_solver )
allocate( me_space_solver )
call me_time_solver % set_class_msg('time solver A')
call me_space_solver % set_class_msg('space solver B')
call me_solver % time_solver_init( me_time_solver )
call me_solver % space_solver_init( me_space_solver )
call me_solver % print_class_msg()
call me_solver % some_algorithm()
END PROGRAM
二、Time相关
2.1、Time抽象基类
module mod_BaseTimeSolver
!---------
! 抽象类 |
!---------
type, abstract, public :: BaseTimeSolver
contains
procedure(abs_set_class_msg), deferred :: set_class_msg
procedure(abs_get_class_msg), deferred :: get_class_msg
procedure(abs_time_algorithm), deferred :: time_algorithm
end type BaseTimeSolver
!=========
!-----------------------
! 定义抽象类方法的接口 |
!-----------------------
abstract interface
subroutine abs_set_class_msg( this, msg )
import BaseTimeSolver
implicit none
class(BaseTimeSolver), intent(inout) :: this
character(len=*), intent(in) :: msg
end subroutine abs_set_class_msg
function abs_get_class_msg( this ) result( msg )
import BaseTimeSolver
implicit none
class(BaseTimeSolver), intent(in) :: this
character(len=180) :: msg
end function abs_get_class_msg
subroutine abs_time_algorithm( this )
import BaseTimeSolver
implicit none
class(BaseTimeSolver), intent(inout) :: this
end subroutine abs_time_algorithm
end interface
end module
2.2、Time基类的一个实现
module mod_MyTimeSolver
use mod_BaseTimeSolver
implicit none
!---------------
! 继承自抽象类 |
!---------------
type, extends(BaseTimeSolver), public :: MyTimeSolver
character(len=180), private :: class_msg = ''
contains
procedure :: set_class_msg => m_set_class_msg
procedure :: get_class_msg => m_get_class_msg
procedure :: time_algorithm => m_time_algorithm
end type MyTimeSolver
!===============
private :: m_set_class_msg
private :: m_get_class_msg
private :: m_time_algorithm
contains
!-----------------------
! 继承类方法的具体实现 |
!-----------------------
subroutine m_set_class_msg( this, msg )
implicit none
class(MyTimeSolver), intent(inout) :: this
character(len=*), intent(in) :: msg
this % class_msg = msg
return
end subroutine m_set_class_msg
function m_get_class_msg( this ) result( msg )
implicit none
class(MyTimeSolver), intent(in) :: this
character(len=180) :: msg
msg = TRIM(ADJUSTL(this % class_msg))
return
end function m_get_class_msg
subroutine m_time_algorithm( this )
implicit none
class(MyTimeSolver), intent(inout) :: this
write(*, *) "... time algorithm ..."
return
end subroutine m_time_algorithm
end module
三、Space相关
3.1、Space抽象基类
module mod_BaseSpaceSolver
!---------
! 抽象类 |
!---------
type, abstract, public :: BaseSpaceSolver
contains
procedure(abs_set_class_msg), deferred :: set_class_msg
procedure(abs_get_class_msg), deferred :: get_class_msg
procedure(abs_space_algorithm), deferred :: space_algorithm
end type BaseSpaceSolver
!=========
!-----------------------
! 定义抽象类方法的接口 |
!-----------------------
abstract interface
subroutine abs_set_class_msg( this, msg )
import BaseSpaceSolver
implicit none
class(BaseSpaceSolver), intent(inout) :: this
character(len=*), intent(in) :: msg
end subroutine abs_set_class_msg
function abs_get_class_msg( this ) result( msg )
import BaseSpaceSolver
implicit none
class(BaseSpaceSolver), intent(in) :: this
character(len=180) :: msg
end function abs_get_class_msg
subroutine abs_space_algorithm( this )
import BaseSpaceSolver
implicit none
class(BaseSpaceSolver), intent(inout) :: this
end subroutine abs_space_algorithm
end interface
end module
3.2、Space基类的一个实现
module mod_MySpaceSolver
use mod_BaseSpaceSolver
implicit none
!---------------
! 继承自抽象类 |
!---------------
type, extends(BaseSpaceSolver), public :: MySpaceSolver
character(len=180), private :: class_msg = ''
contains
procedure :: set_class_msg => m_set_class_msg
procedure :: get_class_msg => m_get_class_msg
procedure :: space_algorithm => m_space_algorithm
end type MySpaceSolver
!===============
private :: m_set_class_msg
private :: m_get_class_msg
private :: m_space_algorithm
contains
!-----------------------
! 继承类方法的具体实现 |
!-----------------------
subroutine m_set_class_msg( this, msg )
implicit none
class(MySpaceSolver), intent(inout) :: this
character(len=*), intent(in) :: msg
this % class_msg = msg
return
end subroutine m_set_class_msg
function m_get_class_msg( this ) result( msg )
implicit none
class(MySpaceSolver), intent(in) :: this
character(len=180) :: msg
msg = TRIM(ADJUSTL(this % class_msg))
return
end function m_get_class_msg
subroutine m_space_algorithm( this )
implicit none
class(MySpaceSolver), intent(inout) :: this
write(*, *) "... space algorithm ..."
return
end subroutine m_space_algorithm
end module
四、Solver相关
4.1、Solver基类
module mod_BaseSolver
use mod_BaseSpaceSolver
use mod_BaseTimeSolver
implicit none
!---------
! 抽象类 |
!---------
type, abstract, public :: BaseSolver
contains
procedure(abs_time_solver_init), deferred :: time_solver_init
procedure(abs_space_solver_init), deferred :: space_solver_init
procedure(abs_print_class_msg), deferred :: print_class_msg
procedure(abs_some_algorithm), deferred :: some_algorithm
end type BaseSolver
!=========
!-----------------------
! 定义抽象类方法的接口 |
!-----------------------
abstract interface
subroutine abs_time_solver_init( this, time_solver )
import :: BaseSolver, BaseTimeSolver
implicit none
class(BaseSolver), intent(inout) :: this
class(BaseTimeSolver), target, intent(in) :: time_solver
end subroutine abs_time_solver_init
subroutine abs_space_solver_init( this, space_solver )
import :: BaseSolver, BaseSpaceSolver
implicit none
class(BaseSolver), intent(inout) :: this
class(BaseSpaceSolver), target, intent(in) :: space_solver
end subroutine abs_space_solver_init
subroutine abs_print_class_msg( this )
import :: BaseSolver
implicit none
class(BaseSolver), intent(inout) :: this
end subroutine abs_print_class_msg
subroutine abs_some_algorithm( this )
import :: BaseSolver
implicit none
class(BaseSolver), intent(inout) :: this
end subroutine abs_some_algorithm
end interface
end module
4.2、Solver类的一个实现
module mod_MySolver
use mod_BaseSolver
use mod_BaseSpaceSolver
use mod_BaseTimeSolver
implicit none
!---------------
! 继承自抽象类 |
!---------------
type, extends(BaseSolver), public :: MySolver
character(len=180), private :: class_msg = ''
class(BaseTimeSolver), pointer, private :: me_time_solver
class(BaseSpaceSolver), pointer, private :: me_space_solver
contains
procedure :: time_solver_init => m_time_solver_init
procedure :: space_solver_init => m_space_solver_init
procedure :: print_class_msg => m_print_class_msg
procedure :: some_algorithm => m_some_algorithm
end type MySolver
!===============
private :: m_time_solver_init
private :: m_space_solver_init
private :: m_print_class_msg
private :: m_some_algorithm
contains
!-----------------------
! 继承类方法的具体实现 |
!-----------------------
subroutine m_time_solver_init( this, time_solver )
implicit none
class(MySolver), intent(inout) :: this
class(BaseTimeSolver), target, intent(in) :: time_solver
this % me_time_solver => time_solver
return
end subroutine m_time_solver_init
subroutine m_space_solver_init( this, space_solver )
implicit none
class(MySolver), intent(inout) :: this
class(BaseSpaceSolver), target, intent(in) :: space_solver
this % me_space_solver => space_solver
return
end subroutine m_space_solver_init
subroutine m_print_class_msg( this )
implicit none
class(MySolver), intent(inout) :: this
this % class_msg = &
TRIM(ADJUSTL(this % me_time_solver % get_class_msg())) &
// ' + ' // &
TRIM(ADJUSTL(this % me_space_solver % get_class_msg()))
write(*, *) "CLASS Msg:"
write(*, *) TRIM(ADJUSTL(this % class_msg))
write(*, *)
return
end subroutine m_print_class_msg
subroutine m_some_algorithm( this )
implicit none
class(MySolver), intent(inout) :: this
write(*, *) "Some algorithm:"
call this % me_time_solver % time_algorithm()
call this % me_space_solver % space_algorithm()
write(*, *)
return
end subroutine m_some_algorithm
end module
