This is my program:

{$N+}
var
  flag:boolean;
  s:string;
  a,b:array [1..601] of longint;
  x,temp,last,lasttemp:extended;
  l,k:longint;
  code,i,j:integer;

procedure pingfanggen;
begin
  if odd(l) then
    begin
      inc(l);
      a[l]:=0;
    end;
  for i:=9 downto 1 do
    if i*i<=a[l]*10+a[l-1] then
      begin
        last:=a[l]*10+a[l-1]-i*i;
        b[1]:=i;
        k:=1;
        break;
      end;
  lasttemp:=0;
  for i:=(l-1) div 2 downto 1 do
    begin
      x:=a[i*2]*10+a[i*2-1]+last*100;
      inc(k);
      temp:=((b[k-1]*2)+lasttemp)*10;
      for j:=9 downto 0 do
        if (temp+j)*j<=x then
          begin
            temp:=temp+j;
            break;
          end;
      b[k]:=j;
      last:=x-b[k]*temp;
      lasttemp:=temp;
    end;
end;

begin
  readln(s);
  l:=length(s);
  for i:=l downto 1 do
    val(s[l-i+1],a[i],code);
  for i:=1 to l do
    a[i]:=a[i]*8;
  a[1]:=a[1]+1;
  for i:=1 to l+2 do
    if a[i]>9 then
      begin
        a[i+1]:=a[i+1]+a[i] div 10;
        a[i]:=a[i] mod 10;
        if i+1>l then l:=i+1;
      end;
  pingfanggen;
  fillchar(a,sizeof(a),0);
  for i:=1 to k do
    a[i]:=b[k-i+1];
  l:=k;
  a[1]:=a[1]-1;
  for i:=1 to l do
    if a[i]<0 then
      begin
        a[i+1]:=a[i+1]-1;
        a[i]:=a[i]+10;
      end;
  for i:=l downto 1 do
    begin
      a[i-1]:=a[i-1]+10*(a[i] mod 2);
      a[i]:=a[i] div 2;
    end;
  flag:=true;
  for i:=l downto 1 do
    if (flag=false)or(a[i]<>0) then begin write(a[i]); flag:=false; end;
  writeln;
end.

Could you help me? Thank you!