home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / NRPAS13.ZIP / FLMOON.DEM < prev    next >
Encoding:
Text File  |  1991-04-29  |  1.6 KB  |  65 lines
  1. PROGRAM d1r1(input,output);
  2. (* driver for routine FLMOON *)
  3. CONST
  4.    zon=-5.0;
  5. TYPE
  6.    name = PACKED ARRAY [1..13] OF char;
  7. VAR
  8.    timzon,frac,secs : real;
  9.    i,i1,i2,i3,id,im,iy : integer;
  10.    j1,j2,n,nph : integer;
  11.    phase : ARRAY [0..3] OF name;
  12.  
  13. (*$I MODFILE.PAS *)
  14. (*$I JULDAY.PAS *)
  15.  
  16. (*$I CALDAT.PAS *)
  17.  
  18. (*$I FLMOON.PAS *)
  19.  
  20. BEGIN
  21.    timzon := zon/24.0;
  22.    phase[0] := 'new moon     ';
  23.    phase[1] := 'first quarter';
  24.    phase[2] := 'full moon    ';
  25.    phase[3] := 'last quarter ';
  26.    writeln('date of the next few phases of the moon');
  27.    writeln('enter today''s date (e.g. 1 31 1982)  :  ');
  28.    readln(im,id,iy);
  29. (* approximate number of full moons since january 1900 *)
  30.    n := trunc(12.37*(iy-1900+trunc((im-0.5)/12.0)));
  31.    nph := 2;
  32.    j1 := julday(im,id,iy);
  33.    flmoon(n,nph,j2,frac);
  34.    n := n+trunc((j1-j2)/28.0);
  35.    writeln;
  36.    writeln('date':10,'time(est)':19,'phase':9);
  37.    FOR i := 1 to 20 DO BEGIN
  38.       flmoon(n,nph,j2,frac);
  39.       frac := 24.0*(frac+timzon);
  40.       IF  (frac < 0.0)  THEN BEGIN
  41.          j2 := j2-1;
  42.          frac := frac+24.0
  43.       END;
  44.       IF  (frac > 12.0)  THEN BEGIN
  45.          j2 := j2+1;
  46.          frac := frac-12.0
  47.       END ELSE BEGIN
  48.          frac := frac+12.0
  49.       END;
  50.       i1 := trunc(frac);
  51.       secs := 3600.0*(frac-i1);
  52.       i2 := trunc(secs/60.0);
  53.       i3 := trunc(secs-60*i2);
  54.       caldat(j2,im,id,iy);
  55.       writeln(im:5,id:3,iy:5,
  56.          i1:9,':',i2:2,':',i3:2,' ':5,phase[nph]);
  57.       IF  (nph = 3)  THEN BEGIN
  58.          nph := 0;
  59.          n := n+1
  60.       END ELSE BEGIN
  61.          nph := nph+1
  62.       END
  63.    END
  64. END.
  65.