Here's my new code:
Program ShapingRegions;
 Const Max=1000;MaxB=10000; MaxC=2500;
 Type TRec=Record
       X1,Y1,X2,Y2,C,ID:Longint;
      End;
 Var a,b,n,i:Longint;
     r1,r,q:Array[0..Max] Of TRec;
     cy,cx,dy,dx:Array[1..3*Max] Of Longint;
     nx,ny:Longint;
     hy:Array[1..MaxB] Of Boolean;
     nc:Array[1..MaxC] Of Longint;
     lasty,lastx:Longint;
     pres:Array[0..Max] Of Longint;
     pr,pl:Array[0..Max+5] Of Longint;
     co,cp,ac,ad:Array[1..3*Max] Of Longint;
     hx:Array[0..3*Max] Of Boolean;
 Procedure ReadData;
  Var i:Longint;
 Begin
  Read(b,a,n);
  With r[0] Do Begin
   x1:=0;
   y1:=0;
   x2:=a;
   y2:=b;
   c:=1;
   id:=0;
  End;
  For i:=1 To n Do
   With r[i] Do Begin
    Read(y1,x1,y2,x2,c);
    id:=i;
   End;
  Move(r,r1,SizeOf(r1));
 End;
 Procedure AddY(y:Longint);
 Begin
  If ((y>=1) And (y<=b)) Then
   If Not hy[y] Then Begin
    hy[y]:=True;
    Inc(ny);
    cy[ny]:=y;
   End;
 End;
 Procedure Sort(x,y:Longint);
  Var z:Longint;
  Procedure Merge;
   Var p,p1,p2:Longint;
  Begin
   p1:=x; p2:=z+1; p:=0;
   While ((p1<=z) Or (p2<=y)) Do Begin
    Inc(p);
    If p1<=z Then Begin
     q[p]:=r[p1];
     Inc(p1);
     If p2<=y Then
      If r[p2].y1<q[p].y1 Then Begin
       q[p]:=r[p2];
       Inc(p2);
       Dec(p1);
      End;
    End Else Begin
     q[p]:=r[p2];
     Inc(p2);
    End;
   End;
   For p:=x To y Do
    r[p]:=q[p-x+1];
  End;
 Begin
  If x<y Then Begin
   z:=(x + y) Div 2;
   Sort(x,z);
   Sort(z+1,y);
   Merge;
  End;
 End;
 Procedure SortBack(x,y:Longint);
  Var z:Longint;
  Procedure Merge;
   Var p,p1,p2:Longint;
  Begin
   p1:=x; p2:=z+1; p:=0;
   While ((p1<=z) Or (p2<=y)) Do Begin
    Inc(p);
    If p1<=z Then Begin
     q[p]:=r[p1];
     Inc(p1);
     If p2<=y Then
      If r[p2].id<q[p].id Then Begin
       q[p]:=r[p2];
       Inc(p2);
       Dec(p1);
      End;
    End Else Begin
     q[p]:=r[p2];
     Inc(p2);
    End;
   End;
   For p:=x To y Do
    r[p]:=q[p-x+1];
  End;
 Begin
  If x<y Then Begin
   z:=(x + y) Div 2;
   Sort(x,z);
   Sort(z+1,y);
   Merge;
  End;
 End;
 Procedure SortY(x,y:Longint);
  Var z:Longint;
  Procedure Merge;
   Var p,p1,p2:Longint;
  Begin
   p1:=x; p2:=z+1; p:=0;
   While ((p1<=z) Or (p2<=y)) Do Begin
    Inc(p);
    If p1<=z Then Begin
     dy[p]:=cy[p1];
     Inc(p1);
     If p2<=y Then
      If cy[p2]<dy[p] Then Begin
       dy[p]:=cy[p2];
       Inc(p2);
       Dec(p1);
      End;
    End Else Begin
     dy[p]:=cy[p2];
     Inc(p2);
    End;
   End;
   For p:=x To y Do
    cy[p]:=dy[p-x+1];
  End;
 Begin
  If x<y Then Begin
   z:=(x + y) Div 2;
   SortY(x,z);
   SortY(z+1,y);
   Merge;
  End;
 End;
 Procedure SortX(x,y:Longint);
  Var z:Longint;
  Procedure Merge;
   Var p,p1,p2:Longint;
  Begin
   p1:=x; p2:=z+1; p:=0;
   While ((p1<=z) Or (p2<=y)) Do Begin
    Inc(p);
    If p1<=z Then Begin
     dx[p]:=cx[p1];
     cp[p]:=co[p1];
     ad[p]:=ac[p1];
     Inc(p1);
     If p2<=y Then
      If cx[p2]<dx[p] Then Begin
       dx[p]:=cx[p2];
       cp[p]:=co[p2];
       ad[p]:=ac[p2];
       Inc(p2);
       Dec(p1);
      End;
    End Else Begin
     dx[p]:=cx[p2];
     cp[p]:=co[p2];
     ad[p]:=ac[p2];
     Inc(p2);
    End;
   End;
   For p:=x To y Do Begin
    cx[p]:=dx[p-x+1];
    co[p]:=cp[p-x+1];
    ac[p]:=ad[p-x+1];
   End;
  End;
 Begin
  If x<y Then Begin
   z:=(x + y) Div 2;
   SortX(x,z);
   SortX(z+1,y);
   Merge;
  End;
 End;
 Procedure AddX(x,act,col:Longint);
 Begin
  If ((x>=0) And (x<=a)) Then Begin
   Inc(nx);
   cx[nx]:=x;
   co[nx]:=col;
   ac[nx]:=act;
  End;
 End;
 Procedure SolveLine(y,k:Longint);
  Var i:Longint;
  Function F

