home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / fortran / calndr.com / CALENDAR.FOR < prev    next >
Encoding:
Text File  |  1990-03-27  |  3.6 KB  |  140 lines
  1. C
  2. C  Returns the day-of-the-week (Sunday=1) of the given daten
  3. C
  4.       integer*4 function dayofwk (y, m, d)
  5. C
  6.       implicit none
  7.       integer*4 y, m, d, tmp1, tmp2
  8.       automatic tmp1, tmp2
  9.  
  10.       tmp1 = m + 10
  11.       tmp2 = y + (m - 14) / 12
  12.       dayofwk = mod ((13 * (tmp1 - tmp1 / 13 * 12) - 1) / 5 +
  13.      +          d + 77 + 5 * (tmp2 - tmp2 / 100 * 100) / 4 +
  14.      +          tmp2 / 400 - tmp2 / 100 * 2, 7) + 1
  15.       return
  16.       end
  17. C
  18. C  Return the day-of-the-year corresponding to the given date
  19. C
  20.       integer*4 function dayofyr (y, m, d)
  21. C
  22.       implicit none
  23.       integer*4 y, m, d, itmp
  24.       automatic itmp
  25.  
  26.       itmp = (m + 10) / 13
  27.       dayofyr = 3055 * (m + 2) / 100 - itmp * 2 - 91 +
  28.      +          (1 - (y - y / 4 * 4 + 3) / 4 +
  29.      +          (y - y / 100 * 100 + 99) / 100 -
  30.      +          (y - y / 400 * 400 + 399) / 400) *
  31.      +          itmp + d
  32.       return
  33.       end
  34. C
  35. C  Compute month and day given year and day-of-the-year
  36. C
  37.       subroutine calndr1 (dayofyr, y, m, d)
  38. C
  39.       implicit none
  40.       integer*4 dayofyr, y, m, d, t1, t2, t3, t4
  41.       automatic t1, t2, t3, t4
  42.  
  43.       t1 = 0
  44.       if (mod (y, 4) .eq. 0) t1 = 1
  45.       t2 = 0
  46.       if ((mod (y, 400) .eq. 0) .or.
  47.      +    (mod (y, 100) .ne. 0)) t2 = t1
  48.       t1 = 0
  49.       if (dayofyr .gt. t2 + 59) t1 = 2 - t2
  50.       t3 = dayofyr + t1
  51.       t4 = ((t3 + 91) * 100) / 3055
  52.       d = (t3 + 91) - (t4 * 3055) / 100
  53.       m = t4 - 2
  54.       return
  55.       end
  56. C
  57. C  Return the day-of-the-year of the first day of a given year and month
  58. C
  59.       function first_mon (y, m)
  60. C
  61.       implicit none
  62.       integer*4 first_mon, y, m, yy, dayofyr, dayofwk
  63.       automatic yy
  64.  
  65.       external dayofyr, dayofwk
  66.       yy = y
  67.       first_mon = dayofyr (yy, m, 1) + mod (9 - dayofwk (yy, m, 1), 7)
  68.       return
  69.       end
  70. C
  71. C  Compute month <m> and day-of-the-month <d> for Easter Sunday
  72. C  in a given year (yr>.
  73. C
  74.       subroutine easter (yr, m, d)
  75.       implicit none
  76.       integer*4 yr, t1, t2, t3, t4, t5, m, d
  77.       automatic t1, t2, t3, t4, t5
  78.  
  79.       t1 = mod(yr,19)
  80.       t2 = yr/100
  81.       t3 = mod(yr,100)
  82.       t4 = mod(19*t1+t2-t2/4-((t2-(t2+8)/25+1)/3)+15,30)
  83.       t5 = mod(32+2*mod(t2,4)+2*(t3/4)-t4-mod(t3,4),7)
  84.       t2 = t4+t5-7*((t1+11*t4+22*t5)/451)+114
  85.       m = t2/31
  86.       d = mod(t2,31)+1
  87.       return
  88.       end
  89. C
  90. C   Returns Julian day number for any Gregorian Calendar date *)
  91. C   GIVEN:   <y> - year <m> - month and <d> - day
  92. C
  93.       integer*4 function julday (y, m, d)
  94.       implicit none
  95.       integer*4 y, m, d, t1, t2, t3, t4
  96.       automatic t1, t2, t3, t4
  97. C
  98.       if (m .gt. 2) then
  99.          t1 = m - 3
  100.          t2 = y
  101.       else
  102.          t1 = m + 9
  103.          t2 = y - 1
  104.       endif
  105.       t3 = t2 / 100
  106.       t4 = mod (t2, 100)
  107.       julday = (146097 * t3) / 4 + (1461 * t4) / 4 +
  108.      +         (153 * t1 + 2) / 5 + d + 1721119
  109.       return
  110.       end
  111.  
  112. C
  113. C  Computes calendar date from a given Julian day number <julday> for
  114. C  any valid Gregorian calendar date <y>, <m>, <d>
  115. C
  116.       subroutine calndrj (julday, y, m, d)
  117.       implicit none
  118.       integer*4 julday, y, m, d, t1, t2
  119.       automatic t1, t2
  120.  
  121.       t1 = julday - 1721119 
  122.       y = (4 * t1 - 1) / 146097 
  123.       t1 = mod (4 * t1 - 1, 146097)
  124.       t2 = t1 / 4 
  125.       t1 = (4 * t2 + 3) / 1461 
  126.       t2 = mod (4 * t2 + 3, 1461)
  127.       t2 = (t2 + 4) / 4 
  128.       m = (5 * t2 - 3) / 153 
  129.       t2 = mod (5 * t2 - 3, 153)
  130.       d = (t2 + 5) / 5 
  131.       y = 100 * y + t1 
  132.       if (m .lt. 10) then
  133.         m = m + 3
  134.       else
  135.         m = m - 9 
  136.         y = y + 1
  137.       endif
  138.       return
  139.       end
  140.