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