My code:

Program t1153;

Const MaxDig=610;

Type BigInt=array[1..MaxDig]of byte;

Var  A,B,C,D      :BigInt;
     i,j,um,u,v,k :integer;
     t            :integer;
     S            :string;
     less         :boolean;

begin
 Readln(S);
 if s='0' then begin
  writeln(0);
  halt(0);
 end;
 j:=length(S);
 FillChar(A,SizeOf(A),0);
 for i:=1 to j do A[MaxDig-j+i]:=Ord(s[i])-Ord('0');
 FillChar(B,SizeOf(B),0);
 um:=0;
 for i:=MaxDig downto 1 do begin
  B[i]:=(A[i]*2+um) mod 10;
  um:=(A[i]*2+um) div 10;
 end;
 A:=B;
 FillChar(C,SizeOf(C),0);
 for k:=MaxDig-((length(S))div 2)-1 to MaxDig do begin
  for i:=1 to 10 do begin
   C[k]:=i;
   FillChar(D,SizeOf(D),0);
   for u:=MaxDig downto MaxDig-((length(S))div 2)-1 do begin
    um:=0;
    for v:=MaxDig downto MaxDig-((length(S))div 2)-1 do begin
     j:=c[u]*c[v]+um+d[-MaxDig+u+v];
     d[-MaxDig+u+v]:=j mod 10;
     um:=j div 10;
     end;
    t:=0;
    while um>0 do begin
     t:=t+1;
     j:=d[-MaxDig+u+v-t]+um;
     d[-MaxDig+u+v-t]:=j mod 10;
     um:=j div 10;
    end;
   end;
   less:=true;
   for u:=1 to MaxDig do
    if d[u]>a[u] then less:=false else
    if d[u]<a[u] then break;
   if not(less) then break;
  end;
  C[k]:=C[k]-1;
 end;
 i:=1;
 while c[i]=0 do i:=i+1;
 for j:=i to MaxDig do write(c[j]);writeln;
end.

> My code:
>
> Program t1153;
>
> Const MaxDig=610;
>
> Type BigInt=array[1..MaxDig]of byte;
>
> Var  A,B,C,D      :BigInt;
>      i,j,um,u,v,k :integer;
>      t            :integer;
>      S            :string;
>      less         :boolean;
>
> begin
>  Readln(S);
>  if s='0' then begin
>   writeln(0);
>   halt(0);
>  end;
>  j:=length(S);
>  FillChar(A,SizeOf(A),0);
>  for i:=1 to j do A[MaxDig-j+i]:=Ord(s[i])-Ord('0');
>  FillChar(B,SizeOf(B),0);
>  um:=0;
>  for i:=MaxDig downto 1 do begin
>   B[i]:=(A[i]*2+um) mod 10;
>   um:=(A[i]*2+um) div 10;
>  end;
>  A:=B;
>  FillChar(C,SizeOf(C),0);
>  for k:=MaxDig-((length(S))div 2)-1 to MaxDig do begin
>   for i:=1 to 10 do begin
>    C[k]:=i;
>    FillChar(D,SizeOf(D),0);
>    for u:=MaxDig downto MaxDig-((length(S))div 2)-1 do begin
>     um:=0;
>     for v:=MaxDig downto MaxDig-((length(S))div 2)-1 do begin
>      j:=c[u]*c[v]+um+d[-MaxDig+u+v];
>      d[-MaxDig+u+v]:=j mod 10;
>      um:=j div 10;
>      end;
>     t:=0;
>     while um>0 do begin
>      t:=t+1;
>      j:=d[-MaxDig+u+v-t]+um;
>      d[-MaxDig+u+v-t]:=j mod 10;
>      um:=j div 10;
>     end;
>    end;
>    less:=true;
>    for u:=1 to MaxDig do
>     if d[u]>a[u] then less:=false else
>     if d[u]<a[u] then break;
>    if not(less) then break;
>   end;
>   C[k]:=C[k]-1;
>  end;
>  i:=1;
>  while c[i]=0 do i:=i+1;
>  for j:=i to MaxDig do write(c[j]);writeln;
> end.

i can't say exactly when it comes to tl, but i've noticed some WA's
in your programme(if you still use the same prog as above).
email me: offsetq@nm.ru

wbr,BCN.