В строку S2 перенести все слова, которые имеют удвоение букв

uses crt;
var s1,s2,s:array[1..71] of char;
    c:char;
    n,m,k,i,j,p:integer;
begin
clrscr;
writeln('Введите посимвольно строку из слов длиной до 70 символов разделенных пробелами');
writeln('в том числе слова с удвоенными буквами, окончание ввода Enter');
n:=1;
s1[1]:=' ';//первым запишем пробел
repeat
c:=readkey;
if (n<=71)and(c<>#13) then
 begin
  write(c);
  inc(n);
  s1[n]:=c;
 end
else writeln
until (n=71)or(c=#13);
m:=0;{размер масссива s2}
for i:=2 to n do
if(s1[i]<>' ')and(s1[i-1]=' ') then {если не пробел, и перед ним пробел, новое слово}
 begin
  k:=0;
  j:=i;
  while (j<=n)and(s1[j]<>' ') do
   begin
    inc(k);
    s[k]:=s1[j];
    inc(j);
   end;
  j:=1;
  while(j<k)and(s[j]<>s[j+1]) do inc(j);
  if j<k then
   begin
    for p:=1 to k do
     begin
      inc(m);
      s2[m]:=s[p];
     end;
    inc(m);
    s2[m]:=' ';
   end;
 end;
if m=0 then write('Слов со сдвоенными буквами нет')
else
 begin
  writeln('Слова со сдвоенными буквами');
  for i:=1 to m do
  write(s2[i]);
 end;
readln
end.

var s1,s2,s:array[1..71] of char;