procedure  PRIMSLUC(var A:TYPPOLE;  {Razene pole     }
                    N:integer       {Pocet prvku pole});
           {Procedura seradi zadane pole metodou slucovani po 2,4,8,..}

var I,J,K,L,T,H,M,P,Q,R : integer;
    NAHORU : Boolean;
    B : array[0..2000] of integer;

begin
  for I := 1 to N do B[I] := A[I];
  NAHORU := true;
  P := 1;
  repeat
    H := 1;
    M := N;
    if NAHORU then begin
                     I := 1;
                     J := N;
                     K := N+1;
                     L := 2*N
                   end
              else begin
                     K := 1;
                     L := N;
                     I := N+1;
                     J := 2*N
                   end;
    repeat
      if M>=P then Q := P
              else Q := M;
      M := M-Q;
      if M>=P then R := P
              else R := M;
      M := M-R;
      while (Q<>0)and(R<>0) do
      begin
        if B[I]<B[J] then begin
                            B[K] := B[I];
                            K := K+H;
                            I := I+1;
                            Q := Q-1
                          end
                     else begin
                            B[K] := B[J];
                            K := K+H;
                            J := J-1;
                            R := R-1
                          end;
      end;
      while R<>0 do
      begin
        B[K] := B[J];
        K := K+H;
        J := J-1;
        R := R-1
      end;
      while Q<>0 do
      begin
        B[K] := B[I];
        K := K+H;
        I := I+1;
        Q := Q-1;
      end;
      H := -H;
      T := K;
      K := L;
      L := T
    until M=0;
    NAHORU := not NAHORU;
    P := 2*P;
  until P>=N;
  if not NAHORU then for I := 1 to N do B[I] := B[I+N];
  for I := 1 to N do A[I] := B[I]
end;  {procedura PRIMSLUC}