Программа с текстовыми файлами

[AlDonea]

Уважаемые программисты! Помогите пожалуйсто с программой. Суть ее в том, что программа делит содержимое входного файла на два других, состоящие из слов, в которых кол-во согласных превышает кол-во гласных и наоборот. Преподователь требует переделать программу из-за массива записей ttt = array [1..20] of tz, говорит мол из-за этого программа занимает большое колличество памяти... не имею понятия как это сделать... помогите чем можете....
вот сама прога :

program masivbuk;

{$APPTYPE CONSOLE}

uses
SysUtils;

type
vek = array[1..254] of char;
tz = record sl: vek;
kl: integer;
pl: integer;
end;
ttt = array [1..20] of tz;
var
qq: set of char;
sb,sc: ttt;
f1: text;
s: string;
st: vek;
z,n,fm,em,q,f: integer;

procedure razb(a: vek; m: integer; var b,c: ttt);
var i,j,sa: integer;
begin
qq:=['a','e','u','y','o','i'];
sa:=0;
j:=0;
for i:=1 to m do
if not(a[i]=' ' then
begin
j:=j+1;
if a[i] in qq then sa:=sa+1;
end else begin if j>0 then
if j-sa>sa then
begin
fm:=fm+1;
b[fm].kl:=j-sa; b[fm].pl:=sa;
j:=i-j;
while j<=i do
begin
f:=f+1;
b[fm].sl[f]:=a[j];
j:=j+1;
end;
sa:=0;
f:=0;
end
else
begin
em:=em+1;
c[em].kl:=j-sa; c[em].pl:=sa;
j:=i-j;
while j<=i do
begin
q:=q+1;
c[em].sl[q]:=a[j];
j:=j+1;
end;
sa:=0;
q:=0;
end;
j:=0; end;
end;

begin
{ TODO -oUser -cConsole Main : Insert code here }
assign(f1,'X:\vhodnoy.txt') ;
reset(f1);
while not eoln(f1) do read(f1,s);
writeln(s); readln;
close(f1);
n:=length(s);
for z:= 1 to n do st[z]:=s[z];
razb(st,n,sb,sc);
assign(f1,'X:\vihodnoy1.txt') ;
rewrite(f1);
writeln;
for z:=1 to fm do
begin
for n:=1 to 20 do begin write(sb[z].sl[n]); write(f1,sb[z].sl[n]); end;
write(sb[z].kl:4); write(sb[z].pl:4);
write(f1,sb[z].kl:4); write(f1,sb[z].pl:4);
writeln(f1);
writeln;
end;
close(f1);
assign(f1,'X:\vihodnoy2.txt') ;
rewrite(f1);
writeln;
for z:=1 to em do
begin
for n:=1 to 20 do begin write(sc[z].sl[n]); write(f1,sc[z].sl[n]); end;
write(sc[z].kl:4); write(sc[z].pl:4);
write(f1,sc[z].kl:4); write(f1,sc[z].pl:4);
writeln(f1);
writeln;
end;
close(f1);
readln;
end.

[Z1000000]

program masivbuk;
type
vek = array[1..254] of char;
tz = record sl: vek;
kl: integer;
pl: integer;
end;
ttt = array [1..20] of tz;
var
qq: set of char;
sb,sc: ttt;
f1,f2,f3: text;
s: string;
st: vek;
z,n,fm,em,q,f: integer;

procedure razb(a: vek; m: integer; var b,c: ttt);
var i,j,sa: integer;
begin
qq:=['a','e','u','y','o','i'];
sa:=0;
j:=0;
for i:=1 to m do
 if not(a[i]=' ') then
  begin
  j:=j+1;
  if a[i] in qq then sa:=sa+1;
  end
 else
  begin
  if j>0 then
   if j-sa>sa then
    begin
    fm:=fm+1;
    b[fm].kl:=j-sa; b[fm].pl:=sa;
    j:=i-j;
    while j<=i do
      begin
      f:=f+1;
      b[fm].sl[f]:=a[j];
      j:=j+1;
      end;
    sa:=0;
    f:=0;
    end
   else
    begin
    em:=em+1;
    c[em].kl:=j-sa; c[em].pl:=sa;
    j:=i-j;
    while j<=i do
     begin
     q:=q+1;
     c[em].sl[q]:=a[j];
     j:=j+1;
     end;
    sa:=0;
    q:=0;
    end;
j:=0;
end;
end;

procedure razb2(a: String);
var
 i,j,n: integer;
 CounterG,CounterS : Integer ; // Счетчики гласных и согласных букв в слове
 CurWord : String;
begin
qq:=['a','e','u','y','o','i'];
a := a + ' ';
n := Length(a);
CounterG := 0;
CounterS := 0;
CurWord := '';
for i := 1 to n do
 if a[i] = ' ' then
  begin
  if CurWord <> '' then
   begin
   if CounterG > CounterS then begin write(f2,CurWord,' ',CounterS,' ',CounterG,#13,#10); end
   else begin write(f3,CurWord,' ',CounterS,' ',CounterG,#13,#10); end;
   CurWord := ''; CounterG := 0; CounterS := 0;
   end;
  end
 else
  begin
  if a[i] in qq then CounterG := CounterG + 1 else CounterS := CounterS + 1;
  CurWord := CurWord + a[i];
  end;
end;

begin
{ TODO -oUser -cConsole Main : Insert code here }
assign(f1,'vhodnoy.txt') ;
Assign(f2,'f2.txt');
Assign(f3,'f3.txt');
reset(f1);
Rewrite(f2);
Rewrite(f3);

while not eof(f1) do
 begin
 readln(f1,s);
 razb2(s);
 end;
Close(f1);
Close(f2);
Close(f3);

{
writeln(s); readln;
close(f1);
n:=length(s);
for z:= 1 to n do st[z]:=s[z];
razb(st,n,sb,sc);
assign(f1,'vihodnoy1.txt') ;
rewrite(f1);
writeln;
for z:=1 to fm do
begin
for n:=1 to 20 do begin write(sb[z].sl[n]); write(f1,sb[z].sl[n]); end;
write(sb[z].kl:4); write(sb[z].pl:4);
write(f1,sb[z].kl:4); write(f1,sb[z].pl:4);
writeln(f1);
writeln;
end;
close(f1);
assign(f1,'vihodnoy2.txt') ;
rewrite(f1);
writeln;
for z:=1 to em do
begin
for n:=1 to 20 do begin write(sc[z].sl[n]); write(f1,sc[z].sl[n]); end;
write(sc[z].kl:4); write(sc[z].pl:4);
write(f1,sc[z].kl:4); write(f1,sc[z].pl:4);
writeln(f1);
writeln;
end;
close(f1);
readln;
}
end.