利用蔡勒公式获得给定日期的星期数
2016-09-02 12:18:33   来源：Fcode研讨团队   评论：0 点击：

本代码在开始输入时，可以按回车获得今天是星期几（根据计算机系统时间），如果输入1582年10月15日之前的日子，或者月份输入不对，月份对应的日子不对，程序都会报错。 蔡勒公式图所示如下：

Integer Function GetWeekByDate( y , mon , day ) result( week )
  Implicit None
  Integer , Intent( IN ) :: y , mon , day
  integer :: month , year , y12 , y34
  integer :: A,B,C,D
  If ( mon==1 .or. mon==2 ) Then
    month = mon + 12 ! If January or Febrary,regarding it as 13 or 14
    year  = y - 1  !Then the year should minus one
  Else
    month = mon
    year  = y
  End If          !e.g. 2012-01-01 is regarding as 2011-13-1
  y12=year/100
  y34=year-y12*100
  A=int(y34/4.0)
  B=int(y12/4.0)
  C=2*y12
  D=int(26*(month+1)/10.0)
  week=abs(mod((y34+A+B-C+D+day-1),7))
End Function GetWeekByDate
  !This program is mainly to obtain the weekday according to date
  !Made by destiny&samsara in 2016-09-02
Program www_fcode_cn
  Implicit None
  Character(len=64)::str=''
  Integer::year,month,day,week,GetWeekByDate
  Character(len=*) , parameter :: WeekCn = "日一二三四五六"
  Character(len=9) , parameter :: WeekEn(0:6) = &
      ["Sunday   ","Monday   ","Tuesday  ","Wednesday","Thursday ","Friday   ","Saturday "]
  Character(len=12)::time(3)
  Integer::date_time(8)
  Logical::t= .true.

  Do
    Call date_and_time(time(1), time(2), time(3), date_time) ! Obtain the date of today
    year =date_time(1) !Get the year of today
    month=date_time(2) !Get the month of today
    day  =date_time(3) !Get the day of today
    Call GetDate("Input the date(e.g. 2008 8 8, Press 'Enter' is today )",&
      year,month,day) ! Press 'Enter' for today or input by yourself
    Call JudgeDate( str,year ) ! Judge the common and leap year
    Call Judgeyear(year,month,day,t)  !Judge the year whether reasonable or not
    If (.not.t) then
      Write(*,"(a)") "Congratuation! Before 1582-10-15 doesn't exist the concept of date."
      Exit
    End if
    Call Judgemonth(month,t) !Judge the month whether reasonable or not
    If (.not.t) then
      Write(*,"(a,g0,1x,a)") 'Are you kidding? You creat the month of ',month,'?!'
      Exit
    End if
    Call Judgeday(str,year,month,day,t) !Judge the day whether reasonable or not
    If (.not.t) then
      Write(*,"(a,g0,a,g0,1x,a,1x,g0,1x,a)") "Don't you really think the date ",year,'-',month, "has",day, "days?!"
      Exit
    End if
    week = GetWeekByDate( year , month , day )
    Select Case(week)
    Case(0:6)
      Write(*,*) '今天是星期',WeekCn(week*2+1:week*2+2),'(Today is ',WeekEn(week),')'
    Case Default
      Write(*,*) 'error!please reput the correct year,month or day.'
    End Select
    Write(*,*) 'press q to exit,otherwise any other keys to continue'
    Read(*,*) str
    If (str=='q') Exit
  End Do
  read(*,*)
End Program www_fcode_cn

Subroutine GetDate( cStr, year, month, day )
  Implicit none
  Character(len=*) , intent(in)::cStr
  Integer ::year,month,day
  Integer input_year,input_month,input_day,ierr
  Character(len=60)::cRead
  Write(*,'(a)',advance='no') cStr
  Read(*,'(a60)') cRead
  If (len_trim(cRead)<=0) then   !Press 'Enter', then get today
    write(*,"(g0,a,g0,a,g0)") year,'-',month,'-',day
  End if
  Read(cRead,*,iostat=ierr) input_year,input_month,input_day
  If (ierr==0) then !The date obtaining through inputing by yourself
    year=input_year
    month=input_month
    day=input_day
    Write(*,"(g0,a,g0,a,g0)") year,'-',month,'-',day
  End if
End subroutine GetDate

Subroutine JudgeDate(str,in_year)
  Implicit none
  Integer,intent(in)::in_year
  Integer judgement1,judgement2,judgement3
  Character(len=60)::str
  judgement1=mod(in_year,400)
  judgement2=mod(in_year,100)
  judgement3=mod(in_year,4)
  If (judgement2==0) then
    If (judgement1==0) then
      str='leap'
    Else
      str='common'
    End if
  Else
    If (judgement3==0) then
      str='leap'
    Else
      str='common'
    Endif
  End if
End subroutine JudgeDate

Subroutine Judgeyear(year,month,day,t)
  Implicit none
  Logical t
  Integer year,month,day
  t = .true.
  If (year<1582) then
    t=.false.
    Return
  Elseif (year==1582 .and. month<10 ) then
    t=.false.
    Return
  Elseif (year==1582 .and. month==10 .and. day<15) then
    t=.false.
    Return
  End if
End subroutine Judgeyear

Subroutine Judgemonth(month,t)
  Implicit none
  Logical t
  Integer month
  t =  .not.(month>12 .or. month<1 )
End subroutine Judgemonth

Subroutine Judgeday(str,year,month,day,t)
  Implicit none
  Integer year,month,day
  Character(len=60),intent(in)::str
  Integer , save :: DayOfMonth(12) = [31,28,31,30,31,30,31,31,30,31,30,31]
  Logical t
  if ( trim(str)=='leap' ) then
    DayOfMonth(2) = 29
  else
    DayOfMonth(2) = 28
  end if
  t = .not.( day<1 .or. day> DayOfMonth(month) )
End subroutine Judgeday