This code was written by Dimitri Vulis and placed into public domain.

(*
This code was written by Dimitri Vulis and placed into public domain.
There is no copyright associated with this code. Use it as you wish.
*)
{$C-} {$K-} {$B-} {Options}
const
CYR_A=176; {0}
CYR_ya=239; {o}
uppertot=182;
BUFFERSIZE=16767;
type
bufferptr=0..BUFFERSIZE;
var
upper:array[0..222] of byte; { values }
uppers:array[0..64] of byte; { start }
upperm:array[0..63] of boolean; {multi-letter}
upperu:byte; { used pointer }
infile,outfile:file;
inbuf,outbuf:array[0..BUFFERSIZE] of byte;
inbufptr,outbufptr,inbuflen:integer;
c,i,xbyte:byte;

{We buffer I/O because otherwise it's agonizingly slow}
function getbyte:boolean; {true if read xbyte, false if end of file}
begin
getbyte:=true;
if inbufptr>=inbuflen then begin
blockread(infile, inbuf, BUFFERSIZE+1, inbuflen);
if inbuflen=0 then
getbyte:=false;
inbufptr:=0;
end;
xbyte:=inbuf[inbufptr];
inbufptr:=inbufptr+1;
end;

procedure putbyte;
begin
outbuf[outbufptr]:=xbyte;
if outbufptr=BUFFERSIZE then begin
blockwrite(outfile, outbuf, BUFFERSIZE+1);
outbufptr:=0;
end
else
outbufptr:=outbufptr+1;
end;

procedure closefiles;
begin
close(infile);
if outbufptr>0 then
blockwrite(outfile, outbuf, outbufptr);
close(outfile);
end;

{Standard PASCAL does not allow statically initialized arrays}
procedure add1(u1:char);
begin
upperm[c]:=false;
uppers[c]:=upperu;
upper[upperu]:=ord(u1);
upperu:=upperu+1;
c:=c+1;
end;

procedure add5(u1,u2,u3,u4,u5:char);
begin
upperm[c]:=true;
uppers[c]:=upperu;
upper[upperu]:=ord(u1);
upper[upperu+1]:=ord(u2);
upper[upperu+2]:=ord(u3);
upper[upperu+3]:=ord(u4);
upper[upperu+4]:=ord(u5);
upperu:=upperu+5;
c:=c+1;
end;

procedure add7(u1,u2,u3,u4,u5,u6,u7:char);
begin
upperm[c]:=true;
uppers[c]:=upperu;
upper[upperu]:=ord(u1);
upper[upperu+1]:=ord(u2);
upper[upperu+2]:=ord(u3);
upper[upperu+3]:=ord(u4);
upper[upperu+4]:=ord(u5);
upper[upperu+5]:=ord(u6);
upper[upperu+6]:=ord(u7);
upperu:=upperu+7;
c:=c+1;
end;

procedure add9(u1,u2,u3,u4,u5,u6,u7,u8,u9:char);
begin
upperm[c]:=true;
uppers[c]:=upperu;
upper[upperu]:=ord(u1);
upper[upperu+1]:=ord(u2);
upper[upperu+2]:=ord(u3);
upper[upperu+3]:=ord(u4);
upper[upperu+4]:=ord(u5);
upper[upperu+5]:=ord(u6);
upper[upperu+6]:=ord(u7);
upper[upperu+7]:=ord(u8);
upper[upperu+8]:=ord(u9);
upperu:=upperu+9;
c:=c+1;
end;

procedure add10(u1,u2,u3,u4,u5,u6,u7,u8,u9,u10:char);
begin
upperm[c]:=true;
uppers[c]:=upperu;
upper[upperu]:=ord(u1);
upper[upperu+1]:=ord(u2);
upper[upperu+2]:=ord(u3);
upper[upperu+3]:=ord(u4);
upper[upperu+4]:=ord(u5);
upper[upperu+5]:=ord(u6);
upper[upperu+6]:=ord(u7);
upper[upperu+7]:=ord(u8);
upper[upperu+8]:=ord(u9);
upper[upperu+9]:=ord(u10);
upperu:=upperu+10;
c:=c+1;
end;

procedure initialize;
begin
{We add the being/end group characters to suppress all ligatures. }
{We could get rid of most of these if we delete the ligtable }
upperu:=0;
c:=0;
add1('A'); {0}
add1('B'); {1}
add1('V'); {2}
add1('G'); {3}
add1('D'); {4}
add1('E'); {5}
add5('{','\','Z','h','}'); {6}
add1('Z'); {7}
add1('I'); {8}
add5('{','\','U','i','}'); {9}
add1('K'); {:}
add1('L'); {;}
add1('M'); {<}
add1('N'); {=}
add1('O'); {>}
add1('P'); {?}
add1('R'); {@}
add1('S'); {A}
add1('T'); {B}
add1('U'); {C}
add1('F'); {D}
add5('{','\','K','h','}'); {E}
add5('{','\','T','s','}'); {F}
add5('{','\','C','h','}'); {G}
add5('{','\','S','h','}'); {H}
add7('{','\','S','h','c','h','}'); {I}
add10('{','\','c','D','p','r','i','m','e','}'); {J}
add1('Y'); {K}
add9('{','\','c','P','r','i','m','e','}'); {L}
add5('{','\','E','e','}'); {M}
add5('{','\','Y','u','}'); {N}
add5('{','\','Y','a','}'); {O}
add1('a'); {P}
add1('b'); {Q}
add1('v'); {R}
add1('g'); {S}
add1('d'); {T}
add1('e'); {U}
add5('{','\','z','h','}'); {V}
add1('z'); {W}
add1('i'); {X}
add5('{','\','u','i','}'); {Y}
add1('k'); {Z}
add1('l'); {[}
add1('m'); {\}
add1('n'); {]}
add1('o'); {^}
add1('p'); {_}
add1('r'); {`}
add1('s'); {a}
add1('t'); {b}
add1('u'); {c}
add1('f'); {d}
add5('{','\','k','h','}'); {e}
add5('{','\','t','s','}'); {f}
add5('{','\','c','h','}'); {g}
add5('{','\','s','h','}'); {h}
add7('{','\','s','h','c','h','}'); {i}
add10('{','\','c','d','p','r','i','m','e','}'); {j}
add1('y'); {k}
add9('{','\','c','p','r','i','m','e','}'); {l}
add5('{','\','e','e','}'); {m}
add5('{','\','y','u','}'); {n}
add5('{','\','y','a','}'); {o}
uppers[c]:=upperu;

if upperu<>uppertot then
writeln('Warning: upperu=',upperu:1,' uppertot=',uppertot:1);
end {initialize};

procedure openfiles;
var
filename: packed array[0..60] of char;
begin
repeat
write('Input file: ');
readln(filename);
assign(infile,filename);
{$I-} reset(infile,1); {$I+}
until ioresult=0;
repeat
write('Output file: ');
readln(filename);
assign(outfile,filename);
{$I-} rewrite(outfile,1); {$I+}
until ioresult=0;

inbufptr:=1;
inbuflen:=0;
outbufptr:=0;
end {openfiles};

begin {main}

initialize;
{
for c:=0 to 63 do begin
if upperm[c] then
for i:=uppers[c] to uppers[c+1]-1 do write(chr(upper[i]))
else write(upper[uppers[c]]);
writeln;
end;
}
openfiles;

while getbyte do begin
if (xbyte>=CYR_A) and (xbyte<=CYR_ya) then begin
c:=xbyte-CYR_A;
if upperm[c] then begin
for i:=uppers[c] to uppers[c+1]-1 do
begin
xbyte:=upper[i];
putbyte;
end
end
else begin
xbyte:=upper[uppers[c]];
putbyte;
end
end
else
putbyte;
end;
closefiles;
end.