Оптимизировать программу

[phenix]

Здраствуйте. Помогите кто-нибудь оптимизировать код. Вот условие задачи :

 По одной корове с каждой из N (1 <= N <= 1000) ферм, пронумерованных
последовательно 1..N, собираются на вечеринку, которая  состоится 
на ферме X (1 <= X <= N). Каждая из M (1 <= M <= 100,000) 
двунаправленных дорог, соединяет соединяет одну ферму с другой. 
Всегда возможно добраться от одной фермы до другой с помощью этой
системы дорог (для любой пары ферм). Путешествие по дороге i 
занимает Ti единиц времени. Одна или более пар ферм может быть
непосредственно связана более чем одной дорогой. 
     После того, как все коровы собрались на ферме X, они поняли,
что забыли ВСЕ что-то на своих фермах. Поэтому вечерину прервали,
все коровы отправились на свои фермы, взять то, что забыли и 
вернулись на вечеринку. Все коровы выбрали оптимальный маршрут.
Какое минимальное время потребуется, чтобы продолжить вечеринку?

PROBLEM NAME: bparty

Формат ввода:

* Строка 1: Три разделенных пробелом целых числа: N M X

* Строки 2..M+1: Строка i+1 описывает дорогу i тремя целыми числами:
            Ai Bi Ti. Эта дорога соединяет фермы Ai и Bi и для ее 
            прохождения требуется Ti единиц времени.

Пример ввода (файл bparty.in):

4 8 2
1 2 7
1 3 8
1 4 4
2 1 3
2 3 1
3 1 2
3 4 6
4 2 2

INPUT DETAILS:

 4 коровы, 8 дорог, вечеринка на ферме 2.

Формат вывода:

* Строка 1: Одно целое число - минимальное количество времени,
            через которое вечеринка сможет быть продолжена.

Пример вывода (файл bparty.out):

6

OUTPUT DETAILS:

Непосредственные дороги соединяют ферму 2 с каждой из остальных ферм.
(к ферме 1 - времена 7 и 3), к ферме 3: 1, к ферме 4: 2. 
Самый долгий путь (из кратчайших) - 3, поэтому ответ 6.

А вот моё решение:

{$R-}
var
  a,MinSum : array[1..1001,1..1001] of longint;
  Que : array[1..1000000,1..2] of longint;
  c : array[1..1001]  of longint;
  i,j,m,n,k,s1,s2,s3,sum,min,QueEnd,QueBegin : longint;

procedure Put(x,sum : longint);
begin
  Inc(QueEnd);
  Que[QueEnd,1]:=x;
  Que[QueEnd,2]:=sum;
end;

procedure Get(var x,sum : longint);
begin
  x:=Que[QueBegin,1];
  sum:=Que[QueBegin,2];
  Inc(QueBegin);
end;

procedure PutAll(x,sum : longint);
var
  i : longint;
begin
  for i:=1 to n do
    if (a[x,i]<>2000000000) and (x<>i) and (sum+a[x,i]<MinSum[x,i]) 
      then 
        begin
          Put(i,sum+a[x,i]);
          MinSum[x,i]:=sum+a[x,i];
          MinSum[i,x]:=sum+a[x,i];
        end;
end;

procedure PoiskMin(var HodX : longint);
var
  i,j,x,MinSum1 : longint;
  est : boolean;
begin
  for i:=1 to n do
    for j:=1 to n do MinSum[i,j]:=2000000000;
  QueBegin:=1;
  QueEnd:=0;
  est:=false;
  for i:=1 to n do
    if a[HodX,i]<>2000000000
      then 
        begin
          est:=true;
          break;
        end;
  if est
    then Put(HodX,0);
  while QueBegin<=QueEnd do
    begin
      Get(x,sum);
      PutAll(x,sum);
    end;
  MinSum1:=2000000000;
  for i:=1 to n do
    if MinSum1>MinSum[k,i]
      then minsum1:=MinSum[k,i]; 
  c[HodX]:=MinSum1;
end;  
  
begin
  Assign(input,'bparty.in'); ReSet(input);
  Assign(output,'bparty.out'); ReWrite(output);
  readln(n,m,k);
  for i:=1 to n do
    for j:=1 to n do
      a[i,j]:=2000000000;
  for i:=1 to m do
    begin
      readln(s1,s2,s3);
      if a[s1,s2]>s3
        then 
          begin
            a[s1,s2]:=s3;
            a[s2,s1]:=s3;
          end;
    end;
  for j:=1 to n do
    if j<>k
      then PoiskMin(j);
  min:=0;
  for i:=1 to n do
    if (c[i]>min) and (i<>k)
      then min:=c[i];
  writeln(min*2);
  Close(input);
  Close(output);
end.

[phenix]

Плиз, очень срочно.