! ============================================================================== ! 通过 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