Here is my code
i got AC in USACO but URAL
Is anybody can tell me why?

Program RECT1;
const
  maxn=10000;
type
  recttype=record lx,ly,rx,ry,c:integer; end;
var
  save:array [1..maxn] of recttype;
  color:array [0..2500] of longint;
  k,mc:integer;

Function check (rd,ru:recttype):boolean;
begin
  if ((rd.lx>=ru.rx) or (rd.rx<=ru.lx) or
     (rd.ly>=ru.ry) or (rd.ry<=ru.ly)) then check:=false else
check:=true;
end;

Procedure add (r:recttype;var u:integer; w:integer);
begin
  if u=0 then begin save[w]:=r; u:=1; end
         else begin inc(k); save[k]:=r; end;
end;

Procedure cut (rd,ru:recttype;w:integer);
var
  tem:recttype;
  u:integer;
begin
  u:=0;

  if check (rd,ru) then
    if (ru.lx<=rd.lx) and (ru.ly<=rd.ly) and (ru.rx>=rd.rx) and
(ru.ry>=rd.ry) then save[w].c:=0 else
    begin
      if rd.lx<ru.lx then
      begin
        tem:=rd;
        tem.rx:=ru.lx;
        add (tem,u,w);
        rd.lx:=ru.lx;
      end;
      if rd.rx>ru.rx then
      begin
        tem:=rd;
        tem.lx:=ru.rx;
        add (tem,u,w);
        rd.rx:=ru.rx;
      end;
      if rd.ry>ru.ry then
      begin
        tem:=rd;
        tem.ly:=ru.ry;
        add (tem,u,w);
        rd.ry:=ru.ry;
      end;
      if rd.ly<ru.ly then
      begin
        tem:=rd;
        tem.ry:=ru.ly;
        add (tem,u,w);
        rd.ly:=ru.ly;
      end;
    end;
end;

Procedure solve;
var
  i,n,i1,t:integer;
begin
  k:=1; save[1].c:=1; mc:=0;

  assign (input,'rect1.in'); reset (input);
  readln (save[1].rx,save[1].ry,n);

  for i:=1 to n do
  begin
    inc(k);
    t:=k;
    with save[k] do begin readln (lx,ly,rx,ry,c); if c>mc then mc:=c;
end;
    for i1:=1 to k-1 do cut (save[i1],save[t],i1);
  end;

  close (input);
end;

Function area (a:recttype):longint;
begin
  area:=abs((a.rx-a.lx)*(a.ly-a.ry));
