program heat;
const m1 = 40; n1 = 50;
      m2 = 120; n2 = 120;
      m3 = 180; n3 = 200;
      m0 = 80;
      border = '*'; blank = ' ';
      templow = 32.0; (* low temp along edge in "bath" *)
      temphigh = 212.0; (* high temp in central rectangle *)
      tempmed = 100.0; (* medium temp at top *)
type atype = array[0..m3+1, 0..n3+1] of real;
     ctype = array[0..m3+1, 0..n3+1] of char;
var a: atype;
    c: ctype;
    istep: integer;
    change: real;
procedure init(var a:atype; var c: ctype);
var i, j: integer;
begin
   for i := 1 to m3 do
      for j := 1 to n3 do
         a[i,j] := tempmed;
   for i := 0 to m3+1 do
      for j := 0 to n3+1 do
         c[i,j] := blank;
   for j := 0 to n3+1 do
   begin
      a[0,j] := tempmed; a[m3+1,j] := templow;
      c[0,j] := border; c[m3+1,j] := border;
   end;
   for i := 0 to m0 do
   begin
      a[i,0] := ((templow - tempmed)/m0)*i + tempmed;
      a[i,n3+1] := a[i,0];
      c[i,0] := border; c[i,n3+1] := border
   end;
   for i := m0+1 to m3+1 do
   begin
      a[i,0] := templow; a[i,n3+1] := templow;
      c[i,0] := border; c[i,n3+1] := border
   end;
   for j := n1+1 to n2 -1 do
   begin
      a[m1+1,j] := temphigh; a[m2-1,j] := temphigh;
      c[m1+1,j] := border; c[m2-1,j] := border
   end;
   for i := m1+2 to m2-2 do
   begin
      a[i,n1+1] := temphigh; a[i,n2-1] := temphigh;
      c[i,n1+1] := border; c[i,n2-1] := border
   end
end; (* init *)

procedure step(var a:atype; var change: real);
var i, j: integer;
    olda, newa: real;
begin
   change := 0.0;
   for i := 1 to m3 do
      for j := 1 to n3 do
      begin
         if ((i <= m1) or (i >= m2) or
             (j <= n1) or (j >= n2)    ) then
         begin
            olda := a[i,j];
            newa := 0.25*(a[i-1,j] + a[i+1,j] +
                       a[i,j-1] + a[i,j+1]);
            if abs(olda - newa) > change then
               change := abs(olda - newa);
            a[i,j] := newa
         end
      end
end; (* step *)

function convert(i: integer):char;
var c: array[1..26] of char;
    cval: integer;
begin
   c := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
   cval := round((templow - i)*(25.0/(temphigh - templow)) + 25.0);
   if (cval < 1) or (cval > 26) then convert := border
   else convert := c[cval]
end; (* convert *)

procedure store(var a:atype; var c: ctype);
var 
    i, j: integer;
begin
   for i := 1 to m3 do
      for j := 1 to n3 do
         if ((i <= m1) or (i >= m2) or
             (j <= n1) or (j >= n2) ) then
            c[i,j] := convert(trunc(a[i,j]))
end; (* store *)

procedure disp(var c: ctype);
var 
    i, j: integer;
begin
   for i := 0 to m3+1 do
   begin
      for j := 0 to n3+1 do
         write(c[i,j]);
      writeln
   end
end; (* disp *)

procedure key;
var i: integer;
begin
   writeln('Temperature key');
   writeln;
   writeln('Temp    Letter');
   writeln;
   i := 32;
   while i <= 212 do
   begin
      writeln(i:6, convert(i):5);
      i := i + 4
   end
end; (* key *)

begin
   init(a, c);
   key;
   istep := 0;
   repeat
      step(a, change);
      istep := istep + 1
   until (change < 0.25) or (istep > 1000);
   writeln('Number of steps:', istep);
   writeln;
   store(a, c);
   disp(c);
end.