729 lines
30 KiB
Fortran
729 lines
30 KiB
Fortran
! ==============================================================================
|
|
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
|
|
! 程序名：
|
|
! 第16章习题
|
|
! 目的:
|
|
!
|
|
! 修订记录:
|
|
! 日期 编程者 改动描述
|
|
! =================== ============= =====================================
|
|
! 2021-06-07 21:12:49 Sola 习题16-1 跳过
|
|
! 2021-06-07 21:13:08 Sola 习题16-2 改进本章创建的date类
|
|
! 2021-06-08 00:33:44 Sola 习题16-3 薪资计算
|
|
! 2021-06-08 15:27:53 Sola 习题16-4 通用多边形
|
|
! 2021-06-08 23:01:22 Sola 习题16-5 多维矢量运算
|
|
! 程序结构:
|
|
!
|
|
! ==============================================================================
|
|
! 主程序：
|
|
program Chapter16
|
|
implicit none
|
|
! call Exercises16_2
|
|
! call Exercises16_3
|
|
! call Exercises16_4
|
|
call Exercises16_5
|
|
end program Chapter16
|
|
! 习题16-2 改进本章创建的date类
|
|
module ModDateClass
|
|
implicit none
|
|
private ! 隐藏变量
|
|
type, public :: date ! 定义日期类
|
|
private
|
|
integer :: year = 1900 ! 年份, 默认1900
|
|
integer :: month = 1 ! 月份, 默认1月
|
|
integer :: day = 1 ! 日期, 默认1日
|
|
contains
|
|
procedure, public :: set_date => set_date_sub ! 设置年月日
|
|
procedure, public :: get_day => get_day_fn ! 获得日期
|
|
procedure, public :: get_month => get_month_fn ! 获得月份
|
|
procedure, public :: get_year => get_year_fn ! 获得年份
|
|
procedure, public :: is_leap_year => is_leap_year_fn ! 是否是闰年
|
|
procedure, public :: is_equal => is_equal_fn ! 年份是否相等
|
|
procedure, public :: is_earlier_than => is_earlier_fn ! 输入日期对象是否早于当前日期
|
|
procedure, public :: is_later_than => is_later_fn ! 输入日期对象是否晚于当前日期
|
|
procedure, public :: to_string => to_string_fn ! 输出当前日期的字符串形式
|
|
procedure, public :: day_of_year => day_of_year_fn ! 判断该日期是对应年份的第几天
|
|
procedure, public :: days_between => days_between_fn ! 计算两个日期之间的间隔天数
|
|
end type date
|
|
contains
|
|
subroutine set_date_sub(this, day, month, year) ! 设置日期
|
|
implicit none
|
|
class(date) :: this ! 返回自身
|
|
integer, intent(in) :: day ! 日期
|
|
integer, intent(in) :: month ! 月份
|
|
integer, intent(in) :: year ! 年份
|
|
this%day = day ! 给日期赋值, 下同
|
|
this%month = month
|
|
this%year = year
|
|
end subroutine set_date_sub
|
|
! 获得日期
|
|
integer function get_day_fn(this)
|
|
implicit none
|
|
class(date) :: this
|
|
get_day_fn = this%day
|
|
end function get_day_fn
|
|
! 获得月份
|
|
integer function get_month_fn(this)
|
|
implicit none
|
|
class(date) :: this
|
|
get_month_fn = this%month
|
|
end function get_month_fn
|
|
! 获得年份
|
|
integer function get_year_fn(this)
|
|
implicit none
|
|
class(date) :: this
|
|
get_year_fn = this%year
|
|
end function get_year_fn
|
|
! 判断是否是闰年
|
|
logical function is_leap_year_fn(this)
|
|
implicit none
|
|
class(date) :: this ! 输入自身
|
|
if ( mod(this%year, 400) == 0 ) then
|
|
is_leap_year_fn = .TRUE. ! 如果可以被400整除, 则是闰年
|
|
else if ( mod(this%year, 100) == 0 ) then
|
|
is_leap_year_fn = .FALSE. ! 如果不可以被400整除, 但可以被100整除, 则不是闰年
|
|
else if ( mod(this%year, 4) == 0 ) then
|
|
is_leap_year_fn = .TRUE. ! 如果不可以被100整除, 但是可以被4整除, 则是闰年
|
|
else
|
|
is_leap_year_fn = .FALSE. ! 如果不可以被4整除, 则不是闰年
|
|
end if
|
|
end function is_leap_year_fn
|
|
! 判断两个日期是否相同
|
|
logical function is_equal_fn(this, that)
|
|
implicit none
|
|
class(date) :: this
|
|
class(date) :: that
|
|
if ( (this%year == that%year) .and. (this%month == that%month) .and. (this%day == that%day) ) then
|
|
is_equal_fn = .TRUE.
|
|
else
|
|
is_equal_fn = .FALSE.
|
|
end if
|
|
end function is_equal_fn
|
|
! 判断输入日期是否较早
|
|
logical function is_earlier_fn(this, that)
|
|
implicit none
|
|
class(date) :: this
|
|
class(date) :: that
|
|
if ( that%year > this%year ) then
|
|
is_earlier_fn = .FALSE. ! 如果输入日期年份更大, 则输入日期更晚
|
|
else if ( that%year < this%year ) then
|
|
is_earlier_fn = .TRUE. ! 如果输入日期年份更小, 则输入日期更早
|
|
else
|
|
if ( that%month > this%month ) then
|
|
is_earlier_fn = .FALSE. ! 如果年份相同, 而输入日期月份更大, 则输入日期更晚
|
|
else if ( that%month < this%month ) then
|
|
is_earlier_fn = .TRUE. ! 如果年份相同, 而输入日期月份更小, 则输入日期更早
|
|
else
|
|
if ( that%day >= this%day ) then
|
|
is_earlier_fn = .FALSE. ! 如果年月相同, 而输入日期更大, 则其更晚
|
|
else
|
|
is_earlier_fn = .TRUE. ! 如果年月相同, 而输入日期更小, 则其更早
|
|
end if
|
|
end if
|
|
end if
|
|
end function is_earlier_fn
|
|
! 判断输入日期是否较晚, 逻辑同上相反, 注释略
|
|
logical function is_later_fn(this, that)
|
|
implicit none
|
|
class(date) :: this
|
|
class(date) :: that
|
|
if ( that%year > this%year ) then
|
|
is_later_fn = .TRUE.
|
|
else if ( that%year < this%year ) then
|
|
is_later_fn = .FALSE.
|
|
else
|
|
if ( that%month > this%month ) then
|
|
is_later_fn = .TRUE.
|
|
else if ( that%month < this%month ) then
|
|
is_later_fn = .FALSE.
|
|
else
|
|
if ( that%day >= this%day ) then
|
|
is_later_fn = .TRUE.
|
|
else
|
|
is_later_fn = .FALSE.
|
|
end if
|
|
end if
|
|
end if
|
|
end function is_later_fn
|
|
! 输入当前日期的字符串
|
|
character(len=10) function to_string_fn(this)
|
|
implicit none
|
|
class(date) :: this
|
|
character(len=2) :: dd
|
|
character(len=2) :: mm
|
|
character(len=4) :: yy
|
|
integer :: i
|
|
write(dd, '(I2.2)') this%day ! 读入日期
|
|
write(mm, '(I2.2)') this%month ! 读入月份
|
|
write(yy, '(I4.4)') this%year ! 读入年份
|
|
to_string_fn = mm//'/'//dd//'/'//yy ! 输出字符串
|
|
! do i = 1, len(to_string_fn)
|
|
! if ( iachar(to_string_fn(i: i)) == 32 ) then
|
|
! to_string_fn(i: i) = '0' ! 如果有空格, 则替换为0
|
|
! end if
|
|
! end do
|
|
end function to_string_fn
|
|
! 计算日期是当前年份的第几天
|
|
integer function day_of_year_fn(this)
|
|
implicit none
|
|
class(date) :: this
|
|
integer, dimension(12) :: daysOfMonth ! 用来保存十二个月份的天数
|
|
if ( this%month > 1 ) then ! 如果输入日期不是1月份的
|
|
daysOfMonth((/1,3,5,7,8,10,12/)) = 31 ! 大月
|
|
daysOfMonth((/4,6,9,11/)) = 30 ! 小月
|
|
if ( this%is_leap_year() ) then ! 判断是否闰年
|
|
daysOfMonth(2) = 29 ! 闰年二月
|
|
else
|
|
daysOfMonth(2) = 28 ! 非闰年二月
|
|
end if
|
|
day_of_year_fn = sum(daysOfMonth(1: this%month)) + this%day ! 计算天数
|
|
else
|
|
day_of_year_fn = this%day ! 如果是1月, 直接计算天数
|
|
end if
|
|
end function day_of_year_fn
|
|
! 计算两个日期之间相隔天数
|
|
integer function days_between_fn(this, that)
|
|
class(date) :: this
|
|
class(date) :: that
|
|
integer :: year_days ! 对应年份天数
|
|
integer :: step ! 步长
|
|
integer :: i ! 循环参数
|
|
if ( this%is_earlier_than(that) ) then ! 如果输入年份更早
|
|
step = -1 ! 步长为-1
|
|
else
|
|
step = 1 ! 否则, 步长为1
|
|
end if
|
|
days_between_fn = 0 ! 初始化间隔
|
|
if ( this%year /= that%year ) then ! 如果非同年
|
|
do i = this%year, that%year, step ! 对两个年份之间的每一年份循环
|
|
if ( i == that%year ) exit ! 如果到达最后一个循环, 则退出(不计算最后一个年份的天数)
|
|
if ( mod(i, 400) == 0 ) then ! 判断是否是闰年, 并赋值
|
|
year_days = 366
|
|
else if ( mod(i, 100) == 0 ) then
|
|
year_days = 365
|
|
else if ( mod(i, 4) == 0 ) then
|
|
year_days = 366
|
|
else
|
|
year_days = 365
|
|
end if
|
|
days_between_fn = days_between_fn + year_days*step ! 间隔天数增加当前年份天数*步长
|
|
end do
|
|
end if
|
|
days_between_fn = days_between_fn + that%day_of_year() - this%day_of_year() ! 计算总天数
|
|
end function days_between_fn
|
|
end module ModDateClass
|
|
subroutine Exercises16_2
|
|
use ModDateClass
|
|
implicit none
|
|
type(date) :: date1
|
|
type(date) :: date2
|
|
type(date) :: date3
|
|
integer :: yy, mm, dd
|
|
integer :: errorLevel
|
|
do
|
|
write(*, '(A)', advance='no') 'Please enter the date1 like YYYY MM DD: '
|
|
read(*, *, iostat=errorLevel) yy, mm, dd
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, *) 'Wrong input, please try again.'
|
|
else
|
|
exit
|
|
end if
|
|
end do
|
|
call date1%set_date(dd, mm, yy)
|
|
do
|
|
write(*, '(A)', advance='no') 'Please enter the date2 like YYYY MM DD: '
|
|
read(*, *, iostat=errorLevel) yy, mm, dd
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, *) 'Wrong input, please try again.'
|
|
else
|
|
exit
|
|
end if
|
|
end do
|
|
call date2%set_date(dd, mm, yy)
|
|
call date3%set_date(1, 1, 1900)
|
|
write(*, 1) date1%to_string(), date1%day_of_year()
|
|
1 format('---- ', A, ' is the ', I3, ' days in this year.')
|
|
write(*, 2) date1%to_string(), date3%days_between(date1)
|
|
2 format('From 01/01/1900 to ', A, ' has ', I6, ' days.')
|
|
write(*, 3) date1%to_string(), date2%to_string(), date1%days_between(date2)
|
|
3 format('From ', A, ' to ', A, ' has ', I6, ' days.')
|
|
end subroutine Exercises16_2
|
|
! empolyee_class
|
|
module ModEmployeeClass
|
|
implicit none
|
|
! private
|
|
type, public :: employee
|
|
character(len=30) :: firstName ! 名
|
|
character(len=30) :: lastName ! 姓
|
|
character(len=11) :: ssn ! 工作号
|
|
real :: pay = 0 ! 薪资
|
|
contains
|
|
procedure, public :: SetEmployee => SetEmployeeSub ! 设置信息
|
|
procedure, public :: SetName => SetNameSub ! 设置名称
|
|
procedure, public :: SetSsn => SetSsnSub ! 设置工作号
|
|
procedure, public :: GetFirstName => GetFirstNameFn ! 获得名
|
|
procedure, public :: GetLastName => GetLastNameFn ! 获得姓
|
|
procedure, public :: GetSsn => GetSsnFn ! 获得工作号
|
|
! procedure(CalcPay), public, deferred :: CalcPay ! 好像用不了抽象类
|
|
procedure, public :: CalcPay => CalcPayFn ! 计算薪资
|
|
end type employee
|
|
! abstract interface
|
|
! real function CalcPay(this, hours)
|
|
! implicit none
|
|
! class(employee) :: this
|
|
! real, intent(in) :: hours
|
|
! end function CalcPay
|
|
! end interface
|
|
private :: SetEmployeeSub, SetNameSub, SetSsnSub
|
|
private :: GetFirstNameFn, GetLastNameFn, GetSsnFn, CalcPayFn
|
|
contains
|
|
subroutine SetEmployeeSub(this, first, last, ssn)
|
|
implicit none
|
|
class(employee) :: this
|
|
character(len=*) :: first
|
|
character(len=*) :: last
|
|
character(len=*) :: ssn
|
|
this%firstName = first
|
|
this%lastName = last
|
|
this%ssn = ssn
|
|
this%pay = 0
|
|
end subroutine SetEmployeeSub
|
|
subroutine SetNameSub(this, first, last)
|
|
implicit none
|
|
class(employee) :: this
|
|
character(len=*), intent(in) :: first
|
|
character(len=*), intent(in) :: last
|
|
this%firstName = first
|
|
this%lastName = last
|
|
end subroutine SetNameSub
|
|
subroutine SetSsnSub(this, ssn)
|
|
implicit none
|
|
class(employee) :: this
|
|
character(len=*), intent(in) :: ssn
|
|
this%ssn = ssn
|
|
end subroutine SetSsnSub
|
|
character(len=30) function GetFirstNameFn(this)
|
|
implicit none
|
|
class(employee) :: this
|
|
GetFirstNameFn = this%firstName
|
|
end function GetFirstNameFn
|
|
character(len=30) function GetLastNameFn(this)
|
|
implicit none
|
|
class(employee) :: this
|
|
GetLastNameFn = this%lastName
|
|
end function GetLastNameFn
|
|
character(len=11) function GetSsnFn(this)
|
|
implicit none
|
|
class(employee) :: this
|
|
GetSsnFn = this%ssn
|
|
end function GetSsnFn
|
|
real function CalcPayFn(this, hours) ! 空函数, 用来重载用
|
|
implicit none
|
|
class(employee) :: this
|
|
real, intent(in) :: hours
|
|
end function CalcPayFn
|
|
end module ModEmployeeClass
|
|
! salaried_employee_class
|
|
module ModSalariedEmployeeClass
|
|
use ModEmployeeClass
|
|
implicit none
|
|
type, public, extends(employee) :: salariedEmployee ! 扩展类, 有固定底薪
|
|
private
|
|
real :: salary = 0 ! 底薪
|
|
contains
|
|
procedure, public :: SetSalary => SetSalarySub
|
|
procedure, public :: CalcPay => CalcPayFn
|
|
end type salariedEmployee
|
|
private :: CalcPayFn, SetSalarySub
|
|
contains
|
|
subroutine SetSalarySub(this, salary)
|
|
implicit none
|
|
class(salariedEmployee) :: this
|
|
real, intent(in) :: salary
|
|
this%pay = salary
|
|
this%salary = salary
|
|
end subroutine SetSalarySub
|
|
real function CalcPayFn(this, hours)
|
|
implicit none
|
|
class(salariedEmployee) :: this
|
|
real, intent(in) :: hours
|
|
CalcPayFn = this%salary ! 工资 = 底薪
|
|
end function CalcPayFn
|
|
end module ModSalariedEmployeeClass
|
|
! hourly_employee_class
|
|
module ModHourlyEmployeeClass
|
|
use ModEmployeeClass
|
|
implicit none
|
|
type, public, extends(employee) :: hourlyEmployee ! 扩展类, 小时工
|
|
private
|
|
real :: rate = 0 ! 每小时薪资
|
|
contains
|
|
procedure, public :: SetPayRate => SetPayRateSub
|
|
procedure, public :: CalcPay => CalcPayFn
|
|
end type hourlyEmployee
|
|
private :: CalcPayFn, SetPayRateSub
|
|
contains
|
|
subroutine SetPayRateSub(this, rate)
|
|
implicit none
|
|
class(hourlyEmployee) :: this
|
|
real, intent(in) :: rate
|
|
this%rate = rate
|
|
end subroutine SetPayRateSub
|
|
real function CalcPayFn(this, hours)
|
|
implicit none
|
|
class(hourlyEmployee) :: this
|
|
real, intent(in) :: hours
|
|
this%pay = hours*this%rate
|
|
CalcPayFn = this%pay
|
|
end function CalcPayFn
|
|
end module ModHourlyEmployeeClass
|
|
! salary_plus_employee
|
|
module ModSalaryPlusEmployeeClass
|
|
use ModEmployeeClass
|
|
implicit none
|
|
type, public, extends(employee) :: salaryPlusEmployee ! 扩展类, 有底薪, 有加班费
|
|
private
|
|
real :: salary = 0 ! 底薪
|
|
real :: rate = 0 ! 加班小时薪资
|
|
contains
|
|
procedure, public :: SetSalary => SetSalarySub
|
|
procedure, public :: SetPayRate => SetPayRateSub
|
|
procedure, public :: CalcPay => CalcPayFn
|
|
end type salaryPlusEmployee
|
|
private :: SetPayRateSub, SetSalarySub, CalcPayFn
|
|
contains
|
|
subroutine SetSalarySub(this, salary)
|
|
implicit none
|
|
class(salaryPlusEmployee) :: this
|
|
real, intent(in) :: salary
|
|
this%salary = salary
|
|
end subroutine SetSalarySub
|
|
subroutine SetPayRateSub(this, rate)
|
|
implicit none
|
|
class(salaryPlusEmployee) :: this
|
|
real, intent(in) :: rate
|
|
this%rate = rate
|
|
end subroutine SetPayRateSub
|
|
real function CalcPayFn(this, hours)
|
|
implicit none
|
|
class(salaryPlusEmployee) :: this
|
|
real, intent(in) :: hours
|
|
if ( hours > 42 ) then
|
|
CalcPayFn = this%salary + this%rate*(hours - 42.)
|
|
else
|
|
CalcPayFn = this%salary
|
|
end if
|
|
end function CalcPayFn
|
|
end module ModSalaryPlusEmployeeClass
|
|
! 习题16-3 薪资计算
|
|
subroutine Exercises16_3
|
|
use ModEmployeeClass
|
|
use ModHourlyEmployeeClass
|
|
use ModSalariedEmployeeClass
|
|
use ModSalaryPlusEmployeeClass
|
|
class(employee), pointer :: workerPtr => null()
|
|
type(salariedEmployee), pointer :: workerPtr1 => null()
|
|
type(hourlyEmployee), pointer :: workerPtr2 => null()
|
|
type(salaryPlusEmployee), pointer :: workerPtr3 => null()
|
|
integer :: i
|
|
integer :: errorLevel
|
|
character(len=30) :: firstName
|
|
character(len=30) :: lastName
|
|
character(len=11) :: ssn
|
|
real :: temp
|
|
real :: pay
|
|
real :: hours
|
|
write(*, '(A)', advance='no') 'Please input your first name : '
|
|
read(*, *) firstName
|
|
write(*, '(A)', advance='no') 'Please input your last name : '
|
|
read(*, *) lastName
|
|
write(*, '(A)', advance='no') 'Please input your ssn : '
|
|
read(*, *) ssn
|
|
write(*, 1, advance='no')
|
|
1 format(&
|
|
&'There are three types of the work below.',/&
|
|
&' 1) Salaried Employee',/&
|
|
&' 2) Hourly Employee',/&
|
|
&' 3) Salary Plus Employee',/&
|
|
&'Please choose your work type : ')
|
|
do
|
|
read(*, *, iostat=errorLevel) i
|
|
if ( (errorLevel /= 0) .or. (i > 3) .or. (i < 1) ) then
|
|
write(*, '(A)', advance='no') 'Warning: Illegal input, please try again: '
|
|
else
|
|
exit
|
|
end if
|
|
end do
|
|
select case(i)
|
|
case(1)
|
|
if ( associated(workerPtr1) ) deallocate(workerPtr1, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
allocate(workerPtr1, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
do
|
|
write(*, '(A)', advance='no') 'Please input the salary : '
|
|
read(*, *, iostat=errorLevel) temp
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, *) ''
|
|
else
|
|
call workerPtr1%SetSalary(temp)
|
|
exit
|
|
end if
|
|
end do
|
|
workerPtr => workerPtr1
|
|
deallocate(workerPtr1, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
case(2)
|
|
if ( associated(workerPtr2) ) deallocate(workerPtr2, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
allocate(workerPtr2, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
do
|
|
write(*, '(A)', advance='no') 'Please input the rate : '
|
|
read(*, *, iostat=errorLevel) temp
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, *) ''
|
|
else
|
|
call workerPtr2%SetPayRate(temp)
|
|
exit
|
|
end if
|
|
end do
|
|
workerPtr => workerPtr2
|
|
deallocate(workerPtr2, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
case(3)
|
|
if ( associated(workerPtr3) ) deallocate(workerPtr3, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
allocate(workerPtr3, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
do
|
|
write(*, '(A)', advance='no') 'Please input the salary : '
|
|
read(*, *, iostat=errorLevel) temp
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, *) ''
|
|
else
|
|
call workerPtr3%SetSalary(temp)
|
|
exit
|
|
end if
|
|
end do
|
|
do
|
|
write(*, '(A)', advance='no') 'Please input the rate : '
|
|
read(*, *, iostat=errorLevel) temp
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, *) ''
|
|
else
|
|
call workerPtr3%SetPayRate(temp)
|
|
exit
|
|
end if
|
|
end do
|
|
workerPtr => workerPtr3
|
|
deallocate(workerPtr3, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
end select
|
|
write(*, '(A)', advance='no') 'Please input the work time a month (h) : '
|
|
read(*, *) hours
|
|
call workerPtr%SetEmployee(firstName, lastName, ssn)
|
|
write(*, 2) workerPtr%GetFirstName(), workerPtr%GetLastName(), workerPtr%GetSsn(), workerPtr%CalcPay(hours)
|
|
2 format(&
|
|
&'Please enjoy the squeeze of capitalists!',/&
|
|
&'Your pay slip:',/&
|
|
&' FIRST NAME LAST NAME SSN PAYCHECK',/&
|
|
&'============================== ============================== =========== ==========',/&
|
|
&A, 1X, A, 1X, A, 1X, '$', F9.2)
|
|
deallocate(workerPtr, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
end subroutine Exercises16_3
|
|
! 习题16-4 通用多边形
|
|
module ModPointClass
|
|
implicit none
|
|
type, public :: point
|
|
real :: x
|
|
real :: y
|
|
end type point
|
|
end module ModPointClass
|
|
module ModShapeClass
|
|
implicit none
|
|
type, public :: shape
|
|
contains
|
|
procedure, public :: Area => CalcAreaFn
|
|
procedure, public :: Perimeter => CalcPerimeterFn
|
|
procedure, public :: ToString => ToStringFn
|
|
end type shape
|
|
private :: CalcAreaFn, CalcPerimeterFn, ToStringFn
|
|
contains
|
|
real function CalcAreaFn(this)
|
|
implicit none
|
|
class(shape) :: this
|
|
CalcAreaFn = 0.
|
|
end function CalcAreaFn
|
|
real function CalcPerimeterFn(this)
|
|
implicit none
|
|
class(shape) :: this
|
|
CalcPerimeterFn = 0.
|
|
end function CalcPerimeterFn
|
|
character(len=50) function ToStringFn(this)
|
|
implicit none
|
|
class(shape) :: this
|
|
ToStringFn = ''
|
|
end function ToStringFn
|
|
end module ModShapeClass
|
|
module ModPolygonClass
|
|
use ModPointClass
|
|
implicit none
|
|
type, public :: polygon
|
|
type(point), dimension(:), allocatable :: p
|
|
contains
|
|
procedure, public :: SetShape => SetShapeSub
|
|
procedure, public :: Area => CalcAreaFn
|
|
procedure, public :: Perimeter => CalcPerimeterFn
|
|
end type polygon
|
|
contains
|
|
subroutine SetShapeSub(this, num, pointArray)
|
|
class(polygon) :: this
|
|
integer, intent(in), optional :: num
|
|
class(point), dimension(:), allocatable, intent(in), optional :: pointArray
|
|
integer :: errorLevel
|
|
integer :: i=0
|
|
integer :: n
|
|
if ( present(num) ) then
|
|
n = num
|
|
else
|
|
write(*, '(A)', advance='no') 'Please enter the number of the points : '
|
|
read(*, *) n
|
|
end if
|
|
do
|
|
if ( n < 3 ) then
|
|
write(*, '(A)', advance='no') 'The number of the points isn''t enough, try again : '
|
|
read(*, *) n
|
|
else
|
|
exit
|
|
end if
|
|
end do
|
|
if ( allocated(this%p) ) then
|
|
deallocate(this%p, stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
end if
|
|
allocate(this%p(n), stat=errorLevel)
|
|
if ( errorLevel /= 0 ) stop ""
|
|
if ( present(pointArray) ) then
|
|
do
|
|
if ( size(pointArray, 1) /= n ) then
|
|
write(*, '(A)') 'Warning: Input array dimensions do not match!'
|
|
write(*, '(A)') 'Please enter the coordinates in counterclockwise order.'
|
|
do
|
|
i = i + 1
|
|
if ( i == n + 1 ) exit
|
|
write(*, '(A, I3, A)', advance='no') 'Please enter the coordinate', i, ' : '
|
|
read(*, *, iostat=errorLevel) this%p(i)%x, this%p(i)%y
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, '(A)') ''
|
|
i = i - 1
|
|
end if
|
|
end do
|
|
else
|
|
this%p = pointArray
|
|
exit
|
|
end if
|
|
end do
|
|
else
|
|
write(*, '(A)') 'No coordinates entered, Please enter the coordinates in counterclockwise order like x y !'
|
|
do
|
|
i = i + 1
|
|
if ( i == n + 1 ) exit
|
|
write(*, '(A, I3, A)', advance='no') 'Please enter the coordinate', i, ' : '
|
|
read(*, *, iostat=errorLevel) this%p(i)%x, this%p(i)%y
|
|
if ( errorLevel /= 0 ) then
|
|
write(*, '(A)') 'Warning: Illegal input information, please try again!'
|
|
i = i - 1
|
|
end if
|
|
end do
|
|
end if
|
|
end subroutine SetShapeSub
|
|
real function CalcAreaFn(this)
|
|
implicit none
|
|
class(polygon) :: this
|
|
integer :: i
|
|
CalcAreaFn = 0
|
|
do i = 1, size(this%p, 1)-1
|
|
CalcAreaFn = CalcAreaFn + (this%p(i)%x*this%p(i+1)%y - this%p(i+1)%x*this%p(i)%y)/2.
|
|
end do
|
|
CalcAreaFn = CalcAreaFn + (this%p(size(this%p, 1))%x*this%p(1)%y - this%p(1)%x*this%p(size(this%p, 1))%y)/2.
|
|
end function CalcAreaFn
|
|
real function CalcPerimeterFn(this)
|
|
implicit none
|
|
class(polygon) :: this
|
|
integer :: i
|
|
do i = 1, size(this%p, 1)-1
|
|
CalcPerimeterFn = CalcPerimeterFn + sqrt((this%p(i+1)%x - this%p(i)%x)**2 + (this%p(i+1)%y - this%p(i)%y)**2)
|
|
end do
|
|
CalcPerimeterFn = CalcPerimeterFn +&
|
|
& sqrt((this%p(1)%x - this%p(size(this%p, 1))%x)**2 + (this%p(1)%y - this%p(size(this%p, 1))%y)**2)
|
|
end function CalcPerimeterFn
|
|
end module ModPolygonClass
|
|
subroutine Exercises16_4
|
|
use ModPolygonClass
|
|
use ModPointClass
|
|
implicit none
|
|
integer, parameter :: numPolygon=4
|
|
type(polygon), dimension(numPolygon) :: shape1
|
|
|
|
call shape1%SetShape()
|
|
! write(*, '(A, F6.2)') 'The area of the polygon is : ', shape1%Area()
|
|
! write(*, '(A, F6.2)') 'The perimeter of the polygon is: ', shape1%Perimeter()
|
|
write(*, 1) size(shape1%p, 1), shape1%Area(), shape1%Perimeter()
|
|
1 format(/&
|
|
&'POINTS AREA PERIMETER',/&
|
|
&'====== ========== ===========',/&
|
|
T2, I3, T9, F6.2, T21, F6.2)
|
|
end subroutine Exercises16_4
|
|
! 习题16-5 多维矢量运算
|
|
module ModVecClass
|
|
implicit none
|
|
type, abstract, public :: vec
|
|
real :: x
|
|
real :: y
|
|
contains
|
|
generic(plus1), public, deferred :: add => plus1
|
|
end type vec
|
|
private :: plus1
|
|
! interface :: operator(+)
|
|
! module procedure plus1
|
|
! end interface
|
|
! abstract interface operator(+)
|
|
! module procedure plus1
|
|
! end interface
|
|
abstract interface
|
|
function plus1(this, that)
|
|
implicit none
|
|
class(type1) :: this
|
|
class(type1) :: that
|
|
class(type1) :: plus1
|
|
end function plus1
|
|
end interface
|
|
end module ModVecClass
|
|
module ModVec2dClass
|
|
use ModVecClass
|
|
implicit none
|
|
type, extends(vec), public :: vec2d
|
|
end type vec2d
|
|
private :: VecAddFn, VecSubFn
|
|
end module ModVec2dClass
|
|
subroutine Exercises16_5
|
|
use ModVecClass
|
|
use ModVec2dClass
|
|
implicit none
|
|
type(vec2d), pointer :: vector1
|
|
type(vec2d), pointer :: vector2
|
|
class(vec), pointer :: vector
|
|
integer :: errorLevel
|
|
! allocate(vector1, stat=errorLevel)
|
|
! if ( errorLevel /= 0 ) stop ""
|
|
! vector1 = vec2d(1, 2)
|
|
! allocate(vector2, stat=errorLevel)
|
|
! if ( errorLevel /= 0 ) stop ""
|
|
! vector2 = vec2d(1, 3)
|
|
! vector => vector1
|
|
! call vector%Add(vector2)
|
|
! write(*, *) vector%x, vector%y
|
|
! write(*, *) vector%Add(vector2)
|
|
end subroutine Exercises16_5 |