home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / JULCAL.ZIP / JULCAL.PAS
Encoding:
Pascal/Delphi Source File  |  1988-05-06  |  4.8 KB  |  148 lines
  1. {Julian (sense 1) date routines, handling both Julian (sense 2) and
  2.   Gregorian calendars}
  3. {Algorithm is valid from 4713 B.C. to 19,999 A.D.}
  4. {Error-free translation based on error-free PL/I source}
  5. {Based on Pascal code copyright 1985 by Michael A. Covington,
  6.    published in P.C. Tech Journal, December 1985, based on formulae
  7.    appearing in Astronomical Formulae for Calculators by Jean Meeus}
  8. {Reconversion to normal Julian epoch, integer arithmetic and 4000-year
  9.    correction by John W. Kennedy}
  10. {Historical exceptions _not_ allowed for in this package:
  11.    Until Julius Caesar established the Julian calendar in 45 B.C.,
  12.        calendars were irregular.
  13.      This package assumes the Julian calendar back to 4713 B.C.
  14.    The Julian calendar was altered in 8 B.C.  From 45 B.C. to 8 B.C.,
  15.        the months were
  16.        Jan=31, Feb=29(30), Mar=31, Apr=30, May=31, Jun=30,
  17.        Jul=31, Aug=30,     Sep=31, Oct=30, Nov=31, Dec=30
  18.      This package assumes the month lengths as we know them.
  19.    Leap years from 45 B.C. to 8 A.D. were miscalculated:
  20.        (45, 42, 39, 36, 33, 30, 27, 24, 21, 18, 15, 12, 9, then none
  21.          at all until 8 A.D.)
  22.      This package assumes leap years every four years, as they were
  23.        meant to have been.
  24.    January 1 was not always the first day of the year.  The United
  25.        Kingdom, in particular, started the year on March 25 until 1752.
  26.        (However, the year ended on December 31, leaving the days between
  27.        in limbo.)
  28.      This package assumes January 1 is the first day of the year.
  29.    Leap-year day was originally done by having February 24 (25 from 45
  30.      to 8 B.C.) twice.
  31.      This package assumes Leap-year day is February 29.}
  32. {"Transition" argument is the first Julian date to be considered as
  33.      belonging to the Gregorian calendar.  Usual values are:
  34.        2299161 = October 5/15, 1582, as in Rome, or
  35.        2361222 = September 3/14, 1752, as in the United Kingdom and the
  36.          Colonies}
  37. Unit JULCAL;
  38. Interface
  39. Type
  40.   Year   = packed -4713..19999;
  41.   Month  = packed 1..12;
  42.   Day    = packed 1..31;
  43.   Date   = packed record
  44.     Y:             Year;
  45.     M:             Month;
  46.     D:             Day;
  47.   End;
  48.   Julian = 0..9026059;
  49.   Function JULDNJ (YMD:        Date;
  50.                    Transition: Julian):
  51.            Julian;
  52.   Function JULDN (YMD: Date):
  53.            Julian;
  54.   Function JULDND (YMD:        Date;
  55.                    Transition: Date):
  56.            Julian;
  57.   Procedure JULCDJ (J:          Julian;
  58.                     Var R:      Date;
  59.                     Transition: Julian);
  60.   Procedure JULCD (J:     Julian;
  61.                    Var R: Date);
  62.   Procedure JULCDD (J:          Julian;
  63.                     Var R:      Date;
  64.                     Transition: Date);
  65. Implementation
  66. Type
  67.   Absolute_year = 3..24715;
  68.   Function JULDNJ;
  69.   Type
  70.     Work_year =  -4714..19999;
  71.     Work_month = 3..14;
  72.     Work =       0..50000000;
  73.   Var
  74.     AY:          Work_year;
  75.     Y:           Absolute_year;
  76.     M:           Work_month;
  77.     D, G:        Julian;
  78.   Begin
  79.     AY := YMD . Y;
  80.     If AY < 0 then
  81.       Y := AY + 4717
  82.     Else
  83.       Y := AY + 4716;
  84.     If YMD . M < 3 then begin
  85.       M := Work (YMD . M) + 12;
  86.       Y := Y - 1;
  87.       AY := AY - 1
  88.     End
  89.     Else
  90.       M := Work (YMD . M);
  91.     D := (1461 * Work (Y)) shr 2 + (153 * (M + 1) div 5)
  92.          + Work (YMD . D) - 1524;
  93.     G := D + 2 - AY div 100 + AY div 400 - AY div 4000;
  94.     If G >= Transition then JULDNJ := G Else JULDNJ := D
  95.   End;
  96.   Function JULDN;
  97.   Begin
  98.     JULDN := JULDNJ (YMD, 2299161)
  99.   End;
  100.   Function JULDND;
  101.   Begin
  102.     JULDND := JULDNJ (YMD, JULDN (Transition))
  103.   End;
  104.   Procedure JULCDJ;
  105.   Type
  106.     Work =       0..200000000;
  107.     Work_month = 4..15;
  108.   Var
  109.     YMD:         Date;
  110.     AA, AB, A:   Julian;
  111.     B, D, EE:    Work;
  112.     C:           Absolute_year;
  113.     E:           Work_month;
  114.     Y:           Year;
  115.   Begin
  116.     If J < Transition then {Julian Calendar}
  117.       A := Work (J)
  118.     Else {Gregorian Calendar} begin
  119.       AA := J - 1721120;
  120.       AB := 31 * (AA div 1460969); AA := AA mod 1460969;
  121.       AB := AB + 3 * (AA div 146097); AA := AA mod 146097;
  122.       If AA = 146096 then AB := AB + 3 Else AB := AB + AA div 36524;
  123.       A := J + (AB - 2)
  124.     End;
  125.     B := A + 1524;
  126.     C := (20 * B - 2442) div 7305;
  127.     D := 1461 * Work (C) shr 2;
  128.     EE := B - D;
  129.     E := 10000 * EE div 306001;
  130.     YMD . D := Day (EE - 306001 * E div 10000);
  131.     If E >= 14 then
  132.       YMD . M := Month (E - 13)
  133.     Else
  134.       YMD . M := Month (E - 1);
  135.     If YMD . M > 2 then Y := C - 4716 Else Y := C - 4715;
  136.     If Y < 1 then YMD . Y := Year (Y - 1) Else YMD . Y := Year (Y);
  137.     R := YMD
  138.   End;
  139.   Procedure JULCD;
  140.   Begin
  141.     JULCDJ (J, R, 2299161)
  142.   End;
  143.   Procedure JULCDD;
  144.   Begin
  145.     JULCDJ (J, R, JULDN (Transition))
  146.   End;
  147. End.
  148.