module date_module
! Collected and put together January 1972,
! h. d. knoble.
! Original references are cited in each routine.
! Code converted using to_f90 by alan miller
! Date: 1999-12-22 time: 10:23:47
! Compatible with imagine1 f compiler: 2002-07-19
! At this time the functions and
! subroutines were as described below
! FUNCTION iday(yyyy, mm, dd) RESULT(ival)
! FUNCTION izlr(yyyy, mm, dd) RESULT(ival)
! SUBROUTINE calend(yyyy, ddd, mm, dd)
! SUBROUTINE cdate(jd, yyyy, mm, dd)
! SUBROUTINE daysub(jd, yyyy, mm, dd, wd, ddd)
! FUNCTION jd(yyyy, mm, dd) RESULT(ival)
! FUNCTION ndays(mm1, dd1, yyyy1,
! mm2, dd2, yyyy2) RESULT(ival)
! SUBROUTINE date_stamp( string, want_day, short )
! Code converted by ian chivers and jane sleightholme
! November 2004 - May 2005
! The changes are to go from
! working with integer variables
! for year, day and month to
! user defined date variables.
! .. Implicit None Statement ..
  implicit none
! ..
! .. Default Accessibility ..
  private
! ..
! .. Derived Type Declarations ..
  type, public :: date
    private
    integer :: day
    integer :: month
    integer :: year
  end type date
! ..
! .. Public Statements ..
  public :: calendar_to_julian, date_, date_stamp, date_to_day_in_year, &
    date_to_weekday_number, get_day, get_month, get_year, julian_to_date, &
    julian_to_date_and_week_and_day, ndays, year_and_day_to_date
! ..
! The above are the contained
! functions and subroutines
! in this module.
! Here is a short description of each one
! date_to_day_in_year - function
! returns the day in the year
! original arguments of day,month,year
! now date
! dayinyear
! date_to_weekday_number - function
! returns the week day number
! original argument d,m,y
! now date
! weekdaynum
! year_and_day_to_date - subroutine
! returns the day and month from
! year and day in year
! julian_to_date - subroutine
! returns a year_and_day_to_datear date from
! a julian date
! ndays - function
! returns the number of days between
! two dates
! julian_to_date_and_week_and_day - subroutine
! given a julian day this routine
! calculates year, month day and
! week day number and day number
! calendar_to_julian - function
! returns julian date from
! year_and_day_to_datear date
contains
! arithmetic functions "izlr" and "iday"
! are taken from remark on
! algorithm 398, by j. douglas robertson,
! cacm 15(10):918.
  function date_to_day_in_year(x)
! Convert from date to day in year
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    integer :: date_to_day_in_year
! ..
! .. Structure Arguments ..
    type (date), intent (in) :: x
! ..
! .. Intrinsic Functions ..
    intrinsic modulo
! ..
    date_to_day_in_year = 3055*(x%month+2)/100 - (x%month+10)/13*2 - 91 + &
      (1-(modulo(x%year,4)+3)/4+(modulo(x%year,100)+99)/100-(modulo( &
      x%year,400)+399)/400)*(x%month+10)/13 + x%day
  end function date_to_day_in_year
  function date_to_weekday_number(x)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    integer :: date_to_weekday_number
! ..
! .. Structure Arguments ..
    type (date), intent (in) :: x
! ..
! .. Intrinsic Functions ..
    intrinsic modulo
! ..
    date_to_weekday_number = modulo((13*(x%month+10-(x%month+10)/13*12)-1)/5+x &
      %day+77+5*(x%year+(x%month-14)/12-(x%year+(x%month-14)/12)/100*100)/4+(x &
      %year+(x%month-14)/12)/400-(x%year+(x%month-14)/12)/100*2,7)
  end function date_to_weekday_number
  function year_and_day_to_date(year,day) result (x)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    type (date) :: x
! ..
! .. Scalar Arguments ..
    integer, intent (in) :: day, year
! ..
! .. Local Scalars ..
    integer :: t
! ..
! .. Intrinsic Functions ..
    intrinsic modulo
! ..
    x%year = year
    t = 0
    if (modulo(year,4)==0) then
      t = 1
    end if
!------the following statement is
! necessary IF year is < 1900 or > 2100.
    if (modulo(year,400)/=0 .and. modulo(year,100)==0) then
      t = 0
    end if
    x%day = day
    if (day>59+t) then
      x%day = x%day + 2 - t
    end if
    x%month = ((x%day+91)*100)/3055
    x%day = (x%day+91) - (x%month*3055)/100
    x%month = x%month - 2
    if (x%month>=1 .and. x%month<=12) then
      return
    end if
! x%month will be correct
! iff day is correct for year.
    write (unit=*,fmt='(a,i11,a)') &
      '$$year_and_day_to_date: day of the year input =', day, &
      ' is out of range.'
  end function year_and_day_to_date
  function julian_to_date(julian) result (x)