end;

Procedure print;
var
  i:integer;
begin
  fillchar (color,sizeof(color),0);
  for i:=1 to k do inc(color[save[i].c],area(save[i]));

  assign (output,'rect1.out'); rewrite (output);
  for i:=1 to mc do if color[i]>0 then writeln (i,' ',color[i]);
  close (output);
end;

begin
  solve;
  print;
end.

> > Here's my program:
> > Program ShapingRegions;
> >  Const Max=1000;MaxB=10000; MaxC=2500;
> >  Type TRec=Record
> >        X1,Y1,X2,Y2,C:Longint;
> >       End;
> >  Var a,b,n,i:Longint;
> >      r:Array[0..Max] Of TRec;
> >      cy,cx,dy,dx:Array[1..3*Max] Of Longint;
> >      nx,ny:Longint;
> >      hy:Array[1..MaxB] Of Boolean;
> >      nc:Array[1..MaxC] Of Longint;
> >      lasty,lastx:Longint;
> >      pres:Array[0..Max] Of Longint;
> >      pr,pl:Array[0..Max+5] Of Longint;
> >      co,cp,ac,ad:Array[1..3*Max] Of Longint;
> >      hx:Array[0..3*Max] Of Boolean;
> >  Procedure ReadData;
> >   Var i:Longint;
> >  Begin
> >   Read(a,b,n);
> >   With r[0] Do Begin
> >    x1:=0;
> >    y1:=0;
> >    x2:=a;
> >    y2:=b;
> >    c:=1;
> >   End;
> >   For i:=1 To n Do
> >    With r[i] Do
> >     Read(x1,y1,x2,y2,c);
> >  End;
> >  Procedure AddY(y:Longint);
> >  Begin
> >   If ((y>=1) And (y<=b)) Then
> >    If Not hy[y] Then Begin
> >     hy[y]:=True;
> >     Inc(ny);
> >     cy[ny]:=y;
> >    End;
> >  End;
> >  Procedure SortY(x,y:Longint);
> >   Var z:Longint;
> >   Procedure Merge;
> >    Var p,p1,p2:Longint;
> >   Begin
> >    p1:=x; p2:=z+1; p:=0;
> >    While ((p1<=z) Or (p2<=y)) Do Begin
> >     Inc(p);
> >     If p1<=z Then Begin
> >      dy[p]:=cy[p1];
> >      Inc(p1);
> >      If p2<=y Then
> >       If cy[p2]<dy[p] Then Begin
> >        dy[p]:=cy[p2];
> >        Inc(p2);
> >        Dec(p1);
> >       End;
> >     End Else Begin
> >      dy[p]:=cy[p2];
> >      Inc(p2);
> >     End;
> >    End;
> >    For p:=x To y Do
> >     cy[p]:=dy[p-x+1];
> >   End;
> >  Begin
> >   If x<y Then Begin
> >    z:=(x + y) Div 2;
> >    SortY(x,z);
> >    SortY(z+1,y);
> >    Merge;
> >   End;
> >  End;
> >  Procedure SortX(x,y:Longint);
> >   Var z:Longint;
> >   Procedure Merge;
> >    Var p,p1,p2:Longint;
> >   Begin
> >    p1:=x; p2:=z+1; p:=0;
> >    While ((p1<=z) Or (p2<=y)) Do Begin
> >     Inc(p);
> >     If p1<=z Then Begin
> >      dx[p]:=cx[p1];
> >      cp[p]:=co[p1];
> >      ad[p]:=ac[p1];
> >      Inc(p1);
> >      If p2<=y Then
> >       If cx[p2]<dx[p] Then Begin
> >        dx[p]:=cx[p2];
> >        cp[p]:=co[p2];
> >        ad[p]:=ac[p2];
> >        Inc(p2);
> >        Dec(p1);
> >       End;
> >     End Else Begin
> >      dx[p]:=cx[p2];
> >      cp[p]:=co[p2];
> >      ad[p]:=ac[p2];
> >      Inc(p2);
> >     End;
> >

Right, it is from IOI..... And, it has been to almost every
competition I have heard about :)