!! Правые границы интервала постоянства группировок do i=l,n

if (k(i)==l) then right(i)=le20

else

right(i)=sqrt(2*gs(i)/(ls(i)*hs(i)*(k(i)*(k(i)~l)))) end if end do

!! Левые границы интервала постоянства группировок do i=l,n

left(i)=sqrt(2*gs(i)/(ls(i)*hs(i)*(k(i)*(k(i)+l)))) end do

print *, Начальное состояние

write (*,4a,el2.5)0 Минимальные затраты = *, 11 write (*,4a,el2.5)) Базисный период = \ tt print *, inew iold g/(h*lam) к left right do i=l,n

j=y(i);

writeC*,(2i6,el2.3,i6,2el2.3)О &

i,j,glh(i),k(i),left(i),right(i)

end do

!! Выбираем направление движения key=0

if (any(right<tt)) then key=l

else

if (any(left>tt)) key=-l end if

if (key==l) then

print *, Пошли вправо do while (key==l) key=0 do i=l,n

if (right(i)<=tt) then key=l

gg=gg+2*gs(i)/(k(i)*(k(i)-l))

lhk=lhk-ls(i)*hs(i)

k(i)=k(i)~l

right(i)=sqrt(2*gs(i)/ &

(ls(i)*hs(i)*k(i)*(k(i)-l)))

end if end do

tt=sqrt(gg/lhk); ll=sqrt(gg*lhk) print *, tt = ,tt, 11 = ,11 end do else

print *, Пошли влево do while (key==-l) key=0 do i=l,n

if (left(i)>=tt) then key=-l

gg=gg-2*gs(i)/(k(i)*(k(i)+l))

lhk=lhk+ls(i)*hs(i)

k(i)=k(i)+l

left(i)=sqrt(2*gs(i)/ &

(ls(i)*hs(i)*k(i)*(k(i)+l)))

end if end do

tt=sqrt(gg/lhk); ll=sqrt(gg*lhk) print *, tt = ,tt, 11 = ,11 end do end if

write (*,(a,el2.5)) Минимальные затраты = , 11 write (*,(a,el2.5)) Базисный период = , tt kk=0

do i=l,n

if (k(i)/=kk) then kk=k(i)

write (*,( ,a,i3)) Коэффициент кратности = ,k(i) end if

write (*,(i6\)) y(i) end do

В строке с заголовками граф результирующей таблицы для размещения ее по ширине страницы часть пробелов опущена.

deallocate (h,hs,g,gs,lam,ls,glh,left,right,к,у)

contains

subroutine chanlin(n,x,y) !! Элементы x будут упорядочены по возрастанию

!! В массиве у - соответствие номеров старым

integer, intent(in) :: n

real, intent(inout) :: x(:)

integer, intent(out) :: y(:) integer i,j,k,l

real p

do i=l,n; y(i)=i; end do do i=l,n

p=x(i); k=i; l=y(i) do j=i+l,n

if (x(j)<p) then

p=x(j); k=j; l=y(k) end if end do

x(k)=x(i); x(i)=p; y(k)=y(i); y(i)=l end do end subroutine chanlin end program