unit DateProx { www.merlyn.demon.co.uk } ;

{ Turbo Pascal 7 / Borland Pascal 7 / Borland Pascal for Windows ;
  "The Delphi Magazine" #34 pp.24 ff. refers to this; the code on their
  included disc is derived partly from an earlier version of this.
  This code also compiles, and is moderately tested, in Delphi 3.

  Conversion of Modified Julian Date (MJD) to/from Gregorian/Julian/Civil
  (UK/Rome/Other) Calendar Date YYYY/MM/DD or "IBM" YYYY-DDD, using only
  well-known rules implemented by JRS; adjusted so that Gregorian Tuesday
  1995-10-10 is MJD 50000 (which I know to be so).  MJD 0 = 1858-11-17 GMT.
  Many other date-related functions.

  Algorithms are independent of TSFAQP and NRPAS;
  ** no floats are used ** (except, in Delphi, TDateTime; and for JDN).

  Year is sometimes type WrdYear, usually type IntYear.  In Pascal, routines
  generally exceed -30000 to +30000, but maybe not the full integer range;
  word likewise.  In Delphi, at least that.  LONGCALC.PAS has a much wider
  range.

  The code, on my 486dx33, may be a little slower than other methods; but
  most algorithms are manifest, fundamental, and adaptable.  Some users may
  prefer to remove Options and simplify for speed (cf. MJDtoYMD, YMDtoMJD).
  But remember that the linker omits unused items, and that this unit is
  sometimes updated.

  *** You should verify this code, especially for use before 8 A.D.,
  and across calendar changes. I use MJD_DATE.PAS and JUL_DATE.PAS.
  Parts have been tested against TSFAQP, AntiVivisektion, and others. ***

  For calendar info, see The Calendar FAQ by Claus Tondering - a link
  is now maintained at http://www.merlyn.demon.co.uk/datelinx.htm#CF -
  Peter Meyer's page, E G Richards' book; and other references at merlyn.

  Here, the Julian Calendar is what it was intended to be; it only
  agrees with the Civil Calendar in 45 B.C., then from 8 A.D. to
  1582/1752/whenever, except where RomanYears is used.

  Years are taken as Jan 1st .. Dec 31st, not always technically correct;
  our Legal / Civil Year started on Mar 25, the Historical Year on Jan 01.
  This uses Historical years only.

  RULES : G=Gregorian, J=Julian, C=Civil J-G :
  GJ  No Year Zero (except for some Astronomers).
  G.  Every 400 years contains Yrs400 days.
  G.  Every 100 years contains Yrs100 days, unless including xx00-02-29.
  G.  Every   4 years contains Yrs004 days, unless not including xxxx-02-29.
  .J  Every   4 years contains Yrs004 days.
  GJ  Every     year  contains Yrs001 days, unless including xxxx-02-29.
  G.  Gregorian 1995-10-10 => MJD 50000.
  .J  In Britain, 1752-09-03 to 13 were omitted;
  .J  Julian 1752-09-02 preceded Gregorian 1752-09-14; therefore
  .J  "Greg 1752-09-12 (MWS -160)" => MJD -38781 => Juln 1752-09-01.
  C   Last Julian (Rome) = 1582-10-04;
  C   Last Julian (England) = 1752-09-02;
  C   Juln/Greg transition will be wrong for Sweden, and possibly elsewhere.
  C   N.B. Julian was in use from 45 BC, incorrectly before 8 AD.
  C   Pre-Augustan month-lengths are ignored; year is Jan 1 - Dec 31.
  C   The French Revolutionary Calendar is utterly ignored.
  C   The Swedish/Finnish calendrical blunder of 1700-1712 is ignored.
  C   The Juln/Greg change malfunctions if the 1st of a month was missed.

  Only if Astr is set is the Year Zero included.  If Astr is changed, all
  corresponding pre-A.D. year numbers must be changed; or Astr must
  be set according to year notation.

  For various Gregorian & Julian Easter routines, see paschal.pas; faster,
  2001-11-12.  See also estrdate.htm zeller-c.htm etc.

  For Leap Years, also see leapyear.pas.

  Julian Day Number is the number of days that have elapsed since Julian
  Greenwich Mean Noon, Jan. 1, 4713 B.C.;  MJD = JDN - 2400000.5 .
  One must be specially careful with negative non-integer days.

  "At noon UTC on 1 January AD 2000, JDN 2,451,545 will start."

  At GMT, CJD = JDN + 0.5; CJD is civil days, Julian BC 4713-01-01 = 0.

  Using MJD rather than JDN avoids doubt with the odd half-day; MJD changes
  at about GMT midnight; for most uses, just ignore timezone and DST.

  Daylight Savings Time & Time Zones are ignored; change-days can be shown.

  Internally, a year from Mar to Feb is sometimes used; it's easier to have
  Feb 29 at the end.

  ISO 8601 days of the week are Mon=1..Sun=7.

  Where required, Week One is defined by giving a month and day that must
  be in it.  For ISO weeks, this is Jan 4th (and ISO Week 1 includes Jan 4).
  The UK Financial Year may have a week-count defined with April 6th.

  UK Inland Revenue Tax Weeks/Months are counted from April 6th
  being the first day of Week 1 and Month 1; months are all 6th..5th.

  Jointly, by default, my MJDtoYMD & MJDtoYMD are 4% slower than DecodeDate
  & EncodeDate (Delphi 3 Console App, Win 98 DOS box, PII/300); but, if
  FASTER is defined, mine becomes 10% faster than Delphi's.

  To convert to pure Delphi Gregorian, remove Options, and use the fact that
  1899-12-30 = TDateTime(0.0) to TDateTime(0.999...) = MJD 15018. Ware <c20.

  For MSDOS filestamps, use :- TP/BP: Pack/UnPack; Delphi: FileDate...

  Windows 98/NT, for filestamps, uses a count of 100 ns units from
  Mon AD 1601-01-01 00:00:00 Gregorian.  This fits into the "comp" type.
  Convert to days by D := Int(Count/8.64E11), etc.  OK to AD 30828.

  For some operations, more than one routine is provided.

  Can now give the MJD of the first full day of a Hebrew Calendar Year
  and vice versa; for more, see HEBCLNDR.PAS.

  Routines involving DAYS-OFF data can be optimised according to intended
  usage.  That section needs particular checking.

  If LOOKUP is defined at compile time, some fast conversions using table
  lookup become available.

  Delphi 6 will have a DateUtils unit, said to be ISO-8601 compliant. It
  includes WeekOfTheYear.

  Note that some Delphi has ShortMonthNames, LongMonthNames, ShortDayNames
  and LongDayNames.

  See my http://www.merlyn.demon.co.uk/miscdate.htm and its links.

  }

{ After Michael Salem for Pascal (but not if Divisor is const = 2^n) :
  For 2-byte quantities:
  var Quotient, Dividend, Divisor, Remainder : word ;
  Quotient := Dividend div Divisor ;
  asm  mov word ptr Remainder,DX  end ;

  For 4-byte quantities:
  var Quotient, Dividend, Divisor, Remainder : LongInt ;
  Quotient := Dividend div Divisor ;
  asm  mov word ptr Remainder,CX ; mov word ptr Remainder+2,BX  end ;
  }

{ Delphi Week Number code also in
  http://home.t-online.de/home/PeterJHaas/Download/DTWeek.zip
  }

{$I Version.pas}

interface

{$IFDEF DELPHI} uses Dialogs, SysUtils ; {$ENDIF}

const UDP = '   Unit DATEPROX.PAS >= 2008-01-19.' ;

type
MJDate = longint ;
IntYear = integer {for signed year} ;
WrdYear = word  {for unsigned year} ;
NearYear = 1901..2099 ;
Part = byte {for M D H M S WN WD};
TWeekNo = shortint {or Part?} ;
OrdDate = word ;
{ Most, but not necessariy all, of the code will work with other
  reasonable choice combinations. }

Calendar = (Gregorian, Julian, Civil) ;
Options = record Cal : Calendar ; Astr : boolean end ;
ChangeDate = (British, Romish, Finnish, Other) ;
WkDys = (Sun0, Mon, Tue, Wed, Thu, Fri, Sat, Sun7) { allows 0..6, 1..7 } ;
HolShift = (Preceding, Nearest, Following) ;
Seasons = (Winter, Spring, Summer, Autumn) ;
WNrec = record
  Case byte of 0: (LI : longint) ; 1: (WN : word ; YN : IntYear) end ;

const
Sun = Sun0 ;
WkDstr : array [WkDys] of string [3] =
  ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat', 'Sun') ;
MonthS : array [1..12] of string [3] =
  ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec') ;
DateSep = '-' { YYYYxMMxDD } ;
JulnSep = '/' { YYYYxDDD } ;
CalName : array [Calendar] of string [9] =
  ('Gregorian', 'JulianCal', 'CivilDate') ;
ChngName : array [ChangeDate] of string [7] =
  ('British', 'Romish', 'Finnish', 'Other') ;
SeasName : array [Seasons] of string [6] =
  ('Winter', 'Spring', 'Summer', 'Autumn') ;


CivCal : Options = (Cal:Civil; Astr:false) ;
JulCal : Options = (Cal:Julian; Astr:false) ;
GrgCal : Options = (Cal:Gregorian; Astr:false) ;


(* Utility *)

procedure GetNow(var Yr, Mo, Dy, Hr, Mn, Sc : word) ;


(* JDN & CJD functions *)

procedure RJDNtoMJDandFrac
  (const RJDN : extended ; var MJD : MJDate ; var Frcn : extended) ;

procedure RCJDtoCMJDandFrac
  (const RCJD : extended ; var CMJD : MJDate ; var Frcn : extended) ;

function MJDandFracToRJDN
  (const MJD : MJDate ; const Frcn : extended) : extended ;

function CMJDandFracToRCJD
  (const CMJD : MJDate ; const Frcn : extended) : extended ;

function YMDtoCJD(const Y : IntYear ; M, D : Part) : longint ;
{ Convert Gregorian Years Months Days to JDN+0.5 }

function ChrJulDate(const Y : IntYear ; M, D : Part) : longint ;
{ ditto }

procedure CJDtoYMD(const X : longint ; var Y : IntYear ; var M, D : Part) ;
{ Convert JDN+0.5 to Gregorian Years Months Days }

procedure YrMoNorm(var Y, M : longint) ;
{ Bring M to 1..12 }

function AnyYMDtoMJD(IY, IM, ID : longint) : MJDate ;
{ IM ID can be out-of-range }


(* Functions returning Day of Week *)

function MJDDayOfWeek(const MJDy : MJDate) : WkDys {Sun=0..Sat=6}
  { MJD prefixed 20080119 to avoid clash with D3 SysUtils } ;

function ISODoW1(const MJDy : MJDate) : Part {Mon=1..Sun=7} ;

function SvenDOW(Yr, M, D : word) : word {Sun=0..Sat=6} ;

function Zeller(Year : WrdYear ; const Month, Day: Part ) : WkDys {0..6} ;

function EchtZeller(const Cal : Calendar ; J, m, q : word) : Part { ISO } ;

function ZelCMJD(Y, M, D : word) : longint ;

function Zel_DoW(Y, M : word ; const D : word) : word ;


(* Y M D to MJD *)

function YMDtoMJD(Yr : IntYear ; Mo : Part ; const Dy : Part) : MJDate ;
{ Convert Gregorian Years Months Days to MJD, first principles shown }

function LongYMDtoMJD(const Yr : longint ; const Mo, Dy : Part) : MJDate ;
{ Convert Gregorian Years Months Days to MJD, first principles shown }

