Please help correct my program.
const maxn=200;
var g:array[1..maxn,1..maxn] of byte;
d,t,l:array[0..maxn] of integer;
f,f1:array[0..maxn] of boolean;
a:array[1..maxn,1..2] of integer;
i,j,k,n,now,gr:integer;
procedure sub(p,gr:integer);
var i:integer;
begin
for i:=1 to n do begin
if (g[p,i]=1)and(t[i]<>gr)and(t[i]<>0) then begin
writeln('No solution');
halt;
end;
if (g[p,i]=1)and f[i] then begin
t[i]:=gr; f[i]:=false;
if odd(gr) then sub(i,gr+1)
else sub(i,gr-1);
end;
end;
end;
begin
assign(input,'teams.in');
reset(input);
assign(output,'teams.out');
rewrite(output);
readln(n);
for i:=1 to n do
for j:=1 to n do
if i<>j then g[i,j]:=1;
fillchar(d,sizeof(d),0);
for i:=1 to n do begin
read(j);
while j<>0 do begin
g[i,j]:=0;
read(j);
end;
end;
for i:=1 to n do
for j:=1 to n do if g[i,j]=1 then g[j,i]:=1;
for i:=1 to n do
for j:=1 to n do
if g[i,j]=1 then inc(d[i]);
fillchar(f,sizeof(f),true);
now:=1;
repeat
i:=1;
while i<=n do
if f[i] then break
else inc(i);
if i>n then break;
t[i]:=now;
f[i]:=false;
sub(i,now+1);
now:=now+2;
until false;
fillchar(a,sizeof(a),0);
gr:=now-2;
for i:=1 to n do
if odd(t[i]) then
inc(a[t[i],1])
else inc(a[t[i]-1,2]);
fillchar(f,sizeof(f),false);
f[0]:=true;
for i:=1 to gr do
if odd(i) then begin
f1:=f;
fillchar(f,sizeof(f),false);
for j:=n downto 0 do
if f1[j] then begin
if (not f[j+a[i,1]])and(a[i,1]>0) then begin
f[j+a[i,1]]:=true;
l[j+a[i,1]]:=i;
end;
if (not f[j+a[i,2]])and(a[i,2]>0) then begin
f[j+a[i,2]]:=true;
l[j+a[i,2]]:=-i;
end;
end;
end;
i:=(n+1) div 2;
while l[i]=0 do dec(i);
write(i);
now:=i;
fillchar(f,sizeof(f),true);
while (l[i]<>0)and(i>0) do begin
for j:=1 to n do
if ((l[i]>0)and(t[j]=l[i]))or((l[i]<0)and(t[j]=abs(l[i])+1))
then begin
write(' ',j);
f[j]:=false;
end;
if l[i]>0 then i:=i-a[l[i],1]
else i:=i-a[-l[i],2];
end;
writeln;
write(n-now);
for i:=1 to n do
if f[i] then write(' ',i);
writeln;
close(input);
close(output);
end.