Метод потенциалов

28.11.2010
9
0
#1
вроде всё сделано по стандартному алгоритму, описанному на всевозможных ресурсах, а программа зацикливается.в чем ошибка?
<div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">пример файла с исходными данными</div></div><div class="sp-body"><div class="sp-content">
3 27 20 43
4 33 13 27 17
14 10 14 28 17 30 21 15 25 28 24 21
<div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">предварительные рассчеты (северо-западный угол)</div></div><div class="sp-body"><div class="sp-content">
Код:
uses crt;
var
p:array [1..100,1..100] of integer;
f1,f2:text;
x,y,i,j,s1,s2,e:integer;
ma,mb,na,nb:array [1..100] of integer;

begin
clrscr;
s1:=0;
s2:=0;
assign(f1,'dan.txt');	 {vvod potrebnostey i nalichiya tovara}
reset(f1);
e:=0;
read(f1,e);
x:=e;
e:=0;

while not eoln(f1) do
begin
for i:=1 to x do
begin
read(f1,e);
ma[i]:=e;
s1:=s1+ma[i];
e:=0;
end;
end;
readln(f1);
read(f1,e);
y:=e;
e:=0;

for i:=1 to y do
begin
read(f1,e);
mb[i]:=e;
s2:=s2+mb[i];
e:=0;
end;

close(f1);


if s1<>s2 then	 {proverka sbalansirovannosty}
begin
writeln('vxodnye dannye nesbalancirovany/perezapustite programmu');
readkey;
halt;
end
else
begin
for i:=1 to x do	 {kopirovanie massivov potrebnostey i nalichiya tovara}
na[i]:=ma[i];
for i:=1 to y do
nb[i]:=mb[i];
end;

for i:=1 to x do	 {sostavlenie opornogo plana}
begin
for j:=1 to y do
begin
if ma[i]>mb[j] then
begin
p[i,j]:=mb[j];
ma[i]:=ma[i]-mb[j];
mb[j]:=0;
end
else
begin
p[i,j]:=ma[i];
mb[j]:=mb[j]-ma[i];
ma[i]:=0;
end;
end;
end;

write('Opornyi plan');	 {vyvod opornogo plana}

for i:=1 to x do
begin
writeln;
for j:=1 to y do
begin
write(p[i,j]:4);
end;
write(' |');
write(na[i]:2);
end;
writeln;
for i:=1 to y do
begin
write('  -');
end;
writeln;
for i:=1 to y do
write(nb[i]:4);

assign(f2,'res_p.txt');
reset(f2);
rewrite(f2);
for i:=1 to x do
begin
for J:=1 to y do
begin
write(f2,p[i,j]:4);
end;
writeln(f2);
end;
close(f2);

readkey;
end.

<div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">решение методом потенциалов</div></div><div class="sp-body"><div class="sp-content">
Код:
uses crt;
label m1,m2,m3,m4,m5,m6,m7,m8;
var
cen,ss:array [1..100,1..100] of integer;
p:array [1..100,1..100] of integer;
f1,f2,f3:text;
x,y,z,i,j,max,m,su,sv,max_i,max_j,min_p,s1,s2:integer;
n,e:integer;
bv,bu,str,d,stb,u,v,ma,mb,na,nb:array [1..100] of integer;

begin
clrscr;


assign(f2,'dan.txt');	 {vvod potrebnostey,nalichiya tovara i stoimostei}
reset(f2);
e:=0;
read(f2,e);
x:=e;
e:=0;


for i:=1 to x do
begin
read(f2,e);
ma[i]:=e;
e:=0;
end;

readln(f2);
read(f2,e);
y:=e;
e:=0;

for i:=1 to y do
begin
read(f2,e);
mb[i]:=e;
e:=0;
end;


readln(f2);
for i:=1 to y do
begin
for j:=1 to x do
begin
read(f2,e);
cen[j,i]:=e;
e:=0;
end;
end;

assign(f1,'res_p.txt');	 {vvod opornogo plana}
reset(f1);
e:=0;

while not eof(f1) do
begin
while not eoln(f1) do
begin
for i:=1 to x do
begin
for j:=1 to y do
begin
read(f1,e);
p[i,j]:=e;
end;
end;
end;
readln(f1);
end;
close(f1);

