Напечатать все слова, отличные от последнего слова, которые состоят из тех же букв, что и первое

program LabRab2;
Uses CRT;
var st, Temp:string;
       i,j,k,n:integer;
       Word1, Word2 : Array [1..100] of String;
       flag:boolean;
const
     symbol=[‘A’,’E’,’I’,’O’,’U’,’Y’,’А’,’Е’,’Ё’,’И’,’О’,’У’,’Ы’,’Э’,’Ю’,’Я’];
     glasnie=['a','e','i','o','u','y','а','е','ё','и','о','у','ы','э','ю','я'];
begin
clrscr;
     writeln('Введите текст');
     readln(st);
     while st[1] in symbol do delete(st,1,1); {удалили ненужные символы до первого слова}
     while st[length(st)] in symbol do delete(st,length(st),1); {удалили ненужные символы в конце строки}
     N := 1;
     //все слова пораздельности выписываем в массив Word1[N]
     while pos(' ', st) > 0 do
     begin
          Word1[N] := copy(st, 1, pos(' ', st)-1);
          delete(st, 1, pos(' ', st));
          inc(N);
     end;
     //записываем последнее слово в массив   Word1[N]
     Word1[N] := st;
     writeln('Слова, отличные от последнего слова и состоящие из букв первого слова');
     for i := 2 to N do
     begin
          flag := True;
          if(Word1[N]<>Word1[i]) then Temp := Word1[i]
          else continue;
          for j := 1 to Length(Temp) do
              if (pos(Temp[j], Word1[1]))>0
                 then Temp[j] := '*'
                 else flag := False;
          if flag Then Write(Word1[i], ' ');
     end;
     writeln;
     writeln('Слова, отличные от последнего слова с прописными гласными буквами');
     k:=0;
     for i:=1 to N do
     begin
          if ((Word1[i]<>Word1[N]) and ((length(Word1[i]) mod 2)<>0.0)) then
          begin
               Temp:=Word1[i];
               inc(k);
               for j := 1 to Length(Temp) do
                   if Temp[j] in glasnie then Temp[j] :=  upCase(Temp[j]);
               Word2[k] := Temp;
               write(Word2[k],'  ');
          end;
     end;
     readln;
end.