function GD_MJD(const YY : IntYear ; const MM, DD : Part) : MJDate ;
{ Convert Gregorian Years Months Days to MJD, first principles shown }

{$IFDEF LOOKUP}

function PC_YMD2MJD0(Yr : NearYear ; Mo : Part ; const Dy : Part) : MJDate ;

function PC_YMD2MJD1(Yr : NearYear ; Mo : Part ; const Dy : Part) : MJDate ;

{$ENDIF LOOKUP}

function YMD_to_MJD(Opts : Options ;
  Yr : IntYear ; Mo : Part ; const Dy : Part) : MJDate ;

function LongYMD_to_MJD(Opts : Options ;
  Yr : longint ; Mo : Part ; const Dy : Part) : MJDate ;

function JPC_MJD(const Y : WrdYear ; const M, D : Part) : MJDate ;


(* MJD to Y M D *)

procedure MJD_to_YMD(const Opts : Options ; MJDy : MJDate ;
  var Yr : IntYear ; var Mo, Dy : Part) ;

procedure MJDtoYMD(MJDy : MJDate ;
  var Yr : IntYear ; var Mo, Dy : Part) ;
{ Convert MJD to Gregorian Years Months Days }

procedure MJDtoLongYMD(MJDy : MJDate ;
  var Yr : longint ; var Mo, Dy : Part) ;
{ Convert MJD to Gregorian Years Months Days }


(* Day-of-year routines *)

procedure DateOfDayNo(const Opts : Options ; const DDD : OrdDate ;
  const Yr : IntYear ; var Mo, Dy : Part) ;

procedure MJD_to_YD(const Opts : Options ; const MJDy : MJDate ;
  var YYYY : IntYear ; var DDD : OrdDate) ;

function YD_to_MJD(const Opts : Options ;
  const YYYY : IntYear ; const DDD : OrdDate) : MJDate ;


(* String output functions *)

function YearStr(const Astr : boolean ; const Yr : IntYear) : string ;

function DateStr(const Astr : boolean ;
  const Yr : IntYear; const Mo, Dy : Part) : string ;

function MJDateStr(const Opts : Options ; const MJD : MJDate) : string ;

function TimeStr(const H, M, S : Part) : string ;

function JDateStr(const Astr : boolean ;
  const Yr : IntYear; const DDD : OrdDate) : string ;


(* String input functions *)

function GetYearOK(var Yr : IntYear ; var Ndx : byte ;
  const Astr : boolean ; const St : string) : boolean ;

function ReadYMDdate(const Astr : boolean ; const St : string ;
  var Yr : IntYear ; var Mo, Dy : Part) : boolean ;

function ReadYDdate(const Astr : boolean ; const St : string ;
  var Yr : IntYear ; var DDD : OrdDate) : boolean ;


(* Leap Year functions *)

function Leap_Year(Opts : Options ; Y : IntYear) : boolean ;
function Greg_Leap_Year(const Y : WrdYear) : boolean ;
function PC_Leap_Year(const Y : NearYear) : boolean ;


(* Validation etc. *)

function Ulti_Mo(const Opts : Options ;
  const Yr : IntYear ; const Mo : Part) : Part ;
{ Last Day of Month }

function Valid_Date(const Opts : Options ;
  const Yr : IntYear ; const Mo, Dy : Part) : boolean ;

function PC_Day_Valid(const Y : NearYear ; M, D : word) : boolean ;


(* Date Arithmetic *)

procedure Incr_Date(const Opts : Options ;
  var Yr : IntYear ; var Mo, Dy : Part ; const By : MJDate) ;

function Date_Diff(const Opts : Options ;
  const Y1 : IntYear ; const M1, D1 : Part ;
  const Y2 : IntYear ; const M2, D2 : Part) : MJDate ;

procedure YMD_Diff(const Opts : Options ;
  const Y1 : IntYear ; const M1, D1 : Part ;
  const Y2 : IntYear ; const M2, D2 : Part ;
  var DY : IntYear ; var DM, DD : Part) { Dubious } ;


procedure InitialiseDates { *** Use after changing calendar details *** } ;

procedure ReportAnError(const ErrorCode : byte) ;

function First_Thurs(const Opts : Options ; const Yr : IntYear) : Part ;

function PC_ThuOne(const Y : NearYear) : Part ;

function PC_Thu_One(const Y : NearYear) : Part ;

function PC_ISOweekCount(const Y : NearYear) : Part ;

function PC_ISOweek_Count(const Y : NearYear) : Part ;

function NthXdayOfMonth(const Opts : Options ;
  const Yr : IntYear ; const Mo, N : byte ; const X : WkDys) : Part ;

function Nth_XdayOfMonth(const Opts : Options ;
  const Yr : IntYear ; const Mo, N : byte ; const X : WkDys) : Part ;

{$IFDEF DELPHI}
function NXDM(const Nth, Xday, Month, Year : word) : TDateTime ;
{$ENDIF}

function DayOfYear(const Opts : Options ;
  const Yr : IntYear ; const Mo, Dy : Part) : OrdDate ;

procedure WkNo_Start(const Opts : Options ; const N : TWeekNo ;
  var Yr : IntYear ; var M, D : Part ; const MS, DS : Part ;
  const FD : WkDys) ;


procedure ISO_Week_Num(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; const M, D : Part) ;

procedure JSWeekNo(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; M, D : Part) ;

procedure CTWeekNo(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; const M, D : Part) ;

function CTWeekNoF(const Opts : Options ;
  const Yr : IntYear ; const M, D : Part) :
{$IFDEF PASCAL} longint {$ENDIF} {$IFDEF DELPHI} WNrec {$ENDIF} ;

procedure Gen_Week_Num(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; const M, D, MS, DS : Part ; const FD : WkDys) ;

{$IFDEF DELPHI}

procedure
  ISO_Week_NumD(var N : TWeekNo ; var Yr : IntYear ; const M, D : Part) ;

procedure
  JSWeekNoD(var N : TWeekNo ; var Yr : WrdYear ; M, D : word) ;

// Good pair, Jan 2008 :

procedure ISODTtoYWD(const DT : TDateTime ; out YN, WN, DN : word) ;

function ISOYWDtoDT(const YN, WN, DN : word) : TDateTime ;

{$ENDIF DELPHI}

function ISO_WNDtoMJD
  (const Opts : Options ; const Y : IntYear ; const N, D : Part) : MJDate ;

