перколяция

[MathKvant]

Привет всем. Нужно сделать задачу на перколяцию. Решетку я задал, нужную концетрацию частиц делает, тупик у меня в нахождении пути от одной стенки до другой. Уже посмотрел много каких алгоритмов этот, этот, этот. Вроде как самый простой алгоритм это алгоритм "правой или левой руки", то есть двигаться нужно по часовой или против, но у меня не получилось это сделать, зацикливается

Используется синтаксис Fortran

        program per
        implicit none
        integer i,j,k,x(100),y(100),l,a,c(100),h,m,d
        real f
        v=1
        k=0
        a=1
        l=0
        do j=1,10
         do i=1,10
          k=k+1
          x(k)=a*i
          y(k)=j*a
          c(k)=0
         enddo
        enddo
        do m=1,1
        l=0
        do d=1,100
            c(d)=0
            enddo
        do while (l<50)
        CALL RANDOM_NUMBER(f)
        h=100*f
         if (c(h)==0) then
         l=l+1
          c(h)=1
          endif
        enddo
        enddo
        end program per
        

[Pphantom]

Начнем с того, что код, который Вы привели, просто не компилируется (переменную v полезно было бы как-нибудь объявить). Если это поправить, то никакого зацикливания не происходит (ничего другого, впрочем, тоже, поскольку никакие результаты эта программа никуда не выводит). Качество кода оставляет желать лучшего (отсутствие комментариев и изыски вроде do m=1,1 особенно), так что понять, чем это отличается от желаемого, совершенно невозможно.

И, кстати, Вам действительно необходимо писать на Fortran 77 (правда, с VAXовскими расширениями) в 2014 году?

[arseniiv]

MathKvant в сообщении #937420 писал(а):

тупик у меня в нахождении пути от одной стенки до другой

А граф обходили когда-нибудь? Пометьте ячейки с одной стенки и распространяйтесь на соседние с ними, не идя на уже помеченные. Если среди новых ячеек есть принадлежащие второй стенке, заканчиваем. Если нет, продолжаем распространение до упора. В какой-то момент все ячейки будут перекрашены, и зацикливаться будет некуда.

-- Пт ноя 28, 2014 22:25:59 --

Между прочим, заодно так можно и длину пути найти, если вдруг она нужна.

[12d3]

Тут простой поиск в ширину. Алгоритм легко нагуглить.

[MathKvant]

Pphantom в сообщении #937489 писал(а):

Начнем с того, что код, который Вы привели, просто не компилируется (переменную v полезно было бы как-нибудь объявить). Если это поправить, то никакого зацикливания не происходит (ничего другого, впрочем, тоже, поскольку никакие результаты эта программа никуда не выводит). Качество кода оставляет желать лучшего (отсутствие комментариев и изыски вроде do m=1,1 особенно), так что понять, чем это отличается от желаемого, совершенно невозможно.

И, кстати, Вам действительно необходимо писать на Fortran 77 (правда, с VAXовскими расширениями) в 2014 году?

Простите, код действительно плох, забыл стереть переменную вместе с тем алгоритмом, что я пытался написать. Комментарии просто не привык писать, за что извиняюсь. Изыск вроде do m=1,1, был добавлен для будущей статистики, и так же не был закомментирован. Кусок, что я привел, создает сетку 10*10 и заполняет ее 1 с концентрацией в 50%. Да, мне действительно необходимо писать на Fortran 77, или вы не про язык, а про стандарт?

arseniiv в сообщении #937506 писал(а):

MathKvant в сообщении #937420 писал(а):

тупик у меня в нахождении пути от одной стенки до другой

А граф обходили когда-нибудь? Пометьте ячейки с одной стенки и распространяйтесь на соседние с ними, не идя на уже помеченные. Если среди новых ячеек есть принадлежащие второй стенке, заканчиваем. Если нет, продолжаем распространение до упора. В какой-то момент все ячейки будут перекрашены, и зацикливаться будет некуда.

-- Пт ноя 28, 2014 22:25:59 --

Между прочим, заодно так можно и длину пути найти, если вдруг она нужна.

Никогда не обходил, сейчас попробую поискать. Спасибо

12d3 в сообщении #937508 писал(а):

Тут простой поиск в ширину. Алгоритм легко нагуглить.

Я натыкался на этот алгоритм. Спасибо

[Pphantom]

MathKvant в сообщении #937745 писал(а):

Да, мне действительно необходимо писать на Fortran 77, или вы не про язык, а про стандарт?

Я именно про стандарт.

Остальное уже подсказали (насколько вообще возможно было понять то, что Вы хотите).

[MathKvant]

Попытался написать алгоритм "левой руки", не могут найти, как выйти из subroutine, когда попал в несвязный кластер, чтобы дальше другой путь найти.

