Const Maxn=7501;
Type chain=^List;
     List=record
      x:integer;
      Next:Chain;
     End;
Var a,c:array[0..maxN] of integer;
    Mask:array[0..maxn]of boolean;
    Sme:Array[1..Maxn]of chain;
    n:integer;
Procedure Init;
var i:integer;
Begin
i:=1;
FillChar(A,SizeOf(a),0);
FillChar(c,SizeOf(c),0);
FillChar(mask,SizeOf(mask),true);
While Not eof do begin
 read(a[i]);
 Inc(c[a[i]]);
 if a[i]<>0 then inc(i);
End;
n:=i-1
End;
Procedure Add(var p:chain; x:integer);
var t,q:chain;
    g:integer;
begin
t:=p;
if p= nil then begin
 New(p);
 p^.x:=x;
 p^.next:=nil;
End
Else begin
 While (t^.next^.x<x) and (t^.next<>nil)do
   t:=t^.next;
 new(q);
 q^.x:=x;
 q^.next:=t^.next;
 if (t^.x>x) then
 begin g:=q^.x; q^.x:=t^.x; t^.x:=g; End;
 t^.next:=q;

 End;
End;
Procedure Obr;
var i,j,k:integer;
    stop:boolean;
begin
For i:=1 to n do begin
 stop:=true;
 j:=1;
 While stop and (j<maxn) do begin
  If (C[j]=0) and (mask[j]) then stop:=false
   else inc(j);
 End;
 Add(Sme[a[i]],j);
 add(sme[j],a[i]);
 if c[a[i]]<>0 then dec(c[a[i]]);
 Mask[j]:=false;
End;
End;
Procedure done;
var t:chain;
    i:integer;
begin
For i:=1 to n+1 do begin
 t:=Sme[i];
 Write(i,': ');
 While t<>nil do begin
  Write(t^.x,' ');
  t:=t^.next;
 End;
 Writeln;
End;

end;
begin
{assign(input,'input.txt');
reset(input);}
Init;
{close(input);}
obr;
Done;
End.
===============================
I don't know why i got Crash in 1 test. Help me please

Change your nick! May be you'll get AC!