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.
Заранее благодарен