var
  a:array[1..100,0..100] of 0..1;
  b:array[1..100] of integer;
  n,i,j,k:integer;
begin
  readln(n);
  for i:=1 to n do begin
    read(j);
    while j<>0 do begin
      a[i,j]:=1;
      read(j);
    end;
    readln;
    b[i]:=i;
  end;
  for i:=1 to n do
    for j:=1 to n do
      for k:=1 to n do
        if (a[i,j]=1)and(a[j,k]=1) then a[i,k]:=1;
  for i:=1 to n do
    for j:=1 to n do inc(a[i,0],a[i,j]);
  for i:=1 to n-1 do for j:=i+1 to n do
    if a[b[i],0]<a[b[j],0] then begin
      k:=b[i];
      b[i]:=b[j];
      b[j]:=k;
    end;
  for i:=1 to n do write(b[i],' ');
  writeln;
end.

Try this: delete the writeln; at the last line

> Try this: delete the writeln; at the last line

Thanks a lot!!!!