home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Phoenix CD 2.0
/
Phoenix_CD.cdr
/
15a
/
murutil.zip
/
ALMANAC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-01-02
|
11KB
|
445 lines
{$P256}
PROGRAM ALMANAC;
{ "Almanac Program"
This Turbo Pascal program displays the current time, day of the week,
date and times for sunrise and sunset.
Reference: "Almanac for Computers 1984", Nautical Almanac Office,
United States Naval Observatory, Washington, D.C.,
Pages B5 to B7.
Version: 1 Jan 1987.
Program by:
Harry M. Murphy, Consultant
3912 Hilton Avenue, NE
Albuquerque, NM 87110
Tel: (505) 881-0519 }
{ NOTICE
Copyright 1986, Harry M. Murphy.
A general license is hereby granted for non-commercial
use, copying and free exchange of this program without
payment of any royalties, provided that this copyright
notice is not altered nor deleted. All other rights are
reserved. Harry M. Murphy }
CONST
LAT = 35.0536; { Local latitude in degrees north. }
LON = -106.5883; { Local longitude in degrees east. }
LOCDST = 'MDST'; { Local daylight savings time abbr.}
LOCST = 'MST'; { Local standard time abbreviation.}
TZONE = -7.0; { Local time zone in hours. }
{ Note: LAT, LON, LOCDST, LOCST and TZONE are for Albuquerque, NM. }
CZ = -0.01454;
RTOD = 57.29577951;
TYPE
DATESTRING = STRING[28];
TIMESTRING = STRING[6];
VAR
ABBR : TIMESTRING;
CD : REAL;
CL : REAL;
CLAT : REAL;
CLOCK : TIMESTRING;
DSTF : BOOLEAN;
H : REAL;
HOUR : TIMESTRING;
ID : INTEGER;
IM : INTEGER;
IW : INTEGER;
IY : INTEGER;
L : REAL;
M : REAL;
N : INTEGER;
RA : REAL;
SD : REAL;
SL : REAL;
SLAT : REAL;
TODAY : DATESTRING;
TR : REAL;
TRH : INTEGER;
TRM : INTEGER;
TS : REAL;
TSH : INTEGER;
TSM : INTEGER;
TT : REAL;
FUNCTION ACOS(X: REAL): REAL;
{ This function returns the arc-cosine of its argument in radians,
over the range of zero to Pi.
Function by Harry M. Murphy, 19 February 1986. }
CONST
R090 = 1.570796327;
R180 = 3.141592654;
VAR
AC : REAL;
BEGIN
IF X = 0.0
THEN
ACOS := R090
ELSE
BEGIN
AC := ARCTAN(SQRT(1.0-SQR(X))/X);
IF AC < 0.0 THEN AC := AC+R180;
ACOS := AC
END
END { Function ACOS };
FUNCTION AMOD(X,Y: REAL): REAL;
{ This function returns X modulus Y, where both X and Y are REAL.
Function by Harry M. Murphy, 19 February 1986. }
BEGIN
AMOD := X-INT(X/Y)*Y
END { Function AMOD };
FUNCTION ATAN2(Y,X: REAL): REAL;
{ This function returns the arc-tangent of Y/X, in radians, over the
range of zero to two-Pi.
Function by Harry M. Murphy, 30 July 1986. }
CONST
R090 = 1.570796327;
R180 = 3.141592654;
R270 = 4.712388980;
R360 = 6.283185307;
VAR
AT : REAL;
BEGIN
IF X <> 0.0
THEN
AT := ARCTAN(Y/X)
ELSE
IF Y > 0.0
THEN
AT := R090
ELSE
AT := R270;
IF X < 0.0 THEN AT := AT+R180;
IF AT < 0.0 THEN AT := AT+R360;
ATAN2 := AT
END { Function ATAN2 };
FUNCTION COSD(X: REAL): REAL;
{ This function returns the cosine of an argument in degrees.
Function by Harry M. Murphy, 19 February 1986. }
CONST
DTOR = 1.745329252E-2;
BEGIN
COSD := COS(DTOR*X)
END { Function COSD };
FUNCTION SIND(X: REAL): REAL;
{ This function returns the sine of an argument in degrees.
Function by Harry M. Murphy, 19 February 1986. }
CONST
DTOR = 1.745329252E-2;
BEGIN
SIND := SIN(DTOR*X)
END { Function SIND };
FUNCTION DST(ND,ID,IM,IW: INTEGER): BOOLEAN;
{ Given the day number, ND, the day number, ID, the month number, IM,
and the weekday number, IW, this function returns TRUE only if
Daylight Savings Time is in effect.
Current with the Congressional change of May, 1986, which defines
Daylight Savings Time to run from the first Sunday in April to the
last Sunday in October.
Routine by Harry M. Murphy, 31 July 1986. }
BEGIN
IF (ND < 91) OR (ND > 305)
THEN
DST := FALSE
ELSE
IF (ND > 98) AND (ND < 296)
THEN
DST := TRUE
ELSE
IF IM=4
THEN
DST := (ID-IW) > 0
ELSE
DST := (ID-IW) < 25
END {Function DST};
PROCEDURE GETTODAY(VAR IY,IM,ID,IW: INTEGER; VAR TODAY: DATESTRING);
{ This procedure returns the current date as the INTEGER year, month,
day and weekday and as a DateString of up to 28 bytes, such as:
"Tuesday, 18 February 1986".
Notes:
(1) The year is returned as four digits (e.g. "1986").
(2) The weekday is returned in the range of 0 to 6,
corresponding to Sunday through Saturday.
(3) TYPE DATESTRING = STRING[28];
Procedure adapted from the Turbo Pascal date example by
Harry M. Murphy, 18 February 1986. Updated 12 April 1986. }
TYPE
REGPAK = RECORD
AX,BX,CX,DX,BP,SI,DI,DS,ES,FL: INTEGER
END;
VAR
JC,JD,JM,JY: INTEGER;
REG: REGPAK;
DAY: STRING[2];
YEAR: STRING[4];
BEGIN
WITH REG DO
BEGIN
AX := $2A00;
MSDOS(REG);
IY := CX;
IM := HI(DX);
ID := LO(DX)
END;
JY := IY;
JM := IM-2;
IF JM < 1
THEN
BEGIN
JM := JM+12;
JY := JY-1
END;
JC := JY DIV 100;
JD := JY-100*JC;
IW := ((ID+42+(13*JM-1) DIV 5 +JD+JD DIV 4+JC DIV 4-2*JC) MOD 7);
CASE IW OF
0: TODAY := 'Sunday, ';
1: TODAY := 'Monday, ';
2: TODAY := 'Tuesday, ';
3: TODAY := 'Wednesday, ';
4: TODAY := 'Thursday, ';
5: TODAY := 'Friday, ';
6: TODAY := 'Saturday, '
END { CASE };
STR(ID:2,DAY);
STR(IY:4,YEAR);
CASE IM OF
1: TODAY := TODAY+DAY+' January '+YEAR;
2: TODAY := TODAY+DAY+' February '+YEAR;
3: TODAY := TODAY+DAY+' March '+YEAR;
4: TODAY := TODAY+DAY+' April '+YEAR;
5: TODAY := TODAY+DAY+' May '+YEAR;
6: TODAY := TODAY+DAY+' June '+YEAR;
7: TODAY := TODAY+DAY+' July '+YEAR;
8: TODAY := TODAY+DAY+' August '+YEAR;
9: TODAY := TODAY+DAY+' September '+YEAR;
10: TODAY := TODAY+DAY+' October '+YEAR;
11: TODAY := TODAY+DAY+' November '+YEAR;
12: TODAY := TODAY+DAY+' December '+YEAR
END { CASE }
END { Procedure GETTODAY };
FUNCTION HOURST(VAR TH,TM: INTEGER): TIMESTRING;
{ This function returns a time in hours (TH) and minutes (TM) as a
6-byte TIMESTRING, such as: "19:05h".
Function by Harry M. Murphy, 1 August 1986. }
VAR
HR : STRING[2];
MN : STRING[2];
BEGIN
STR(TH:2,HR);
STR(TM:2,MN);
IF MN[1]=' ' THEN MN[1] := '0';
HOURST := HR+':'+MN+'h'
END {Function HOURST};
FUNCTION IDOYF(VAR IY,IM,ID: INTEGER): INTEGER;
{ This function returns the day of the year, given the year, month
and day of the month. The day of the year is defined as the time
elapsed in days since January 0 of the current year.
Note: This routine is valid from 0 January 1583 onwards.
Inputs:
IY The year number, 1583 to ????. (INTEGER)
IM The month number, 1 to 12. (INTEGER)
ID The day number, 0 to 31. (INTEGER)
Output:
IDOYF The day of the year, 1 to 365 (or 366). (INTEGER)
Ref: "Almanac for Computers 1981", Naval Almanac Office, U.S.
Naval Observatory, Washington, D.C., page B1.
Routine by Harry M. Murphy. Adapted for Pascal on 9 March 1986. }
VAR
LEAP : BOOLEAN;
BEGIN
LEAP := (IY MOD 4) = 0;
IF (IY MOD 100) = 0 THEN LEAP := (IY MOD 400) = 0;
IF LEAP
THEN
IDOYF := (275*IM) DIV 9 - (IM+9) DIV 12 +ID-30
ELSE
IDOYF := (275*IM) DIV 9 -2*((IM+9) DIV 12)+ID-30;
END { Function IDOYF };
FUNCTION TIME: TIMESTRING;
{ This function returns the current clock time as a TimeString
of 6 bytes, such as: "19:05h".
Note: TYPE TIMESTRING = STRING[6];
Procedure adapted from the Turbo Pascal date example by
Harry M. Murphy, 19 February 1986. }
TYPE
REGPAK = RECORD
AX,BX,CX,DX,BP,SI,DI,DS,ES,FL: INTEGER
END;
VAR
H,M,S,T: INTEGER;
HR: STRING[2];
MN: STRING[2];
REG: REGPAK;
BEGIN
WITH REG DO
BEGIN
AX := $2C00;
MSDOS(REG);
H := HI(CX);
M := LO(CX);
S := HI(DX);
T := LO(DX)
END;
IF T > 50 THEN S := S+1;
IF S > 30 THEN M := M+1;
IF M = 60
THEN
BEGIN
H := H+1;
M := 0;
IF H = 24 THEN H := 0
END;
STR(H:2,HR);
STR(M:2,MN);
IF MN[1]=' ' THEN MN[1] := '0';
TIME := HR+':'+MN+'h'
END {Function TIME};
BEGIN
LOWVIDEO;
CLOCK := TIME;
GETTODAY(IY,IM,ID,IW,TODAY);
N := IDOYF(IY,IM,ID);
DSTF := DST(N,ID,IM,IW);
IF DSTF
THEN
ABBR := LOCDST
ELSE
ABBR := LOCST;
WRITELN;
WRITELN(CLOCK,' ',ABBR,', ',TODAY);
WRITELN('This is day',N:4,' of the year',IY:5,'.');
SLAT := SIND(LAT);
CLAT := COSD(LAT);
TR := N+(6.0-LON/15.0)/24.0;
M := 0.9856*TR-3.289;
L := AMOD(M+1.916*SIND(M)+0.020*SIND(2.0*M)+282.634,360.0);
SL := SIND(L);
CL := COSD(L);
RA := RTOD*ATAN2(0.91746*SL,CL)/15.0;
SD := 0.39782*SL;
CD := SQRT(1.0-SQR(SD));
H := (360.0-RTOD*ACOS((CZ-SD*SLAT)/(CD*CLAT)))/15.0;
TR := AMOD(H+RA-0.065710*TR-6.622-LON/15.0+TZONE,24.0);
IF DSTF THEN TR := TR+1;
TRH := TRUNC(TR);
TRM := TRUNC(FRAC(TR)*60.0);
IF TRM = 60
THEN
BEGIN
TRH := TRH+1;
TRM := 0
END;
HOUR:=HOURST(TRH,TRM);
WRITELN('Sunrise today is at ',HOUR,' ',ABBR,'.');
TS := N+(18.0-LON/15.0)/24.0;
M := 0.9856*TS-3.289;
L := AMOD(M+1.916*SIND(M)+0.020*SIND(2.0*M)+282.634,360.0);
SL := SIND(L);
CL := COSD(L);
RA := RTOD*ATAN2(0.91746*SL,CL)/15.0;
SD := 0.39782*SL;
CD := SQRT(1.0-SQR(SD));
H := (RTOD*ACOS((CZ-SD*SLAT)/(CD*CLAT)))/15.0;
TS := AMOD(H+RA-0.065710*TS-6.622-LON/15.0+TZONE+24.0,24.0);
IF DSTF THEN TS := TS+1;
IF TS < 0.0
THEN
TS := TS+24.0;
TSH := TRUNC(TS);
TSM := ROUND(FRAC(TS)*60.0);
IF TSM = 60
THEN
BEGIN
TRH := TRH+1;
TRM := 0
END;
HOUR:=HOURST(TSH,TSM);
WRITELN('Sunset today is at ',HOUR,' ',ABBR,'.')
END.