Найти студента, который наибольшее количество недель продержался без троек

Program P1;
Const m=40;{количество студентов}
      n=35;{количество недель}
Type stud=Record
          prog:array[1..n] of integer;{оценки по программированию}
          mat:array[1..n] of integer;{оценки по математике }
          fiz:array[1..n] of integer;{оценки по физике}
     end;
Var grupa:array[1..m] of stud;{массив записей}
    usp:array[1..m] of integer;{рейтинг успеваемости студентов}
    i,j,k:integer;
 
BEGIN
     {заполняем журнал}
     For i:=1 to m do
          begin
               With grupa[i] do begin
                    For j:=1 to n do begin
                         prog[j]:=random(4)+2;{оценки по программированию }
                         mat[j]:=random(4)+2; {оценки по математике       }
                         fiz[j]:=random(4)+2; {оценки по физике           }
                         {подсчет удачных недель}
                         If (prog[j]>3) And (mat[j]>3) And (fiz[j]>3) Then usp[i]:=usp[i]+1;
                    end;
               end;
          end;
     {поиск максимальной успеваемости студентов}
     k:=0;
     For i:=1 to m do
          If usp[i]>k Then k:=usp[i];
     {вывод журнала успеваемости}
     For i:=1 to m do begin
          Writeln (i,' Количество удачных недель -> ',usp[i]);
          With grupa[i] do begin
               Write ('оценки по программированию ');
               For j:=1 to n do Write (prog[j]:2);
               Writeln;
               Write ('оценки по математике       ');
               For j:=1 to n do Write (mat[j]:2);
               Writeln;
               Write ('оценки по физике           ');
               For j:=1 to n do Write (fiz[j]:2);
               Writeln;
          end;
     end;
     {--------------------------}
     Writeln;
     Write('Лучший студент :');
     For i:=1 to m do 
          if usp[i]=k Then Write(i:2);
     Writeln(' он продержался ',k,' недель')
END.