home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug039.arc / SUNCALC.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  4KB  |  109 lines
  1. (**from Colin Mc Carthy    date 17/11/84
  2. The following program written in Turbo Pascal
  3. calculates sunrise and sunset for any longitude
  4. and latitude. Although not elegent, it seems to
  5. work ok. Please note negative argument for east
  6. longitude, south latitude, east timezone.**)
  7.  
  8. (* Program to find sunrise & sunset for any lat. long.
  9.    Modified from D. Rapson's Sbasic program Day.bas
  10.    This version written in Turbo Pascal by C.McCarthy 18 Oct 1984
  11.    Accuracy +/- 10 min. from 1752 UK. 1610 Europe. *)
  12. var factor,fa,day,daysaving,date,month,lat,long,timezone:real;
  13.     s,x,c,cons,t,ds,et,br,bs,gmt1,gmt2,rise,riset,sets,sett:real;
  14.     d,m,y,weekday:integer;
  15.     start,error:boolean;
  16.     more,dsaving:char;
  17. function tan(angle:real):real;
  18. begin
  19.     tan:=sin(angle)/cos(angle);
  20. end;
  21. begin
  22.     start:=true;
  23.     while start do begin
  24.     error:=true;
  25.     while error do
  26.     begin
  27.         clrscr;
  28.         writeln('---------- Sunrise and Sunset ----------':61);
  29.         writeln('(Not valid prior to 1610)':54);writeln;
  30.         write('Day: ');read(d);write('  Month: ');read(m);
  31.         write('  Year: ');readln(y);
  32.         error:=false;
  33.         if (d>31) or (m>12) or (y<1610) then error:=true;
  34.     end;
  35.     write('Daylight saving? (Y/N) ');
  36.     repeat read(kbd,dsaving) until upcase(dsaving) in ['Y','N'];
  37.     writeln(dsaving);
  38.     if upcase(dsaving)='Y' then daysaving:=1 else daysaving:=0;
  39.     writeln;
  40.     writeln('Enter -DD.MM for east longitude, south latitude, east timezone');
  41.     write('Longitude: ');readln(long);
  42.     write('Latitude: ');readln(lat);
  43.     write('Timezone: ');readln(timezone);
  44.     if lat=90 then lat:=89.99;
  45.     if lat=-90 then lat:=-89.99;
  46.     if (m=1) or (m=2) then
  47.     factor:=365.0*y+d+31*(m-1)+int((y-1)/4)-int(0.75*int((y/100)+1))
  48.     else
  49.     factor:=365.0*y+d+31*(m-1)-int(0.4*m+2.3)+int(y/4)-int(0.75*int((y/100)+1));
  50.     fa:=int(-factor/7);
  51.     day:=factor+(fa*7);
  52.     weekday:=trunc(day);è    writeln;
  53.     case weekday of
  54.        0:write('Saturday');
  55.        1:write('Sunday');
  56.        2:write('Monday');
  57.        3:write('Tuesday');
  58.        4:write('Wednesday');
  59.        5:write('Thursday');
  60.        6:write('Friday');
  61.     end;
  62.     write(' ',d,' ');
  63.     case m of
  64.        1:write('January');
  65.        2:write('February');
  66.        3:write('March');
  67.        4:write('April');
  68.        5:write('May');
  69.        6:write('June');
  70.        7:write('July');
  71.        8:write('August');
  72.        9:write('September');
  73.        10:write('October');
  74.        11:write('November');
  75.        12:write('December');
  76.     end;
  77.     writeln(' ',y);
  78.      date:=int(d);
  79.      month:=int(m);
  80.      c:=0.0174532925;
  81.      t:=0.988*(date+30.3*(month-1));
  82.      ds:=23.5*(cos((t+10)*c));
  83.      et:=0.123*(cos((t+87)*c))-(sin(2*(t+10)*c))/6;
  84.      x:=tan(ds*c)*tan(lat*c);
  85.      s:=sqr(x);
  86.      cons:=(1.5708-(x*(1+s/2*(1/3+3/4*s*(1/5+5/6*s*(1/7+7/8*s*(1/9+0.9*s/11)))))))/c;
  87.      gmt1:=12-et+(long-cons)/15;
  88.      gmt2:=12-et+(long+cons)/15;
  89.      rise:=gmt1-timezone-0.05;
  90.      sets:=gmt2-timezone+0.05;
  91.      br:=(rise-int(rise))*60/100-0.005;
  92.      bs:=(sets-int(sets))*60/100-0.005;
  93.      riset:=int(rise)+br+daysaving;
  94.      sett:=int(sets)+bs+daysaving;
  95.      writeln;
  96.      if sett>23.59 then writeln('Sun does not set.')
  97.      else if riset>sett then writeln('Sun does not rise.')
  98.      else
  99.      begin
  100.          writeln('Sunrise  ',riset:11:2);
  101.          writeln('Sunset   ',sett:11:2);
  102.      end;
  103.      writeln;writeln;
  104.      write('More? (Y/N) ');
  105.      repeat read(kbd,more) until upcase(more) in ['Y','N'];
  106.      writeln(more);
  107.      if upcase(more)='N' then start:=false;
  108.  end;(* start *)
  109. end.