~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
{1152}
var
  a               : array[1..20] of byte;
  lab             : array[1..20] of boolean;
  min,k,n,d       : integer;
procedure dfs(w:integer);
var
  i,j,d1          : integer;
  k1              : array[1..2] of byte;
begin
  j:=1;
  if w<n then i:=w+1 else i:=1;
  k1[1]:=0;
  while (i<>w) and (j<3) do
    begin
      if not lab[i] then
        begin
          k1[j]:=i;
          inc(j);
        end;
      if i<n then inc(i) else i:=1;
    end;
  if j<3 then
    begin
      if d<min then min:=d;
      exit;
    end
  else
    begin
      lab[w]:=true;
      lab[k1[1]]:=true;
      lab[k1[2]]:=true;
      d1:=0;
      for i:=1 to n do
        if not lab[i] then d1:=d1+a[i];
      d:=d+d1;
      if w<n then i:=w+1 else i:=1;
      while true do
        begin
          if (i=w) then
            begin
              if (d<min) then min:=d;
              exit;
            end;
          if not lab[i] then dfs(i);
          if i<n then inc(i) else i:=1;
        end;
      lab[w]:=false;
      lab[k1[1]]:=false;
      lab[k1[2]]:=false;
      d:=d-d1;
    end;
end;
begin
  min:=30000;
  readln(n);for k:=1 to n do read(a[k]);
  for k:=1 to n do
  begin
    d:=0;
    fillchar(lab,sizeof(lab),False);
    dfs(k);
  end;
  writeln(min);
end.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

{1152}
var
  a               : array[1..20] of integer;
  lab             : array[1..20] of boolean;
  min,k,n,d       : longint;
procedure dfs(w:integer);
var
  i,j,d1          : longint;
  k1              : array[1..3] of integer;
begin
  k1[1]:=w;j:=0;
  for i:=1 to n do
    if not lab[i] then
      inc(j);
  if j<3 then
    begin
      if d<min then min:=d;
      exit;
    end;
  if w=n then
    begin
      k1[2]:=1;
      k1[3]:=2;
    end;
  if w=n-1 then
    begin
      k1[2]:=n;
      k1[3]:=1;
    end
  else
    begin
      k1[2]:=w+1;
      k1[3]:=w+2;
    end;
  if (not lab[k1[1]]) and (not lab[k1[2]]) and (not lab[k1[3]]) then
    begin
     d1:=0;
     for i:=1 to 3 do
      lab[k1[i]]:=true;
     for i:=1 to n do
      if not lab[i] then d1:=d1+a[i];
     d:=d+d1;
     if w<n then i:=w+1 else i:=1;
     while true do
      begin
        if w=i then
          begin
            if d<min then min:=d;
            exit;
          end;
        if not lab[i] then dfs(i);
        if i<n then inc(i) else i:=1;
      end;
      d:=d-d1;
      for i:=1 to 3 do
        lab[k1[i]]:=false;
    end;
end;
begin
  min:=maxlongint;
  readln(n);for k:=1 to n do read(a[k]);
  for k:=1 to n do
  begin
    d:=0;
    fillchar(lab,sizeof(lab),False);
    dfs(k);
  end;
  writeln(min);
end.

this is my AC program
I think it will help you:
(sending my programs won't help your programing you
 should work on your program by maybe some others helps
 not sending their programs)
type
    Arr                 = array[1..20] of longint;

var
    A ,Mark             : Arr;
    MinD ,I ,J ,Dam ,N  : longint;
    Sum                 : longint;


procedure back;
var
  I ,J : integer;
begin
  if Sum = 0 then
  begin
      if Dam < MinD then
        MinD := Dam;
  end
  else
  begin
    for I := 1 to N do
    begin
        if Mark[I] = 0 then
        begin
            Inc(Mark[I]);
            if Mark[I] = 1 then Sum := Sum - A[I];

            if I = 1 then
            begin
              Inc(Mark[N]);
              if Mark[N] = 1 then Sum := Sum - A[N];
            end
            else
            begin
              Inc(Mark[I-1]);
              if Mark[I-1] = 1 then Sum := Sum - A[I-1];
            end;

            Inc(Mark[I mod N + 1]);
            if Mark[I mod N + 1] = 1 then Sum := Sum - A[I mod N + 1];

            Dam := Dam + Sum;

            if Dam < MinD then
              Back;

            Dam := Dam - Sum;

            Dec(Mark[I]);
            if Mark[I] = 0 then Sum := Sum + A[I];

            if I = 1 then
            begin
              Dec(Mark[N]);
              if Mark[N] = 0 then Sum := Sum + A[N];
            end
            else
            begin
              Dec(Mark[I-1]);
              if Mark[I-1] = 0 then Sum := Sum + A[I-1];
            end;

            Dec(Mark[I mod N + 1]);
            if Mark[I mod N + 1] = 0 then Sum := Sum + A[I mod N + 1];
        end;
    end;
  end;
end;

begin
    Mind := Maxlongint;
    read(N);
    for I := 1 to N do
    begin
        read(A[I]);
        Sum := Sum + A[I];
    end;

    Dam := 0;
    Back;

    writeln(MinD);
end.

  yours
  Pooya
> {1152}
> var
>   a               : array[1..20] of integer;
>   lab             : array[1..20] of boolean;
>   min,k,n,d       : longint;
> procedure dfs(w:integer);
> var
>   i,j,d1          : longint;
>   k1              : array[1..3] of integer;
> begin
>   k1[1]:=w;j:=0;
>   for i:=1 to n do
>     if not lab[i] then
>       inc(j);
>   if j<3 then
>     begin
>       if d<min then min:=d;
>       exit;
>     end;
>   if w=n then
>     begin
>       k1[2]:=1;
>       k1[3]:=2;
>     end;
>   if w=n-1 then
>     begin
>       k1[2]:=n;
>       k1[3]:=1;
>     end
>   else
>     begin
>       k1[2]:=w+1;
>       k1[3]:=w+2;
>     end;
>   if (not lab[k1[1]]) and (not lab[k1[2]]) and (not lab[k1[3]]) then
>     begin
>      d1:=0;
>      for i:=1 to 3 do
>       lab[k1[i]]:=true;
>      for i:=1 to n do
>       if not lab[i] then d1:=d1+a[i];
>      d:=d+d1;
>      if w<n then i:=w+1 else i:=1;
>      while true do
>       begin
>         if w=i then
>           begin
>             if d<min then min:=d;
>             exit;
>           end;
>         if not lab[i] then dfs(i);
>         if i<n then inc(i) else i:=1;
>       end;
>       d:=d-d1;
>       for i:=1 to 3 do
>         lab[k1[i]]:=false;
>     end;
> end;
> begin
>   min:=maxlongint;
>   readln(n);for k:=1 to n do read(a[k]);
>   for k:=1 to n do
>   begin
>     d:=0;
>     fillchar(lab,sizeof(lab),False);
>     dfs(k);
>   end;
>   writeln(min);
> end.

it was better send me some test, and not to send ur AC one for all
but thanx anyway i still don understand my bug ... :-(
SABER