

 This page uses content from Wikipedia. The original article was at Forest-fire model. The list of authors can be seen in the page history. As with Rosetta Code, the text of Wikipedia is available under the GNU FDL. (See links for details on variance)



Task

Implement the Drossel and Schwabl definition of the forest-fire model.



It is basically a 2D   cellular automaton   where each cell can be in three distinct states (empty, tree and burning) and evolves according to the following rules (as given by Wikipedia)

 A burning cell turns into an empty cell
 A tree will burn if at least one neighbor is burning
 A tree ignites with probability   f    even if no neighbor is burning
 An empty space fills with a tree with probability    p 

Neighborhood is the   Moore neighborhood;   boundary conditions are so that on the boundary the cells are always empty ("fixed" boundary condition).

At the beginning, populate the lattice with empty and tree cells according to a specific probability (e.g. a cell has the probability 0.5 to be a tree). Then, let the system evolve.

Task's requirements do not include graphical display or the ability to change parameters (probabilities    p    and    f )   through a graphical or command line interface.



Related tasks

   See   Conway's Game of Life 
   See   Wireworld.


module ForestFireModel
  implicit none
 
  type :: forestfire
     integer, dimension(:,:,:), allocatable :: field
     integer :: width, height
     integer :: swapu
     real :: prob_tree, prob_f, prob_p
  end type forestfire
 
  integer, parameter :: &
       empty = 0, &
       tree = 1, &
       burning = 2
 
  private :: bcheck, set, oget, burning_neighbor ! cset, get
 
contains
 
  ! create and initialize the field(s)
  function forestfire_new(w, h, pt, pf, pp) result(res)
    type(forestfire) :: res
    integer, intent(in) :: w, h
    real, intent(in), optional :: pt, pf, pp
 
    integer :: i, j
    real :: r
 
    allocate(res%field(2,w,h)) ! no error check
    res%prob_tree = 0.5
    res%prob_f = 0.00001
    res%prob_p = 0.001
    if ( present(pt) ) res%prob_tree = pt
    if ( present(pf) ) res%prob_f = pf
    if ( present(pp) ) res%prob_p = pp
 
    res%width = w
    res%height = h
    res%swapu = 0
 
    res%field = empty
 
    do i = 1,w
       do j = 1,h
          call random_number(r)
          if ( r <= res%prob_tree ) call cset(res, i, j, tree)
       end do
    end do
 
  end function forestfire_new
 
  ! destroy the field(s)
  subroutine forestfire_destroy(f)
    type(forestfire), intent(inout) :: f
 
    if ( allocated(f%field) ) deallocate(f%field)
 
  end subroutine forestfire_destroy
 
  ! evolution
  subroutine forestfire_evolve(f)
    type(forestfire), intent(inout) :: f
 
    integer :: i, j
    real :: r
 
    do i = 1, f%width
       do j = 1, f%height
          select case ( get(f, i, j) )
          case (burning)
             call set(f, i, j, empty)
          case (empty)
             call random_number(r)
             if ( r > f%prob_p ) then
                call set(f, i, j, empty)
             else
                call set(f, i, j, tree)
             end if
          case (tree)
             if ( burning_neighbor(f, i, j) ) then
                call set(f, i, j, burning)
             else
                call random_number(r)
                if ( r > f%prob_f ) then
                   call set(f, i, j, tree)
                else
                   call set(f, i, j, burning)
                end if
             end if
          end select
       end do
    end do
    f%swapu = ieor(f%swapu, 1)
  end subroutine forestfire_evolve
 
  ! helper funcs/subs
  subroutine set(f, i, j, t)
    type(forestfire), intent(inout) :: f
    integer, intent(in) :: i, j, t
 
    if ( bcheck(f, i, j) ) then
       f%field(ieor(f%swapu,1), i, j) = t
    end if
  end subroutine set
 
  subroutine cset(f, i, j, t)
    type(forestfire), intent(inout) :: f
    integer, intent(in) :: i, j, t
 
    if ( bcheck(f, i, j) ) then
       f%field(f%swapu, i, j) = t
    end if
  end subroutine cset
 
  function bcheck(f, i, j)
    logical :: bcheck
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j
 
    bcheck = .false.
    if ( (i >= 1) .and. (i <= f%width) .and. &
         (j >= 1) .and. (j <= f%height) ) bcheck = .true.
 
  end function bcheck
 
 
  function get(f, i, j) result(r)
    integer :: r
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j
 
    if ( .not. bcheck(f, i, j) ) then
       r = empty
    else
       r = f%field(f%swapu, i, j)
    end if
  end function get
 
  function oget(f, i, j) result(r)
    integer :: r
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j
 
    if ( .not. bcheck(f, i, j) ) then
       r = empty
    else
       r = f%field(ieor(f%swapu,1), i, j)
    end if
  end function oget
 
  function burning_neighbor(f, i, j) result(r)
    logical :: r
    type(forestfire), intent(in) :: f
    integer, intent(in) :: i, j
 
    integer, dimension(3,3) :: s
 
    s = f%field(f%swapu, i-1:i+1, j-1:j+1)
    s(2,2) = empty
    r = any(s == burning)
  end function burning_neighbor
 
  subroutine forestfire_print(f)
    type(forestfire), intent(in) :: f
 
    integer :: i, j
 
    do j = 1, f%height
       do i = 1, f%width
          select case(get(f, i, j))
          case (empty) 
             write(*,'(A)', advance='no') '.'
          case (tree)
             write(*,'(A)', advance='no') 'Y'
          case (burning) 
             write(*,'(A)', advance='no') '*'
          end select
       end do
       write(*,*)
    end do
  end subroutine forestfire_print
 
end module ForestFireModel