сделать новый масив из старого по условию

var
   a,b: array[1..100] of integer;
   i,j,n,m,x: integer;
   f,r: boolean;
begin
   readln(n); 
   f:=true; //ни одно четное число не расположено после нечетного
   for i:=1 to n do readln(a[i]);
   for i:=2 to n do
      if odd(a[i])=false then
         begin
            r:=true; //указывает на то, что в массиве есть хотя бы 1 четный элемент
            if odd(a[i-1])=true then
               begin
                  f:=false; //предыдущий четному - нечетный
                  break; //выход из цикла
               end;
         end;
   x:=n;
   if f or r then
      begin
         for i:=1 to n do 
            if a[i]<0 then inc(m); //подсчитываем отрицательные элементы
         for j:=1 to m do
         for i:=x downto 1 do
            if a[i]<0 then
               begin
                  b[j]:=a[i];
                  x:=i-1; //чтобы в дальнейшем цикл i начинался со следующего элемента
                  break;
               end;
      end
      else
      begin
         for i:=1 to n do
            if a[i]>0 then inc(m); //подсчитываем положительные элементы
         for j:=1 to m do
         for i:=x downto 1 do
            if a[i]>0 then
               begin
                  b[j]:=a[i];
                  x:=i-1;
                  break;
               end;
      end;
   writeln;
   for i:=1 to m do write(b[i],' ');
   readln;
end.

Uses
 Crt;
Var
 i,m,kol:integer;
 t:boolean;
 a,b:array[1..100] of integer;
begin
clrscr;
 readln(m);
 t:=false;
 for i:=1 to m do
 begin
  write('a[',i,']:=');
  readln(a[i]);
 end;
writeln;
for i:=1 to m-1 do
if odd(a[i]) and not odd(a[i+1]) then
begin
 t:=true;
 break;
end;
kol:=0;
if not(t) then
begin
for i:=m downto 1 do
if a[i]<0 then
begin
 inc(kol);
 b[kol]:=a[i];
end;
end
else
begin
for i:=m downto 1 do
if a[i]>0 then
begin
 inc(kol);
 b[kol]:=a[i];
end;
end;
for i:=1 to kol do
  write(b[i]:4);
writeln;
readln
end.