Here is my code!!! Please help me!!! What my mistake?
Const stroka='friend';
TYpe lmas=array[1..5000]of string;
VAR n     :integer;
    fr    :array[1..100]of string;
    a,b,c :array[1..100]of lmas;
    d,g,h :array[0..100]of integer;
Procedure INIT;
var i,j,p :integer;
    ch    :char;
    s,s1  :string;
begin
  readln(n);
  for i:=1 to n do begin
    readln(fr[i]);
    readln(s); j:=0; s1:='';
    while s<>'</blog>' do begin
      s1:=copy(s,pos('<',s)+1,6);
      while s1=stroka do begin
        p:=pos('<',s);
        if stroka=s1 then begin
           delete(s,pos('<',s),8);
           if copy(s,p,pos('<',s)-p)<>fr[i] then begin inc(j); a[i,j]:=copy(s,p,pos('<',s)-p); end;
        end;
        s1:=copy(s,pos('<',s)+1,6);
      end;
      s1:='';
      for p:=length(s) downto 1 do
        if s[p]<>' ' then begin s1:=s[p]+s1; if s1='</blog>' then begin s:=''; break; end else if length(s1)>7 then break;  end;
      if s='' then break; readln(s);
    end;
    d[i]:=j;
  end;
end;
Function FRIEND(x,y:integer):integer;
var i   :integer;
begin
  FRIEND:=0;
  for i:=1 to n do
    if x<>i then if fr[i]=a[x,y] then begin FRIEND:=i; exit end;
end;
Function OK(x,y:integer):boolean;
var i,j   :integer;
begin
  i:=FRIEND(x,y); OK:=FALSE;
  for j:=1 to d[i] do
    if a[i,j]=fr[x] then begin OK:=TRUE; exit end;
end;
Procedure SORT(var s:lmas;n:integer);
var i,j :integer;
    k   :string;
begin
  for j:=1 to n-1 do
    for i:=1 to n-j do
      if s[i]>s[i+1] then begin k:=s[i]; s[i]:=s[i+1]; s[i+1]:=k; end;
end;
Procedure SOLVE;
var i,j,p :integer;
begin
  for i:=1 to n do
    for j:=1 to d[i] do begin
      p:=FRIEND(i,j);
      inc(g[p]); b[p,g[p]]:=fr[i];
    end;
  for i:=1 to n do
    for j:=1 to d[i] do
      if OK(i,j) then begin inc(h[i]); c[i,h[i]]:=a[i,j]; end;
  for i:=1 to n do SORT(a[i],d[i]);
  for i:=1 to n do SORT(b[i],g[i]);
  for i:=1 to n do SORT(c[i],h[i]);
end;
Procedure OUT;
var i,j   :integer;
begin
  for i:=1 to n do begin
    writeln(fr[i]);
    write('1: '); j:=1; while j<d[i] do begin write(a[i,j],', '); inc(j); end; if a[i,j]<>'' then writeln(a[i,j]) else writeln;
    write('2: '); j:=1; while j<g[i] do begin write(b[i,j],', '); inc(j); end; if b[i,j]<>'' then writeln(b[i,j]) else writeln;
    write('3: '); j:=1; while j<h[i] do begin write(c[i,j],', '); inc(j); end; if c[i,j]<>'' then writeln(c[i,j]) else writeln;
    writeln;
  end;
end;
BEGIN
  INIT;
  SOLVE;
  OUT;
END.

I have wa17 when I had some dublicate names in array of friends.