Here 's another source I got C.E although it works properly on my BP
7.0 Compiler .
  Please help me .
{ memory management _ heap technique }

CONST
     INP                =               '1037.in1';
     OUT                =               '1037.out';
     chk                =               '1037.ou2';
     maxn               =               30000 ;

TYPE
  inttype           =       word ;
      ar1           =       array[1..maxn] of inttype ;

VAR
  posbheap,ctime,bheap,fheap           :       ^ar1 ;
  s                                    :       string ;
  pfheap,pbheap,btime,idblock                        :       inttype ;

PROCEDURE       InputRead ;
  begin
{    assign (input,inp);
    reset(input);
    assign (output,out) ;
    rewrite (output) ;}
  end;

PROCEDURE       newVari ;
  begin
    new ( posbheap ) ;
    new (ctime ) ;
    new (bheap ) ;
    new (fheap ) ;
  end ;

PROCEDURE       d_Analyse ;
  var
    i           :       inttype ;
    b_code        :       inttype ;
    s1          :       string ;
  begin
    i:=pos('+',s) ;
    if i <> 0 then
      begin
        while not (s[length(s)] in ['0'..'9'] ) do delete(s,length
(s),1) ;
        val ( s , btime,b_code) ;
        idblock:=0 ;
      end
    else
      begin
        i:=pos ('.',s) ;
        s1:=copy ( s , 1,i-1) ;
        while not (s1[length(s1)] in ['0'..'9']) do delete ( s1,length
(s1),1) ;
        val (s1 , btime,b_code) ;
        delete(s,1,i) ;
        while not (s[length(s)] in ['0'..'9'] ) do delete(s,length
(s),1) ;
        while not (s[1] in ['0'..'9'] ) do delete(s,1,1) ;
        val (s,idblock , b_code ) ;
      end ;
  end ;

PROCEDURE       d_swap ( var a,b : inttype ) ;
  var
    tam :       inttype ;
  begin
    tam:=a ; a:=b ; b:=tam ;
  end ;

PROCEDURE       fsiftup ( i : inttype ) ;
  var
    j           :       inttype ;
  begin
    while i*2 <= pfheap do
      begin
        if (i*2+1 <= pfheap) and (fheap^[i*2+1] < fheap^[i*2]) then
j:=i*2+1
        else j:=i*2 ;
        if fheap^[i] < fheap^[j] then exit
        else
          begin
            d_swap ( fheap^[i] , fheap^[j] ) ;
            i:=j ;
          end ;
      end ;
  end ;

PROCEDURE       bsiftup ( i : inttype ) ;
  var
    j           :       inttype ;
  begin
    while i*2 <= pbheap do
      begin
        if (i*2+1 <= pbheap) and (ctime^[bheap^[i*2+1]] < ctime^[
bheap^[i*2] ])
          then j:=i*2+1
        else j:=i*2 ;
        if ctime^[ bheap^[i] ] < ctime^ [ bheap^[j] ] then exit
        else
          begin
            d_swap ( bheap^[i] , bheap^[j] ) ;
            d_swap ( posbheap^ [ bheap^[i] ] , posbheap^[ bheap^
[j] ] ) ;
            i:=j ;
          end ;
      end ;
  end ;

PROCEDURE       fsiftdown ( i : inttype ) ;
  begin
    while i div 2 > 0 do
      begin
        if fheap^[i] <  fheap^[i div 2] then
          begin
            d_swap (fheap^[i] , fheap^[i div 2]) ;
            i:=i div 2 ;
          end
        else exit ;
      end ;
  end ;

PROCEDURE       bsiftdown ( i : inttype ) ;
  begin
    while i div 2 > 0 do
      begin
        if ctime^[ bheap^[i] ] <  ctime^ [ bheap^[i div 2] ] then
          begin
            d_swap (bheap^[i] , bheap^[i div 2]) ;
            d_swap (posbheap^ [ bheap^[i] ] , posbheap^ [ bheap^[i
div 2] ]) ;
            i:=i div 2 ;
          end
        else exit ;
      end ;
  end ;

PROCEDURE       insertfheap ( d : inttype ) ;
  begin
    inc ( pfheap ) ;
    fheap^[pfheap ] := d;
    fsiftdown ( pfheap ) ;
  end ;

PROCEDURE       insertbheap ( d : inttype ) ;
  begin
    inc ( pbheap ) ;
    bheap^[pbheap ] := d;
    posbheap^[d]:=pbheap;

    bsiftdown ( pbheap ) ;
  end ;

PROCEDURE       deletefheap ( d : inttype ) ;
  var
    bufid               :