Используется синтаксис Fortran

    program perkolation
        implicit none
        integer, parameter :: m = 10, n = 10
        integer a(0:m+1, 0:n+1)
        integer k,f,g,i,j,x,y,yy
        real l,c
        common a
        g=0
        a=0
        do while(g<50)
        call random_number(l)
        call random_number(c)
        k=10*l
        f=10*c
        if (a(k,f)==0) then!      Создаю сетку 10*10  и заполняю 50% "1"
            a(k,f)=1
            g=g+1
        endif
        enddo
        do j=1,n
            a(0,j)=0!            Накладываю граничные условия в виде "0" слева
        enddo
        do j=1,n
            a(m+1,j)=0!          Накладываю граничные условия в виде "0" справа
        enddo
        do i=1,m
            a(i,0)=0!            Накладываю граничные условия в виде "0" вверху
        enddo
        do i=1,m
            a(i,n+1)=0!          Накладываю граничные условия в виде "0" внизу
        enddo
        do yy=1,n!Перебор элементов по оси y сверху вниз для того, чтобы искать другой путь, если тупик
            x=1
            y=yy
            if (a(x,y+1)==1) then! Ищу, куда сделать первый шаг
                y=y+1
                Call up(x,y)
                endif
                if (a(x+1,y)==1) then
                x=x+1
                Call forward(x,y)
                endif
                if (a(x,y-1)==1) then
                y=y-1
                Call down(x,y)
                endif
                if (a(x-1,y)==1) then
                x=x-1
                Call ago(x,y)
                endif
            enddo
        end program perkolation


                subroutine up(x1,y1)! Подпрограмма шага вверх
                implicit none
                integer, parameter :: m = 10, n = 10
                integer a(0:m+1, 0:n+1)
                integer x1,y1
                common a
                if (a(x1-1,y1)==1) then
                x1=x1-1
                Call ago(x1,y1)
                endif
                if (a(x1,y1+1)==1) then
                    y1=y1+1
                Call up(x1,y1)
                endif
                if (a(x1+1,y1)==1) then
                    x1=x1+1
                Call forward(x1,y1)
                endif
                if (a(x1,y1-1)==1) then
                    y1=y1-1
                    Call down(x1,y1)
                endif
            end subroutine up


            subroutine forward(x2,y2)! Подпрограмма шага вперед
                implicit none
                integer, parameter :: m = 10, n = 10
                integer a(0:m+1, 0:n+1)
                integer x2,y2
                common a
                if (a(x2,y2+1)==1) then
                    y2=y2+1
                Call up(x2,y2)
                endif
                if (a(x2+1,y2)==1) then
                    x2=x2+1
                Call forward(x2,y2)
                endif
                if (a(x2,y2-1)==1) then
                    y2=y2-1
                Call down(x2,y2)
                endif
                if (a(x2-1,y2)==1) then
                    x2=x2-1
                Call ago(x2,y2)
                endif
            end subroutine forward


            subroutine down(x3,y3)! Подпрограмма шага вниз
                implicit none
                integer, parameter :: m = 10, n = 10
                integer a(0:m+1, 0:n+1)
                integer x3,y3
                common a
                if (a(x3+1,y3)==1) then
                    x3=x3+1
                Call forward(x3,y3)
                endif
                if (a(x3,y3-1)==1) then
                    y3=y3-1
                Call down(x3,y3)
                endif
                if (a(x3-1,y3)==1) then
                    x3=x3-1
                Call ago(x3,y3)
                endif
                if (a(x3,y3+1)==1) then
                    y3=y3+1
                Call up(x3,y3)
                endif
            end subroutine down


            subroutine ago(x4,y4)! Подпрограмма шага назад
                implicit none
                integer, parameter :: m = 10, n = 10
                integer a(0:m+1, 0:n+1)
                integer x4,y4
                common a
                if (a(x4,y4-1)==1) then
                    y4=y4-1
                Call down(x4,y4)
                endif
                if (a(x4-1,y4)==1) then
                    x4=x4-1
                Call ago(x4,y4)
                endif
                if (a(x4,y4+1)==1) then
                    y4=y4+1
                Call up(x4,y4)
                endif
                if (a(x4+1,y4)==1) then
                    x4=x4+1
                Call forward(x4,y4)
                endif
            end subroutine ago
 

[arseniiv]

Далась вам эта левая рука. Хотя если её и писать, нечего делать шаги влево, вправо, вниз и вверх отдельными процедурами — они аналогичны, так и напишите одну, параметризованную направлением.

[MathKvant]

arseniiv, Я не понимаю, как нужно параметризовать, если это не верно, скажите как нужно сделать

[arseniiv]

Не знаю, верно ли, но четыре процедуры, которые переходят друг в друга, если поповорачивать массив — это явно лишнее. Параметризовать можно по-всякому. Можно решить, что 0 — влево, 1 — вверх, 2 — вправо, 3 — вниз. Можно решить, что чётные — это влево/вниз, нечётные — вправо/вверх, а направление зависит от того, больше ли единицы. Можно ещё константы завести, что будет пограмотнее, и функцию от них, выдающую смещения координат.

