home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / MURUTIL.ZIP / ALMANAC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-01-02  |  10.7 KB  |  445 lines
  1. {$P256}
  2.  
  3. PROGRAM ALMANAC;
  4.  
  5. {  "Almanac Program"
  6.  
  7.    This Turbo Pascal program displays the current time, day of the week,
  8.    date and times for sunrise and sunset.
  9.  
  10.    Reference:  "Almanac for Computers 1984", Nautical Almanac Office,
  11.                United States  Naval  Observatory,  Washington,  D.C.,
  12.                Pages B5 to B7.
  13.  
  14.    Version:  1 Jan 1987.
  15.  
  16.    Program by:
  17.                 Harry M. Murphy, Consultant
  18.                 3912 Hilton Avenue, NE
  19.                 Albuquerque, NM  87110
  20.                 Tel:  (505) 881-0519  }
  21.  
  22.  
  23. {                               NOTICE
  24.  
  25.        Copyright 1986, Harry M. Murphy.
  26.  
  27.        A general license is hereby  granted  for  non-commercial
  28.        use,  copying and free exchange of this  program  without
  29.        payment of any royalties,  provided that  this  copyright
  30.        notice is not altered nor deleted.   All other rights are
  31.        reserved.  Harry M. Murphy  }
  32.  
  33. CONST
  34.       LAT    = 35.0536;      { Local latitude in degrees north. }
  35.       LON    = -106.5883;    { Local longitude in degrees east. }
  36.       LOCDST = 'MDST';       { Local daylight savings time abbr.}
  37.       LOCST  = 'MST';        { Local standard time abbreviation.}
  38.       TZONE  = -7.0;         { Local time zone in hours.        }
  39.  
  40. {  Note:  LAT, LON, LOCDST, LOCST and TZONE are for Albuquerque, NM. }
  41.  
  42.       CZ     = -0.01454;
  43.       RTOD   = 57.29577951;
  44.  
  45. TYPE
  46.      DATESTRING = STRING[28];
  47.      TIMESTRING = STRING[6];
  48.  
  49. VAR
  50.     ABBR  : TIMESTRING;
  51.     CD    : REAL;
  52.     CL    : REAL;
  53.     CLAT  : REAL;
  54.     CLOCK : TIMESTRING;
  55.     DSTF  : BOOLEAN;
  56.     H     : REAL;
  57.     HOUR  : TIMESTRING;
  58.     ID    : INTEGER;
  59.     IM    : INTEGER;
  60.     IW    : INTEGER;
  61.     IY    : INTEGER;
  62.     L     : REAL;
  63.     M     : REAL;
  64.     N     : INTEGER;
  65.     RA    : REAL;
  66.     SD    : REAL;
  67.     SL    : REAL;
  68.     SLAT  : REAL;
  69.     TODAY : DATESTRING;
  70.     TR    : REAL;
  71.     TRH   : INTEGER;
  72.     TRM   : INTEGER;
  73.     TS    : REAL;
  74.     TSH   : INTEGER;
  75.     TSM   : INTEGER;
  76.     TT    : REAL;
  77.  
  78.  
  79. FUNCTION ACOS(X: REAL): REAL;
  80.  
  81. {  This function returns the arc-cosine of its argument in radians,
  82.    over the range of zero to Pi.
  83.  
  84.    Function by Harry M. Murphy,  19 February 1986.  }
  85.  
  86. CONST
  87.       R090 = 1.570796327;
  88.       R180 = 3.141592654;
  89.  
  90. VAR
  91.     AC : REAL;
  92.  
  93. BEGIN
  94.   IF X = 0.0
  95.     THEN
  96.       ACOS := R090
  97.     ELSE
  98.       BEGIN
  99.         AC := ARCTAN(SQRT(1.0-SQR(X))/X);
  100.         IF AC < 0.0 THEN AC := AC+R180;
  101.         ACOS := AC
  102.       END
  103. END  { Function ACOS };
  104.  
  105.  
  106. FUNCTION AMOD(X,Y: REAL): REAL;
  107.  
  108. {  This function returns X modulus Y, where both X and Y are REAL.
  109.  
  110.    Function by Harry M. Murphy,  19 February 1986.  }
  111.  
  112. BEGIN
  113.   AMOD := X-INT(X/Y)*Y
  114. END { Function AMOD };
  115.  
  116.  
  117. FUNCTION ATAN2(Y,X: REAL): REAL;
  118.  
  119. {  This function returns the arc-tangent of Y/X, in radians, over the
  120.    range of zero to two-Pi.
  121.  
  122.    Function by Harry M. Murphy,  30 July 1986.  }
  123.  
  124. CONST
  125.       R090 = 1.570796327;
  126.       R180 = 3.141592654;
  127.       R270 = 4.712388980;
  128.       R360 = 6.283185307;
  129.  
  130. VAR
  131.     AT : REAL;
  132.  
  133. BEGIN
  134.   IF X <> 0.0
  135.     THEN
  136.       AT := ARCTAN(Y/X)
  137.     ELSE
  138.       IF Y > 0.0
  139.         THEN
  140.           AT := R090
  141.         ELSE
  142.           AT := R270;
  143.   IF X < 0.0  THEN AT := AT+R180;
  144.   IF AT < 0.0 THEN AT := AT+R360;
  145.   ATAN2 := AT
  146. END  { Function ATAN2 };
  147.  
  148.  
  149. FUNCTION COSD(X: REAL): REAL;
  150.  
  151. { This function returns the cosine of an argument in degrees.
  152.  
  153.   Function by Harry M. Murphy,  19 February 1986.  }
  154.  
  155. CONST
  156.       DTOR = 1.745329252E-2;
  157.  
  158. BEGIN
  159.   COSD := COS(DTOR*X)
  160. END  { Function COSD };
  161.  
  162.  
  163. FUNCTION SIND(X: REAL): REAL;
  164.  
  165. { This function returns the sine of an argument in degrees.
  166.  
  167.   Function by Harry M. Murphy,  19 February 1986.  }
  168.  
  169. CONST
  170.           DTOR = 1.745329252E-2;
  171.  
  172. BEGIN
  173.   SIND := SIN(DTOR*X)
  174. END  { Function SIND };
  175.  
  176.  
  177. FUNCTION DST(ND,ID,IM,IW: INTEGER): BOOLEAN;
  178.  
  179. {  Given the day number, ND, the day number, ID, the month number, IM,
  180.    and the weekday number,  IW,  this function returns  TRUE  only  if
  181.    Daylight Savings Time is in effect.
  182.  
  183.    Current with the Congressional change of May, 1986,  which defines
  184.    Daylight Savings Time to run from the first Sunday in April to the
  185.    last Sunday in October.
  186.  
  187.    Routine by Harry M. Murphy,  31 July 1986.  }
  188.  
  189. BEGIN
  190.   IF (ND < 91) OR (ND > 305)
  191.     THEN
  192.       DST := FALSE
  193.     ELSE
  194.       IF (ND > 98) AND (ND < 296)
  195.         THEN
  196.           DST := TRUE
  197.         ELSE
  198.           IF IM=4
  199.             THEN
  200.               DST := (ID-IW) > 0
  201.             ELSE
  202.               DST := (ID-IW) < 25
  203. END {Function DST};
  204.  
  205.  
  206. PROCEDURE GETTODAY(VAR IY,IM,ID,IW: INTEGER; VAR TODAY: DATESTRING);
  207.  
  208. {  This procedure returns the current date as the INTEGER year, month,
  209.    day and weekday and as a DateString of up to 28 bytes, such as:
  210.    "Tuesday, 18 February 1986".
  211.  
  212.    Notes:
  213.            (1)  The year is returned as four digits (e.g. "1986").
  214.            (2)  The weekday is returned in the range of 0 to 6,
  215.                 corresponding to Sunday through Saturday.
  216.            (3)  TYPE DATESTRING = STRING[28];
  217.  
  218.    Procedure adapted from the Turbo Pascal date example by
  219.    Harry M. Murphy,  18 February 1986.  Updated 12 April 1986.  }
  220.  
  221.   TYPE
  222.        REGPAK = RECORD
  223.                   AX,BX,CX,DX,BP,SI,DI,DS,ES,FL: INTEGER
  224.                 END;
  225.  
  226.   VAR
  227.       JC,JD,JM,JY: INTEGER;
  228.       REG:  REGPAK;
  229.       DAY:  STRING[2];
  230.       YEAR: STRING[4];
  231.  
  232.   BEGIN
  233.     WITH REG DO
  234.       BEGIN
  235.         AX := $2A00;
  236.         MSDOS(REG);
  237.         IY := CX;
  238.         IM := HI(DX);
  239.         ID := LO(DX)
  240.       END;
  241.     JY := IY;
  242.     JM := IM-2;
  243.     IF JM < 1
  244.       THEN
  245.         BEGIN
  246.           JM := JM+12;
  247.           JY := JY-1
  248.         END;
  249.     JC := JY DIV 100;
  250.     JD := JY-100*JC;
  251.     IW := ((ID+42+(13*JM-1) DIV 5 +JD+JD DIV 4+JC DIV 4-2*JC) MOD 7);
  252.     CASE IW OF
  253.       0: TODAY := 'Sunday, ';
  254.       1: TODAY := 'Monday, ';
  255.       2: TODAY := 'Tuesday, ';
  256.       3: TODAY := 'Wednesday, ';
  257.       4: TODAY := 'Thursday, ';
  258.       5: TODAY := 'Friday, ';
  259.       6: TODAY := 'Saturday, '
  260.     END { CASE };
  261.     STR(ID:2,DAY);
  262.     STR(IY:4,YEAR);
  263.     CASE IM OF
  264.       1: TODAY := TODAY+DAY+' January '+YEAR;
  265.       2: TODAY := TODAY+DAY+' February '+YEAR;
  266.       3: TODAY := TODAY+DAY+' March '+YEAR;
  267.       4: TODAY := TODAY+DAY+' April '+YEAR;
  268.       5: TODAY := TODAY+DAY+' May '+YEAR;
  269.       6: TODAY := TODAY+DAY+' June '+YEAR;
  270.       7: TODAY := TODAY+DAY+' July '+YEAR;
  271.       8: TODAY := TODAY+DAY+' August '+YEAR;
  272.       9: TODAY := TODAY+DAY+' September '+YEAR;
  273.       10: TODAY := TODAY+DAY+' October '+YEAR;
  274.       11: TODAY := TODAY+DAY+' November '+YEAR;
  275.       12: TODAY := TODAY+DAY+' December '+YEAR
  276.     END { CASE }
  277.   END { Procedure GETTODAY };
  278.  
  279.  
  280. FUNCTION HOURST(VAR TH,TM: INTEGER): TIMESTRING;
  281.  
  282. {  This function returns a time in hours (TH) and minutes (TM) as a
  283.    6-byte TIMESTRING, such as:  "19:05h".
  284.  
  285.    Function by Harry M. Murphy,  1 August 1986.  }
  286.  
  287. VAR
  288.     HR : STRING[2];
  289.     MN : STRING[2];
  290.  
  291. BEGIN
  292.   STR(TH:2,HR);
  293.   STR(TM:2,MN);
  294.   IF MN[1]=' ' THEN MN[1] := '0';
  295.   HOURST := HR+':'+MN+'h'
  296. END {Function HOURST};
  297.  
  298.  
  299. FUNCTION IDOYF(VAR IY,IM,ID: INTEGER): INTEGER;
  300.  
  301. {  This function returns the day of the year, given the year,  month
  302.    and day of the month.  The day of the year is defined as the time
  303.    elapsed in days since January 0 of the current year.
  304.  
  305.    Note:  This routine is valid from 0 January 1583 onwards.
  306.  
  307.    Inputs:
  308.              IY  The year number, 1583 to ????.  (INTEGER)
  309.              IM  The month number, 1 to 12.      (INTEGER)
  310.              ID  The day number, 0 to 31.        (INTEGER)
  311.  
  312.    Output:
  313.              IDOYF  The day of the year, 1 to 365 (or 366).  (INTEGER)
  314.  
  315.     Ref:     "Almanac for Computers 1981",  Naval Almanac Office, U.S.
  316.              Naval Observatory, Washington, D.C.,  page B1.
  317.  
  318.     Routine by Harry M. Murphy.  Adapted for Pascal on 9 March 1986.  }
  319.  
  320. VAR
  321.     LEAP : BOOLEAN;
  322.  
  323. BEGIN
  324.   LEAP := (IY MOD 4) = 0;
  325.   IF (IY MOD 100) = 0 THEN LEAP := (IY MOD 400) = 0;
  326.   IF LEAP
  327.     THEN
  328.       IDOYF := (275*IM) DIV 9 -  (IM+9) DIV 12  +ID-30
  329.     ELSE
  330.       IDOYF := (275*IM) DIV 9 -2*((IM+9) DIV 12)+ID-30;
  331. END  { Function IDOYF };
  332.  
  333.  
  334. FUNCTION TIME: TIMESTRING;
  335.  
  336. {  This function returns the current clock time as a TimeString
  337.    of 6 bytes, such as:  "19:05h".
  338.  
  339.    Note:  TYPE TIMESTRING = STRING[6];
  340.  
  341.    Procedure adapted from the Turbo Pascal date example by
  342.    Harry M. Murphy,  19 February 1986.  }
  343.  
  344.   TYPE
  345.        REGPAK = RECORD
  346.                   AX,BX,CX,DX,BP,SI,DI,DS,ES,FL: INTEGER
  347.                 END;
  348.  
  349.   VAR
  350.       H,M,S,T: INTEGER;
  351.       HR:      STRING[2];
  352.       MN:      STRING[2];
  353.       REG:     REGPAK;
  354.  
  355.   BEGIN
  356.     WITH REG DO
  357.       BEGIN
  358.         AX := $2C00;
  359.         MSDOS(REG);
  360.         H := HI(CX);
  361.         M := LO(CX);
  362.         S := HI(DX);
  363.         T := LO(DX)
  364.       END;
  365.     IF T > 50 THEN S := S+1;
  366.     IF S > 30 THEN M := M+1;
  367.     IF M = 60
  368.       THEN
  369.         BEGIN
  370.           H := H+1;
  371.           M := 0;
  372.           IF H = 24 THEN H := 0
  373.         END;
  374.     STR(H:2,HR);
  375.     STR(M:2,MN);
  376.     IF MN[1]=' ' THEN MN[1] := '0';
  377.     TIME := HR+':'+MN+'h'
  378.   END {Function TIME};
  379.  
  380.  
  381. BEGIN
  382.   LOWVIDEO;
  383.   CLOCK := TIME;
  384.   GETTODAY(IY,IM,ID,IW,TODAY);
  385.   N := IDOYF(IY,IM,ID);
  386.   DSTF := DST(N,ID,IM,IW);
  387.   IF DSTF
  388.     THEN
  389.       ABBR := LOCDST
  390.     ELSE
  391.       ABBR := LOCST;
  392.   WRITELN;
  393.   WRITELN(CLOCK,' ',ABBR,',  ',TODAY);
  394.   WRITELN('This is day',N:4,' of the year',IY:5,'.');
  395.   SLAT := SIND(LAT);
  396.   CLAT := COSD(LAT);
  397.  
  398.   TR := N+(6.0-LON/15.0)/24.0;
  399.   M := 0.9856*TR-3.289;
  400.   L := AMOD(M+1.916*SIND(M)+0.020*SIND(2.0*M)+282.634,360.0);
  401.   SL := SIND(L);
  402.   CL := COSD(L);
  403.   RA := RTOD*ATAN2(0.91746*SL,CL)/15.0;
  404.   SD := 0.39782*SL;
  405.   CD := SQRT(1.0-SQR(SD));
  406.   H := (360.0-RTOD*ACOS((CZ-SD*SLAT)/(CD*CLAT)))/15.0;
  407.   TR := AMOD(H+RA-0.065710*TR-6.622-LON/15.0+TZONE,24.0);
  408.   IF DSTF THEN TR := TR+1;
  409.   TRH := TRUNC(TR);
  410.   TRM := TRUNC(FRAC(TR)*60.0);
  411.   IF TRM = 60
  412.     THEN
  413.       BEGIN
  414.         TRH := TRH+1;
  415.         TRM := 0
  416.       END;
  417.   HOUR:=HOURST(TRH,TRM);
  418.   WRITELN('Sunrise today is at ',HOUR,' ',ABBR,'.');
  419.  
  420.   TS := N+(18.0-LON/15.0)/24.0;
  421.   M := 0.9856*TS-3.289;
  422.   L := AMOD(M+1.916*SIND(M)+0.020*SIND(2.0*M)+282.634,360.0);
  423.   SL := SIND(L);
  424.   CL := COSD(L);
  425.   RA := RTOD*ATAN2(0.91746*SL,CL)/15.0;
  426.   SD := 0.39782*SL;
  427.   CD := SQRT(1.0-SQR(SD));
  428.   H := (RTOD*ACOS((CZ-SD*SLAT)/(CD*CLAT)))/15.0;
  429.   TS := AMOD(H+RA-0.065710*TS-6.622-LON/15.0+TZONE+24.0,24.0);
  430.   IF DSTF THEN TS := TS+1;
  431.   IF TS < 0.0
  432.     THEN
  433.       TS := TS+24.0;
  434.   TSH := TRUNC(TS);
  435.   TSM := ROUND(FRAC(TS)*60.0);
  436.   IF TSM = 60
  437.     THEN
  438.       BEGIN
  439.         TRH := TRH+1;
  440.         TRM := 0
  441.       END;
  442.   HOUR:=HOURST(TSH,TSM);
  443.   WRITELN('Sunset  today is at ',HOUR,' ',ABBR,'.')
  444. END.
  445.