var i,j,k,n,l,m,m1:longint;
    a,b,c,r:array [0..10000]      of integer;
    stack  :array [0..1,0..10000] of integer;

function search(k:integer):integer;
var i,j,l:integer;
begin
 l:=0;
 if k>1 then
  if c[a[k]]=0 then begin c[a[k]]:=c[k]+1; l:=1; end;
 for i:=1 to n do
 begin
  if a[i]=k then
   if c[i]=0 then begin c[i]:=c[k]+1; l:=1; end;
 end;
search:=l;
end;

begin
 read(n);
 for i:=2 to n do read(a[i]);
 for i:=1 to n do b[a[i]]:=1;
 for k:=1 to n do
 begin
  if b[k]=0 then continue;
  fillchar(stack,sizeof(stack),0);
  fillchar(c,sizeof(c),0);
  c[k]:=1; l:=0;
  while l=0 do
  begin
   for i:=1 to n do if c[i]>0 then l:=search(i);
   l:=1-l;
  end;
  l:=0;
  for i:=1 to n do if c[i]>l then l:=c[i];
  if l>m then
  begin
   fillchar(r,sizeof(r),0); m1:=0; m:=l;
  end;
  inc(m1);
  r[m1]:=k;
 end;
 for i:=1 to m1-1 do write(r[i],' ');
 writeln(r[m1]);
end.

var i,j,k,n,l,m,m1:longint;
    a,b,c,r:array [0..10000]      of integer;

function search(k:integer):integer;
var i,j,l:integer;
begin
 l:=0;
 if k>1 then if c[a[k]]=0 then begin c[a[k]]:=c[k]+1; l:=1; end;
 for i:=1 to n do if a[i]=k then
   if c[i]=0 then begin c[i]:=c[k]+1; l:=1; end;
search:=l;
end;

begin
 read(n);
 for i:=2 to n do begin read(a[i]); b[a[i]]:=1; end;
 for k:=1 to n do
 begin
  fillchar(c,sizeof(c),0);
  c[k]:=1; l:=0;
  while l=0 do
  begin
   for i:=1 to n do if c[i]>0 then
    if search(i)=1 then l:=1;
   l:=1-l;
  end;
  l:=0;
  for i:=1 to n do if c[i]>l then l:=c[i];
  if (l<m) or (m=0) then
  begin
   fillchar(r,sizeof(r),0); m1:=0; m:=l;
  end;
  if l=m then
  begin
   inc(m1);
   r[m1]:=k;
  end;
 end;
 for i:=1 to m1-1 do write(r[i],' ');
 writeln (r[m1]);
end.

my olgoritm is O(n*n*n); int`s bad;
Can you give me algoritm

var i,j,k,n,m,k1:integer;
    a,b,c :array [1..10000] of integer;
    s:array [0..1,0..10000] of integer;

procedure push(k,x:integer);
begin
 inc(s[k,0]);
 s[k,s[k,0]]:=x;
end;

function pop(k:integer):integer;
begin
 if s[k,0]>0 then
 begin
  pop:=s[k,s[k,0]];
  dec(s[k,0]);
 end else pop:=-1;
end;

function search(k:integer):integer;
var i,j,l:integer;
begin
 l:=0;
 if k>1 then if c[a[k]]=0 then
 begin
  c[a[k]]:=c[k]+1;
  l:=1;
  push(1-k1,a[k]);
 end;
 for i:=1 to n do
  if a[i]=k then
   if c[i]=0 then
   begin
    c[i]:=c[k]+1;
    l:=1;
    push(1-k1,i);
   end;
search:=l;
end;

procedure Init;
var i : integer;
begin
 read(n);
 b[1] := 0;
 for i := 2 to n do b[i] := 1;
 for i := 2 to n do begin read(a[i]); inc(b[a[i]]); end;
end;

begin
 Init;
 k1:=0;
 for i:=1 to n do
  if b[i]=1 then
  begin
   push(k,i);
   c[i]:=1;
  end;
 if n>2 then
 repeat
  while true do
  begin
   i:=pop(k1);
   if i=-1 then break;
   search(i);
  end;
  k1:=1-k1;
 until (pop(0)=-1) and (pop(1)=-1);
 j:=0;
 for i:=1 to n do if j<c[i] then j:=c[i];
 k := 0;
 for i:=1 to n do begin
    if c[i]=j then begin
       k:= k+1;
       b[k] := i;
    end;
 end;
 for i := 1 to k-1 do begin
    write(b[i],' ');
 end;
 write(b[k]);
end.

i can giv AC program
 if you give 1013

Tuphanov@eastnet.febras.ru

if you give me ac program 1089 or 1189 or 1013 or 1012 or else then i
give you 1059 ac

I can email you 1013 please email me 1056 and I will reply your
email with the solution to 1013. Thanks Email me at
drajmsadeq@yahoo.com