Но чем не угодил поиск в ширину — непонятно.

[MathKvant]

arseniiv, Я последовал вашему совету и попробовал реализовать алгоритм поиска в ширину. Я делал так: брал клетку с координатой (1,1) и смотрел ее соседей, если рядом есть клетки с "1", то присваивал "2", потом искал все клетки с "2" и также проверял. Но попал в тупик, если кластер не стягивается в клетки с началом (1,1), то нужно как-то перепрыгнуть на (2,1) и тд до конца. Также не понятно до какого момента я должен перекрашивать. Понятное дело, что нужно перекрашивать до того, пока в последнем столбце не появится хотя бы одно значение отличное от 0 и 1, хотя больше 10, так как это самый короткий путь, но как это записать не знаю.

Используется синтаксис Fortran

program perkolation
implicit none
integer, parameter :: m = 10, n = 10
integer a(0:m+1, 0:n+1)
integer k,f,g,i,j,x,y,ii,jj,sub
real l,c
common a
g=0
a=0
do while(g<50)
call random_number(l)
call random_number(c)
k=10*l
f=10*c
if (a(k,f)==0) then!      Создаю сетку 10*10  и заполняю 50% "1"
a(k,f)=1
g=g+1
endif
enddo
do j=1,n
a(0,j)=0!            Накладываю граничные условия в виде "0" слева
enddo
do j=1,n
a(m+1,j)=0!          Накладываю граничные условия в виде "0" справа
enddo
do i=1,m
a(i,0)=0!            Накладываю граничные условия в виде "0" вверху
enddo
do i=1,m
a(i,n+1)=0!          Накладываю граничные условия в виде "0" внизу
enddo
x=1!                    координаты для первой клетки, начинаю обход с нее
y=1
sub=1
do while()!           тут проблема, так как не знаю как организовать, чтобы проверял последний столбец отличный от 0,1
call move(x,y,sub)
do jj=1,10!           поиск по всем элементам на соответсвующие числа
do ii=1,10
if (a(ii,jj)==sub) then
call move(ii,jj,sub)
end if
enddo
enddo
enddo
end program perkolation
subroutine move(x1,y1,neighbor)!подпрограмма, которая просматривает всех соседей  и если равна "1", то присваивает с.з.
implicit none
integer, parameter :: m = 10, n = 10
integer a(0:m+1, 0:n+1)
integer x1,y1,neighbor
common a
if (a(x1,y1+1)==1) then
a(x1,y1+1)=neighbor+1
endif
if (a(x1+1,y1)==1) then
a(x1+1,y1)=neighbor+1
endif
if (a(x1,y1-1)==1) then
a(x1,y1-1)=neighbor+1
endif
if (a(x1-1,y1)==1) then
a(x1-1,y1)=neighbor+1
endif
end subroutine move
 

[arseniiv]

(О советах.)

MathKvant в сообщении #944616 писал(а):

Я последовал вашему совету

Это настолько же совет и 12d3, тем более что его название тут написал впервые именно 12d3, а я, к своему стыду, почему-то сначала решил, что это поиск не в ширину, а какой-то другой.

MathKvant в сообщении #944616 писал(а):

Я делал так: брал клетку с координатой (1,1) и смотрел ее соседей, если рядом есть клетки с "1", то присваивал "2", потом искал все клетки с "2" и также проверял. Но попал в тупик, если кластер не стягивается в клетки с началом (1,1), то нужно как-то перепрыгнуть на (2,1) и тд до конца.

Перекрасьте сразу все единичные клетки с «исходной» стороны. Потом добавляете их в очередь, которую можно реализовать хотя бы с помощью массива (не знаю о стандартной библиотеке возможностях Fortran и конкретно этой его версии — может, всё проще или яснее сделать можно). Потом, пока очередь не пуста, вынимаете из неё координаты клетки и пытаетесь покрасить соседей, и т. п..

Конечно, можно не выделять здесь очередь, но тогда каждый раз надо будет бегать по всему массиву в поисках перекрашенной клетки с неперекрашенными соседями — этого делать не стоит.

[MathKvant]

arseniiv
Вот организовать очередь у меня не получается. Предположим я перекрасил элементы a(1,1)=2, a(1,4)=3, a(1,6)=4. Как их добавить в очередь,этого я не понимаю?

[arseniiv]

Увы, я в Fortran ни одной из версий не разбираюсь. Очередь — это тип данных, таких очередей может быть как ни одной, так и куча. Какие-либо встроенные в языки очереди встречаются если не никогда, то крайне редко.

В вашем фортране есть указатели? Тогда можно реализовать очередь связным списком. Или можно с помощью массива, как выше упоминал (если наибольшее возможное в ней число элементов известно, иначе нужны динамические массивы). Эти способы описываются очень много где, псевдокод и основания здесь писать не буду.