write('Opornyi plan');	 {vyvod opornogo plana}

for i:=1 to x do
begin
writeln;
for j:=1 to y do
begin
write(p[i,j]:4);
end;
write(' |');
write(Ma[i]:2);
end;
writeln;
for i:=1 to y do
begin
write('  -');
end;
writeln;
for i:=1 to y do
write(Mb[i]:4);

for i:=1 to x do	 {obnulenie bool peremennyh pri alfa(u) i beta(v)}
bu[i]:=0;
for i:=1 to y do
begin
bv[i]:=0;
d[i]:=0;
end;

for i:=1 to x do	 {poisk stolbza opornogo plana s 2 i bolee elementami>0}
begin
for j:=1 to y do
begin
if p[i,j]>0 then
d[j]:=d[j]+1;
end;
end;

sv:=0;
su:=0;

for i:=1 to y do
begin
if d[i]>1 then
begin
for j:=1 to x do
if p[j,i]>0 then
begin
u[j]:=0;
bu[j]:=1;
su:=1;
goto m1;
end;
end;
end;


m1:
z:=1;

m2:
for i:=1 to x do	 {poisk alfa(u) i beta(j)}
begin
for j:=1 to y do
begin
if (p[i,j]>0) and (bu[i]=0) and (bv[j]=1) then
begin
u[i]:=v[j]-cen[i,j];
bu[i]:=1;
su:=su+1;
end;
end;
end;

for i:=1 to x do
begin
for j:=1 to y do
begin
if (p[i,j]>0) and (bv[j]=0) and (bu[i]=1) then
begin
v[j]:=cen[i,j]+u[i];
bv[j]:=1;
sv:=sv+1;
end;
end;
end;

for i:=1 to x do
begin
for j:=1 to y do
begin
if (p[i,j]>0) and (bu[i]=0) and (bv[j]=0) then
begin
v[j]:=cen[i,j];
sv:=sv+1;
bv[j]:=1;
end;
end;
end;

if (su<x) or (sv<y) then
goto m2;

for i:=1 to x do	 {proverka optimalnosty plana}
begin
for j:=1 to y do
begin
if p[i,j]=0 then
begin
ss[i,j]:=v[j]-u[i]-cen[i,j];
if ss[i,j]>0 then
begin
z:=0;
end;
end;
end;
end;

n:=0;
e:=0;
for i:=1 to x do	 {podschet stoimosti vseh perevosok}
begin
for j:=1 to y do
begin
e:=p[i,j]*cen[i,j];
n:=n+e;
end;
end;

writeln;
writeln;
writeln('Stoimost perevozok=',n);



m3:
z:=1;			  {esli z=0}
for i:=1 to x do	{poisk kletki s maximalnym ss}
begin
for j:=1 to y do
begin
if (p[i,j]=0) and (ss[i,j]>0) then
begin
max:=ss[i,j];
max_i:=i;
max_j:=j;
goto m4;
end;
end;
end;

m4:
for i:=1 to x do
begin
for j:=1 to y do
begin
if (p[i,j]=0) and (ss[i,j]>max) then
begin
max:=ss[i,j];
max_i:=i;
max_j:=j;
end;
end;
end;

str[1]:=max_i;
stb[1]:=max_j;
str[2]:=0;
stb[2]:=0;

for i:=1 to x do	 {poisk zikla}
begin
for j:=1 to y do
begin
if (i<>max_i) and ((j<max_j-1) or (j>max_j+1)) or (j<>max_j) and ((i<max_i-1) or (i>max_i+1)) then
begin
if (p[str[1],j]>0) and (p[i,stb[1]]>0) and (p[str[i],stb[j]]>0) then
begin
str[2]:=i;
stb[2]:=j;
goto m5;
end;
end;
end;
end;

if (str[2]=0) or (stb[2]=0) then
begin
for i:=1 to x do	 {poisk zikla}
begin
for j:=1 to y do
begin
if (i<>max_i) and ((j<max_j-1) or (j>max_j+1)) or (j<>max_j) and ((i<max_i-1) or (i>max_i+1)) then
begin
if (p[str[1],j]>0) and (p[i,stb[1]]>0) then
begin
str[2]:=i;
stb[2]:=j;
goto m5;
end;
end;
end;
end;
end;