! Given a julian day number the date is returned.
! julian is the julian date from an epoch
! in the very distant past. see cacm 1968 11(10):657,
! letter to the editor by fliegel and van flandern.
! .. Implicit None Statement ..
    implicit none
! ..
! .. Scalar Arguments ..
    integer, intent (in) :: julian
! ..
! .. Local Scalars ..
    integer :: l, n
! ..
! .. Function Return Value ..
    type (date) :: x
! ..
    l = julian + 68569
    n = 4*l/146097
    l = l - (146097*n+3)/4
    x%year = 4000*(l+1)/1461001
    l = l - 1461*x%year/4 + 31
    x%month = 80*l/2447
    x%day = l - 2447*x%month/80
    l = x%month/11
    x%month = x%month + 2 - 12*l
    x%year = 100*(n-49) + x%year + 1
  end function julian_to_date

  subroutine julian_to_date_and_week_and_day(jd,x,wd,ddd)
! given jd, a julian day # (see asf jd),
! this routine calculates dd,
! the day number of the month;
! mm, the month number; yyyy the year;
! wd the weekday number, and
! ddd the day number of the year.
! example:
! CALL julian_to_date_and_week_and_day
! (2440588, yyyy, mm, dd, wd, ddd)
! yields 1970 1 1 4 1.
! .. Implicit None Statement ..
    implicit none
! ..
! .. Scalar Arguments ..
    integer, intent (out) :: ddd, wd
    integer, intent (in) :: jd
! ..
! .. Structure Arguments ..
    type (date), intent (out) :: x
! ..
    x = julian_to_date(jd)
    wd = date_to_weekday_number(x)
    ddd = date_to_day_in_year(x)
  end subroutine julian_to_date_and_week_and_day
  function calendar_to_julian(x) result (ival)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    integer :: ival
! ..
! .. Structure Arguments ..
    type (date), intent (in) :: x
! ..
! date routine calendar_to_julian converts date to
! julian date. see cacm 1968 11(10):657,
! letter to the
! editor by henry f. fliegel and
! thomas c. van flandern.
! example calendar_to_julian(1970, 1, 1) = 2440588
    ival = x%day - 32075 + 1461*(x%year+4800+(x%month-14)/12)/4 + &
      367*(x%month-2-((x%month-14)/12)*12)/12 - 3*((x%year+4900+(x%month-14)/ &
      12)/100)/4
  end function calendar_to_julian
  function ndays(date1,date2)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    integer :: ndays
! ..
! .. Structure Arguments ..
    type (date), intent (in) :: date1, date2
! ..
! dates; that is mm1/dd1/yyyy1 minus
! mm2/dd2/yyyy2,
! where datei and datej have elements mm, dd, yyyy.
! ndays will be positive iff
! date1 is more recent than date2.
    ndays = calendar_to_julian(date1) - calendar_to_julian(date2)
  end function ndays
  subroutine date_stamp(string,want_day,short)
! Returns the current date as a character string
! e.g.
! want_day short string
! .TRUE. .TRUE. Thursday, 23 Dec 1999
! .TRUE. .FALSE. Thursday, 23 December 1999
! <- default/
! .FALSE. .TRUE. 23 Dec 1999
! .FALSE. .FALSE. 23 December 1999
! .. Implicit None Statement ..
    implicit none
! ..
! .. Scalar Arguments ..
    logical, optional, intent (in) :: short, want_day
    character (*), intent (out) :: string
! ..
! .. Local Scalars ..
    integer :: pos
    logical :: sh, want_d
! ..
! .. Local Arrays ..
    integer :: val(8)
    character (9) :: day(0:6) = (/ 'Sunday   ', 'Monday   ', 'Tuesday  ', &
      'Wednesday', 'Thursday ', 'Friday   ', 'Saturday '/)
    character (9) :: month(1:12) = (/ 'January  ', 'February ', 'March    ', &
      'April    ', 'May      ', 'June     ', 'July     ', 'August   ', 'September', 'October  ', &
      'November ', 'December '/)
! ..
! .. Intrinsic Functions ..
    intrinsic date_and_time, len_trim, present, trim
! ..
! .. Local Structures ..
    type (date) :: x
! ..
    want_d = .true.
    if (present(want_day)) want_d = want_day
    sh = .false.
    if (present(short)) sh = short
    call date_and_time(values=val)
    x = date_(val(3),val(2),val(1))
    if (want_d) then
      pos = date_to_weekday_number(x)
      string = trim(day(pos)) // ','
      pos = len_trim(string) + 2
    else
      pos = 1
      string = ' '
    end if
    write (string(pos:pos+1),'(i2)') val(3)
    if (sh) then
      string(pos+3:pos+5) = month(val(2)) (1:3)
      pos = pos + 7
    else
      string(pos+3:) = month(val(2))
      pos = len_trim(string) + 2
    end if
    write (string(pos:pos+3),'(i4)') val(1)
    return
  end subroutine date_stamp
  function date_(dd,mm,yyyy) result (x)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    type (date) :: x
