[size=3]program a;
var f1,z3:text; sts:array[1..50] of string; chrs:array[1..50] of char;
   i,n,m,max,k,l,k2,l2,k3,l3,max2:integer; pro:set of 'А'..'Я';
   ch1,ch2,ch3:char;
begin
assign(f1,'f1.txt');
assign(z3,'z3.txt');
reset(f1);
rewrite(z3);
i:=0; max:=0; max2:=0;
while not eof(f1) do begin
i:=i+1;
readln(f1,sts[i]);
end;
for n:=1 to i do
for m:=1 to length(sts[n]) do
pro:=pro+[sts[n][m]];
for n:=1 to i do
for m:=1 to length(sts[n]) do
if (sts[n][m] in pro) then begin
max2:=0;
for k:=1 to i do
for l:=1 to length(sts[k]) do begin
if (sts[n][m]=sts[k][l]) then begin
max2:=max2+1; k2:=k; l2:=l;
end;
end;
if (max<max2) then begin
max:=max2; k3:=k2; l3:=l2;
end;
end;
writeln(sts[k3][l3]);
close(f1);
close(z3);
end.[/size]

var f   : text;
   i   : integer;
   a   : array[1..255] of integer;
   c   : char;
   max : integer;
   maxn : byte;
begin
 assign(f, 'c:TEMPtest.txt');
 reset(f);

 fillchar(a, sizeof(a), 0); {Зануляю массив a}

 while not eof(f) do
 begin
     read(f, c); {считали символ}
     inc(a[byte(c)]) {и пометили, что он встретился еще раз}
 end;

{Осталось найти максимум в этом массиве}
 max := -1;
 for i:=128 to 159 do {в этом диапазоне находятся заглавные русские буквы}
 if a[i] > max then begin
   maxn:=i; max:=a[i] end;

 writeLn('Answer: ', char(maxn),' ', max,' times');
 close(f)
end.