m5:

min_p:=p[str[1],stb[2]];	 {poisk minimalnoi yacheiki zikla}
if p[str[2],stb[1]]<min_p then
min_p:=p[str[2],stb[1]];

p[str[1],stb[1]]:=p[str[1],stb[1]]+min_p;
p[str[2],stb[2]]:=p[str[2],stb[2]]+min_p;
p[str[1],stb[2]]:=p[str[1],stb[2]]-min_p;
p[str[2],stb[1]]:=p[str[2],stb[1]]-min_p;

for i:=1 to x do	 {obnulenie bool peremennyh pri alfa(u) i beta(v)}
bu[i]:=0;
for i:=1 to y do
begin
bv[i]:=0;
d[i]:=0;
end;

for i:=1 to x do	 {poisk stolbza opornogo plana s 2 i bolee elementami>0}
begin
for j:=1 to y do
begin
if p[i,j]>0 then
d[j]:=d[j]+1;
end;
end;

sv:=0;
su:=0;

for i:=1 to y do
begin
if d[i]>1 then
begin
for j:=1 to x do
if p[j,i]>0 then
begin
u[j]:=0;
bu[j]:=1;
su:=1;
goto m6;
end;
end;
end;

m6:
z:=1;

m7:
for i:=1 to x do	 {poisk alfa(u) i beta(j)}
begin
for j:=1 to y do
begin
if (p[i,j]>0) and (bu[i]=0) and (bv[j]=1) then
begin
u[i]:=v[j]-cen[i,j];
bu[i]:=1;
su:=su+1;
end;
end;
end;

for i:=1 to x do
begin
for j:=1 to y do
begin
if (p[i,j]>0) and (bv[j]=0) and (bu[i]=1) then
begin
v[j]:=cen[i,j]+u[i];
bv[j]:=1;
sv:=sv+1;
end;
end;
end;

for i:=1 to x do
begin
for j:=1 to y do
begin
if (p[i,j]>0) and (bu[i]=0) and (bv[j]=0) then
begin
v[j]:=cen[i,j];
sv:=sv+1;
bv[j]:=1;
end;
end;
end;

if (su<x) or (sv<y) then
goto m7;

for i:=1 to x do
begin
for j:=1 to y do
begin
ss[i,j]:=0;
end;
end;

for i:=1 to x do	 {proverka optimalnosty plana}
begin
for j:=1 to y do
begin
if p[i,j]=0 then
begin
ss[i,j]:=v[j]-u[i]-cen[i,j];
if ss[i,j]>0 then
z:=0;
end;
end;
end;

n:=0;
e:=0;
for i:=1 to x do	 {podschet stoimosti vseh perevosok}
begin
for j:=1 to y do
begin
e:=p[i,j]*cen[i,j];
n:=n+e;
end;
end;

if z=0 then
goto m3;

m8:
writeln;
writeln('Optimalnoe reshenie');
for i:=1 to x do
begin
for j:=1 to y do
write(p[i,j]:4);
write(' |');
write(na[i]:2);
writeln;
end;

for i:=1 to y do
write('  -');
writeln;
for i:=1 to y do
write(nb[i]:4);

writeln;
writeln;
writeln('Tabliza stoimostei');
for i:=1 to x do
begin
for j:=1 to y do
begin
write(cen[i,j]:4);
end;
write(' |');
write(u[i]:2);
writeln;
end;
for i:=1 to y do
write('  -');
writeln;
for i:=1 to y do
write(v[i]:4);

n:=0;
e:=0;
for i:=1 to x do
begin
for j:=1 to y do
begin
e:=p[i,j]*cen[i,j];
n:=n+e;
end
end;

writeln;
writeln;
write('Stoimost perevozok=',n);

assign(f3,'res_p.txt');
reset(f3);
rewrite(f3);
for i:=1 to x do
begin
for j:=1 to y do
begin
write(f3,p[i,j]:4);
end;
writeln(f3);
end;
close(f3);

readkey;
end.