! ..
! .. Scalar Arguments ..
    integer, intent (in) :: dd, mm, yyyy
! ..
    x = date(dd,mm,yyyy)
  end function date_
  function get_year(x)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    integer :: get_year
! ..
! .. Structure Arguments ..
    type (date), intent (in) :: x
! ..
    get_year = x%year
  end function get_year
  function get_month(x)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    integer :: get_month
! ..
! .. Structure Arguments ..
    type (date), intent (in) :: x
! ..
    get_month = x%month
  end function get_month
  function get_day(x)
! .. Implicit None Statement ..
    implicit none
! ..
! .. Function Return Value ..
    integer :: get_day
! ..
! .. Structure Arguments ..
    type (date), intent (in) :: x
! ..
    get_day = x%day
  end function get_day
end module date_module

program ch2206
! .. Use Statements ..
  use date_module, only : calendar_to_julian, date, date_, date_stamp, &
    date_to_day_in_year, date_to_weekday_number, get_day, get_month, get_year, &
    julian_to_date_and_week_and_day, ndays, year_and_day_to_date
! ..
! .. Implicit None Statement ..
  implicit none
! ..
! .. Local Scalars ..
  integer :: dd, ddd, i, mm, ndiff, wd, yyyy
  character (50) :: message
! ..
! .. Local Arrays ..
  integer :: val(8)
! ..
! .. Intrinsic Functions ..
! compute date this year for changing clocks
! back to est.
! i.e. compute date for the last
! Sunday in October for this year.
  intrinsic date_and_time
! ..
! .. Local Structures ..
  type (date) :: date1, date2, x
! ..
! The following no longer works as the data
! components of the type are private
! type (date) :: birthday=date_(11,2,1952)
! Test date_stamp
  message = ' date_stamp = '
  call date_stamp(message(15:))
  write (*,'(a)') message
  message = ' date_stamp = '
  call date_stamp(message(15:),want_day=.false.)
  write (*,'(a)') message
  message = ' date_stamp = '
  call date_stamp(message(15:),short=.true.)
  write (*,'(a)') message
  message = ' date_stamp = '
  call date_stamp(message(15:),want_day=.false.,short=.true.)
  write (*,'(a)') message
  call date_and_time(values=val)
  yyyy = val(1)
  mm = 10
  do i = 31, 26, -1
    x = date_(i,mm,yyyy)
    if (date_to_weekday_number(x)==0) then
      print *, 'turn clocks back to est on: '
      print *, i, ' October ', get_year(x)
      exit
    end if
  end do
! compute date this year for
! turning clocks ahead to dst
! i.e., compute date for the first
! Sunday in April for this year.
  call date_and_time(values=val)
  yyyy = val(1)
  mm = 4
  do i = 1, 8
    x = date_(i,mm,yyyy)
    if (date_to_weekday_number(x)==0) then
      print *, 'turn clocks ahead to dst on: '
      print *, i, ' April ', get_year(x)
      exit
    end if
  end do
  call date_and_time(values=val)
  yyyy = val(1)
  mm = 12
  dd = 31
  x = date_(dd,mm,yyyy)
! is this a leap year? i.e., is
! 12/31/yyyy the 366th day of the year?
  if (date_to_day_in_year(x)==366) then
    print *, get_year(x), ' is a leap year'
  else
    print *, get_year(x), ' is not a leap year'
  end if
  x = date_(1,1,1970)
  call julian_to_date_and_week_and_day(calendar_to_julian(x),x,wd,ddd)
  if (get_year(x)/=1970 .or. get_month(x)/=1 .or. get_day(x)/=1 .or. &
      wd/=4 .or. ddd/=1) then
    print *, 'julian_to_date_and_week_and_day failed'
    print *, ' date, wd, ddd = ', get_year(x), get_month(x), get_day(x), wd, &
      ddd
    stop
  end if
! difference between to same
! months and days over 1 leap year is 366.
  date1 = date_(22,5,1984)
  date2 = date_(22,5,1983)
  ndiff = ndays(date1,date2)
  yyyy = 1970
  x = year_and_day_to_date(yyyy,ddd)
  if (ndiff/=366) then
    print *, 'ndays failed; ndiff = ', ndiff
  else
! recover month and day
! from year and day number.
    if (get_month(x)/=1 .and. get_day(x)/=1) then
      print *, 'year_and_day_to_date failed'
      print *, ' mma, dda = ', get_month(x), get_day(x)
    else
      print *, '** date manipulation subroutines'
      print *, '** simple test ok.'
    end if
  end if
end program ch2206