home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / NRPAS13.ZIP / BADLUK.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-29  |  1.5 KB  |  53 lines
  1. PROGRAM badluk(input,output);
  2. LABEL 1,2;
  3. CONST
  4.    zon=-5.0;
  5.    iybeg=1900;
  6.    iyend=2000;
  7. VAR
  8.    timzon,frac: real;
  9.    ic,icon,idwk,im: integer;
  10.    iyyy,jd,jday,n: integer;
  11. (*$I MODFILE.PAS *)
  12. (*$I JULDAY.PAS *)
  13. (*$I FLMOON.PAS *)
  14. BEGIN
  15.    timzon := zon/24.0;
  16.    writeln('Full moons on Friday the 13th from',iybeg:5,' to',iyend:5);
  17.    FOR iyyy := iybeg TO iyend DO BEGIN
  18.       FOR im := 1 TO 12 DO BEGIN
  19.          jday := julday(im,13,iyyy);
  20.          idwk := (jday+1) MOD 7;
  21.          IF (idwk = 5)  THEN BEGIN
  22.             n := trunc(12.37*(iyyy-1900+(im-0.5)/12.0));
  23.             icon := 0;
  24. 1:            flmoon(n,2,jd,frac);
  25.             frac := 24.0*(frac+timzon);
  26.             IF (frac < 0.0) THEN BEGIN
  27.                jd := jd-1;
  28.                frac := frac+24.0
  29.             END;
  30.             IF (frac > 12) THEN BEGIN
  31.                jd := jd+1;
  32.                frac := frac-12.0
  33.             END ELSE BEGIN
  34.                frac := frac+12.0
  35.             END;
  36.             IF (jd = jday) THEN BEGIN
  37.                writeln;
  38.                writeln(im:2,'/',13:2,'/',iyyy:4);
  39.                writeln('Full moon ',frac:5:1,
  40.                   ' hrs after midnight (EST).');
  41.                GOTO 2 END
  42.             ELSE BEGIN
  43.                IF (jday >= jd) THEN ic := 1 ELSE ic := -1;
  44.                IF (ic = -icon) THEN GOTO 2;
  45.                icon := ic;
  46.                n := n+ic
  47.             END;
  48.             GOTO 1;
  49. 2:         END
  50.       END
  51.    END
  52. END.
  53.