What's wrong? Here is my solution:

var i,j,k,y,fl,s,t,max,min,r:longint; a:array [1..100] of string;
b,c:array [1..100] of longint; d,x:string;
begin
for i:=1 to 6 do begin
readln (d); readln (x); readln (y); fl:=0;
for j:=1 to k do
If a[j]=x then fl:=j;
If fl=0 then begin k:=k+1; a[k]:=x; b[k]:=y; c[k]:=1;end;
If fl>0 then If y<b[fl] then begin b[fl]:=y; c[fl]:=c[fl]+1;end else c[fl]:=c[fl]+1;
end;
max:=-2000000000;
for i:=1 to k do
if c[i]>max then max:=c[i];
for i:=1 to k do
if c[i]=max then begin s:=s+1; r:=i;end;
If s=1 then writeln (a[r]) else begin
min:=2000000000;
for i:=1 to k do
If b[i]<min then min:=b[i];
i:=0;
repeat
i:=i+1;
if b[i]=min then writeln (a[i]);
until (b[i]=min) or (i=k);
end;
end.