home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / JULIAN.ZIP / JULIAN.PAS
Encoding:
Pascal/Delphi Source File  |  1988-04-10  |  32.6 KB  |  693 lines
  1. {$R+,S+,I+,D+,T+,F-,V+,B-,N-,L+ }
  2. UNIT Julian; {version 2.00 of 04/10/88}
  3. {
  4. This conversion by Carley Phillips (76630,3312) is placed in the PUBLIC DOMAIN.
  5.  
  6. This Turbo Pascal 4.0 unit provides the most general Gregorian calendar
  7. procedures I've seen.  A LongInt Julian day number is produced for any valid
  8. Gregorian calendar date without using tables of any kind.  And, of course,
  9. a reverse conversion is provided.  The mathematically valid range is
  10. 03-01-0000 through 12-31-65535.  See discussion below of when the Gregorian
  11. system actually was put into use.
  12.  
  13. The number of procedures provided here is deliberately restricted to a set of
  14. two time-tested critical calculations.  In fact, every routine in the package
  15. is based on the calculations in either MDYtoJul or JulToMDY.  The intent is
  16. partly to illustrate that these two procedures can then become the basis for
  17. more comprehensive set of procedures to determine the day of the week, test for
  18. a leap year, convert to/from ASCII, validate keyboard input, etc.  Another part
  19. of the concept behind these routines is that of isolating the hard stuff into
  20. only two places.
  21.  
  22. To summarize what is here:
  23.    primary procedures:
  24.    JulToMDY      - convert Julian day to month, day, year
  25.    MDYtoJul      - convert month, day, year to Julian day
  26.  
  27.    useful functions:
  28.    ValidJulToMDY - boolean function result plus above
  29.    ValidMDYtoJul - boolean function result plus above
  30.    DOWofJul      - day of week returned from Julian day
  31.    IsLeapYear    - true if year specified is leap year
  32.  
  33.    if an application can use a 179-year range of dates, here's what's needed:
  34.    IntToMDY      - integer day to month, day, year (user-selected base point)
  35.    MDYtoInt      - month, day, year to integer day (user-selected base point)
  36.    DOWofInt      - day of week returned from integer day
  37.  
  38.    and if you really need the serial day (1-366) for a year:
  39.    MDYtoSD       - convert month, day for specified year to serial day number
  40.    SDYtoMD       - convert serial day number and year to month, day
  41.  
  42.    the following procedures are provided in the form of comments FIY
  43.    IsLeapYearQ   - this package doesn't use it, but here is what it takes
  44.    ValidMDYQ     - an alternate way to validate dates (Scott Bussinger)
  45.    JulToMDYQ     - an alternate way to convert without using IF statements
  46.    MDYtoJulQ     - an alternate way to convert without using IF statements
  47.    ZellerQ       - day of week using Zeller's technique
  48.  
  49. The basic algorithms are based on those contained in the COLLECTED ALGORITHMS
  50. from Communications of the ACM, algorithm number 199, originally submitted
  51. by Robert G. Tantzen in the August, 1963 issue (Volume 6, Number 8).  Note
  52. that these algorithms do not take into account that years divisible by 4000
  53. are NOT leap years.  Therefore the calculations are only valid until
  54. 02-28-4000.  I would be interested in any references to refereed updates to
  55. Tantzen's formulas to support higher dates.
  56.  
  57. I have upgraded Tantzen's work on my own to include the years up to 65535.
  58. This upgrading is part of the reason for NOT using a mixture of methods.  By
  59. using the two upgraded routines for leap year, day of week, and all other
  60. derivative calculations, then at least any errors can only be in a small
  61. number of places.  By the way, I do NOT believe we will still be using the
  62. Gregorian calendar in the year 65535 or even in 4000.
  63.  
  64. The main part of Tantzen's original algorithm depends on treating January and
  65. February as the last months of the preceding year.  Then, one can look at a
  66. series of four years (for example, 3-1-84 through 2-29-88) in which the last
  67. day will be either the 1460th or the 1461st day depending on whether the 4-year
  68. series ended in a leap day.  If you're curious what years are leap years, see
  69. the commented function IsLeapYearQ.  However, Tantzen's formula and my additions
  70. to it avoid using this function directly.  In fact, the leap year function
  71. actually compiled here is based on simply testing if 2-29 is a valid day for
  72. the year in question by using the modified Tantzen formula.
  73.  
  74. An astronomers' Julian day number is a calendar system which is useful over
  75. a very large span of time.  (January 1, 1988 A.D. is 2,447,162 in this system.)
  76. The mathematics of these procedures originally restricted the valid range to
  77. March 1, 0000 through February 28, 4000.  The update in version 2.0 changes the
  78. valid end date to December 31, 65535.  Note that the Julian day number is not
  79. the same as the serial day number (1-366) which is sometimes (erroneously)
  80. called a Julian date.  Separate procedures are provided for the serial day.
  81.  
  82. The Julian day can be biased by a constant to produce any kind of sequential
  83. day number imaginable.  For example, the DOS date is based on 0 = 01-01-1980.
  84. If you subtract 2444240 from a Julian day, then you will get a number which is
  85. -32767 for 04-15-1890, 0 for 01-01-1980, and 32767 for 09-17-2069.  This means
  86. that, for many applications where a date range of 179 years is sufficient,
  87. you may put a shell around MTDtoJul to return integer dates (perhaps reserving
  88. -32768 to indicate an invalid or null date) rather than LongInts.
  89.  
  90. Such a routine is included here, but note that you must change the constant
  91. JulianInt from 2444240 to some other number if you want an integer range of
  92. dates different than that which DOS uses (that is, a range different from
  93. 04-15-1890 thru 09-17-2069).
  94.  
  95. From (among others) Ted Lassagne (70325,206) of Cor Communications comes the
  96. following historical information.  The Gregorian calendar was not in effect
  97. until 10-15-1582.  Great Britain did not change to the Gregorian system until
  98. 1752, Russia until 1918, and Turkey until 1928.
  99.  
  100. I found it interesting that the Gregorian-to-Julian and the Julian-to-Gregorian
  101. conversions can be done with no "if" tests at all.  Robert B. Wooster
  102. (72415,1602) had some routines in the Turbo 3 library which he thought
  103. required an 8087 chip, but are here converted to Turbo 4 integers with no
  104. problems.  He did not provide sufficient references to trace the code's
  105. history, but did make reference to being able to do the entire Gregorian
  106. to Julian conversion in a single assignment statement.  I've put it back in
  107. that form but left the range checking wrapped around the conversion statement.
  108. In any case, the implementation without "if"s requires more calculations, so
  109. they are included here in commented form just for the curious to peruse.  Note
  110. this algorithm has the same problem as Tantzen's (which it is apparently
  111. derived from) of not being valid past 02-28-4000.
  112.  
  113. There is a method attributed to Zeller which calculates the day of the week
  114. with relatively few calculations.  It is included here in a form I converted
  115. from ExDate by Ted Lassagne.  Note that (at least Lassagne's version of)
  116. Zeller's method does not work past 02-28-4000.
  117.  
  118. A check of BProgA DL 2 (Turbo Pascal 4) and DL 4 (other Turbo Pascals) on
  119. April 1, 1988, turned up the following files related to date conversions:
  120.  
  121. Zeller.Inc - restricted to 1901-2099 (Zeller = DOW for restricted date range)
  122. ExDate.Arc - 1-3999, but no validity checking (origin of ZellerQ)
  123. Date.Arc   - restricted to 1900-2078 (origin of ValidMDYQ)
  124. Calndr.Arc - Pascal demo program for Basic programmers, not general conversion
  125. NewJ1.Pas  - restricted to 1900 - 2079
  126. Julian.Pas - 1-3999, reals, no checks, no IFs (origin of JulToMDYQ & MDYtoJulQ)
  127. JDate.Pas  - restricted to 1900-2079, real arithmetic
  128. DD.Arc     - specialized routines with no error checking
  129. ReadSt.Arc - restricted to 1901 - 2099
  130. Day.Pas    - not conversion routines
  131. DayLib.Plb - restricted to 1888-2067, uses tables
  132.  
  133. Revision History:
  134.    2.00 (04-05-88)
  135.       a. Correction to Tantzen's original formula to correct for the fact that
  136.          years which are a multiple of 4000 are NOT leap years.  This allowed
  137.          expanding the valid range to 12-31-65535 in case anybody cares.
  138.       b. Major additions to initial comments.
  139.       c. Change in range of valid dates.
  140.       d. Change in method of some computations.
  141.       e. Addition of leap year test function.
  142.       f. Addition of Gregorian-to-integer, integer-to-Gregorian, and DOWofInt.
  143.       g. Addition of serial day conversion procedures.
  144.       h. Addition (as comments) of interesting no-if-statement conversions.
  145.       i. Addition (as comments) of other possibly interesting routines.
  146.    1.00 (original version)
  147.  
  148. When sufficient time has passed for comments, etc., the next planned step
  149. is to convert the two primary routines to inline since constructs such as
  150. (a div b) followed by (a mod b) are somewhat wasteful of processing time.
  151.  
  152. Comments, suggestions, bug reports, etc. should be sent on Compuserve (via
  153. EasyPlex since I'm not necessarily on every few days) to
  154.  
  155. Carley Phillips, 76630,3312.
  156. }
  157.  
  158. {*****************************************************************************}
  159. INTERFACE
  160. {*****************************************************************************}
  161.  
  162. const
  163.    {Do not change these constants}
  164.    JulianNull   = -1;    {Constant to indicate an invalid or null Julian day.}
  165.    IntDateNull  = -32768;{Constant to indicate an invalid or null integer day.}
  166.    SerialDayNull=  0;    {Constatn to indicate an invalid or null serial day.}
  167.  
  168. type
  169.    t_JulDay = longint;   {the basic Julian day type}
  170.    t_DOW    = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday,
  171.                InvalidDOW);
  172.  
  173. const
  174.    {This constant is the Julian day which is to correspond to an integer day=0}
  175.    {If you are using full 4-byte Julian day numbers, ignore this constant.}
  176.    {Do not set this value below 1,753,887 or above 25,624,808.}
  177.    JulianInt   = 2444240; {This is initially 01-01-1980 to match DOS.}
  178.  
  179. {
  180.    A couple of useful string constants.  Note that, handily, common
  181.    abbreviations for both day and month names can be obtained with
  182.    Copy (nameString[x], 1, 3);
  183. }
  184.    DOWString : array [t_DOW] of string[10] =
  185.       ('Sunday',   'Monday', 'Tuesday',  'Wednesday',
  186.        'Thursday', 'Friday', 'Saturday', 'InvalidDOW');
  187.    MonthString : array [1..12] of string[9] =
  188.       ('January', 'February', 'March',     'April',   'May',      'June',
  189.        'July',    'August',   'September', 'October', 'November', 'December');
  190.  
  191. {-----------------------------------------------------------------------------}
  192. procedure JulToMDY (    JDay  : t_JulDay; {valid Julian day number}
  193.                     var month : word;     {Gregorian month returned}
  194.                     var day   : word;     {Gregorian day   returned}
  195.                     var year  : word);    {Gregorian year  returned}
  196.   {--Converts an astronomer's Julian day to Gregorian month, day, and year.}
  197.   {--If you're not sure JDay is valid, then use ValidJulToMDY.}
  198.  
  199. {-----------------------------------------------------------------------------}
  200. procedure MDYtoJul (    month : word;      {Gregorian calendar month}
  201.                         day   : word;      {Gregorian calendar day}
  202.                         year  : word;      {Gregorian calendar year}
  203.                     var JDay  : t_JulDay); {Julian day number returned}
  204.   {--Converts Gregorian month, day, year to a Julian day number.}
  205.   {--If you're not sure month, day, year are valid then use ValidMDYtoJul.}
  206.  
  207. {-----------------------------------------------------------------------------}
  208. function ValidJulToMDY (JDay      : t_JulDay; {a Julian day number}
  209.                         var month : word;     {Gregorian month returned}
  210.                         var day   : word;     {Gregorian day   returned}
  211.                         var year  : word      {Gregorian year  returned}
  212.                        )          : boolean;  {true if the JDay is valid}
  213.   {--Returns true and the month, day, year if the Julian day is valid.}
  214.  
  215. {-----------------------------------------------------------------------------}
  216. function ValidMDYtoJul (    month : word;      {Gregorian calendar month}
  217.                             day   : word;      {Gregorian calendar day}
  218.                             year  : word;      {Gregorian calendar year}
  219.                         var JDay  : t_JulDay   {Julian day number returned}
  220.                        )          : boolean;   {true if month,day,year is valid}
  221.   {--Returns true and the Julian day number if month, day, year are valid.}
  222.  
  223. {-----------------------------------------------------------------------------}
  224. function DOWofJul (    JDay : t_JulDay  {valid Julian day number}
  225.                   )         : t_DOW;    {0 thru 6 for Sun thru Sat, 7=invalid}
  226.   {--Returns the day of the week (as an integer) of a valid Julian day number}
  227.  
  228. {-----------------------------------------------------------------------------}
  229. function IsLeapYear (year : word     {the year to be tested}
  230.                     )     : boolean; {true if year is a leap year}
  231.   {--Returns true if the year specified is a leap year}
  232.  
  233. {-----------------------------------------------------------------------------}
  234. procedure IntToMDY (    IDay  : integer;  {valid integer day number}
  235.                     var month : word;     {Gregorian month returned}
  236.                     var day   : word;     {Gregorian day   returned}
  237.                     var year  : word);    {Gregorian year  returned}
  238.   {--Converts an integer day to Gregorian month, day, and year.}
  239.  
  240. {-----------------------------------------------------------------------------}
  241. procedure MDYtoInt (    month : word;      {Gregorian calendar month}
  242.                         day   : word;      {Gregorian calendar day}
  243.                         year  : word;      {Gregorian calendar year}
  244.                     var IDay  : integer);  {Integer day number returned}
  245.   {--Converts Gregorian month, day, year to a integer day number.}
  246.   {--Valid range is + or - 32767 from JulianInt constant.  If this constant}
  247.   {--is 2444240, then positive values of IDay will match DOS day number.}
  248.  
  249. {-----------------------------------------------------------------------------}
  250. function DOWofInt (    IDay : integer   {valid integer day number}
  251.                   )         : t_DOW;    {0 thru 6 for Sun thru Sat, 7=invalid}
  252.   {--Returns the day of the week (as an integer) of a valid integer day number}
  253.  
  254. {-----------------------------------------------------------------------------}
  255. procedure SDYToMD (    SDay  : integer;  {valid serial day number}
  256.                        year  : word;     {valid year}
  257.                    var month : word;     {Gregorian month returned}
  258.                    var day   : word);    {Gregorian day   returned}
  259.   {--Converts a valid serial day and year to month and day.}
  260.  
  261. {-----------------------------------------------------------------------------}
  262. procedure MDYtoSD (    month : word;      {Gregorian calendar month}
  263.                        day   : word;      {Gregorian calendar day}
  264.                        year  : word;      {Gregorian calendar year}
  265.                    var SDay  : word);     {Serial day number returned}
  266.   {--Converts Gregorian month, day, year to 0 or a serial day number 1-366.}
  267.  
  268. (*
  269. {-----------------------------------------------------------------------------}
  270. {Note that these routines are commented out.  Interface was here for testing. }
  271. {-----------------------------------------------------------------------------}
  272. function IsLeapYearQ (year : word     {the year to be tested}
  273.                      )     : boolean; {true if year is a leap year}
  274.   {--Returns true if the year specified is a leap year}
  275.  
  276. {-----------------------------------------------------------------------------}
  277. function ValidMDYQ (    month : word;      {Gregorian calendar month}
  278.                         day   : word;      {Gregorian calendar day}
  279.                         year  : word       {Gregorian calendar year}
  280.                    )          : boolean;   {true if month, day, year is valid}
  281.   {--Returns true if month, day, year are valid for use with MDYtoJul.}
  282.  
  283. {-----------------------------------------------------------------------------}
  284. procedure JulToMDYQ (    JDay  : t_JulDay; {valid Julian day number}
  285.                      var month : word;     {Gregorian month returned}
  286.                      var day   : word;     {Gregorian day   returned}
  287.                      var year  : word);    {Gregorian year  returned}
  288.   {--Converts an astronomer's Julian day to Gregorian month, day, and year.}
  289.  
  290. {-----------------------------------------------------------------------------}
  291. procedure MDYtoJulQ (    month : word;      {Gregorian calendar month}
  292.                          day   : word;      {Gregorian calendar day}
  293.                          year  : word;      {Gregorian calendar year}
  294.                      var JDay  : t_JulDay); {Julian day number returned}
  295.   {--Converts Gregorian month, day, year to a Julian day number.}
  296.  
  297. {-----------------------------------------------------------------------------}
  298. function ZellerQ (month : word;
  299.                   day   : word;
  300.                   year  : word
  301.                  )      : t_DOW;
  302.   {--Return day of week of month, day, year using Zeller's method}
  303. *)
  304. {*****************************************************************************}
  305. IMPLEMENTATION
  306. {*****************************************************************************}
  307.  
  308. const
  309.    JulianConstant =  1721119; {constant for Julian day for 02-28-0000}
  310.    {numbers outside the following range can not be converted back to Gregorian}
  311.    JulianMin      =  1721120; {constant for Julian day for 03-01-0000}
  312.    JulianMax      = 25657575; {constant for Julian day for 12-31-65535}
  313.  
  314. {*****************************************************************************}
  315. procedure JulToMDY (    JDay  : t_JulDay; {valid Julian day number}
  316.                     var month : word;     {Gregorian month returned}
  317.                     var day   : word;     {Gregorian day   returned}
  318.                     var year  : word);    {Gregorian year  returned}
  319.   {--Converts an astronomer's Julian day to Gregorian month, day, and year.}
  320.   {--If you're not sure JDay is valid, then use ValidJulToMDY.}
  321. var
  322.    tmp1 : longint;
  323.    tmp2 : longint;
  324. begin {JulToMDY}
  325.    if (JulianMin <= JDay) and (JDay <= JulianMax) then
  326.       begin
  327.          tmp1  := JDay - JulianConstant; {will be at least 1}
  328.          year  := ((tmp1-1) div 1460969) * 4000;
  329.          tmp1  := ((tmp1-1) mod 1460969) + 1;
  330.          tmp1  := (4   *   tmp1) - 1;
  331.          tmp2  := (4   * ((tmp1 mod 146097) div 4)) + 3;
  332.          year  := (100 *  (tmp1 div 146097)) + (tmp2 div 1461) + year;
  333.          tmp1  := (5 * (((tmp2 mod 1461) + 4) div 4)) - 3;
  334.          month :=   tmp1 div 153;
  335.          day   := ((tmp1 mod 153) + 5) div 5;
  336.          if (month < 10) then
  337.             month  := month + 3
  338.          else
  339.             begin
  340.                month  := month - 9;
  341.                year := year + 1;
  342.             end {else}
  343.       end {if}
  344.    else
  345.       begin
  346.          month := 0;
  347.          day   := 0;
  348.          year  := 0;
  349.       end; {else}
  350. end; {JulToMDY}
  351.  
  352. {*****************************************************************************}
  353. procedure MDYtoJul (    month : word;      {Gregorian calendar month}
  354.                         day   : word;      {Gregorian calendar day}
  355.                         year  : word;      {Gregorian calendar year}
  356.                     var JDay  : t_JulDay); {Julian day number returned}
  357.   {--Converts Gregorian month, day, year to a Julian day number.}
  358.   {--If you're not sure month, day, year are valid then use ValidMDYtoJul.}
  359. var
  360.    tMon  : longint;
  361.    tYear : longint;
  362. begin {MDYtoJul}
  363.    if (month > 2) then
  364.       begin
  365.          tMon  := month - 3;
  366.          tYear := year;
  367.       end {if}
  368.    else
  369.       begin
  370.          tMon  := month + 9;
  371.          tYear := longint(year) - 1;
  372.       end; {else}
  373.    JDay  := (tYear div 4000) * 1460969;
  374.    tYear := (tYear mod 4000);
  375.    JDay  := JDay +
  376.             (((tYear div 100) * 146097) div 4) +
  377.             (((tYear mod 100) *   1461) div 4) +
  378.             (((153   *  tMon) +      2) div 5) +
  379.             day +
  380.             JulianConstant;
  381.    if (JDay < JulianMin) or (JulianMax < JDay) then
  382.       JDay := JulianNull;
  383. end; {MDYtoJul}
  384.  
  385. {*****************************************************************************}
  386. function ValidJulToMDY (JDay      : t_JulDay; {a Julian day number}
  387.                         var month : word;     {Gregorian month returned}
  388.                         var day   : word;     {Gregorian day   returned}
  389.                         var year  : word      {Gregorian year  returned}
  390.                        )          : boolean;  {true if the JDay is valid}
  391.   {--Returns true and the month, day, year if the Julian day is valid.}
  392. begin {ValidJulToMDY}
  393.    JulToMDY (JDay, month, day, year);
  394.    ValidJulToMDY := (month <> 0);
  395. end; {ValidJulToMDY}
  396.  
  397. {*****************************************************************************}
  398. function ValidMDYtoJul (    month : word;      {Gregorian calendar month}
  399.                             day   : word;      {Gregorian calendar day}
  400.                             year  : word;      {Gregorian calendar year}
  401.                         var JDay  : t_JulDay   {Julian day number returned}
  402.                        )          : boolean;   {true if month,day,year is valid}
  403.   {--Returns true and the Julian day number if month, day, year are valid.}
  404. var
  405.    tmon  : word;
  406.    tday  : word;
  407.    tyear : word;
  408. begin {ValidMDYtoJul}
  409.    MDYtoJul (month, day, year, JDay);
  410.    JultoMDY (JDay, tmon, tday, tyear);
  411.    ValidMDYtoJul := (tmon=month) and (tday=day) and (tyear=year);
  412. end; {ValidMDYtoJul}
  413.  
  414. {*****************************************************************************}
  415. function DOWofJul (    JDay : t_JulDay  {valid Julian day number}
  416.                   )         : t_DOW;    {0 thru 6 for Sun thru Sat, 7=invalid}
  417.   {--Returns the day of the week (as an integer) of a valid Julian day number}
  418. begin {DOWofJul}
  419.    if (JulianMin <= JDay) and (JDay <= JulianMax) then
  420.       DOWofJul := t_DOW (succ(JDay) mod 7)  {use DOS standard of 0=Sunday}
  421.    else
  422.       DOWofJul := InvalidDOW;
  423. end; {DOWofJul}
  424.  
  425. {*****************************************************************************}
  426. function IsLeapYear (year : word     {the year to be tested}
  427.                     )     : boolean; {true if year is a leap year}
  428.   {--Returns true if the year specified is a leap year}
  429. var
  430.    tJul : t_JulDay;
  431. begin {IsLeapYear}
  432.    IsLeapYear := ValidMDYtoJul (2, 29, year, tJul);
  433. end; {IsLeapYear}
  434.  
  435. {*****************************************************************************}
  436. procedure IntToMDY (    IDay  : integer;  {valid integer day number}
  437.                     var month : word;     {Gregorian month returned}
  438.                     var day   : word;     {Gregorian day   returned}
  439.                     var year  : word);    {Gregorian year  returned}
  440.   {--Converts an integer day to Gregorian month, day, and year.}
  441. begin {IntToMDY}
  442.    if IDay = IntDateNull then
  443.       JulToMDY (JulianNull, month, day, year)      {use to set m,d,y to 0}
  444.    else
  445.       JulToMDY (IDay+JulianInt, month, day, year);
  446. end; {IntToMDY}
  447.  
  448. {*****************************************************************************}
  449. procedure MDYtoInt (    month : word;      {Gregorian calendar month}
  450.                         day   : word;      {Gregorian calendar day}
  451.                         year  : word;      {Gregorian calendar year}
  452.                     var IDay  : integer);  {Integer day number returned}
  453.   {--Converts Gregorian month, day, year to a integer day number.}
  454.   {--Valid range is + or - 32767 from JulianInt constant.  If this constant}
  455.   {--is 2444240, then positive values of IDay will match DOS day number.}
  456. var
  457.    tJul : t_JulDay;
  458. begin {MDYtoInt}
  459.    IDay := IntDateNull;
  460.    if not ValidMDYtoJul (month, day, year, tJul) then
  461.       exit;
  462.    tJul := tJul - JulianInt;
  463.    if (-32767 <= tJul) and (tJul <= 32767) then
  464.       IDay := tJul;
  465. end; {MDYtoInt}
  466.  
  467. {*****************************************************************************}
  468. function DOWofInt (    IDay : integer   {valid integer day number}
  469.                   )         : t_DOW;    {0 thru 6 for Sun thru Sat, 7=invalid}
  470.   {--Returns the day of the week (as an integer) of a valid integer day number}
  471. begin {DOWofInt}
  472.    if (IDay <> IntDateNull) then
  473.       DOWofInt := t_DOW ((IDay + JulianInt + 1) mod 7)
  474.    else
  475.       DOWofInt := InvalidDOW;
  476. end; {DOWofInt}
  477.  
  478. {*****************************************************************************}
  479. procedure SDYToMD (    SDay  : integer;  {valid serial day number}
  480.                        year  : word;     {valid year}
  481.                    var month : word;     {Gregorian month returned}
  482.                    var day   : word);    {Gregorian day   returned}
  483.   {--Converts a valid serial day and year to month and day.}
  484. var
  485.    tJul  : t_JulDay;
  486.    tYear : word;
  487. begin {IntToMDY}
  488. {
  489.    As long as nobody mucks with SerialDayNull=0, then this is caught below.
  490.    if SDay = SerialDayNull then begin month := 0; day   := 0; exit; end;
  491. }
  492.    {We want 60-0 to 365-0 to work, so just treat 0 as 1 (neither are leap)}
  493.    if year = 0 then
  494.       inc(year); {local copy only!}
  495.    MDYtoJul (1,1,year,tJul); {what is January 1?}
  496.    JulToMDY (pred(tJul+SDay), month, day, tyear);
  497.    if tyear <> year then {serial day number was 0 or too large for year}
  498.       begin
  499.          month := 0;
  500.          day   := 0;
  501.       end;
  502. end; {IntToMDY}
  503.  
  504. {*****************************************************************************}
  505. procedure MDYtoSD (    month : word;      {Gregorian calendar month}
  506.                        day   : word;      {Gregorian calendar day}
  507.                        year  : word;      {Gregorian calendar year}
  508.                    var SDay  : word);     {Serial day number returned}
  509.   {--Converts Gregorian month, day, year to 0 or a serial day number 1-366.}
  510. var
  511.    tJul1 : t_JulDay;
  512.    tJul2 : t_JulDay;
  513. begin {MDYtoSD}
  514.    SDay := SerialDayNull;
  515.    {We want 3-1-0 to 12-31-0 to work, so just treat 0 as 1 (neither are leap)}
  516.    if year = 0 then
  517.       inc(year); {local copy only!}
  518.    if not ValidMDYtoJul (month, day, year, tJul1) then
  519.       exit;
  520.    MDYtoJul (1,1,year,tJul2); {what is January 1?}
  521.    SDay := succ(tJul1-tJul2);
  522. end; {MDYtoSD}
  523.  
  524. (*
  525. {*****************************************************************************}
  526. {NOTE THAT ALL OF THE 5 ROUTINES BELOW ARE COMMENTS FOR YOUR INFORMATION      }
  527. {       THEY MUST USE A JULIANMAXQ = 3,182,088 TO FUNCTION PROPERLY!          }
  528. {*****************************************************************************}
  529. const
  530.    JulianMaxQ     =  3182088; {constant for Julian day for 02-28-4000}
  531.  
  532. {*****************************************************************************}
  533. {
  534. This is the logical way of figuring this out with little math.
  535. }
  536. function IsLeapYearQ (year : word     {the year to be tested}
  537.                      )     : boolean; {true if year is a leap year}
  538.   {--Returns true if the year specified is a leap year}
  539. begin {IsLeapYearQ}
  540.    IsLeapYearQ :=  ((year mod   4) = 0) and ((year mod 4000) <> 0) and
  541.                   (((year mod 100) <> 0) or ((year mod  400) =  0));
  542. end; {IsLeapYearQ}
  543.  
  544. {*****************************************************************************}
  545. {
  546. Converted from a routine by Scott Bussinger.  Included here as comments
  547. simply to allow curious readers to see a different way to accomplish
  548. validation without actually getting a Julian day number and converting back.
  549. The code has been compiled and tested.  It produces the same results as
  550. ValidMDYtoJul over the same range except that a Julian day is not returned.
  551. Since Scott's version was for a 179 year or so range, so some tests were
  552. modified to get the range up to (almost) 65536 years.
  553. }
  554. function ValidMDYQ (    month : word;      {Gregorian calendar month}
  555.                         day   : word;      {Gregorian calendar day}
  556.                         year  : word       {Gregorian calendar year}
  557.                    )          : boolean;   {true if month, day, year is valid}
  558.   {--Returns true if month, day, year are valid for use with MDYtoJul.}
  559. var
  560.    tmon  : word;
  561.    tday  : word;
  562.    tyear : word;
  563. begin {ValidMDYQ}
  564.    if (Day=0) or (Month=0) or (Month>12) or ((Year=0) and (Month<3)) then
  565.       ValidMDYQ := false
  566.    else
  567.       case Month of
  568.          2:               ValidMDYQ := Day <= 28 + ord(IsLeapYearQ(year));
  569.          4,6,9,11:        ValidMDYQ := Day <= 30;
  570.          else             ValidMDYQ := Day <= 31;
  571.       end;
  572. end; {ValidMDYQ}
  573.  
  574. {*****************************************************************************}
  575. {
  576. Converted from a routine by Robert B. Wooster.  Included here as comments
  577. simply to allow curious readers to see a conversion without using "IF".
  578. The code has been compiled and tested.  It produces the same results as
  579. JulToJDY over the range from 03-01-0000 through 02-28-4000 but does not
  580. account for every 4000 years being a non-leap year.
  581. }
  582. procedure JulToMDYQ (    JDay  : t_JulDay; {valid Julian day number}
  583.                      var month : word;     {Gregorian month returned}
  584.                      var day   : word;     {Gregorian day   returned}
  585.                      var year  : word);    {Gregorian year  returned}
  586.   {--Converts an astronomer's Julian day to Gregorian month, day, and year.}
  587. var
  588.    tmp1 : longint;
  589.    tmp2 : longint;
  590.    tmp3 : longint;
  591.    tmp4 : longint;
  592. begin {JulToMDYQ}
  593.    if (JulianMin <= JDay) and (JDay <= JulianMaxQ) then
  594.       begin
  595.          tmp1  := JDay + 68569;
  596.          tmp2  := 4 * tmp1 div 146097;
  597.          tmp1  := tmp1 - ((146097 * tmp2 + 3) div 4);
  598.          tmp3  := 4000 * (tmp1+1) div 1461001;
  599.          tmp1  := tmp1 - (1461*tmp3 div 4) + 31;
  600.          tmp4  := 80 * tmp1 div 2447;
  601.          day   := tmp1 - (2447 * tmp4 div 80);
  602.          tmp1  := tmp4 div 11;
  603.          month := tmp4 + 2 -12 * tmp1;
  604.          year  := 100*(tmp2 - 49) + tmp3 + tmp1;
  605.       end {if}
  606.    else
  607.       begin
  608.          month := 0;
  609.          day   := 0;
  610.          year  := 0;
  611.       end; {else}
  612. end; {JulToMDYQ}
  613.  
  614. {*****************************************************************************}
  615. {
  616. Converted from a routine by Robert B. Wooster.  Included here as comments
  617. simply to allow curious readers to see a conversion without using "IF".
  618. The code has been compiled and tested.  It produces the same results as
  619. MDYtoJul over the range from 03-01-0000 through 02-28-4000 but does not
  620. account for every 4000 years being a non-leap year.  Wooster attributed
  621. the technique to a Fortran one-assignment statement conversion from a place
  622. which he did not specify.  The two-statement version here is simply to
  623. avoid repeating  a division 3 extra times.
  624. }
  625. procedure MDYtoJulQ (    month : word;      {Gregorian calendar month}
  626.                          day   : word;      {Gregorian calendar day}
  627.                          year  : word;      {Gregorian calendar year}
  628.                      var JDay  : t_JulDay); {Julian day number returned}
  629.   {--Converts Gregorian month, day, year to a Julian day number.}
  630. var
  631.    tmp : longint;
  632. begin {MDYtoJulQ}
  633.    tmp  := (longint(month) - 14) div 12;
  634.    JDay := longint(day) - 32075 +
  635.            (1461 * ( longint(year) + 4800 + tmp         ) div 4 ) +
  636.            ( 367 * ( longint(month) - 2   - tmp * 12    ) div 12) -
  637.            (   3 * ((longint(year) + 4900 + tmp) div 100) div 4);
  638.    if (JDay < JulianMin) or (JulianMaxQ < JDay) then
  639.       JDay := JulianNull;
  640. end; {MDYtoJulQ}
  641.  
  642. {*****************************************************************************}
  643. {
  644. Converted from a routine by Ted Lassagne.  Included here as comments simply
  645. to allow curious readers to see Zeller's technique for obtaining the day of
  646. the week by a different method.  The code has been compiled and tested.  It
  647. produces the same results as JulToDOW over the range from year 1 through
  648. year 3999 but does not account for every 4000 years being a non-leap year.
  649. }
  650. function ZellerQ (month : word;
  651.                   day   : word;
  652.                   year  : word
  653.                  )      : t_DOW;
  654.   {--Return day of week of month, day, year using Zeller's method}
  655. var
  656.    tyear  : longint;
  657.    tmonth : integer;
  658.    cen    : integer;
  659.    dow    : integer;
  660. begin {ZellerQ}
  661.    if (year >= 4000) then
  662.       begin
  663.          ZellerQ := InvalidDOW;
  664.          exit;
  665.       end;
  666.    if month < 3 then
  667.       begin
  668.          tmonth := month + 10;
  669.          tyear  := longint(year) -1
  670.       end
  671.    else
  672.       begin
  673.          tmonth := month - 2;
  674.          tyear  := year;
  675.       end;
  676.    cen   := tyear div 100;
  677.    tyear := tyear mod 100;
  678.    dow   := ((cen div 4) -
  679.              (2*cen) +
  680.              tyear +
  681.              (tyear div 4) +
  682.              ((26*tmonth - 2) div 10) +
  683.              day) mod 7;
  684.    ZellerQ := t_DOW((dow + 7) mod 7);
  685. end; {ZellerQ}
  686.  
  687. {*****************************************************************************}
  688. {NOTE THAT ALL OF THE ABOVE 5 ROUTINES ARE COMMENTS FOR YOUR INFORMATION      }
  689. {*****************************************************************************}
  690. *)
  691.  
  692. end.
  693.