Fast copying records in sorted order / was Sorting

So much interest was shown in the original posting, the method below
is shown, which includes the method used to make the test records.

A randomly ordered file of 5.6MBytes is copied to another file in
alphabetical order in about 1.5 seconds using a 25 char key.

Program File_of_Records_And_Sorting;
{TO GET ENOUGH HEAP SPACE TO RUN THIS PROGRAM, COMPILE IT TO DISK.
                Uses about 12M of disk space.
A test file of 5.6Mbytes storing 16000 records is stored as the
source. The name field in the source is a random odrder of 25
uppercase chars. Each of the 16000 records is read and a data record
with 2 fields is made --(1) a sort key of 25 chars and (2) the source
file record number, 0..15999. The data records are stored in the heap.
An array of pointers is used to access the data. This array of
pointers is sorted in alphabetic order of the sort key using a very
fast modification of Shell's sort. Using the record number field of
the sorted array, SEEK is used to find the complete record in the
source and copy it to the destination file.

With a 300MHz CPU and 10msec average access hard disk, the unsorted
source is read, the data record array formed, sorted and source copied
to the destination file in about 1.5 second.
            Turbo v 6.0  <clifp...@airmail.net> Feb 2, 01 }

CONST source = 'recstuff.dat'; dest = 'sorted.dat';
      max = 16000;
      s = 'abcdefghijklmnopqrstuvwxyz0123456789ASDF';
      t = s + s;
TYPE
s25 = String[25];
myRec = Record  {16000 stored in the source file}
          name:s25;
          test:Array[1..4] of String[80];
        end;
FileType = File of myRec;

ptr = ^data;
data = Record   {16000 on heap}
          SortKey:s25;
          RecNum:Integer;
        end;
VAR
single:myRec;
fs, fd:FileType;
a:Array[1..max] of ptr;   {used globally}

Procedure FileRecords(VAR f:fileType);
{Making test records}
VAR j,k:Integer;
    tmp:s25;
    sing:MyRec;
Begin
     Rewrite(f);
     For j := 1 to max Do
     Begin
          tmp := '';
          For k := 1 to 25 Do tmp := tmp + Chr(Random(26) + Ord('A'));
          sing.name := tmp;
          For k := 1 to 4 Do sing.test[k] := t;
          Write(f, sing);
     End;
End;

Procedure DataToHeap(VAR f:FileType);
VAR ct:integer;
    sing:myRec;
Begin
     ct := 0;
     Reset(f);
     While not eof(f) do
     Begin
          Read(f, sing);
          Inc(ct);
          New(a[ct]);
          a[ct]^.RecNum := ct-1;
          a[ct]^.SortKey := sing.name;
    End;
End;

Procedure ShellMod;   {sorts in alphabetic order of sort key}
{This sort makes only 1 pass of the array per gap setting. To
speed long first moves, the first gap is 2/3 down the array.
On shorter gaps, if an element is found to be out of order,
back tracking is used to find where it should be inserted at
this gap. Gaps are reduced faster than by half. The last pass
is always a gap = 1, so a proper sort is guaranteed. Uses no
recursion and is comparable to the QuickSort (usually faster
on mostly ordered data.)}

VAR gap, j, tmp, m:Integer;
    buf:ptr;
Begin
     m := max ;
     If m > 1 then gap := m - (m div 3) else gap := m div 2;
     While gap > 0 Do
     Begin
          For j := 1 to m - gap Do
          Begin
              tmp := j ;           {to avoid changing j}
              buf := a[tmp + gap]; {buffer for item to be placed}
              While (buf^.SortKey < a[tmp]^.SortKey) AND (tmp > 0) Do
              Begin
                  a[tmp + gap] := a[tmp];   {ready for buf insertion}
                  Dec(tmp, gap);  {move comparison point toward a[1]}
              End;
              a[tmp + gap] := buf; {where buf belongs at this gap}
          End;
          If gap in [2..3] then gap := 1 else gap := (gap - 1) div 3;
     End;
End;

Procedure RecordsToDest(VAR f1, f2:FileType);
VAR len:Integer;
    sing:Myrec;
Begin
     Rewrite(f2);
     For len := 1 to max Do
     Begin
         Seek(f1, a[len]^.RecNum);
         Read(f1, sing);
         Write(f2, sing);
     End;
End;

BEGIN  {main}
     Randomize;
     Assign(fs, source);
     Assign(fd, dest);
     Writeln('Making source:');
     FileRecords(fs);
     Writeln('Press enter to make alphabetic destination:');  
     readln;

     DataToHeap(fs);
     ShellMod;
     RecordsToDest(fs, fd);
     Close(fs);
     Writeln('DONE DONE DONE -- Press <Enter> to show dest:');
     readln;

     Reset(fd);  {show disk sort results}
     While not eof(fd) do
     Begin
         Read(fd, single);
         Write(single.name:40);
     End;
     Close(fd);
END.