procedure ISO_Week_Num_Day
  (const Opts : Options ; const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;

procedure CTWeekNo_Day
  ({const Opts : Options ;} const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;


(* UK IR Tax Dating *)

procedure UKTaxWeekNo {undertested}
  (const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;

function UKTax_WNDtoMJD(const Y : IntYear ; const N, D : Part) : MJDate ;


procedure UKTaxMonthDay {undertested}
  (const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var MN : shortint ; var DN : Part) ;

function UKTax_WMDtoMJD(Y : IntYear ; M, D : Part) : MJDate ;


(***
  procedure JSWeekNo_Day
  (const Opts : Options ; const Y : IntYear ;       M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;

  procedure Gen_Week_Num_Day
  (const Opts : Options ; const Y : IntYear ; const M, D : Part ;
  const MS, DS : Part ; const FD : WkDys ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;

  {$IFDEF DELPHI}

  procedure ISO_Week_NumD_Day
  (const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;

  procedure JSWeekNoD_Day
  (const Y : WrdYear    ;       M, D : word ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;

  {$ENDIF DELPHI}
  ***)

function LastSun(const Yr : IntYear ; const Mo, Ult : Part)
  { Last Sunday of Year Month, given last Day } : Part ;

function YearNear(const Y : IntYear) : boolean ;
{ Y in NearYear }

function EUSTon(const Y : NearYear) : Part ;
{ Day of March for EU Summer Time ON }

function EUSToff(const Y : NearYear) : Part ;
{ Day of October for EU Summer Time OFF }


procedure JulianEaster(const Yr : WrdYear ; var Mo, Dy : Part)
  { Julian Easter Month and Day, from Year } ;

procedure LongJulianEaster(const Yr : longint ; var Mo, Dy : Part)
  { Julian Easter Month and Day, from Year } ;

(*
  procedure Easter0(const Yr : WrdYear ; var Mo, Dy : Part)
  { Gregorian Easter Month and Day, from Year }  ;
  *)

procedure GregorianEaster(const Yr : WrdYear ; var Mo, Dy : Part)
  { Gregorian Easter Month and Day, from Year }  ;

procedure LongGregorianEaster(const Yr : longint ; var Mo, Dy : Part)
  { Gregorian Easter Month and Day, from Year }  ;

{$IFDEF DELPHI}
function NearEaster(const Year : NearYear) : TDateTime
  { Gregorian Easter Month and Day, from Year in (1900) 1901-2099 }  ;
{$ENDIF}


function LZ(const Q : Part) : string
  { Number to two-digit string } ;

function TrueCal(Opts : Options ; const MJDy : MJDate) : Calendar ;
{ Returns Julian or Gregorian }

function Season21(const Mo, Dy : Part) : Seasons
  { Assumes Seasons start in 21st of 3 6 9 12; Northern } ;

function OZ(const J : Seasons) : Seasons
  { Invert Seasons, for Southern } ;

procedure MJDtoAbsWeek(const MJD : MJDate ; var Q : longint ; var R : Part)
  { converts MJD to Week (0..) and Day (1..7) from 0001-01-01 Mon } ;


(* Time Routines *)

function HMS_to_Seconds(const H, M, S : Part) : longint ;
{ Convert Hours Minutes Seconds to Seconds }

procedure Seconds_to_HMS(const Sx : longint ; var H, M, S : Part) ;
{ Convert Seconds to Hours Minutes Seconds }

function DS_to_Seconds(const Dy : word ; const S : longint) : longint ;
{ Convert Days Seconds to Seconds }

function Seconds_to_DS(const Sx : longint ; var D : word) : longint ;
{ Convert Seconds to Days Seconds }


(* Jewish/Hebrew Calendar Functions - see HEBCLNDR.PAS *)

type HebrYr = 1..5879542 { Max HY for MJD in MJDate = longint } ;

function HYtoMJD(const Y : HebrYr) : MJDate ;

function MJDtoHY(const MJD : MJDate) : HebrYr ;


(* Holidays routines - check with care *)

type PHolsList = ^HolsListEl ;
HolsListEl = record Next : PHolsList ; DayNo : MJDate end ;


function IsWeekDay(const MJD : MJDate) : boolean ;

function IsHoliday(P : PHolsList ; const MJD : MJDate) : boolean ;

function IsWorkDay(const P : PHolsList ; const MJD : MJDate) : boolean ;

procedure MakeDayOff(var Yr : IntYear ; var Mo, Dy : Part ;
  const HS : HolShift)
  { Nearest weekday before / to / after given date ; caveat Boxing Day ! } ;

procedure ReadDaysOffFile(var HolsList : PHolsList) ;

procedure WorkDaysFromTo(const HolsList : PHolsList ;
  MJD1, MJD2 : MJDate ; const BV1, BV2 : boolean ;
  var WeekDays, WorkDays : longint ; var Safe : boolean) ;

procedure WorkDaysAfter(const HolsList : PHolsList ;
  MJD1 : MJDate ; const BV1 : boolean ;
  WorkDays : longint ; var MJD3 : MJDate ; var Safe : boolean) ;

procedure WorkDaysFrom(const HolsList : PHolsList ;
  MJD1 : MJDate ; const BV1 : boolean ;
  WorkDays : longint ; var MJD3 : MJDate ; var Safe : boolean) ;

procedure WorkDaysOnwards(const HolsList : PHolsList ;
  MJD1, MJD2 : MJDate ; const BV1, BV2 : boolean ;
  var WeekDays, WorkDays : longint ; var Safe : boolean) ;



const
LastBrit =  -38780 {MJD} ;
LastFinn =  -38612 {MJD} ;
LastRome = -100841 {MJD} ;

const {variable}
LastJulianMJD : array [ChangeDate] of MJDate
  = (LastBrit, LastRome, LastFinn, 0) ;
ChangeDay : ChangeDate = British ;
RomanYears : boolean = false ;


var ChangeData : array [ChangeDate] of
record CY : IntYear ; CMth, LastJ, FirstG : Part end ;



implementation   {$B-}

{$IFDEF PASCAL} uses Dos ; {$ENDIF}

const
BaseYr = -32000 ;
BaseMo =  3 {Mar} ;
LastMo = 14 {Feb} ;
Yrs001 =           365 ;
Yrs004 = Yrs001* 4 + 1 ;
Yrs100 = Yrs004*25 - 1 ;
Yrs400 = Yrs100* 4 + 1 { 146097 } ;
GregBias = ( { MJD +50000 => Greg 1995/10/10 }
  Yrs400*(((1995-BaseYr)        ) div 400) +
  Yrs100*(((1995-BaseYr) mod 400) div 100) +
  Yrs004*(((1995-BaseYr) mod 100) div   4) +
  Yrs001*(((1995-BaseYr) mod   4)        ) +
  31+30+31+30+31+31+30 + 10 ) - 50000 ;
JulnBias = ( { MJD -38781 => Juln 1752/09/01 }
  Yrs004*(((1752-BaseYr)        ) div   4) +
  Yrs001*(((1752-BaseYr) mod   4)        ) +
  31+30+31+30+31+31    +  1 ) + 38781 ;

Bias : array [Gregorian..Julian] of MJDate = (GregBias, JulnBias) ;

DaysInMonth : array [0..Pred(LastMo)] of Part =
  (31, {} 31, 28, {} 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31{, Feb}) ;

var
DaysFromDec : array [1..12] of OrdDate ;
DaysFromFeb : array [BaseMo..LastMo] of OrdDate ;


procedure GetNow(var Yr, Mo, Dy, Hr, Mn, Sc : word) ;
var {$IFDEF DELPHI} DT : TDateTime ; {$ENDIF}
{$IFDEF PASCAL} DoW, X, {$ENDIF} fs : word ;
begin
  {$IFDEF PASCAL} { from NOWMINUS }
  GetDate(Yr, Mo, Dy, DoW) ;
  repeat X := DoW ;
    GetTime(Hr, Mn, Sc, fs) ; GetDate(Yr, Mo, Dy, Dow) until DoW=X ;
  {$ENDIF PASCAL}
  {$IFDEF DELPHI} DT := Now ;
  DecodeTime(DT, Hr, Mn, Sc, fs) ; DecodeDate(DT, Yr, Mo, Dy) ;
  {$ENDIF DELPHI}
  end {GetNow} ;


(* CJD to/from CMJD untested *)

procedure Split(const R, N : extended ; var D : MJDate ; var F : extended) ;
{ Correct; but not optimum accuracy }
var T : extended ;
const Big = 32768*366 { ? enough ? Year is Pascal/Delphi integer } ;
begin T := R - N + Big ; D := Trunc(T) - Big ; F := Frac(T) end {Split} ;

procedure RCJDtoCMJDandFrac
  (const RCJD : extended ; var CMJD : MJDate ; var Frcn : extended) ;
begin Split(RCJD, 2400001.0, CMJD, Frcn) end {RCJDtoCMJDandFrac} ;

procedure RJDNtoMJDandFrac
  (const RJDN : extended ; var MJD : MJDate ; var Frcn : extended) ;
begin Split(RJDN, 2400000.5, MJD, Frcn) end {RJDNtoMJDandFrac} ;

function CMJDandFracToRCJD
  (const CMJD : MJDate ; const Frcn : extended) : extended ;
begin CMJDandFracToRCJD := 2400001.0 + CMJD + Frcn end {CMJDandFracToRCJD} ;

function MJDandFracToRJDN
  (const MJD : MJDate ; const Frcn : extended) : extended ;
begin MJDandFracToRJDN := 2400000.5 + MJD + Frcn end {MJDandFracToRJDN} ;



function YMDtoCJD(const Y : IntYear ; M, D : Part) : longint ;
begin YMDtoCJD :=
    (longint(1461)*(Y+4800+(M-14) div 12)) div 4
    + (367*(M-2-12*((M-14) div 12))) div 12
    - (3*((Y+4900+(M-14) div 12) div 100)) div 4
    + D - 32075 ;
  end {YMDtoCJD - from http://www.hermetic.ch/cal_stud/jdn.htm } ;

procedure CJDtoYMD(const X : longint ; var Y : IntYear ; var M, D : Part) ;
var L : longint ; J, K, N : integer ;
begin
  L := X + 68569 ;
  N := (4*L) div 146097 ;
  L := L - (146097*N+3) div 4 ;
  K := (4000*(L+1)) div 1461001 ;
  L := L - (longint(1461)*K) div 4 + 31 ;
  J := (80*L) div 2447 ;
  D := L - (2447*J) div 80 ;
  L := J div 11 ;
  M := J + 2 - 12*L ;
  Y := 100*(N-49) + K + L ;
  end {CJDtoYMD - from .../jdn.htm } ;


procedure YrMoNorm(var Y, M : longint) ;
{ Bring M to 1..12 ; use in such as DateSerial }
var YM : longint ;
begin
  YM := Y*12 + M - 1 ;
  Y := YM div 12 ; M := 1 + YM mod 12 end {YrMoNorm} ;


function AnyYMDtoMJD(IY, IM, ID : longint) : MJDate ;
  begin
  YrMoNorm(IY, IM) ;
  AnyYMDtoMJD := YMDtoMJD(IY, IM, 0) + ID ;
  end {AnyYMDtoMJD} ;


function ChrJulDate(const Y : IntYear ; M, D : Part) : longint ;
{ Unknown source, adapted }
var Yr : longint ;
begin { OK after -1-02-28 }
  Yr := Y { for range } ;
  ChrJulDate := 367 * Yr
    - 7 * (Yr + (M + 9) div 12) div 4
    - 3 * ((Yr + (M - 9) div 7) div 100 + 1) div 4
    + 275 * M div 9 + D - 730516 + 2451545 end {ChrJulDate} ;


(* Day of Week *)

function MJDDayOfWeek(const MJDy : MJDate) : WkDys ;
begin MJDDayOfWeek := WkDys((MJDy+987654321) mod 7) end {MJDDayOfWeek} ;


function ISODoW1(const MJDy : MJDate) : Part { Mon=1..Sun=7 } ;
begin ISODoW1 := Succ((MJDy+Pred(987654321)) mod 7) end {ISODoW1} ;


function SvenDOW(Yr, m, d : word) : word { Greg: Sven Pran, altered by JRS } ;
begin if m<3 then begin Inc(m, 12) ; Dec(Yr) end ;
  SvenDOW := 1 + ( ( (3*m + 3) div 5 ) + 2*m + d + Yr +
    (Yr div 4) - (Yr div 100) + (Yr div 400) ) mod 7 ;
  end {SvenDOW} ;


function Zeller(Year : WrdYear ; const Month, Day: Part ) : WkDys {0..6} ;
{ I had not seen Christian Zeller's own version }
var M, C, D, N : byte ;
begin
  M := 1 + (Month+9) mod 12 ; if M>10 then Dec(Year) ;
  C := Year div 100; D := Year mod 100 ;
  N := ((13*M-1) div 5 + 1 + D + D div 4 + C div 4 + 5 * C) mod 7 ;
  { N is true Zeller? }
  Zeller := WkDys((N+Day+6) mod 7) end {Zeller} ;


function EchtZeller(const Cal : Calendar ; J, m, q : word) : Part {ISO} ;
var K, h : word ;
begin
  { Directly from Zeller's AM article, SK & JRS : }
  if m < 3 then begin Inc(m, 12) ; Dec(J) end ;
  K := J mod 100 ; J := J div 100 ;
  h := q + (m+1)*26 div 10 + K + K div 4 ;
  case Cal of
    Julian    : h := h +    5    + 6*J ; { was   -J; +6*J avoids negative }
    Gregorian : h := h + J div 4 + 5*J ; { was -2*J; +5*J avoids negative }
    else RunError(245) end ;
  { Now adjust to ISO 8601} EchtZeller := Succ((h+5) mod 7) ;
  end {EchtZeller} ;


function ZelCMJD(Y, M, D : word) : longint ;
  begin { Inc(Y, 7e5) ; Dec(Result, 7e5*365.2425) ;; 153 = 13 + 5*28 }
  if M<3 then begin Inc(M, 12) ; Dec(Y) end ;
  ZelCMJD := longint(Y)*365 - 678973 + (D + (M*153-2) div 5 +
    Y div 4 - Y div 100 + Y div 400) end {ZelCMJD} ;


function Zel_DoW(Y, M : word ; const D : word) : word ;
  begin { Inc(Y, 7e5) }
  if M<3 then begin Inc(M, 12) ; Dec(Y) end ;
  Zel_DoW := (Y + 1 + D + (M*13-2) div 5 +
    Y div 4 - Y div 100 + Y div 400) mod 7 end {Zel_DoW} ;


procedure MakeDayOff(var Yr : IntYear ; var Mo, Dy : Part ;
  const HS : HolShift)
  { Nearest weekday before / to / after given date ; caveat Boxing Day ! } ;
var MJD : MJDate ;
begin
  MJD := YMDtoMJD(Yr, Mo, Dy) ;
  if MJDDayOfWeek(MJD) in [Sat, Sun] then begin
    MJD := Ord(HS) + MJD - 1 ;
    case MJDDayOfWeek(MJD) of
      Sat : Dec(MJD) ;
      Sun : Inc(MJD) ;
      end ;
    MJDtoYMD(MJD, Yr, Mo, Dy) ;
    end ;
  end {MakeDayOff} ;


procedure ReportAnError(const ErrorCode : byte) ;
var S : string [90] ;
begin Str(ErrorCode, S) ;
  S := 'ErrorCode ' + S +
    ' (see program source) - impossible input value (I hope)' ;
  {$IFDEF PASCAL} Writeln(^G^M^J + S + ^G) ; {$ENDIF}
  {$IFDEF DELPHI} ShowMessage(S) ; {$ENDIF}
  end {ReportAnError} ;


function TrueCal(Opts : Options ; const MJDy : MJDate) : Calendar ;
begin with Opts do begin
    if Cal=Civil then if MJDy>LastJulianMJD[ChangeDay]
      then Cal := Gregorian else Cal := Julian ;
    TrueCal := Cal end end {TrueCal} ;


procedure MJD_to_YMD(const Opts : Options ; MJDy : MJDate ;
  var Yr : IntYear ; var Mo, Dy : Part)
  { Modified Julian Day to Gregorian/Julian/Civil Y, M, D
  - from <32000 B.C. to >32000 A.D. } ;
var T : longint ;
procedure MoveDays(const D, Y, N : longint)
  { Reduce MJDy by up to N steps of D, counting in Yr } ;
begin T := MJDy div D ; if T>N then Dec(T) {Feb 29 } { T:=N ? } ;
  Inc(Yr, T*Y) ; Dec(MJDy, T*D) end {MoveDays} ;
var Cal : Calendar ;
begin Cal := TrueCal(Opts, MJDy) ;
  Inc(MJDy, Pred(Bias[Cal])) ;
  if MJDy>MJDate(2)*(-BaseYr)*Succ(Yrs001) then ReportAnError(232) ;
  if MJDy<0 then ReportAnError(233) ;
  Yr := BaseYr ; Mo := BaseMo ;
  if Cal=Gregorian then begin
    MoveDays(Yrs400, 400, MaxLongInt) ; MoveDays(Yrs100, 100, 3) end {Greg} ;
  MoveDays(Yrs004,   4, MaxLongInt) ; MoveDays(Yrs001,   1, 3) ;
  repeat T := MJDy-DaysInMonth[Mo] ; if T<0 then BREAK ;
    MJDy := T ; Inc(Mo) until Mo=LastMo {Feb is long enough} ;
  Dy := Succ(MJDy) ;
  if Mo>12 then begin Dec(Mo, 12) ; Inc(Yr) end ;
  if not Opts.Astr then if Yr<1 then Dec(Yr) { No Year Zero } ;
  end {MJD_to_YMD} ;


procedure MJDtoLongYMD(MJDy : MJDate ;
  var Yr : longint ; var Mo, Dy : Part) ;
{ Convert MJD to positive Gregorian Years Months Days }
var { MJD : MJDate ;} LY : longint ; GY : IntYear ;
begin
  if MJDy<=0 then LY := 0 else
    begin LY := 400*(MJDy div Yrs400) ; MJDy := MJDy mod Yrs400 end ;
  MJDtoYMD(MJDy, GY, Mo, Dy) ; Yr := GY+LY ;
  end {MJDtoLongYMD} ;




procedure MJDtoYMD(MJDy : MJDate ; var Yr : IntYear ; var Mo, Dy : Part)
  { Modified Julian Day to Gregorian Y M D - from 1 A.D. to >32000 A.D. } ;
var X : longint ; Y : WrdYear ; MJ : word absolute MJDy ;
{$IFDEF SLOWER} T : integer ; {$ENDIF}
begin
  Inc(MJDy, GregBias-1) ; Yr := BaseYr ; Mo := BaseMo ;
  {$IFDEF FASTER}

  X := MJDy div Yrs400 ;
  { Dec(MJDy, X*Yrs400) ; }
  {$IFDEF PASCAL}
  asm  mov word ptr MJDy,cx ; mov word ptr MJDy+2,bx  end ; {$ENDIF}
  {$IFDEF DELPHI}
  asm  mov dword ptr MJDy,edx  end ; {$ENDIF}
  Inc(Yr, X*400) ;

  X := MJDy div Yrs100 ; if X>3 then X := 3 { XX00/02/29 } ;
  Inc(Yr, X*100) ; Dec(MJDy, X*Yrs100) ;

  { MJDy is now < Yrs100 so fits in a word }

  Y := MJ div Yrs004 ;
  { Dec(MJ, Y*Yrs004) ; } asm  mov word ptr MJDy,dx  end ;
  Inc(Yr, Y*004) ;

  Y := MJ div Yrs001 ; if Y>3 then Y := 3 { XXXX/02/29 } ;
  Inc(Yr, Y    ) ; Dec(MJ, Y*Yrs001) ;

  {$ELSE}
  X := MJDy div Yrs400 ;
  Inc(Yr, X*400) ; Dec(MJDy, X*Yrs400) ;
  X := MJDy div Yrs100 ; if X>3 then X := 3 { XX00/02/29 } ;
  Inc(Yr, X*100) ; Dec(MJDy, X*Yrs100) ;
  { MJDy is now < Yrs100 so fits in a word }
  Y := MJ div Yrs004 ;
  Inc(Yr, Y*004) ; Dec(MJ, Y*Yrs004) ;
  Y := MJ div Yrs001 ; if Y>3 then Y := 3 { XXXX/02/29 } ;
  Inc(Yr, Y    ) ; Dec(MJ, Y*Yrs001) ;
  {$ENDIF}
  {$IFNDEF SLOWER}
  Mo := (MJ shr 5) + BaseMo ;
  if (Mo<LastMo) and (DaysFromFeb[Succ(Mo)]<=MJ) then Inc(Mo) ;
  Dy := Succ(MJ) - DaysFromFeb[Mo] ;
  {$ELSE}
  repeat T := integer(MJ)-DaysInMonth[Mo] ; if T<0 then BREAK ;
    MJ := T ; Inc(Mo) until Mo=LastMo {Feb is long enough} ;
  Dy := Succ(MJ) ;
  {$ENDIF}
  if Mo>12 then begin Dec(Mo, 12) ; Inc(Yr) end ;
  end {MJDtoYMD} ;


function YMD_to_MJD(Opts : Options ;
  Yr : IntYear ; Mo : Part ; const Dy : Part) : MJDate
  { Gregorian/Julian/Civil Y, M, D to Modified Julian Day
  - from <32000 B.C. to >32000 A.D. } ;
var MJDy : MJDate ;
var Anni : WrdYear ;
procedure DayMoves(const D : longint ; Y : WrdYear)
  { Increase MJDy by steps of D per Y Years } ;
begin Inc(MJDy, (Anni div Y)*D) ; Anni := Anni mod Y end {DayMoves} ;
var M : Part ;
begin with Opts do begin
    if (Mo=0) or (Mo>12) or (Dy=0) or (Dy>31) then ReportAnError(230) ;
    if Cal=Civil then with ChangeData[ChangeDay] do
      if (Yr>CY) or ((Yr=CY) and ((Mo>CMth) or ((Mo=CMth) and (Dy>LastJ))))
      then Cal := Gregorian else Cal := Julian ;
    if not Astr then if Yr<1 then Inc(Yr) { No Year Zero } ;
    if Mo<BaseMo then begin Inc(Mo, 12) ; Dec(Yr) end ;
    if Yr<BaseYr then ReportAnError(235) ;
    Anni := longint(Yr) - BaseYr ; MJDy := -Bias[Cal] ;
    if Cal=Gregorian then begin
      DayMoves(Yrs400, 400) ; DayMoves(Yrs100, 100) end {Greg} ;
    DayMoves(Yrs004,   4) ; Inc(MJDy, Anni*Yrs001) ;
    for M := BaseMo to Pred(Mo) do Inc(MJDy, DaysInMonth[M]) ;
    YMD_to_MJD := MJDy + Dy end end {YMD_to_MJD} ;


function LongYMD_to_MJD(Opts : Options ;
  Yr : longint ; Mo : Part ; const Dy : Part) : MJDate
  { Gregorian/Julian/Civil Y, M, D to Modified Julian Day
  - from <32000 B.C. to >32000 A.D. PLUS, undertested } ;
var MJDy : MJDate ;
var Anni : longint ;
procedure DayMoves(const D : longint ; Y : WrdYear)
  { Increase MJDy by steps of D per Y Years } ;
begin Inc(MJDy, (Anni div Y)*D) ; Anni := Anni mod Y end {DayMoves} ;
var M : Part ;
begin with Opts do begin
    if (Mo=0) or (Mo>12) or (Dy=0) or (Dy>31) then ReportAnError(230) ;
    if Cal=Civil then with ChangeData[ChangeDay] do
      if (Yr>CY) or ((Yr=CY) and ((Mo>CMth) or ((Mo=CMth) and (Dy>LastJ))))
      then Cal := Gregorian else Cal := Julian ;
    if not Astr then if Yr<1 then Inc(Yr) { No Year Zero } ;
    if Mo<BaseMo then begin Inc(Mo, 12) ; Dec(Yr) end ;
    if Yr<BaseYr then ReportAnError(235) ;
    Anni := longint(Yr) - BaseYr ; MJDy := -Bias[Cal] ;
    if Cal=Gregorian then begin
      DayMoves(Yrs400, 400) ; DayMoves(Yrs100, 100) end {Greg} ;
    DayMoves(Yrs004,   4) ; Inc(MJDy, Anni*Yrs001) ;
    for M := BaseMo to Pred(Mo) do Inc(MJDy, DaysInMonth[M]) ;
    LongYMD_to_MJD := MJDy + Dy end end {LongYMD_to_MJD} ;


function LongYMDtoMJD(const Yr : longint ; const Mo, Dy : Part) : MJDate ;
{ Convert Gregorian Years Months Days to MJD }
begin
  LongYMDtoMJD := YMDtoMJD(Yr mod 400, Mo, Dy) + (Yr div 400) * Yrs400 ;
  end {LongYMDtoMJD} ;


function YMDtoMJD(Yr : IntYear ; Mo : Part ; const Dy : Part) : MJDate
  { Gregorian Y M D to Modified Julian Day - from 1 A.D. to >32000 A.D. } ;
var MJDy : MJDate ; Anni : WrdYear ;
{$IFDEF FASTER} T : word ; {$ENDIF}
{$IFDEF SLOWER} M : byte ; {$ENDIF}

begin
  if Mo<BaseMo then begin Inc(Mo, 12) ; Dec(Yr) end ;
  Anni := longint(Yr) - BaseYr ; MJDy := -GregBias ;
  {$IFDEF FASTER}

  T := Anni div 400 ; asm  mov word ptr Anni,dx  end ;
  Inc(MJDy, longint(T)*Yrs400) ;

  T := Anni div 100 ; asm  mov word ptr Anni,dx  end ;
  Inc(MJDy, longint(T)*Yrs100) ;

  Inc(MJDy, (Anni shr 2)*Yrs004) ;

  Inc(MJDy, (Anni and 3)*Yrs001) ;

  {$ELSE}
  Inc(MJDy, longint(Anni div 400)*Yrs400) ; Anni := Anni mod 400 ;
  Inc(MJDy, longint(Anni div 100)*Yrs100) ; Anni := Anni mod 100 ;
  Inc(MJDy, longint(Anni div 004)*Yrs004) ; Anni := Anni mod 004 ;
  Inc(MJDy, Anni*Yrs001) ;
  {$ENDIF}
  {$IFNDEF SLOWER}
  YMDtoMJD := Dy + DaysFromFeb[Mo] + MJDy ;
  {$ELSE}
  for M := BaseMo to Pred(Mo) do Inc(MJDy, DaysInMonth[M]) ;
  YMDtoMJD := MJDy + Dy ;
  {$ENDIF}
  end {YMDtoMJD} ;


{ From: Garry Deane <garrydeane_at_yahoo.com.au>
  Newsgroups: alt.msdos.batch.nt
  Subject: Re: Formatting a date
  Date: Tue, 19 Mar 2002 05:52:16 GMT
  Message-ID: <3c96d206.19894667@192.168.0.2>

  @echo off
  setlocal
  set dd=19
  set mm=3
  set yy=2002
  :: Modified Julian Day 0 on 17 Nov, 1858 is a Wednesday
  set Days=WedThuFriSatSunMonTue
  set /a z=14-mm,z/=12
  set /a jy=yy-z
  set /a jm=12*z+mm-3
  set /a mjd=153*jm+2,mjd/=5
  set /a mjd=mjd+dd+365*jy+jy/4-jy/100+jy/400-678882
  set /a "DoW=mjd%%7"
  set /a DoW*=3
  call set DoW=%%Days:~%DoW%,3%%
  echo %DoW%
  }

function GD_MJD(const YY : IntYear ; const MM, DD : Part) : MJDate ;
var JY, MJD : longint ; JM : integer ;
begin
  JY := YY - Ord(MM<3) ;
  JM := (MM+9) mod 12 ;
  MJD := (153*JM+2) div 5 ;
  GD_MJD := MJD + DD + 365*JY + JY div 4 - JY div 100 + JY div 400 - 678882 ;
  end {GD_MJD} ;


{$IFDEF LOOKUP}

var
MJDTable0 : array [NearYear, 1..12] of longint ;
MJDTable1 : array [0..3, 1..12] of longint ;


function PC_YMD2MJD0(Yr : NearYear ; Mo : Part ; const Dy : Part) : MJDate
  { Gregorian Y M D to Modified Julian Day - from 1901 A.D. to 2099 A.D. } ;
begin
  PC_YMD2MJD0 := MJDTable0[Yr, Mo] + Dy ;
  { for wider range, add something like ((Yr-Ord(Mon<3)) div 100)*3 div 4 ; }
  end {PC_YMD2MJD0} ;


function PC_YMD2MJD1(Yr : NearYear ; Mo : Part ; const Dy : Part) : MJDate
  { Gregorian Y M D to Modified Julian Day - from 1901 A.D. to 2099 A.D. } ;
begin
  PC_YMD2MJD1 := longint(Yr div 4)*1461 + MJDTable1[Yr mod 4, Mo] + Dy ;
  { for wider range, add something like ((Yr-Ord(Mon<3)) div 100)*3 div 4 ; }
  end {PC_YMD2MJD1} ;

{$ENDIF LOOKUP}



function JPC_MJD(const Y : WrdYear ; const M, D : Part) : MJDate
  { Valid 1897/03/01 to 2100/02/28 inclusive ONLY ; the extension back to
  1897 happens because the argument of "div" goes negative. } ;
const MonthStarts : array [1..12] of word = { Jan+Feb into previous year }
  (15384,15415,15078,15109,15139,15170,15200,15231,15262,15292,15323,15353) ;
{ Jan   Feb   Mar   Apr   May   Jun   Jul   Aug   Sep   Oct   Nov   Dec }
begin
  JPC_MJD := ((longint(Y)-1900-Ord(M<3))*1461) div 4 + MonthStarts[M] + D ;
  end { Derived from JPC by JRS; "optimised" for integers ; maybe fast } ;



function YD_to_MJD(const Opts : Options ;
  const YYYY : IntYear ; const DDD : OrdDate) : MJDate
  { IBM's julian date format YYYY-DDD } ;
begin YD_to_MJD := YMD_to_MJD(Opts, YYYY, 1, 1)+Pred(DDD) end {YD_to_MJD} ;


function GetCivilCal(const Y : IntYear) : Calendar ;
begin
  GetCivilCal := Calendar(Y<ChangeData[ChangeDay].CY) end {GetCivilCal} ;


function Leap_Year(Opts : Options ; Y : IntYear) : boolean ;
const RL = [44, 41, 38, 35, 32, 29, 26, 23, 20, 17, 14, 11, 8] ;
var LY : longint ;
begin with Opts do begin
    if (Y<0) and not Astr then Inc(Y) { No AD 0 } ;

    if Cal=Civil then begin
      if Y<-44 then begin Leap_Year := False ; EXIT end else
        if RomanYears then
        if Y<=0 then begin Leap_Year := -Y in RL ; EXIT end else
        if Y<8 then begin Leap_Year := False ; EXIT end ; {}
      Cal := GetCivilCal(Y) end ;

    LY := 1000000+Y { to make mod correct for neg prol Greg year } ;
    Leap_Year := ((LY and 3) = 0) and
      ( (Cal=Julian) or ((LY mod 100 > 0) or (LY mod 400 = 0)) ) ;
    end end {Leap_Year - Civil may not be OK in some transition years?} ;


function Greg_Leap_Year(const Y : WrdYear) : boolean ;
begin
  Greg_Leap_Year :=
    ((Y and 3) = 0) and ((Y mod 100 > 0) or (Y mod 400 = 0)) ;
  end {Greg_Leap_Year} ;


function PC_Leap_Year(const Y : NearYear) : boolean ;
begin PC_Leap_Year := (Y and 3) = 0 end {PC_Leap_Year - PC 1980-2099 only} ;


function DayOfYear(const Opts : Options ;
  const Yr : IntYear ; const Mo, Dy : Part) : OrdDate ;
var DoY : OrdDate ;
begin
  DoY := Dy + DaysFromDec[Mo] + Ord((Mo>2) and Leap_Year(Opts, Yr)) ;
  if Opts.Cal=Civil then with ChangeData[ChangeDay] do
    if (Yr=CY) and ((Mo>CMth) or ((Mo=CMth) and (Dy>LastJ)))
    then Dec(DoY, FirstG-LastJ-1) ;
  DayOfYear := DoY end {DayOfYear} ;


procedure DateOfDayNo(const Opts : Options ; const DDD : OrdDate ;
  const Yr : IntYear ; var Mo, Dy : Part) ;
(* NOT YET? OK for change-years : use YD_to_MJD, MJD_to_YMD *)
var L : boolean ;
begin L := Leap_Year(Opts, Yr) ;
  Mo := Succ((DDD-1) shr 5) ;
  if (Mo<12) and ((DaysFromDec[Succ(Mo)]+Ord(L and (Mo>1)))<DDD)
    then Inc(Mo) ;
  Dy := DDD - DaysFromDec[Mo] - Ord(L and (Mo>2)) ;
  end {DateOfDayNo} ;


procedure MJD_to_YD(const Opts : Options ; const MJDy : MJDate ;
  var YYYY : IntYear ; var DDD : OrdDate) ;
const Msg = 'Consistency failure in MJD_to_YD' ;
var M, D : Part ; D3 : OrdDate ;
begin MJD_to_YMD(Opts, MJDy, YYYY, M, D) ;
  D3 := DayOfYear(Opts, YYYY, M, D) ;
  DDD := Succ(MJDy - YMD_to_MJD(Opts, YYYY, 1, 1)) ;
  if DDD<>D3 then begin
    {$IFDEF PASCAL} Write(^M^J, Msg, D3:4, DDD:4, ' ? '^G) ; {$ENDIF}
    {$IFDEF DELPHI} ShowMessage(Msg) ; {$ENDIF}
    Readln end ;
  end {MJD_to_YD} ;


function LZ(const Q : Part) : string ;
var S : string [3] ;
begin Str(Q:2, S) ; if S[1]=#32 then S[1] := '0' ; LZ := S end {LZ} ;


function TimeStr(const H, M, S : Part) : string ;
begin TimeStr := LZ(H)+':'+LZ(M)+':'+LZ(S) end {TimeStr} ;


function YearStr(const Astr : boolean ; const Yr : IntYear) : string ;
const Pf : array [boolean] of string [2] = ('BC', 'AD') ;
var Y : string [8] ;
begin if Astr then Str(Yr:7, Y) else
    if Yr=0 then Y := 'Year=0!' else begin
    Str(Abs(Yr):5, Y) ; Y := Pf[Yr>0]+Y end ;
  YearStr := Y end {YearStr} ;


function DateStr(const Astr : boolean ;
  const Yr : IntYear; const Mo, Dy : Part) : string ;
begin DateStr :=
    YearStr(Astr, Yr) + DateSep+LZ(Mo) +DateSep+LZ(Dy) +#32 end {DateStr} ;


function MJDateStr(const Opts : Options ; const MJD : MJDate) : string ;
var Y : IntYear ; M, D : Part ;
begin MJD_to_YMD(Opts, MJD, Y, M, D) ;
  MJDateStr := DateStr(Opts.Astr, Y, M, D) end {MJDateStr} ;


function JDateStr(const Astr : boolean ;
  const Yr : IntYear ; const DDD : OrdDate) : string ;
var Z : string [3] ; B : byte ;
begin Str(DDD:3, Z) ;
  for B := 1 to 2 do if Z[B]=#32 then Z[B] := '0' ;
  JDateStr := YearStr(Astr, Yr) + JulnSep + Z+#32 end {JDateStr} ;


const Digit = ['0'..'9'] ;


function Get(var Ndx : byte ; const St : string) : longint ;
var A : longint ; Ch : char ;
begin A := 0 ;
  while Ndx<Length(St) do begin Inc(Ndx) ; Ch := St[Ndx] ;
    if Ch in Digit then A := A*10 + Ord(Ch)-Ord('0') else if A>0 then BREAK ;
    end ;
  Get := A end {Get} ;


function GetYearOK(var Yr : IntYear ; var Ndx : byte ;
  const Astr : boolean ; const St : string) : boolean
  { if Astr then year can be +/- else year can be AD/BC } ;
var Li : longint ; Ix : byte ; Ch : char ; Sign : (Nun, Pos, BC, Neg) ;
begin GetYearOK := false ; Sign := Nun ;
  for Ix := 1 to Length(St) do begin Ch := UpCase(St[Ix]) ;
    if Ch in Digit then BREAK ;
    if (Ch=#9) or (Ch=#32) then CONTINUE ;
    if Astr then
      case Ch of
      '+' : Sign := Pos ;
      '-' : Sign := Neg ;
      else EXIT ;
      end else
      if Ch='B' then Sign := BC else
      if not (Ch in ['.', 'A'..'D']) then EXIT ;
    end {Ix} ;
  Ndx := 0 ;
  Li := Get(Ndx, St) ; Yr := IntYear(LI) ; if Yr<>Li then EXIT ;
  if Sign>Pos then Yr := -Yr ;
  GetYearOK := (Odd(Ord(Sign)) or (Yr<>0)) end {GetYearOK} ;


function ReadYMDdate(const Astr : boolean ; const St : string ;
  var Yr : IntYear ; var Mo, Dy : Part) : boolean
  { Should read any reasonable numerical date in Y/M/D form } ;
var Ndx : byte ; Li : longint ;
begin ReadYMDdate := false ;
  if not GetYearOK(Yr, Ndx, Astr, St) then EXIT ;
  Li := Get(Ndx, St) ; Mo := Part(LI) ; if Mo<>Li then EXIT ;
  Li := Get(Ndx, St) ; Dy := Part(LI) ; if Dy<>Li then EXIT ;
  ReadYMDdate := (Mo>0) and (Dy>0) and (Get(Ndx, St)=0) end {ReadYMDdate} ;


function ReadYDdate(const Astr : boolean ; const St : string ;
  var Yr : IntYear ; var DDD : OrdDate) : boolean
  { Should read any reasonable numerical date in Y/D form } ;
var Ndx : byte ; Li : longint ;
begin ReadYDdate := false ;
  if not GetYearOK(Yr, Ndx, Astr, St) then EXIT ;
  Li := Get(Ndx, St) ; DDD := OrdDate(LI) ; if DDD<>Li then EXIT ;
  ReadYDdate := (DDD>0) and (Get(Ndx, St)=0) end {ReadYDdate} ;


procedure JulianEaster(const Yr {Julian} : WrdYear ; var Mo, Dy : Part) ;
var g, i, j : word ; L : integer ;
begin { Julian }
  g := Yr mod 19 ;
  i := (19*g + 15) mod 30 ;
  j := (Yr mod 7 + Yr div 4 + i) mod 7 { JRS mod } ;
  L := integer(i) - integer(j) ;
  Mo := 3 + (L + 40) div 44 ;
  Dy := L + 28 - 31*(Mo div 4) ;
  end {JulianEaster} ;



procedure LongJulianEaster(const Yr {Julian} : longint ; var Mo, Dy : Part) ;
var g, i, j : longint ; L : integer ;
begin { Julian }
  g := Yr mod 19 ;
  i := (19*g + 15) mod 30 ;
  j := (Yr mod 7 + Yr div 4 + i) mod 7 { JRS mod } ;
  L := integer(i) - integer(j) ;
  Mo := 3 + (L + 40) div 44 ;
  Dy := L + 28 - 31*(Mo div 4) ;
  end {LongJulianEaster} ;




procedure GregorianEaster(const Yr {Gregorian} : WrdYear ; var Mo, Dy : Part) ;
(* See my PASCHAL.PAS for details ; this method from Claus Tondering
  The Calendar FAQ ; agrees with Peter Duffett-Smith & Ted Richards *)
(* Assumes proposals of WCC in Aleppo (March 1997) are *NOT* implemented *)
var g, c, h, i, j, L : word ;
begin
  g := Yr mod 19 { 0..18 } ;
  c := Yr div 100 ;
  h := (c - c div 4 - (8*c+13) div 25 + 19*g + 15) mod 30 { 0..29 } ;
  if (h<28) or ((h=28) and (g<=10)) then i := h else i := h - 1 ;
  j := (Yr mod 7 + Yr div 4 + i + 2 - c + c div 4) mod 7 ;
  L := (i+28) - j ;
  if L<=31 then begin Mo := 3 ; Dy := L    end
  {}       else begin Mo := 4 ; Dy := L-31 end ;
  end {GregorianEaster} ;




procedure Easter0(const Yr {Gregorian} : WrdYear ; var Mo, Dy : Part) ;
(* See my PASCHAL.PAS for details ; this method from Claus Tondering
  The Calendar FAQ ; agrees with Peter Duffett-Smith & Ted Richards *)
(* Assumes proposals of WCC in Aleppo (March 1997) are *NOT* implemented *)
var g, c, h, i, j : word ; L : integer ;
begin
  g := Yr mod 19 ;
  c := Yr div 100 ;
  h := (c - c div 4 - (8*c+13) div 25 + 19*g + 15) mod 30 ;
  i := h - (h div 28)*(1 - (h div 28)*(29 div (h+1))*((21-g) div 11)) ;
  j := (Yr mod 7 + Yr div 4 + i + 2 - c + c div 4) mod 7 ;
  L := integer(i) - integer(j) ;
  Mo := 3 + (L + 40) div 44 ;
  Dy := L + 28 - 31*(Mo div 4) ;
  end {Easter0} ;

{For other moveable feasts, go via MJD & add offsets from moredate.htm}


procedure LongGregorianEaster(const Yr : longint ; var Mo, Dy : Part) ;
(* See my PASCHAL.PAS for details ; this method from Claus Tondering
  The Calendar FAQ ; agrees with Peter Duffett-Smith & Ted Richards *)
(* Assumes proposals of WCC in Aleppo (March 1997) are *NOT* implemented *)
var g, c, h, i, j : longint ; L : integer ;
begin
  g := Yr mod 19 ;
  c := Yr div 100 ;
  h := (c - c div 4 - (8*c+13) div 25 + 19*g + 15) mod 30 ;
  i := h - (h div 28)*(1 - (h div 28)*(29 div (h+1))*((21-g) div 11)) ;
  j := (Yr mod 7 + Yr div 4 + i + 2 - c + c div 4) mod 7 ;
  L := integer(i) - integer(j) ;
  Mo := 3 + (L + 40) div 44 ;
  Dy := L + 28 - 31*(Mo div 4) ;
  end {LongGregorianEaster} ;

{For other moveable feasts, go via MJD & add offsets from moredate.htm}


{$IFDEF DELPHI}

function NearEaster(const Year : NearYear) : TDateTime ;
{ Origin unknown; quoted by AGL; tested by JRS; modified }
var B, D, E, Q : integer ;
begin
  B := 225 - (11 * (Year mod 19)) ;
  D := ((B - 21) mod 30) + 21 ;
  if D > 48 then dec(D);
  E := (Year + (Year div 4) + D + 1) mod 7 ;
  Q := D + 6 - E ;
  Result := EncodeDate(Year, 3, 1) + Q ;
  end {NearEaster} ;

{$ENDIF DELPHI}



function Ulti_Mo(const Opts : Options ;
  const Yr : IntYear ; const Mo : Part) : Part ;
begin
  if ((Yr=0) and not Opts.Astr) or not (Mo in [1..12])
    then Ulti_Mo := 0 else
    Ulti_Mo := DaysInMonth[Mo] + Ord((Mo=2) and Leap_Year(Opts, Yr)) ;
  end {Ulti_Mo} ;


function Valid_Date(const Opts : Options ;
  const Yr : IntYear ; const Mo, Dy : Part) : boolean ;
begin
  Valid_Date := false ;
  if ((Yr=0) and not Opts.Astr) then EXIT ;
  if not (Mo in [1..12]) then EXIT ;
  if (Dy=0) or (Dy>Ulti_Mo(Opts, Yr, Mo)) then EXIT ;
  if (Opts.Cal=Civil) then with ChangeData[ChangeDay] do
    if (Yr=CY) and (Mo=CMth) and not ((Dy<=LastJ) or (Dy>=FirstG))
    then EXIT ;
  Valid_Date := true end {Valid_Date} ;


function PC_Day_Valid(const Y : NearYear ; M, D : word) : boolean ;
begin PC_Day_Valid := false ;
  if (M=0) or (D=0) or (M>12) or (D>31) then EXIT ;
  if D=31 then if M in [2, 4, 6, 9, 11] then EXIT ;
  if M=2 then begin
    if D=30 then EXIT ;
    if D=29 then if ((Y and 3)>0) then EXIT ;
    end ;
  PC_Day_Valid := true end {PC_Day_Valid} ;


procedure JSWeekNo(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; M, D : Part) ;
(* js-dates:
  function YMDtoYN(y, m, d) {
  var P3D=259200000 ; var P7D=604800000
  var s=Math.floor((Date.UTC(y,m-1,d)+P3D)/P7D);
  var yy
  with (new Date(s*P7D)) { yy=getFullYear() }
  return [yy, 1+s-Math.floor((Date.UTC(yy,0,4)+P3D)/P7D)] }
  "add 3 to date, then go to beginning of that week,
  return first the true year of that date, return secondly one plus the
  week-count of that minus the week-count of Jan 4 of that year" *)
var S : longint ;
const K = 77777777-1 ;
begin
  S := (YMD_to_MJD(Opts, Yr, M, D) + 3 + K) div 7 ;
  MJD_to_YMD(Opts, S*7 - K, Yr, M, D) ;
  N := 1 + S - (YMD_to_MJD(Opts, Yr, 1, 4) + 3 + K) div 7 ;
  end {JSWeekNo} ;



function First_Thurs(const Opts : Options ; const Yr : IntYear) : Part ;
begin
  First_Thurs := 7 - Ord(MJDDayOfWeek(YMD_to_MJD(Opts, Yr, 1, 3))) ;
  end {First_Thurs} ; (* TSFAQP #92 may be quicker; this is independent *)


function PC_ThuOne(const Y : NearYear) : Part ;
const Tbl : array [0..27] of Part =
  (7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1) ;
begin PC_ThuOne := Tbl[Y mod 28] end {PC_ThuOne} ;


function PC_Thu_One(const Y : NearYear) : Part ;
begin PC_Thu_One :=
    Succ((37 - (((Y+3) mod 28) * 5) div 4) mod 7) end {PC_Thu_One} ;


function PC_ISOweekCount(const Y : NearYear) : Part ;
const Tbl : array [0..27] of Part = (
  52,52,52,52,53, 52,52,52,52,52,
  53,52,52,52,52, 52,53,52,52,52,
  52,53,52,52,52, 52,52,53) ;
begin PC_ISOweekCount := Tbl[Y mod 28] end {PC_ISOweekCount} ;


function PC_ISOweek_Count(const Y : NearYear) : Part ;
begin PC_ISOweek_Count := 52 +
    Ord(((((Y+24) mod 28) * 5) mod 28) < 5) end {PC_ISOweek_Count} ;


procedure ISO_Week_Num(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; const M, D : Part)
  { May be INCORRECT in calendar-step years } ;
{ TSFAQP #92 does not indicate changes in Yr }
begin N := (7 + 3 - First_Thurs(Opts, Yr) + DayOfYear(Opts, Yr, M, D)) div 7 ;
  if N=0 then begin Dec(Yr) ; ISO_Week_Num(Opts, N, Yr, 12, 31) end else
    if N=53 then
    if D>=First_Thurs(Opts, Succ(Yr))+(31-3) then begin Inc(Yr) ; N := 1 end ;
  end {ISO_Week_Num} ;


procedure ISO_Week_Num_Day
  (const Opts : Options ; const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part)
  { May be INCORRECT in calendar-step years } ;
var T : integer ;
begin YN := Y ;
  T := (7 + 3 - First_Thurs(Opts, Y) + DayOfYear(Opts, Y, M, D)) ;
  WN := T div 7 ; DN := Succ(T mod 7) ;
  if WN=0 then begin Dec(YN) ;
    ISO_Week_Num_Day(Opts, YN, 12, 31+D, YN, WN, DN) end else
    if WN=53 then
    if D>=First_Thurs(Opts, Succ(YN))+(31-3) then
    begin Inc(YN) ; WN := 1 end ;
  end {ISO_Week_Num_Day} ;



function ISO_WNDtoMJD
  (const Opts : Options ; const Y : IntYear ; const N, D : Part) : MJDate ;
begin
  ISO_WNDtoMJD :=
    YMD_to_MJD(Opts, Y, 1, First_Thurs(Opts, Y)) + 7*word(N) + D - 11 ;
  end {ISO_WNDtoMJD} ;



{$IFDEF DELPHI}

procedure
  ISO_Week_NumD(var N : TWeekNo ; var Yr : IntYear ; const M, D : Part) ;
begin N := ( 7+3+1 - PC_Thu_One(Yr) +
    Round(EncodeDate(Yr, M, D)-EncodeDate(Yr, 1, 1)) ) div 7 ;
  if N=0 then begin Dec(Yr) ; ISO_Week_NumD(N, Yr, 12, 31) end else
    if N=53 then
    if D>=PC_Thu_One(Succ(Yr))+(31-3) then begin Inc(Yr) ; N := 1 end ;
  end {ISO_Week_NumD} ;


procedure JSWeekNoD(var N : TWeekNo ; var Yr : WrdYear ; M, D : word) ;
var S : longint ;
const K = 77777777 + 2 ;
begin
  S := (Round(EncodeDate(Yr, M, D)) + 3 + K) div 7 ;
  DecodeDate(S*7 - K, Yr, M, D) ;
  N := 1 + S - (Round(EncodeDate(Yr, 1, 4)) + 3 + K) div 7 ;
  end {JSWeekNoD} ;


{ Next two tested elsewhere and in MJD_DATE }

// 2008-01-17 - I derived the next two routines from ISO principles
// All weeks have 7 days, DN being Monday = 1 to Sunday = 7
// Thursday of (first) Week 1 of YN is in the Calendar Year of Date
// The YN and WN of a Date are those of its nearest Thursday

procedure ISODTtoYWD(const DT : TDateTime ; out YN, WN, DN : word) ;
var X : word ; NT, J1 : TDateTime ;
begin
  DN := 1 + (DayOfWeek(DT)+5) mod 7 { Mon=1..Sun=7 } ;
  NT := DT + 4 - DN { NT is the Nearest Thursday } ;
  DecodeDate(NT, YN, X, X) { get the Year Number } ;
  J1 := EncodeDate(YN, 1, 1) { Jan 1 of YN } ;
  WN := 1 + Trunc(NT-J1) div 7 { Count of Thursdays } ;
  end {ISODTtoYWD} ; // Ideally, this would be a pure function

function ISOYWDtoDT(const YN, WN, DN : word) : TDateTime ;
var DT : TDateTime ; DW : integer ;
begin
  DT := EncodeDate(YN, 1, 4) { YN Jan 4, which is in YN Week 1 } ;
  DW := 1 + (DayOfWeek(DT)+5) mod 7 { Mon=1..Sun=7 } ;
  DT := DT - DW { go to day before Week 1 } ;
  Result := DT + (WN-1)*7 + DN { increment for Weeks and Days } ;
  end {ISOYWDtoDT} ;

{$ENDIF DELPHI}


procedure CTWeekNo(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; const M, D : Part) ;
(* E-mail from Claus Tondering, 2000-06-11 *)
var J, D400 : longint ; D4, L, D1 : word ;
begin
  J := YMD_to_MJD(Opts, Yr, M, D) + 2400001 ;
  D400 := (J + 31741 - J mod 7) mod Yrs400 ;
  D4 := (D400 mod 36524) mod 1461 ;
  L := D4 div 1460 ;
  D1 := ((D4 - L) mod 365) + L ;
  N := D1 div 7 + 1 ;
  {JRS:} case M of
    01 : if N>=52 then Dec(Yr) ;
    12 : if N = 1 then Inc(Yr) ;
    end ;
  end {CTWeekNo} ;


procedure CTWeekNo_Day
  ({const Opts : Options ;} const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;
var J, D400 : longint ; D4, L, D1 : word ;
begin YN := Y ;
  { J := YMD_to_MJD(Opts, YN, M, D) + 2400001 ; }
  J := YMDtoMJD(YN, M, D) + 2400001 ;
  D400 := (J + 31741 - J mod 7) mod Yrs400 ;
  D4 := (D400 mod 36524) mod 1461 ;
  L := D4 div 1460 ;
  D1 := ((D4 - L) mod 365) + L ;
  WN := D1 div 7 + 1 ; {jrs:} DN := J mod 7 + 1 ;
  {JRS:} case M of
    01 : if WN>=52 then Dec(YN) ;
    12 : if WN = 1 then Inc(YN) ;
    end ;
  end {CTWeekNo} ;


function CTWeekNoF(const Opts : Options ;
  const Yr : IntYear ; const M, D : Part) :
{$IFDEF PASCAL} longint {$ENDIF} {$IFDEF DELPHI} WNrec {$ENDIF} ;
(* E-mail from Claus Tondering, 2000-06-11 *)
var {$IFDEF PASCAL} Result : WNrec ; {$ENDIF}
J, D400 : longint ; D4, L, D1 : word ;
begin
  J := YMD_to_MJD(Opts, Yr, M, D) + 2400001 ;
  D400 := (J + 31741 - J mod 7) mod Yrs400 ;
  D4 := (D400 mod 36524) mod 1461 ;
  L := D4 div 1460 ;
  D1 := ((D4 - L) mod 365) + L ;
  with Result do begin WN := D1 div 7 + 1 ; YN := Yr ;
    {JRS:} case M of
      01 : if WN>=52 then Dec(YN) ;
      12 : if WN = 1 then Inc(YN) ;
      end ;
    {$IFDEF PASCAL} CTWeekNoF := LI ; {$ENDIF}
    end ;
  end {CTWeekNoF} ;


procedure Gen_Week_Num(const Opts : Options ; var N : TWeekNo ;
  var Yr : IntYear ; const M, D, {Date in Week 1:} MS, DS : Part ;
  {First day of week:} const FD : WkDys)
  { May be INCORRECT in calendar-step years }
  { After J J Quick   jjquick@foxtrot.co.uk   http://www.foxtrot.co.uk } ;
var
StartMJD, ThisMJD : MJDate ;
DoW : WkDys ;
begin
  ThisMJD := YMD_to_MJD(Opts, Yr, M, D) ;
  if (M=12) and (D>25) then if (MS=1) and (DS<7) then
    { The conditions are merely for efficiency } Inc(Yr) ;
  repeat
    StartMJD := YMD_to_MJD(Opts, Yr, MS, DS) ;
    DoW := MJDDayOfWeek(StartMJD-Ord(FD)) ;
    StartMJD := StartMJD - Ord(DoW) ;
    if ThisMJD >= StartMJD then BREAK ;
    Dec(Yr) until false ;
  N := Succ((ThisMJD-StartMJD) div 7) ;
  end {Gen_Week_Num} ;


procedure WkNo_Start(const Opts : Options ; const N : TWeekNo ;
  var Yr : IntYear ; var M, D : Part ;
  const {Date in Week 1:} MS, DS : Part ;
  const {First day of week:} FD : WkDys) ;
var StartMJD : MJDate ; DoW : WkDys ;
begin
  { WkNo_Start - RECENTLY DEVELOPED - DOUBLE CHECK }
  StartMJD := YMD_to_MJD(Opts, Yr, MS, DS) ;
  DoW := MJDDayOfWeek(StartMJD-Ord(FD)) ;
  StartMJD := StartMJD - Ord(DoW) ;
  MJD_to_YMD(Opts, StartMJD + 7*Pred(N), Yr, M, D) ;
  end {WkNo_Start} ;


procedure UKTaxWeekNo {undertested}
  (const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var WN : TWeekNo ; var DN : Part) ;
var Diff : MJDate ;
begin YN := Y ;
  if word(M)*32+D < 4*32+6 then Dec(YN) ;
  Diff := YMDtoMJD(Y, M, D) - YMDtoMJD(YN, 4, 6) ;
  WN := Diff div 7 + 1 ;
  DN := Diff mod 7 + 1 ;
  end {UKTaxWeekNo} ;


function UKTax_WNDtoMJD(const Y : IntYear ; const N, D : Part) : MJDate ;
begin
  UKTax_WNDtoMJD := YMDtoMJD(Y, 4, 6) + 7*(N-1) + (D-1) ;
  end {UKTax_WNDtoMJD} ;


procedure UKTaxMonthDay {undertested}
  (const Y : IntYear ; const M, D : Part ;
  var YN : IntYear ; var MN : shortint ; var DN : Part) ;
var X : integer ;
begin YN := Y ; MN := M ;
  if D<6 then Dec(MN) ;
  if MN<4 then begin Inc(MN, 12) ; Dec(YN) end ;
  Dec(MN, 3) ;

  X := D-5 ;
  if X<1 then begin
    Inc(X, DaysInMonth[M-1]) ;
    if (M=3) and PC_Leap_Year(Y) then Inc(X) ;
    end ;
  DN := X ;

  end {UKTaxMonthDay} ;


function UKTax_WMDtoMJD(Y : IntYear ; M, D : Part) : MJDate ;
begin
  Inc(M, 3) ; if M>12 then begin Inc(Y) ; Dec(M, 12) end ;
  if D<6 then begin Dec(M) ; Inc(D, DaysInMonth[M]) ;
    if (M=2) and PC_Leap_Year(Y) then Inc(D) ;
    if M=0 then begin M := 12 ; Dec(Y) end end ;
  UKTax_WMDtoMJD := YMDtoMJD(Y, M, 6) + (D-1) end {UKTax_WMDtoMJD} ;



{ For legal work, take care with the definitions of date differences.
  For DateTime differences, for reasons of range, take the difference
  of the MJDs, multiply by 86400, add the seconds difference.
  Do not follow TSFAQP#57; Pack/Unpack are monotonic, but non-linear.
  This code ignores LeapSecs and Winter/Summer Time.

  For date arithmetic using out-of-range dates, remember that the
  Gregorian Calendar repeats every 400 years, and therefore every
  10000 years.  Use this, set to Gregorian, with Year mod 10000,
  and handle the rest allowing 10000 years = 3652425 days. }


procedure Incr_Date(const Opts : Options ;
  var Yr : IntYear ; var Mo, Dy : Part ; const By : MJDate) ;
begin MJD_to_YMD(Opts,
    YMD_to_MJD(Opts, Yr, Mo, Dy)+By, Yr, Mo, Dy) end {Incr_Date} ;


function Date_Diff(const Opts : Options ;
  const Y1 : IntYear ; const M1, D1 : Part ;
  const Y2 : IntYear ; const M2, D2 : Part) : MJDate ;
begin
  Date_Diff := YMD_to_MJD(Opts, Y1, M1, D1) - YMD_to_MJD(Opts, Y2, M2, D2) ;
  end {Date_Diff} ;


procedure YMD_Diff(const Opts : Options ;
  const Y1 : IntYear ; const M1, D1 : Part ;
  const Y2 : IntYear ; const M2, D2 : Part ;
  var DY : IntYear ; var DM, DD : Part) { Dubious } ;
var Borrow : boolean ; Diff : shortint ;
begin
  Diff := D2-D1 ; Borrow := Diff<0 ;
  if Borrow then Inc(Diff,
    Ulti_Mo(Opts, Y1, Succ((M2+10) mod 12)) {length of prev month}) ;
  DD := Diff ;
  Diff := M2-M1 ; if Borrow then Dec(Diff) ;
  Borrow := Diff<0 ;
  if Borrow then Inc(Diff, 12) ;
  DM := Diff ;
  DY := Y2-Y1 ; if Borrow then Dec(DY) ;
  end {YMD_Diff} ;


function HMS_to_Seconds(const H, M, S : Part) : longint ;
begin HMS_to_Seconds := ((H*word(60))+M)*longint(60)+S end {HMS_to_Seconds} ;


function DS_to_Seconds(const Dy : word ; const S : longint) : longint ;
begin DS_to_Seconds := Dy*86400+S end {DS_to_Seconds} ;


function Seconds_to_DS(const Sx : longint ; var D : word) : longint ;
begin D := Sx div 86400 ; Seconds_to_DS := Sx mod 86400 end {Seconds_to_DS} ;


procedure Seconds_to_HMS(const Sx : longint ; var H, M, S : Part) ;
begin H := Sx div (60*60) ; M := (Sx div 60) mod 60 ; S := Sx mod 60 ;
  end {Seconds_to_HMS} ;


procedure InitialiseDates ;
type ChangeHectoYears = 15..19 ;
const GJgap : array [ChangeHectoYears] of byte = (10, 10, 11, 12, 13) ;
var {$IFDEF LOOKUP} Yr : NearYear ; {$ENDIF} CD : ChangeDate ; Mo : Part ;
const Op : Options = (Cal:Julian; Astr:false) ;
begin for CD := Low(CD) to High(CD) do
    with ChangeData[CD] do begin
    MJD_to_YMD(Op, LastJulianMJD[CD], CY, CMth, LastJ) ;
    FirstG := Succ(LastJ) + GJgap[CY div 100] ;
    end ;
  DaysFromDec[1] := 0 ; for Mo := 1 to 11 do
    DaysFromDec[Mo+1] := DaysFromDec[Mo] + DaysInMonth[Mo] ;
  DaysFromFeb[3] := 0 ; for Mo := 3 to 13 do
    DaysFromFeb[Mo+1] := DaysFromFeb[Mo] + DaysInMonth[Mo] ;

  {$IFDEF LOOKUP}
  for Yr := Low(NearYear) to High(NearYear) do for Mo := 1 to 12 do
    MJDTable0[Yr, Mo] := Pred(YMDtoMJD(Yr, Mo, 1)) ;
  for Yr := 2000 to 2003 do for Mo := 1 to 12 do
    MJDTable1[Yr mod 4, Mo] := YMDtoMJD(Yr, Mo, 1)-Succ(20*36525) ;
  {$ENDIF LOOKUP}

  end {InitialiseDates} ;


function LastSun(const Yr : IntYear ; const Mo, Ult : Part) : Part ;
begin LastSun := Ult - Ord(MJDDayOfWeek(YMDtoMJD(Yr, Mo, Ult))) end {LastSun} ;


function YearNear(const Y : IntYear) : boolean ;
begin YearNear := (Y>=Low(NearYear)) and (Y<=High(NearYear)) end {YearNear} ;

function EUSTon(const y : NearYear) : Part ;
begin EUSTon := 31 - ((5*y) div 4 + 4) mod 7 end {EUSTon} ;

function EUSToff(const y : NearYear) : Part ;
begin EUSToff := 31 - ((5*y) div 4 + 1) mod 7 end {EUSToff} ;


function NthXdayOfMonth(const Opts : Options ;
  const Yr : IntYear ; const Mo, N : byte ; const X : WkDys) : Part ;
var Dy, Ult : Part ;
begin Ult := Ulti_Mo(Opts, Yr, Mo) ;
  Dy := 1 +
    (7+Ord(X)-Ord(MJDDayOfWeek(YMD_to_MJD(Opts, Yr, Mo, 1)))) mod 7 ;
  if N=0 then begin repeat NthXdayOfMonth := Dy ; Inc(Dy, 7) until Dy>Ult ;
    EXIT end ;
  Inc(Dy, (N-1)*7) ;
  if Dy>Ult then NthXdayOfMonth := 0 else NthXdayOfMonth := Dy ;
  end {NthXdayOfMonth} ;


function Nth_XdayOfMonth(const Opts : Options ;
  const Yr : IntYear ; const Mo, N : byte ; const X : WkDys) : Part ;
var MJD : longint ; D, M : Part ; Y : IntYear ;
begin
  MJD := YMD_to_MJD(Opts, Yr, Mo, 1) ;
  MJD := MJD + (7+Ord(X)-Ord(MJDDayOfWeek(MJD))) mod 7 ;
  if N=0 then begin repeat Nth_XdayOfMonth := D ;
      Inc(MJD, 7) ; MJD_to_YMD(Opts, MJD, Y, M, D) until M<>Mo ;
    EXIT end ;
  Inc(MJD, (N-1)*7) ; MJD_to_YMD(Opts, MJD, Y, M, D) ;
  if M<>Mo then Nth_XdayOfMonth := 0 else Nth_XdayOfMonth := D ;
  end {Nth_XdayOfMonth} ;


{$IFDEF DELPHI}   // UNDERTESTED.  2004-03-10

function NXDM(const Nth, Xday, Month, Year : word) : TDateTime ;
var ED : TDateTime ;
begin ED := EncodeDate(Year, Month, 1) ;
  Result := ED + (XDay + 7 - DayOfWeek(ED)) mod 7 + 7*(Nth-1) end ;

{$ENDIF DELPHI}


function Season21(const Mo, Dy : Part) : Seasons ;
begin Season21 := Seasons(((Mo - Ord(Dy<21)) div 3) and 3) end {Season21} ;


function OZ(const J : Seasons) : Seasons ;
begin OZ := Seasons(Part(J) XOR 2) end {OZ} ;


procedure MJDtoAbsWeek(const MJD : MJDate ; var Q : longint ; var R : Part) ;
var P : MJDate ;
begin
  P := MJD + 678582 ;
  Q := P div 7 ; R := Succ(P mod 7) ;
  end {MJDtoAbsWeek} ;




const
MJD_AM1 = -2052003 ;
Three761 = 3761 ;


function HYtoMJD(const Y : HebrYr) : MJDate ;
{ based on E G Richards, Algorithm G, Hebrew Year Start (1 Tishri) to JDN
  with input from Remy Landau, http://www.geocities.com/Athens/1584/
  OK by L E Doggett in http://charon.nmsu.edu/~lhuber/leaphist.html }
const
hpd = 24   { hours per day } ;
pph = 1080 { parts per hour } ;
var
m  { months from AM 1/1/1 },
  tm { minor contribution from parts },
  th { hours from hours & parts },
  d  { days },
  t_ { parts of day } : longint ;
w  { DoW Sun=1 .. Sat=7 } : word ;
E  { This Year Leap },
  E_ { Last Year Leap } : boolean ;
begin
  {a } m  := (235*Y - 234) div 19 ;
  {b'} tm := 204 + 793*(m mod pph) ;
  {c } th := 5 + 12*m + tm div pph + 793*(m div pph) ;
  {d } d  := 1 + 29*m + th div hpd ;
  {e } t_ := (tm mod pph) + pph*(th mod hpd) ;
  {          (d, t_) is Molod in Days & Parts from Hebrew time origin }

  {4 } w  := Succ(d mod 7) ;
  {5 } E  := ((7*Y + 13) mod 19) >= 12 ; { Whatever Y is, these  }
  {6 } E_ := ((7*Y +  6) mod 19) >= 12 ; { cannot both give TRUE }

  {7 } if  (t_ >= 18*pph)                                             { DMZ }
    {} or ((t_ >=  9*pph + 204) and (w=3) and not E)                 { DGTR }
    {} or ((t_ >= 15*pph + 589) and (w=2) {and (not E)} and E_)      { DB'T }
    {} then Inc(d) ;
  {8 } if Succ(d mod 7) in [1, 4, 6] then Inc(d) ;                   { DADU }

  HYtoMJD := d + (347997-2400001) { d + 347997 is EGR's answer } ;
  end {HYtoMJD} ;



function MJDtoHY(const MJD : MJDate) : HebrYr ;
var HY, X : longint ; {Z : integer ;}
begin { firstly use X to approximate well; then shift if needed }
  X := MJD{+2052003}-MJD_AM1 ;
  HY := Succ(X div 365 - X div (1480*365)) ;    {     Z := 0 ; }
  while HYtoMJD(HY)   >  MJD do begin Dec(HY) ; { Dec(Z) } end ;
  while HYtoMJD(HY+1) <= MJD do begin Inc(HY) ; { Inc(Z) } end ;
  { Write(Z:5) ; }
  MJDtoHY := HY end {MJDtoHY} ;



function IsWeekDay(const MJD : MJDate) : boolean ;
begin IsWeekDay := ISODoW1(MJD)<=5 end {IsWeekDay} ;


function IsHoliday(P : PHolsList ; const MJD : MJDate) : boolean ;
begin
  while P<>NIL do with P^ do begin
    if DayNo=MJD then begin IsHoliday := true ; EXIT end ;
    P := Next end ;
  IsHoliday := false end {IsHoliday} ;


function IsWorkDay(const P : PHolsList ; const MJD : MJDate) : boolean ;
begin IsWorkDay := IsWeekDay(MJD) and not IsHoliday(P, MJD) end {IsWorkDay} ;


procedure ReadDaysOffFile(var HolsList : PHolsList) ;
var F : text ; P : PHolsList ; NHols : integer ; S : string [10] ;
function VV(const J, K : byte) : integer ;
{} var X, N : integer ;
{} begin Val(Copy(S, J, K), X, N) ;
  {} if N<>0 then begin Writeln('File DAYS-OFF.DAT error!'^G) ; HALT end ;
  {} VV := X end {VV} ;
begin NHols := 0 ;
  Write('   Needs valid DAYS-OFF.DAT in current directory - ') ;
  Assign(F, 'days-off.dat') ;
  {$I-} Reset(F) ; {$I+}
  if IOresult=0 then begin
    while not EoF(F) do begin Readln(F, S) ;
      if (Length(S)<>10) or not (S[1] in ['0'..'9']) then CONTINUE ;

      New(P) ; P^.Next := HolsList ; HolsList := P ;
      P^.DayNo := YMDtoMJD(VV(1, 4), VV(6, 2), VV(9, 2)) ;

      Inc(NHols) end ;
    Close(F) end
  else Write(^M^J'   *** no holiday file, ') ;
  Writeln(NHols, ' holidays.') ;
  end {ReadDaysOffFile} ;


procedure WorkDaysFromTo(const HolsList : PHolsList ;
  MJD1, MJD2 : MJDate ; const BV1, BV2 : boolean ;
  var WeekDays, WorkDays : longint ; var Safe : boolean) ;
var P : PHolsList ; Min, Max : MJDate ; Q1, Q2 : longint ; R, R1, R2 : byte ;
begin
  if BV1 then Inc(MJD1) ; if BV2 then Dec(MJD2) ;
  if MJD2<MJD1 then
    begin Weekdays := 0 ; Workdays := 0 ; Safe := true ; EXIT end { ?? } ;

  MJDtoAbsWeek(MJD1, Q1, R1) ; MJDtoAbsWeek(MJD2, Q2, R2) ;

  if R2<R1 then begin Dec(Q2) ; Inc(R2, 7) end ;
  WeekDays := (Q2-Q1)*5 ;
  for R := R1 to R2 do if not (R in [6, 7]) then Inc(WeekDays) ;

  WorkDays := WeekDays ;
  P := HolsList ; Min := MJD2 ; Max := MJD1 ;
  while P<>NIL do with P^ do begin
    if (DayNo>=MJD1) and (DayNo<=MJD2) then Dec(WorkDays) ;
    if DayNo<Min then Min := DayNo ;
    if DayNo>Max then Max := DayNo ;
    P := Next end ;
  Safe := (Max>=MJD2) and (Min<=MJD1) ;
  end {WorkDaysFromTo} ;


procedure WorkDaysOnwards(const HolsList : PHolsList ;
  MJD1, MJD2 : MJDate ; const BV1, BV2 : boolean ;
  var WeekDays, WorkDays : longint ; var Safe : boolean) ;
var MJD : MJDate ;
begin Weekdays := 0 ; Workdays := 0 ;
  if BV1 then Inc(MJD1) ; if BV2 then Dec(MJD2) ;
  if MJD2<MJD1 then
    begin Safe := true ; EXIT end { ?? } ;

  for MJD := MJD1 to MJD2 do begin
    if not IsWeekDay(MJD) then CONTINUE ;
    Inc(WeekDays) ;
    if IsHoliday(HolsList, MJD) then CONTINUE ;
    Inc(WorkDays) ;
    end {MJD} ;

  Safe := false ;
  end {WorkDaysOnwards} ;


procedure WorkDaysAfter(const HolsList : PHolsList ;
  MJD1 : MJDate ; const BV1 : boolean ;
  WorkDays : longint ; var MJD3 : MJDate ; var Safe : boolean) ;
var Wk, Wo : longint ; OK : boolean ;
{ N.B. Not exact opposite of WorkDaysFromTo ? }
begin
  if BV1 then Inc(MJD1) ;
  MJD3 := MJD1 ; Safe := true ; Dec(workdays) ;
  while WorkDays>0 do begin
    Inc(MJD3, WorkDays) ; Write(' *', MJD3, '* ') ;
    WorkdaysFromTo(HolsList, MJD1, MJD3, false, true, Wk, Wo, OK) ;
    if not OK then Safe := false ;
    Dec(WorkDays, Wo) ; MJD1 := MJD3 ;
    end ;
  Writeln end {WorkDaysAfter} ;


procedure WorkDaysFrom(const HolsList : PHolsList ;
  MJD1 : MJDate ; const BV1 : boolean ;
  WorkDays : longint ; var MJD3 : MJDate ; var Safe : boolean) ;
{ N.B. Not exact opposite of WorkDaysFromTo ? }
begin
  if not BV1 then Dec(MJD1) ;
  MJD3 := MJD1 ; Safe := false ;
  while WorkDays>0 do begin
    Inc(MJD3) ; if IsWorkDay(HolsList, MJD3) then Dec(WorkDays) ;
    end ;
  end {WorkDaysFrom} ;



BEGIN ;
InitialiseDates ;
END.