программа на строки(pascal)

[SHAURMA]

В файле f1 набран текст. Вывести все слова,которые встречаются в тексте только 2 раза. Результат вывести в файл z1.Программу нужно оформить как процедуру.Ни как не получается пробывал с счетчиком не получилось.Помогите курсовую сдавать на днях

[Sheka]

работает до 2000 слов длиной до 20 символов.
с русской расскладкой возникают маленькие проблемы, английская 100пудово работает.
[syntax='delphi']
program same2;

uses crt;

const
MWS=2000;
WML=20;

type
wmas=array[1..MWS] of string[WML];
bmas=array[1..MWS] of boolean;

var
w:wmas;
b:bmas;
i,wmax,main,curr,currs1,same:integer;

procedure CreateZ1;
var
z:text;
begin
assign(z,'z1.txt');
rewrite(z);
close(z);
end;

procedure IntoZ1(s:string);
var
z:text;
begin
assign(z,'z1.txt');
append(z);
writeln(z,s);
close(z);
end;

procedure ToW(var w:wmas;var b:bmas;var wmax:integer);
var
f:text; c:char; s:string[20];
begin
assign(f,'f1.txt');
reset(f);
wmax:=0;
s:='';
while not eof(f) do begin
read(f,c);
if c in [#48..#57,#64..#90,#95..#96,#97..#122,#128..#175,#224..#249] then s:=s+c
else
begin
if s<>'' then
begin
inc(wmax);
w[wmax]:=s;
end;
s:='';
end;
end;
close(f);
for i:=1 to wmax do b:=true;
end;



BEGIN
clrscr;
CreateZ1;
ToW(w,b,wmax);
for main:=1 to wmax-1 do if b[main]=true then
begin
same:=0;
currs1:=0;
for curr:=main+1 to wmax do if b[curr]=true then
begin
if w[main]=w[curr] then
begin
inc(same);
currs1:=main;
end;
if same>=2 then
begin
currs1:=0;
for i:=main to wmax do if w[main]=w then b:=false;
break;
end;
end;
if same=0 then b[main]:=false;
if same=1 then
begin
b[main]:=false;
b[currs1]:=false;
intoz1(w[main]);
end;
end;
END.[/syntax]