Дана строка, состоящая из слов: вывести слова, которые повторяются хотя бы один раз

Program lab_7;
const n=10;
type
 mas=array[1..n] of string;
 mas2=array[1..n] of string;
procedure str(var a:mas);
 var i:integer;
 begin
  writeln('');
  for i:=1 to n do
   Readln(a[i])
 end;
procedure concl(var b:mas2);
 var i:integer;
 begin
  writeln('');
  for i:=1 to n do
  writeln(b[i])
 end;
var
 i,j:integer;
 a:mas;
 b:mas2;
 begin
 str(a);
for i:=1 to n-1 do
for j:=i+1 to n do
If a[i]=a[j] then
b[i]:=a[i];
mas2(b)
end.

var
  st:array of record
    s:string;
    c:integer;
  end;
  s,t:string;
  i,j,k:integer;
 
begin
  write('CTPOKA:');readln(s);
  s:=s+' ';
  for i:=1 to length(s) do begin
    if s[i]=' ' then begin
      k:=-1;
      for j:=0 to length(st)-1 do
        if st[j].s=t then k:=j;
      if k=-1 then begin
        k:=length(st);
        setlength(st,k+1);
      end;
        st[k].s:=t;
        inc(st[k].c);
        t:='';
     end else t:=t+s[i];
   end;
   writeln('PE3-TAT:'); 
   for j:=0 to length(st)-1 do begin
     if st[j].c>1 then writeln(st[j].s);
   end;
   readln;
end.

{ вывод повторяющихся слов }
const Blanks=[#9,#32];
var
  s, w: String;
  i, j, k, p, q, n: Integer;
begin
  Write(' Текст: '); ReadLn(s); 
  i:=1; while (i<=Length(s)) and (s[i] in Blanks) do Inc(i); Delete(s,1,i-1);
  i:=1;
  while i<=Length(s) do begin
    p:=i; while (i<=Length(s)) and not (s[i] in Blanks) do Inc(i);
    j:=i; while (i<=Length(s)) and     (s[i] in Blanks) do Inc(i);
    w:=Copy(s,p,j-p); Delete(s,j+1,i-j-1); Dec(i,i-j-1); k:=i; n:=0;
    while k<=Length(s) do begin
      q:=k; while (k<=Length(s)) and not (s[k] in Blanks) do Inc(k);
      j:=k; while (k<=Length(s)) and     (s[k] in Blanks) do Inc(k);
      Delete(s,j+1,k-j-1); Dec(k,k-j-1);
      if w=Copy(s,q,k-q-1) then begin
        Delete(s,q,k-q); Dec(k,k-q); Inc(n);
      end;
    end;
    if n=0 then begin
      Delete(s,p,i-p); Dec(i,i-p);
    end;
  end;
  if s[Length(s)] in Blanks then Delete(s,Length(s),1);
  WriteLn('Замена: ',s);
end.