My code:

Program t1153;

Const MaxDig=1400;
      CanUse='0123456789';

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

Var  A,B,C,D      :BigInt;
     i,j,um,u,v,k :integer;
     t,p,lens     :integer;
     ch           :char;
     less         :boolean;

begin
 FillChar(A,SizeOf(A),0);
 j:=0;
 while not(EOLN) do begin
  read(ch);
  while (pos(ch,CanUse)=0)and(EOLN=false) do read(ch);
  if ch=#13 then break;
  if ch=#10 then break;
  j:=j+1;
  B[j]:=pos(ch,CanUse)-1;
 end;
 for i:=1 to j do A[MaxDig-j+i]:=B[i];
 lens:=j;
 p:=MaxDig-lens-1;
 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-((lenS)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-((lenS)div 2)-1 do begin
    um:=0;
    for v:=MaxDig downto MaxDig-((lenS)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 begin less:=false;break; end 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.