одномерный массив Опции

[falcon]

Помогите пожалуйста со следующей задачей: Разделить одномерный массив на 3 части, которые по возможности имеют минимальное расхождение сумм. Например: исходный массив - 1 2 3 4 5 6, полученые массивы - 6 1, 5 2, 3 4. Необязательно чтоб в полученном массиве было одинаковое количество чисел. Я пробывал что-то сделать но ответ выводится неправильно. Не понял только как сделать так чтобы выводились 3 массива которые бы включали все введенные числа.

uses crt;
var
   a,b:array[1..100] of integer;
   n:byte;
   sym:integer;sum,k:real;
   f:boolean;
   i,j,h,s,rab:integer;
begin
     {Vvodim vse podryat}
     clrscr;
     Writeln('Vvedite kolichestvo elimentov massiva<=100');
     Readln(n);
     for i:=1 to n do
     begin
     writeln(i,' :eliment');
     readln(a[i]);
     end;
      {sortirovka elementov}
      begin
      for j:=1 to n-1 do
      for i:=1 to n-1 do
      if a[i]>a[i+1] then begin
      rab:=a[i];
      a[i]:=a[i+1];
      a[i+1]:=rab;
      end;
     end; 
     sym:=0;
     for i:=1 to n do
     sym:=sym+a[i];
     sum:=sym/3; 
     {Nachinaetsya glavniji cikl
     idem sverhu v niz}
     for i:=n downto 1 do
     begin
         s:=1;
         b[1]:=a[i];
         repeat
         h:=1;
         k:=sum-a[i]; {vichitaem naibol'shiji eliment podposledovatel'nosti
                      i nachinaem proveryat' so sledueshigo}
         if k=0 then begin write(a[i]);break;end {dobavil proverku pered
                                                  ciklom}
         else
         begin
         for j:=i-s downto 1 do
         begin
             if k<a[j] then continue else   {esli eliment bol'she k, to
                                                  idem k sleduushimu}
             begin
             k:=k-a[j];
             inc(h);b[h]:=a[j];            {sohronyaem na vsyakji sluchaji}
             if k=0 then break;            {esli k=0 vihodim iz cikla}
             end;
         end;
         if k=0 then          {proviryam esli k=0, to raspichativaem
                              posledovatel'nost', esli net
                              to posledovatel'nosti s dannim
                              naibol'shim chlenom izchrponi, perehodim k
                              sleduushimu}
         begin
             writeln;
             for j:=1 to h do write(b[j],' ');f:=true;inc(s);
         end else f:=false;
         end; {konec dobavki}
         until not f;
     end;
     repeat until keypressed;
end.  

Заранее благодарен