Ну вот так у меня получилось третья. Замечу, что введенное ограничение диапазона в 10000 связано с тем, что программа очень долго добирается до следующего после 8128 идеального числа 33550336. Но Вы можете попробовать это ограничение снять, поставив, например, вместо 10000 40000000, и, соответственно, Dmin=80000000 (например). Может быть, у Вас и пойдет, мой DOS-Pascal на таких числах затыкается.
Код:
var
a,j,D,Dmin,Id_near:Integer;
Function Ideal(R:Integer):Boolean;
var i,Sum:Integer;
begin
Sum:=0;
For i:=R-1 downto 1 do
if (R mod i)=0 then Inc(Sum,i);
Ideal:=(R=Sum);
end;
Begin
Write('a (<10000) = ');
Readln(a);
Dmin:=20000;
j:=1;
Repeat
Inc(j);
If Ideal(j) then
begin
D:=Abs(a-j);
if D<Dmin then
begin
Id_near:=j;
Dmin:=D;
end;
end;
Until (D>Dmin) or (j=10000);
Writeln('Nearest Ideal is ',Id_near);
readln
End.