Program DIATAB; {HT20050805 minor modification 20061116}
{$R+}
uses CRT;

const        maxjump = 6; {largest gap + 1, for fillgap}

type            line = array [0..144] of single;

var        row, next : array [1..27] of single; {rows of main data}
               table : array [1..20] of line;
            measured : line;
   cycle, num, grade : integer;

procedure filter;
   var x, y, c : line;
       i, j, k : integer;
        sx, sn : single;
   begin
      for j := 1 to 20 do begin
         c := measured;
         {interpolation}
         x := table [j];
         y [0] := x [1];
         for i := 1 to num - 1 do begin
            sx := c [i] * x [i] + c [i + 1] * x [i + 1];
            sn := c [i] + c [i + 1];
            if sn = 0 then y [i] := 0
            else begin y [i] := sx / sn; c [i] := 1; end;
         end;
         y [num] := x [num];
         {filter}
         if grade > 0 then for k := 1 to grade do begin {triple averages}
            x := y;
            for i := 1 to num - 1 do begin
               sx := c [i - 1] * x [i - 1]
                   + 2 * c [i] * x [i]
                   + c [i + 1] * x [i + 1];
               sn := c [i - 1] + 2 * c [i] + c [i + 1];
               if sn > 1.5 then y [i] := sx / sn;
            end;
         end;
         for i := 0 to num do if y [i] < 0 then table [j, i] := 0
                                           else table [j, i] := y [i];
      end;
      measured := c;
   end;

procedure fillgaps;
   {uses variables table and cycle}
   var i, j, p, q, d : integer;
   begin
      for p := 0 to num - maxjump do {p = left border}
      if (measured [p] = 1) and (measured [p + 1] = 0) then begin {gap found}
         q := p + 2; {q = right border}
         while (measured [q] = 0) and (q < (p + maxjump)) do q := q + 1;
         if measured [q] = 1 then begin  {fill the gap}
            d := q - p;
            for j := p + 1 to q - 1 do for i := 1 to 20 do begin
               table [i, j] := {linear interpolation}
                               ((j - p) / d) * table [i, p]
                             + ((q - j) / d) * table [i, q];
            end;
         end;
      end;
   end;

procedure savetable (filename : string; b : integer);
   var i, j : integer;
          f : text;
          d : string;
   begin
   assign (f, filename); rewrite (f);
   for i := 1 to 10 do begin
      for j := 0 to num do begin
         write (f, table [b + i, j]:1:0);
         if j = num then writeln (f) else write (f, #09);
      end;
   end;
   close (f);
   getdir (0, d);
   writeln (d, '\',  filename, ' is written');
   end; {of savetable}

procedure savetables;
   var   s : string;
      i, j : integer;
   begin
   for j := 1 to num do begin
      measured [j] := 0;
      for i := 1 to 20 do if table [i, j] > 0
                          then measured [j] := 1;
   end;
   measured [0] := measured [1];
   filter;
   fillgaps;
   str (round (1000000 + row [1]), s);
   s := copy (s, 2, 6) + '.xl';
   savetable ('p' + s, 0);
   savetable ('n' + s, 10);
   for i := 1 to 20 do for j := 0 to num do table [i, j] := 0;
   end;

procedure upgradetable;
   var hhmm, m, i, j : integer;
                a, b : single;
   begin
   {correct zero error if negative value}
   for i := 1 to 10 do begin
      a := row [7 + i];
      b := row [17 + i];
      if (a < 0) and (b > 0) then begin
         if (a + b) < 0 then begin a := a + b; b := 0 end
                        else begin b := a + b; a := 0 end
      end
      else if (b < 0) and (a > 0) then begin
         if (a + b) > 0 then begin a := a + b; b := 0 end
                        else begin b := a + b; a := 0 end
      end;
      row [7 + i] := a;
      row [17 + i] := b;
   end;
   {write row to the table}
   hhmm := round (row [2]);
   m := 60 * (hhmm div 100) + hhmm mod 100;
   j := 1 + m div cycle;
   for i := 1 to 20 do table [i, j] := 8 * row [7 + i];
                                      {8 = 1 / d(log d)}
   end;

var    i, j, y : longint;
   s, dataname : string;
          data : text;
begin
   clrscr;
   if paramcount > 0 then begin
      s := paramstr (1);
      y := length (s);
      i := y;
      repeat i := i - 1 until s [i] = '\';
      chdir (copy (s, 1, i - 1));
      dataname := copy (s, i + 1, y - i);
   end
   else begin
      writeln;
      writeln (' Normal way to run this program is to drag the icon of');
      writeln (' a BSMA output file onto the icon of the program file');
      writeln (' If you wish to use this method then exit now the program');
      writeln (' pressing immediately ENTER instead of the filename.');
      write (' Please press ENTER or write the name of the data file: ');
      readln (dataname);
      if dataname = '' then halt;
   end;
   assign (data, dataname);
   {$I-} reset (data); {$I+}
   if IOresult <> 0 then begin
      writeln (' Sorry, ', dataname, ' is not available.');
      writeln (' Press ENTER for escape!');
      readln; halt;
   end;
   if  (copy (dataname, 1, 2) <> '2E')
   and (copy (dataname, 1, 2) <> '3A') then begin
      writeln (' Sorry, ', dataname, ' is not BSMA2E/3A output file.');
      writeln (' Press ENTER for escape!');
      readln; halt;
   end;
   repeat
      writeln;
      writeln ('Data can be smoothed repeating N times',
               ' averaging over the triads of neighbors.');
      writeln ('Recommended standard smoothing grade N = 1.');
      write ('Please tell your choice of the smoothing grade N (0...5) : ');
      readln (grade);
   until grade in [0..5];
   j := 0;
   readln (data, s);
   repeat
      readln (data, y, i);
      cycle := i - j;
      j := i;
   until (cycle = 10) or (cycle = 15);
   num := 1440 div cycle;
   reset (data); readln (data, s);
   for i := 1 to 20 do for j := 0 to num do table [i, j] := 0;
   for i := 1 to 27 do read (data, next [i]); readln (data);
   repeat
      row := next;
      upgradetable;
      for i := 1 to 27 do read (data, next [i]); readln (data);
      if next [1] <> row [1] then savetables;
   until eof (data);
   row := next;
   upgradetable;
   savetables;
   writeln (' Done. Press ENTER for escape!');
   readln;
end.