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

Тема в разделе "Pascal and Delphi", создана пользователем SchwarzeWolfin, 22 дек 2010.

  1. SchwarzeWolfin

    Регистрация:
    28 ноя 2010
    Сообщения:
    9
    Симпатии:
    0
    вроде всё сделано по стандартному алгоритму, описанному на всевозможных ресурсах, а программа зацикливается.в чем ошибка?
    <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">
    Код (Text):
    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">
    Код (Text):
    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.
     
Загрузка...

Поделиться этой страницей