Fortran自身并不带有日期时间处理函数，故仿照vb.net编写 Mod_DateTime 模块(点击下载，文后同样附有代码)，其中包含两个结构体TimeSpan 和 DateTime。模块内部采用32位整型数据和64位浮点数据，主要功能：1、计算两个时间间隔(TimeSpan类型)之间的时间间隔；2、计算两个时刻(DateTime类型)之间的时间间隔；3、计算与某时刻相距一定时间间隔的时刻。
一、TimeSpan类型
1.1 结构体声明
type, public:: TimeSpan
!定义TimeSpan结构体
integer(IP) :: Sign = 1 !用1、-1分别表示正负
integer(IP) :: Days = 0, Hours = 0, Minutes = 0, Seconds = 0, &
Milliseconds = 0, Microseconds = 0, Nanoseconds = 0
contains
procedure, pass :: TotalDays, TotalHours, TotalMinutes, TotalSeconds, &
TotalMilliseconds, TotalMicroseconds, TotalNanoseconds
procedure, pass :: CompareTo
procedure, pass :: ToString
procedure, pass :: Set
procedure, pass :: Add
procedure, pass :: Subtract
end type TimeSpan1.2 成员
| Sign | 当前TimeSpan结构所表示的时间间隔的正(1)负(-1) |
| Days | 当前TimeSpan结构所表示的时间间隔的天数部分 |
| Hours | 当前TimeSpan结构所表示的时间间隔的小时数部分 |
| Minutes | 当前TimeSpan结构所表示的时间间隔的分钟数部分 |
| Seconds | 当前TimeSpan结构所表示的时间间隔的秒数部分 |
| Milliseconds | 当前TimeSpan结构所表示的时间间隔的毫秒数部分 |
| Microseconds | 当前TimeSpan结构所表示的时间间隔的微秒数部分 |
| Nanoseconds | 当前TimeSpan结构所表示的时间间隔的纳秒数部分 |
1.3 方法
| 返回值 | 函数名(参数) | 功能 |
| double | TotalDays | 返回以天为单位表示的当前TimeSpan结构的值 |
| double | TotalHours | 返回以小时为单位表示的当前TimeSpan结构的值 |
| double | TotalMinutes | 返回以分钟为单位表示的当前TimeSpan结构的值 |
| double | TotalSeconds | 返回以秒为单位表示的当前TimeSpan结构的值 |
| double | TotalMilliseconds | 返回以毫秒为单位表示的当前TimeSpan结构的值 |
| double | TotalMicroseconds | 返回以微秒为单位表示的当前TimeSpan结构的值 |
| double | TotalNanoseconds | 返回以纳秒为单位表示的当前TimeSpan结构的值 |
| Int32 | CompareTo(TimeSpan) | 将此实例与指定TimeSpan对象进行比较，并返回一个整数，该整数指示此实例是小于(-1)、等于(0)还是大于(1)指定对象 |
| string | ToString | 将当前TimeSpan对象的值转换为字符串表示形式 |
| void | Set(Sign, Days, Hours Minutes, Seconds, Milliseconds, Microseconds, Nanoseconds, status ) Set(Sign, Days, Hours Minutes, Seconds, Milliseconds, Microseconds, Nanoseconds) Set(seconds) | 1. 设置TimeSpan结构的变量，参数含义见成员列表。具有status参数，时间参数必须符合时间格式(最大23:59:59.999999999)。status值为0表示数据无误，-1表示出现赋值，1表示超过范围 2. 设置TimeSpan结构的变量，参数含义见成员列表。无status参数，时间参数无需符合时间格式(25:62:59.999999999也可) 3. 将双精度的秒数转为TimeSpan结构的变量 |
| void | Add(TimeSpan) | 将此实例与指定TimeSpan对象相加 |
| void | Subtract(TimeSpan) | 将此实例与指定TimeSpan对象相减 |
二、DateTime类型
2.1 结构体声明
type DateTime
integer(IP) :: Year = 1800, Month = 1, Day = 1
integer(IP) :: Hour = 0, Minute = 0, Second = 0, Millisecond = 0
contains
procedure, pass :: DayOfYear
procedure, pass :: DayOfWeek
procedure, pass :: CompareTo
procedure, pass :: ToString
procedure, pass :: IsLeapYear
procedure, pass :: Now
procedure, pass :: Set
procedure, pass :: Add
procedure, pass :: SubtractTimeSpan
procedure, pass :: SubtractDateTime
end type DateTime2.2 成员
| Year | 当前DateTime结构所表示日期的年份部分 |
| Month | 当前DateTime结构所表示日期的月份部分 |
| Day | 当前DateTime结构所表示日期为该月中的第几天 |
| Hour | 当前DateTime结构所表示日期的小时部分 |
| Minute | 当前DateTime结构所表示日期的分钟部分 |
| Second | 当前DateTime结构所表示日期的秒部分 |
| Millisecond | 当前DateTime结构所表示日期的毫秒部分 |
2.3 方法
| 返回值 | 函数名(参数) | 功能 |
| Int32 | DayOfYear | 获取此实例所表示的日期是该年中的第几天 |
| Int32 | DayOfWeek | 获取此实例所表示的日期是星期几（1-7） |
| Int32 | CompareTo(DateTime) | 将此实例的值与指定的DateTime值相比较，并返回一个整数，该整数指示此实例是早于(-1)、等于(0)还是晚于(1)指定的DateTime值 |
| string | ToString | 当前DateTime对象的值转换为字符串表示形式 |
| logical | IsLeapYear | 当前DateTime对象是否为闰年 |
| void | Now | 获取一个DateTime对象，该对象设置为此计算机上的当前日期和时间，表示为本地时间 |
| void | Set(yy, mm, dd, h, m, s, ms, status) | 设置日期时间, status参数可选 |
| void | Add(TimeSpan) | 将指定TimeSpan的值添加到此实例的值上 |
| void | SubtractTimeSpan(TimeSpan) | 从此实例的值中减去指定持续时间间隔 |
| TimeSpan | SubtractDateTime(DateTime) | 从此实例的值中减去指定时刻，返回时间间隔 |
三、使用
将代码Module_DateTime.f90加入项目即可。该源文件中包含两个模块Mod_TimeSpan和Mod_DateTime，前者为后者的子集，使用时可只use后者。
四、示例
program Test
use Mod_DateTime
implicit none
type(TimeSpan) ts1, ts2
type(DateTime) DT1, DT2
integer i
call ts1%Set(-86521.123456789D0) !以秒设置时间间隔 -1::00:02:01.123456789
write(*,"('ts1 = ',a)") ts1%ToString() !输出字符形式的时间间隔
call ts1%Set(1,0,0,61,0,0,0,0,i) !设置时间间隔, 有status参数, 检查数据格式. 分钟大于59, 不符合时间格式
write(*,"('status = ',g0)") i !输出1. 数据合法(0), 数据小于零(-1), 数据超过限制(1)
call ts1%Set(1,3,1,63,4,5,6,301) !设置时间间隔, 无status参数, 不检查时间格式, +3::02:03:04.005006301
write(*,"('ts1 = ',a)") ts1%ToString() !输出字符形式的时间间隔
call ts2%Set(-1,2,3,5,1,1,121,405) !设置时间间隔 -2::03:05:01.001121405
write(*,"('ts2 = ',a)") ts2%ToString()
write(*,"('ts1==ts2? = ',g0)") ts1%CompareTo(ts2) !两个时间间隔比较，1,0,-1分别表示大于、等于、小于
call ts1%Add(ts2) !两个时间间隔相加 0::22:58:03.003884896
write(*,"('ts1+ts2 = ',a)") ts1%ToString()
call ts1%subtract(ts2) !两个时间间隔相减 3::02:03:04.005006301
write(*,"('(ts1+ts2)-ts2 = ',a)") ts1%ToString()
!时间间隔转为 天,小时,分钟,秒,毫秒,微秒,纳秒
write(*,"('ts1: ')")
write(*,"('转为 天: ',g0)") ts1%TotalDays()
write(*,"('转为 小时: ',g0)") ts1%TotalHours()
write(*,"('转为 分钟: ',g0)") ts1%TotalMinutes()
write(*,"('转为 秒: ',g0)") ts1%TotalSeconds()
write(*,"('转为 毫秒: ',g0)") ts1%TotalMilliseconds()
write(*,"('转为 微秒: ',g0)") ts1%TotalMicroseconds()
write(*,"('转为 纳秒: ',g0)") ts1%TotalNanoseconds()
!----------------------------------------------------
write(*,*)
call DT1%Now() !获取当前的日期时间
write(*,"('当前日期时间 = ',a)") DT1%ToString() !输出字符形式的日期时间
write(*,"('在当年的天数 = ',g0)") DT1%DayOfYear() !该日期是当年的第几天
write(*,"('星期 = ',g0)") DT1%DayOfWeek() !该日期是星期几
call DT1%Set(2020,3,1,2,16,30,123) !设置日期时间
write(*,"('日期时间DT1 = ',a)") DT1%ToString()
write(*,"('是否闰年 = ',g0)") DT1%IsLeapYear() !是否闰年
call DT2%Set(2020,2,27,2,16,30,124)
write(*,"('日期时间DT2 = ',a)") DT2%ToString()
write(*,"('DT1==DT2? = ',g0)") DT1%CompareTo(DT2) !两个日期时间比较，1,0,-1分别表示大于、等于、小于
ts1 = DT2%SubtractDateTime(DT1) !两个日期时间相减, 得到时间间隔
write(*,"('DT2-DT1 = ',a)") ts1%ToString()
call DT2%SubtractTimeSpan(ts1) !日期减去时间间隔, 得到日期
write(*,"('DT2-(DT2-DT1) = ',a)") DT2%ToString()
call DT2%Add(ts1) !日期加上时间间隔, 得到日期
write(*,"('DT1+(DT2-DT1) = ',a)") DT2%ToString()
pause
end program
五、其他说明
- 为保证计算精度，日期应不早于1800年；如有特殊需求，可自行修改代码；
- 代码未经过严格测试，可能存在bug，如有发现请联系作者修订；
- 作者不对因使用该代码造成的任何后果负责，请酌情采用；
- 使用和传播时请保留作者版权信息。
附代码：
!************************************************************
! 自定义TimeSpan类数据类型
! 作者：lixingwang@chd.edu.cn, 2022-12-02
!************************************************************
module Mod_TimeSpan
implicit none
private
integer(4), parameter :: IP = 4, RP = 8
type, public:: TimeSpan
!定义TimeSpan结构体
integer(IP) :: Sign = 1 !用1、-1分别表示正负
integer(IP) :: Days = 0, Hours = 0, Minutes = 0, Seconds = 0, &
Milliseconds = 0, Microseconds = 0, Nanoseconds = 0
contains
procedure, pass :: TotalDays, TotalHours, TotalMinutes, TotalSeconds, &
TotalMilliseconds, TotalMicroseconds, TotalNanoseconds
procedure, pass :: CompareTo
procedure, pass :: ToString
procedure, pass :: SetTimeSpan, SetFromSeconds
procedure, pass :: Add
procedure, pass :: Subtract
generic:: Set => SetTimeSpan, SetFromSeconds
end type TimeSpan
contains
!************************************************************
!获取以整天数和天的小数部分表示的当前 TimeSpan 结构的值。
!************************************************************
elemental function TotalDays(ts) result(res)
implicit none
class(TimeSpan), intent(in):: ts
real(RP) res
res = TotalSeconds(ts) / 86400D0
end function
!************************************************************
!获取以整小时数和小时的小数部分表示的当前 TimeSpan 结构的值。
!************************************************************
elemental function TotalHours(ts) result(res)
implicit none
class(TimeSpan), intent(in):: ts
real(RP) res
res = TotalSeconds(ts) / 3600D0
end function
!************************************************************
!获取以整分钟数和分钟的小数部分表示的当前 TimeSpan 结构的值。
!************************************************************
elemental function TotalMinutes(ts) result(res)
implicit none
class(TimeSpan), intent(in):: ts
real(RP) res
res = TotalSeconds(ts) / 60D0
end function
!************************************************************
!获取以整秒数和秒的小数部分表示的当前 TimeSpan 结构的值。
!************************************************************
elemental function TotalSeconds(ts) result(res)
implicit none
class(TimeSpan), intent(in):: ts
real(RP) res
res = 86400D0*ts%Days + 3600D0*ts%Hours + 60D0*ts%Minutes + &
ts%Seconds + 1D-3*ts%Milliseconds + 1D-6*ts%Microseconds + &
1D-9*ts%Nanoseconds
if(ts%Sign<0) res = -res
end function
!************************************************************
!获取以整毫秒数和毫秒的小数部分表示的当前 TimeSpan 结构的值
!************************************************************
elemental function TotalMilliseconds(ts) result(res)
implicit none
class(TimeSpan), intent(in):: ts
real(RP) res
res = TotalSeconds(ts) * 1D3
end function
!************************************************************
!获取以整微秒和小数微秒表示的当前 TimeSpan 结构的值。
!************************************************************
elemental function TotalMicroseconds(ts) result(res)
implicit none
class(TimeSpan), intent(in):: ts
real(RP) res
res = TotalSeconds(ts) * 1D6
end function
!************************************************************
!获取以整数和小数纳秒表示的当前 TimeSpan 结构的值。
!************************************************************
elemental function TotalNanoseconds(ts) result(res)
implicit none
class(TimeSpan), intent(in):: ts
real(RP) res
res = TotalSeconds(ts) * 1D9
end function
!************************************************************
!返回一个新的 TimeSpan 对象
!其值为指定的 TimeSpan 对象与此实例的值之和.
!************************************************************
elemental subroutine Add(ts1, ts2)
implicit none
class(TimeSpan), intent(inout):: ts1
class(TimeSpan), intent(in):: ts2
integer(IP), parameter :: SPAN(7) = [huge(1_IP), 24, 60, 60, 1000, 1000, 1000]
integer(IP) IA(7), IB(7)
integer(IP) i
IA = [ts1%Days, ts1%Hours, ts1%Minutes, ts1%Seconds, ts1%Milliseconds, ts1%Microseconds, ts1%Nanoseconds]
if(ts1%Sign<0) IA = -IA
IB = [ts2%Days, ts2%Hours, ts2%Minutes, ts2%Seconds, ts2%Milliseconds, ts2%Microseconds, ts2%Nanoseconds]
if(ts2%Sign<0) IB = -IB
IA = IA + IB
!确定正负
ts1%Sign = 1
do i = 1, size(IA)
if(IA(i)>0) then
exit
else if(IA(i)<0) then
ts1%Sign = -1
IA = -IA
exit
end if
end do
!进位
do i = size(IA), 2, -1
if(IA(i)<0) then
IA(i) = IA(i) + SPAN(i)
IA(i-1) = IA(i-1) - 1
else if(IA(i)>=SPAN(i)) then
IA(i) = IA(i) - SPAN(i)
IA(i-1) = IA(i-1) + 1
end if
end do
call SetTimeSpan(ts1,ts1%Sign,IA(1),IA(2),IA(3),IA(4),IA(5),IA(6),IA(7))
end subroutine
!************************************************************
!返回一个新的 TimeSpan 对象
!其值为指定的 TimeSpan 对象与此实例的差值.
!************************************************************
elemental subroutine Subtract(ts1, ts2)
implicit none
class(TimeSpan), intent(inout):: ts1
class(TimeSpan), intent(in):: ts2
type(TimeSpan) ts
ts = ts2; ts%Sign = -ts%Sign
call Add(ts1, ts)
end subroutine
!************************************************************
!比较两个 TimeSpan 值，并返回一个整数，
!该整数指示第一个值是短于(-1)、等于(0)还是长于(1)第二个值。
!************************************************************
elemental function CompareTo(ts1, ts2) result(res)
implicit none
class(TimeSpan), intent(in):: ts1, ts2
integer(IP) res
integer(IP) IA(7), IB(7)
integer(IP) i
IA = [ts1%Days, ts1%Hours, ts1%Minutes, ts1%Seconds, ts1%Milliseconds, ts1%Microseconds, ts1%Nanoseconds]
if(ts1%Sign<0) IA = -IA
IB = [ts2%Days, ts2%Hours, ts2%Minutes, ts2%Seconds, ts2%Milliseconds, ts2%Microseconds, ts2%Nanoseconds]
if(ts2%Sign<0) IB = -IB
IA = IA - IB
!确定正负
res = 0
do i = 1, size(IA)
if(IA(i)>0) then
res = 1
exit
else if(IA(i)<0) then
res = -1
exit
end if
end do
end function
!************************************************************
!赋值TimeSpan类
!************************************************************
pure subroutine SetTimeSpan(ts, sign, d, h, m, s, ms, us, ns, status)
implicit none
class(TimeSpan), intent(out) :: ts
integer(IP), intent(in):: sign, d, h, m, s, ms, us, ns
integer(IP), intent(out), optional:: status
integer(IP), parameter :: SPAN(7) = [huge(1_IP), 24, 60, 60, 1000, 1000, 1000]
integer(IP) IA(7), i, n
logical(IP) sta
!判断是否有小于零的值
IA = [d, h, m, s, ms, us, ns]
if(any(IA<0)) then
if(present(status)) then
status = -1 !数据小于零
else
error stop 'the value of TimeSpan is wrong.'
end if
return
end if
!数据不符合时间格式
if(present(status) .and. any(IA>=SPAN)) then
status = 1 !数据超过上限
return
end if
!数据处理
do i = 7, 2, -1 !进位
n = IA(i) / SPAN(i)
IA(i) = IA(i) - n*SPAN(i)
IA(i-1) = IA(i-1) + n
end do
!赋值
if(sign>=0) then
ts%Sign = 1
else
ts%Sign = -1
end if
ts%Days = IA(1); ts%Hours = IA(2); ts%Minutes = IA(3); ts%Seconds = IA(4)
ts%Milliseconds = IA(5); ts%Microseconds = IA(6); ts%Nanoseconds = IA(7)
!检查值是否合法
sta = checkTimeSpan(ts)
if(present(status)) then
status = merge(0,-1,sta) !无误返回0，否则-1
else
if(.not.sta) error stop 'the value of TimeSpan is wrong.'
end if
end subroutine
!************************************************************
!赋值TimeSpan类
!************************************************************
pure subroutine SetFromSeconds(ts, seconds)
implicit none
class(TimeSpan), intent(out) :: ts
real(RP), intent(in):: seconds
logical(IP) sta
integer(8) s, n
if(seconds>=0) then
ts%Sign = 1
else
ts%Sign = -1
end if
s = abs(seconds) !整数部分
n = s / 86400; s = s - n*86400; ts%Days = n
n = s / 3600; s = s - n*3600; ts%Hours = n
n = s / 60; s = s - n*60; ts%Minutes = n
ts%Seconds = s
s = mod(abs(seconds),1D0)*1D9 + 0.01 !小数部分, 纳秒
n = s / 1000000; s = s - n*1000000; ts%Milliseconds = n
n = s / 1000; s = s - n*1000; ts%Microseconds = n
ts%Nanoseconds = s
!检查值是否合法
sta = checkTimeSpan(ts)
if(.not.sta) error stop 'the value of TimeSpan is wrong.'
end subroutine
!************************************************************
!将当前 TimeSpan 对象的值转换为其等效的字符串表示形式。
!************************************************************
elemental function ToString(ts) result(res)
implicit none
class(TimeSpan), intent(in) :: ts
character res*40, str*18
res = ''
write(res,*) ts%Days
res = adjustl(res)
if(ts%Sign<0) then
res = '-' // res
else
res = '+' // res
end if
str = '12:45:78.123456789'
write(str(1:2),'(i2.2)') ts%Hours
write(str(4:5),'(i2.2)') ts%Minutes
write(str(7:8),'(i2.2)') ts%Seconds
write(str(10:12),'(i3.3)') ts%Milliseconds
write(str(13:15),'(i3.3)') ts%Microseconds
write(str(16:18),'(i3.3)') ts%Nanoseconds
res = trim(res) // '::' // str
end function ToString
!************************************************************
!检查 TimeSpan 对象的值是否正确。
!************************************************************
elemental function checkTimeSpan(ts) result(res)
implicit none
type(TimeSpan), intent(in) :: ts
integer(IP), parameter :: SPAN(7) = [huge(1_IP), 24, 60, 60, 1000, 1000, 1000]
integer(IP) IA(7)
logical(IP) res
res = .true.
IA = [ts%Days, ts%Hours, ts%Minutes, ts%Seconds, ts%Milliseconds, ts%Microseconds, ts%Nanoseconds]
if(any(IA>=SPAN) .or. any(IA<0)) res = .false.
end function
end module
!************************************************************
! 自定义Date类数据类型
! 作者：lixingwang@chd.edu.cn, 2022-12-02
!************************************************************
module Mod_DateTime
use Mod_TimeSpan, only: TimeSpan
implicit none
private
public TimeSpan, DateTime
integer(4), parameter:: IP = 4
integer(IP), parameter:: baseYear = 1800, maxYear = 5000 !能处理的日期上下界
integer(IP), parameter:: DaysOfMonth(12)=[31,28,31,30,31,30,31,31,30,31,30,31]
type DateTime
integer(IP) :: Year = baseYear, Month = 1, Day = 1
integer(IP) :: Hour = 0, Minute = 0, Second = 0, Millisecond = 0
contains
procedure, pass :: DayOfYear
procedure, pass :: DayOfWeek
procedure, pass :: CompareTo
procedure, pass :: ToString
procedure, pass :: IsLeapYear => fun_IsLeapYear
procedure, pass :: Now
procedure, pass :: Set
procedure, pass :: Add
procedure, pass :: SubtractTimeSpan
procedure, pass :: SubtractDateTime
end type DateTime
contains
!************************************************************
!返回一个新的 DateTime
!它将指定 TimeSpan 的值加到此实例的值上。
!************************************************************
elemental subroutine Add(DT, ts)
implicit none
class(DateTime), intent(inout) :: DT
class(TimeSpan), intent(in) :: ts
type(TimeSpan) ts0
integer(IP) days(12)
integer(IP) y, m, d, i
!寻找基准时间
y = DT%Year
m = 1
d = DayOfYear(DT) - 1
if(ts%Sign<0) then
do while(d<=ts%days)
y = y - 1
d = d + 365
if(IsLeapYear(y)) d = d + 1
end do
end if
!相加, 结果肯定为正
call ts0%Set(1, d, DT%Hour, DT%Minute, DT%Second, DT%Millisecond, 0, 0)
call ts0%Add(ts)
!转为时间
do !年
if(IsLeapYear(y)) then
d = 366
else
d = 365
end if
if(ts0%Days>=d) then
y = y + 1
ts0%Days = ts0%Days - d
else
d = ts0%Days + 1 !日期比天数多1
exit
end if
end do
!月
days = DaysOfMonth
if(IsLeapYear(y)) days(2) = days(2) + 1
do i = 1, 11
if(d>=days(i)) then
m = m + 1
d = d - days(i)
else
exit
end if
end do
!设置时间
call Set(DT, y, m, d, ts0%Hours, ts0%Minutes, ts0%Seconds, ts0%Milliseconds)
end subroutine
!************************************************************
!将此实例的值与包含指定的 DateTime 值的指定对象相比较
!并返回一个整数
!该整数指示此实例是早于(-1)、等于(0)还是晚于(1)指定的 DateTime 值。
!************************************************************
elemental function CompareTo(DT1, DT2) result(Res)
implicit none
class(DateTime), intent(in) :: DT1, DT2
integer(IP) Res, IA(7), IB(7), i
IA = [DT1%Year, DT1%Month, DT1%Day, DT1%Hour, DT1%Minute, DT1%Second, DT1%Millisecond]
IB = [DT2%Year, DT2%Month, DT2%Day, DT2%Hour, DT2%Minute, DT2%Second, DT2%Millisecond]
Res = 0
do i = 1, 7
if(IA(i)>IB(i)) then
Res = 1
exit
else if(IA(i)<IB(i)) then
Res = -1
exit
end if
end do
end function
!************************************************************
!返回一个新的 DateTime
!从此实例中减去指定持续时间间隔。
!************************************************************
elemental subroutine SubtractTimeSpan(DT, ts)
implicit none
class(DateTime), intent(inout) :: DT
class(TimeSpan), intent(in) :: ts
type(TimeSpan) ts0
ts0 = ts
ts0%Sign = -ts0%Sign
call Add(DT, ts0)
end subroutine
!************************************************************
!返回一个新的 TimeSpan
!从此实例中减去指定的日期时间。
!************************************************************
elemental function SubtractDateTime(DT1, DT2) result(res)
implicit none
class(DateTime), intent(in):: DT1, DT2
type(DateTime) p1, p2
type(TimeSpan) res, ts
integer(IP) sign, i, d
!排序
i = CompareTo(DT1, DT2)
if(i<0) then
p1 = DT2; p2 = DT1
sign = -1
elseif(i==0) then
call res%Set(1,0,0,0,0,0,0,0)
return
else
p1 = DT1; p2 = DT2
sign = 1
end if
d = DayOfYear(p1)
do i = p2%Year, p1%Year-1
d = d + 365
if(IsLeapYear(i)) d = d + 1
end do
call res%Set(1, d, p1%Hour, p1%Minute, p1%Second, p1%Millisecond, 0, 0)
call ts%Set(1, DayOfYear(p2), p2%Hour, p2%Minute, p2%Second, p2%Millisecond, 0, 0)
call res%Subtract(ts)
res%sign = sign
end function
!************************************************************
!赋值DateTime类
!************************************************************
pure subroutine Set(DT, yy, mm, dd, h, m, s, ms, status)
implicit none
class(DateTime), intent(out) :: DT
integer(IP), intent(in) :: yy, mm, dd, h, m, s, ms
integer(IP), intent(out), optional:: status
logical(IP) sta
DT%Year = yy; DT%Month = mm; DT%Day = dd; DT%Hour = h
DT%Minute = m; DT%Second = s; DT%Millisecond = ms
sta = checkDateTime(DT) !检查数据
if(present(status)) then
status = merge(0,-1,sta) !无误返回0，否则-1
else
if(.not.sta) error stop 'the value of DateTime is wrong.'
end if
end subroutine
!************************************************************
!将当前 DateTime 对象的值转换为它的等效字符串表示形式。
!************************************************************
elemental function ToString(DT) Result(Res)
implicit none
class(DateTime), intent(in) :: DT
character Res*23
Res = '2015-05-12 21:01:25.345'
write(Res(1:4),'(i4.4)') DT%Year
write(Res(6:7),'(i2.2)') DT%Month
write(Res(9:10),'(i2.2)') DT%Day
write(Res(12:13),'(i2.2)') DT%Hour
write(Res(15:16),'(i2.2)') DT%Minute
write(Res(18:19),'(i2.2)') DT%Second
write(Res(21:23),'(i3.3)') DT%Millisecond
end function
!************************************************************
!获取此实例所表示的日期是该年中的第几天。
!************************************************************
elemental function DayOfYear(DT) result(res)
implicit none
class(Datetime), intent(in) :: DT
integer(IP) res
res = sum(DaysOfMonth(1:DT%Month-1)) + DT%Day
if(DT%Month>2 .and. IsLeapYear(DT%Year)) res = res + 1
end function DayOfYear
!************************************************************
!获取此实例所表示的日期是星期几。
!************************************************************
elemental function DayOfWeek(DT) Result(Res)
implicit none
class(Datetime), intent(in) :: DT
integer(IP) Res, year, month, day
year = DT%Year
month = DT%Month
day = DT%Day
Res = Week(year, month, day)
if(res==0) res = 7
contains
!***************************************************
! 利用蔡勒(Zeller)公式计算星期
!***************************************************
elemental function Week(year, month, day)
implicit none
integer(IP), intent(in) :: year, month, day
integer(IP) week, c
integer(IP) y, m
y = year; m = month
!每年1、2月当做上一年的13、14月处理
if(m < 3) then
y = y-1; m = m+12
end if
c = int(y/100); y = mod(y,100); m = (m+1)*13
y = y + day - 1 - (c+c) + int(c/4) + int(y/4) + int(m/5)
week = mod(y,7)
!防止取余结果为负数
if(week < 0) week = week + 7
end function
end function
!************************************************************
!获取一个 DateTime 对象
!该对象设置为此计算机上的当前日期和时间，表示为本地时间。
!************************************************************
subroutine Now(DT)
implicit none
class(DateTime), intent(out):: DT
integer(IP) Date_Time(8)
call date_and_time(values = Date_Time)
DT%Year = Date_Time(1)
DT%Month = Date_Time(2)
DT%Day = Date_Time(3)
DT%Hour = Date_Time(5)
DT%Minute = Date_Time(6)
DT%Second = Date_Time(7)
DT%Millisecond = Date_Time(8)
end subroutine
!************************************************************
! 功能： 判断是否闰年
! 返回值： IsLeapYear(4字节逻辑型),闰年则返回.true.
! 输入参数： year(4字节整型)，代表年份
!************************************************************
elemental function IsLeapYear(year)
implicit none
integer(IP), intent(in) :: year
logical(IP) IsLeapYear
IsLeapYear = .false.
if(mod(year,400)==0 .or. (mod(year,100)/=0.and.mod(year,4)==0) ) IsLeapYear = .true.
end function IsLeapYear
elemental function fun_IsLeapYear(DT) result(res)
class(DateTime), intent(in) :: DT
logical(IP) res
res = IsLeapYear(DT%Year)
end function
!************************************************************
!检查 DateTime 对象的值是否合法。
!************************************************************
elemental function checkDateTime(DT) result(res)
implicit none
type(DateTime), intent(in) :: DT
integer(IP) SPAN(7)
integer(IP) IA(7)
logical(IP) res
res = .true.
if(DT%Month<1 .or. DT%Month>12) then
res = .false.
return
end if
!数据合理范围
SPAN(:) = [maxYear, 13, DaysOfMonth(DT%Month)+1, 24, 60, 60, 1000]
if(DT%Month==2 .and. IsLeapYear(DT%Year)) SPAN(3) = SPAN(3) + 1
!检验
IA = [DT%Year, DT%Month, DT%Day, DT%Hour, DT%Minute, DT%Second, DT%Millisecond]
if(DT%Year<baseYear .or. any(IA>=SPAN) .or. any(IA<0)) res = .false.
end function
end module
扫一扫
855
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
