module mod_bitset
  implicit none

  integer, parameter :: ADDRESS_BITS_PER_WORD = 6
  integer, parameter :: BITS_PER_WORD = lshift(1,ADDRESS_BITS_PER_WORD)
  integer, parameter :: BIT_INDEX_MASK = BITS_PER_WORD-1
  integer(8), parameter :: WORD_MASK = -1_8

  type t_bitset
    private
    integer(8), pointer :: words(:) => null()
    integer :: wiu = 0
    logical :: sticky = .false.
  contains
    procedure :: to_long_array => to_long_array
    procedure :: flip => flip
    procedure :: set => set
    procedure :: clear => clear
    procedure :: get => get1
    procedure :: subset => get2
    procedure :: next_set_bit => next_set_bit
    procedure :: next_clear_bit => next_clear_bit
    procedure :: prev_set_bit => prev_set_bit
    procedure :: prev_clear_bit => prev_clear_bit
    procedure :: length => length
    procedure :: is_empty => is_empty
    procedure :: intersects => intersects
    procedure :: cardinality => cardinality
    procedure :: and => bitset_and
    procedure :: or => bitset_or
    procedure :: xor => bitset_xor
    procedure :: and_not => bitset_and_not
    procedure :: hashcode => bitset_hashcode
    procedure :: size => size_of
  end type

  interface bitset
    module procedure :: new_bitset0, new_bitset1, value_of1
  end interface bitset

contains

  integer function word_index(idx)
    integer, intent(in) :: idx
    word_index = rshift(idx,ADDRESS_BITS_PER_WORD)
  end

  subroutine check_invariants(this)
    type(t_bitset), intent(in) :: this
    if (this%wiu == 0 .and. .not.associated(this%words)) return
    if (this%wiu > 1 .and. this%words(this%wiu-1) == 0_8) then
      write(*,'(a)') "Error: Internal error (1) at check_invariants"
    end if
    if (this%wiu < 0 .or. this%wiu > size(this%words,1)) then
      write(*,'(a)') "Error: Internal error (2) at check_invariants"
    end if
    if (this%wiu < size(this%words,1) .and. this%words(this%wiu) /= 0_8) then
      write(*,'(a)') "Error: Internal error (3) at check_invariants"
    end if
  end

  subroutine recalculate_wiu(this)
    type(t_bitset), intent(inout) :: this
    integer :: i
    i = this%wiu-1
    do while (i >= 0)
      if (this%words(i) /= 0_8) exit
      i = i-1
    end do
    this%wiu = i+1
  end

  function new_bitset0() result(ret)
    type(t_bitset) :: ret
    call init_words(ret,BITS_PER_WORD)
    ret%sticky = .false.
  end

  function new_bitset1(n) result(ret)
    integer, intent(in) :: n
    type(t_bitset) :: ret
    if (n < 0) then
      write(*,'(a)') "Error: Negative array size (n < 0) at init_bitset"
      stop
    end if
    call init_words(ret,n)
    ret%sticky = .true.
  end

  subroutine init_words(this,n)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: n
    if (associated(this%words)) deallocate(this%words)
    allocate(this%words(0:word_index(n-1)))
    this%words = 0_8
  end

  function new_bitset2(words) result(ret)
    integer(8), intent(in) :: words(:)
    integer :: n
    type(t_bitset) :: ret
    n = size(words,1)
    allocate(ret%words(0:n-1))
    ret%words(0:n-1) = words(1:n)
    ret%wiu = n
    call check_invariants(ret)
  end

  function value_of1(arr) result(ret)
    integer(8), intent(in) :: arr(:)
    integer :: n
    type(t_bitset) :: ret
    n = size(arr)
    do while (n > 0 .and. arr(n) == 0_8)
      n = n-1
    end do
    if (n == 0) return
    ret = new_bitset2(arr(1:n))
  end

  function to_long_array(this) result(ret)
    class(t_bitset), intent(inout) :: this
    integer(8) :: ret(0:this%wiu-1)
    ret(0:this%wiu-1) = this%words(0:this%wiu-1)
  end

  subroutine ensure_capacity(this,require)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: require
    integer :: n, request
    integer, allocatable :: tmp(:)
    if (.not.associated(this%words)) then
      allocate(this%words(0:require-1))
      this%sticky = .false.
      return
    end if
    n = size(this%words,1)
    if (n >= require) return
    request = max(2*n,require)
    allocate(tmp(n))
    tmp(1:n) = this%words(0:n-1)
    deallocate(this%words)
    allocate(this%words(0:request-1))
    this%words = 0_8
    this%words(0:n-1) = tmp(1:n)
    this%sticky = .false.
  end

  subroutine expand_to(this,widx)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: widx
    integer :: require
    require = widx+1
    if (this%wiu < require) then
      call ensure_capacity(this,require)
      this%wiu = require
    end if
  end

  subroutine check_range(fidx,tidx)
    integer, intent(in) :: fidx, tidx
    if (fidx < 0) then
      write(*,'(a)') "Error: Index out of bounds (fidx < 0) at check_range"
    end if
    if (tidx < 0) then
      write(*,'(a)') "Error: Index out of bounds (fidx < 0) at check_range"
    end if
    if (fidx > tidx) then
      write(*,'(a)') "Error: Index out of bounds (fidx > tidx) at check_range"
    end if
  end

  subroutine flip(this,fidx,tidx)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: fidx
    integer, optional :: tidx
    if (present(tidx)) then
      call flip2(this,fidx,tidx)
    else
      call flip1(this,fidx)
    end if
  end

  subroutine flip1(this,idx)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: idx
    integer :: widx
    if (idx < 0) then
      write(*,'(a)') "Error: Index out of bounds (idx < 0) at flip1"
    end if
    widx = word_index(idx)
    call expand_to(this,widx)
    this%words(widx) = xor(this%words(widx),lshift(1_8,idx))
    call recalculate_wiu(this)
    call check_invariants(this)
  end

  subroutine flip2(this,fidx,tidx)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: fidx, tidx
    integer :: sidx, eidx, i
    integer(8) :: fmask, lmask
    call check_range(fidx,tidx)
    if (fidx == tidx) return
    sidx = word_index(fidx)
    eidx = word_index(tidx-1)
    call expand_to(this,eidx)
    fmask = lshift(WORD_MASK,fidx)
    lmask = not(lshift(WORD_MASK,-tidx))
    if (sidx == eidx) then
      this%words(sidx) = xor(this%words(sidx),and(fmask,lmask))
    else
      this%words(sidx) = xor(this%words(sidx),fmask)
      do i = sidx+1, eidx-1
        this%words(i) = xor(this%words(i),WORD_MASK)
      end do
      this%words(eidx) = xor(this%words(eidx),lmask)
    end if
    call recalculate_wiu(this)
    call check_invariants(this)
  end

  subroutine set(this,fidx,tidx,val)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: fidx
    integer, optional :: tidx
    logical, optional :: val
    if (present(val)) then
      if (present(tidx)) then
        call set2a(this,fidx,tidx,val)
      else
        call set1a(this,fidx,val)
      end if
    else
      if (present(tidx)) then
        call set2(this,fidx,tidx)
      else
        call set1(this,fidx)
      end if
    end if
  end

  subroutine set1(this,idx)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: idx
    integer :: widx
    if (idx < 0) then
      write(*,'(a)') "Error: Index out of bounds (idx < 0) at set1"
    end if
    widx = word_index(idx)
    call expand_to(this,widx)
    this%words(widx) = ibset(this%words(widx),idx)
    call check_invariants(this)
  end

  subroutine set1a(this,idx,val)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: idx
    logical, intent(in) :: val
    if (val) then
      call set1(this,idx)
    else
      call clear1(this,idx)
    end if
  end

  subroutine set2(this,fidx,tidx)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: fidx, tidx
    integer :: sidx, eidx, i
    integer(8) :: fmask, lmask
    call check_range(fidx,tidx)
    if (fidx == tidx) return
    sidx = word_index(fidx)
    eidx = word_index(tidx-1)
    call expand_to(this,eidx)
    fmask = lshift(WORD_MASK,fidx)
    lmask = not(lshift(WORD_MASK,-tidx))
    if (sidx == eidx) then
      this%words(sidx) = or(this%words(sidx),and(fmask,lmask))
    else
      this%words(sidx) = or(this%words(sidx),fmask)
      do i = sidx+1, eidx-1
        this%words(i) = WORD_MASK
      end do
      this%words(eidx) = or(this%words(eidx),lmask)
    end if
    call check_invariants(this)
  end

  subroutine set2a(this,fidx,tidx,val)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: fidx, tidx
    logical, intent(in) :: val
    if (val) then
      call set2(this,fidx,tidx)
    else
      call clear2(this,fidx,tidx)
    end if
  end

  subroutine clear(this,fidx,tidx)
    class(t_bitset), intent(inout) :: this
    integer, optional :: fidx, tidx
    if (present(fidx)) then
      if (present(tidx)) then
        call clear2(this,fidx,tidx)
      else
        call clear1(this,fidx)
      end if
    else
      call clear3(this)
    end if
  end

  subroutine clear1(this,idx)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: idx
    integer :: widx
    if (idx < 0) then
      write(*,'(a)') "Error: Index out of bounds (idx < 0) at clear1"
    end if
    widx = word_index(idx)
    if (widx >= this%wiu) return
    this%words(widx) = ibclr(this%words(widx),idx)
    call recalculate_wiu(this)
    call check_invariants(this)
  end

  subroutine clear2(this,fidx,toidx)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: fidx, toidx
    integer :: sidx, eidx, i, tidx
    integer(8) :: fmask, lmask
    tidx = toidx
    call check_range(fidx,tidx)
    if (fidx == tidx) return
    sidx = word_index(fidx)
    if (sidx >= this%wiu) return
    eidx = word_index(tidx-1)
    if (eidx >= this%wiu) then
      tidx = length(this)
      eidx = this%wiu-1
    end if
    fmask = lshift(WORD_MASK,fidx)
    lmask = not(lshift(WORD_MASK,-tidx))
    if (sidx == eidx) then
      this%words(sidx) = and(this%words(sidx),not(and(fmask,lmask)))
    else
      this%words(sidx) = and(this%words(sidx),not(fmask))
      do i = sidx+1, eidx-1
        this%words(i) = 0_8
      end do
      this%words(eidx) = and(this%words(eidx),not(lmask))
    end if
    call recalculate_wiu(this)
    call check_invariants(this)
  end

  subroutine clear3(this)
    type(t_bitset), intent(inout) :: this
    this%words(0:this%wiu-1) = 0_8
  end

  function get1(this,idx) result(ret)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: idx
    integer :: widx
    logical :: ret
    if (idx < 0) then
      write(*,'(a)') "Error: Index out of bounds (idx < 0) at get1"
    end if
    call check_invariants(this)
    widx = word_index(idx)
    ret = widx < this%wiu .and. btest(this%words(widx),idx)
  end

  function get2(this,fidx,toidx) result(ret)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: fidx, toidx
    integer :: tar, src, i, tidx, l
    integer(8) :: lmask, tmp
    type(t_bitset) :: ret
    logical :: align
    tidx = toidx
    call check_range(fidx,tidx)
    call check_invariants(this)
    l = length(this)
    if (l <= fidx .or. fidx == tidx) return
    if (tidx > l) tidx = l
    ret = new_bitset1(tidx-fidx)
    tar = word_index(tidx-fidx-1)+1
    src = word_index(fidx)
    if (and(fidx,BIT_INDEX_MASK) == 0) then
      do i = 0, tar-2
        ret%words(i) = this%words(src)
        src = src+1
      end do
    else
      do i = 0, tar-2
        tmp = rshift(this%words(src),fidx)
        if (this%words(src) < 0_8) tmp = not(lshift(WORD_MASK,-fidx))
        ret%words(i) = or(tmp,lshift(this%words(src+1),fidx))
        src = src+1
      end do
    end if
    lmask = WORD_MASK
    if (tidx /= 0) lmask = not(lshift(WORD_MASK,-tidx))
    if (and(tidx-1,BIT_INDEX_MASK) < and(fidx,BIT_INDEX_MASK)) then
      tmp = rshift(this%words(src),fidx)
      if (this%words(src) < 0_8) tmp = not(lshift(WORD_MASK,-fidx))
      ret%words(tar-1) = or(tmp,lshift(and(this%words(src+1),lmask),-fidx))
    else
      tmp = and(this%words(src),lmask)
      if (tmp < 0_8) then
        tmp = not(lshift(WORD_MASK,-fidx))
      else
        tmp = rshift(tmp,fidx)
      end if
      ret%words(tar-1) = and(tmp,lmask)
    end if
    ret%wiu = tar
    call recalculate_wiu(ret)
    call check_invariants(ret)
  end

  function num_of_trailing_zeros(n) result(ret)
    integer(8), intent(in) :: n
    integer :: ret, x, y
    ret = 64
    if (n == 0_8) return
    ret = 63
    y = int(n,4)
    if (y /= 0) then
      ret = ret-32
      x = y
    else
      x = int(rshift(n,32),4)
    end if
    y = lshift(x,16)
    if (y /= 0) then
      ret = ret-16
      x = y
    end if
    y = lshift(x,8)
    if (y /= 0) then
      ret = ret-8
      x = y
    end if
    y = lshift(x,4)
    if (y /= 0) then
      ret = ret-4
      x = y
    end if
    y = lshift(x,2)
    if (y /= 0) then
      ret = ret-2
      x = y
    end if
    ret = ret-rshift(lshift(x,1),31)
  end

  function num_of_leading_zeros(n) result(ret)
    integer(8), intent(in) :: n
    integer :: ret, x
    ret = 64
    if (n == 0_8) return
    ret = 1
    x = int(rshift(n,32),4)
    if (x == 0) then
      ret = ret+32
      x = int(n,4)
    end if
    if (rshift(x,16) == 0) then
      ret = ret+16
      x = lshift(x,16)
    end if
    if (rshift(x,24) == 0) then
      ret = ret+8
      x = lshift(x,8)
    end if
    if (rshift(x,28) == 0) then
      ret = ret+4
      x = lshift(x,4)
    end if
    if (rshift(x,30) == 0) then
      ret = ret+2
      x = lshift(x,2)
    end if
    ret = ret-rshift(x,31)
  end

  function next_set_bit(this,idx) result(ret)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: idx
    integer :: ret, u
    integer(8) :: word
    ret = -1
    if (idx < 0) then
      write(*,'(a)') "Error: Index out of bounds (idx < 0) at next_set_bit"
    end if
    call check_invariants(this)
    u = word_index(idx)
    if (u >= this%wiu) return
    word = and(this%words(u),lshift(WORD_MASK,idx))
    do
      if (word /= 0_8) then
        ret = u*BITS_PER_WORD+num_of_trailing_zeros(word)
        return
      end if
      u = u+1
      if (u == this%wiu) return
      word = this%words(u)
    end do
  end

  function next_clear_bit(this,idx) result(ret)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: idx
    integer :: ret, u
    integer(8) :: word
    ret = idx
    if (idx < 0) then
      write(*,'(a)') "Error: Index out of bounds (idx < 0) at next_set_bit"
    end if
    call check_invariants(this)
    u = word_index(idx)
    if (u >= this%wiu) return
    word = and(not(this%words(u)),lshift(WORD_MASK,idx))
    do
      if (word /= 0_8) then
        ret = u*BITS_PER_WORD+num_of_trailing_zeros(word)
        return
      end if
      u = u+1
      if (u == this%wiu) then
        ret = this%wiu*BITS_PER_WORD
        return
      end if
      word = this%words(u)
    end do
  end

  function prev_set_bit(this,idx) result(ret)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: idx
    integer :: ret, u
    integer(8) :: word
    ret = -1
    if (idx < 0) then
      if (idx /= -1) write(*,'(a)') "Error: Index out of bounds (idx < 0) at next_set_bit"
      return
    end if
    call check_invariants(this)
    u = word_index(idx)
    if (u >= this%wiu) then
      ret = length(this)-1
      return
    end if
    word = and(this%words(u),not(lshift(WORD_MASK,-(idx+1))))
    do
      if (word /= 0_8) then
        ret = (u+1)*BITS_PER_WORD-1-num_of_leading_zeros(word)
        return
      end if
      if (u == 0) return
      u = u-1
      word = this%words(u)
    end do
  end

  function prev_clear_bit(this,idx) result(ret)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: idx
    integer :: ret, u
    integer(8) :: word
    ret = -1
    if (idx < 0) then
      if (idx /= -1) write(*,'(a)') "Error: Index out of bounds (idx < 0) at next_set_bit"
      return
    end if
    call check_invariants(this)
    u = word_index(idx)
    if (u >= this%wiu) then
      ret = idx
      return
    end if
    word = and(not(this%words(u)),not(lshift(WORD_MASK,-(idx+1))))
    do
      if (word /= 0_8) then
        ret = (u+1)*BITS_PER_WORD-1-num_of_leading_zeros(word)
        return
      end if
      if (u == 0) return
      u = u-1
      word = not(this%words(u))
    end do
  end

  integer function length(this)
    class(t_bitset), intent(in) :: this
    length = 0
    if (this%wiu == 0) return
    length = BITS_PER_WORD*(this%wiu-1)+BITS_PER_WORD-num_of_leading_zeros(this%words(this%wiu-1))
  end

  logical function is_empty(this)
    class(t_bitset), intent(in) :: this
    is_empty = this%wiu == 0
  end

  function intersects(this,other) result(ret)
    class(t_bitset), intent(in) :: this
    type(t_bitset), intent(in) :: other
    logical :: ret
    integer :: i
    ret = .false.
    do i = min(this%wiu,other%wiu)-1, 0, -1
      if (and(this%words(i),other%words(i)) /= 0_8) then
        ret = .true.
      end if
    end do
  end

  integer function cardinality(this)
    class(t_bitset), intent(in) :: this
    integer :: i
    cardinality = 0
    do i = 0, this%wiu-1
      cardinality = cardinality+popcnt(this%words(i))
    end do
  end

  function bitset_eq(this,other) result(ret)
    class(t_bitset), intent(in) :: this
    type(t_bitset), intent(in) :: other
    integer :: i
    logical :: ret
    ret = .false.
    if (this%wiu /= other%wiu) return
    do i = 0, this%wiu-1
      if (this%words(i) /= other%words(i)) return
    end do
    ret = .true.
  end

  subroutine bitset_and(this,other)
    class(t_bitset), intent(inout) :: this
    type(t_bitset), intent(in) :: other
    integer :: i
    if (bitset_eq(this,other)) return
    do while (this%wiu > other%wiu)
      this%wiu = this%wiu-1
      this%words(this%wiu) = 0_8
    end do
    do i = 0, this%wiu-1
      this%words(i) = and(this%words(i),other%words(i))
    end do
    call recalculate_wiu(this)
    call check_invariants(this)
  end

  subroutine bitset_or(this,other)
    class(t_bitset), intent(inout) :: this
    type(t_bitset), intent(in) :: other
    integer :: i, same
    if (bitset_eq(this,other)) return
    same = min(this%wiu,other%wiu)
    if (this%wiu < other%wiu) then
      call ensure_capacity(this,other%wiu)
      this%wiu = other%wiu
    end if
    do i = 0, same-1
      this%words(i) = or(this%words(i),other%words(i))
    end do
    if (same < other%wiu) then
      this%words(same:other%wiu-1) = other%words(same:other%wiu-1)
    end if
    call check_invariants(this)
  end

  subroutine bitset_xor(this,other)
    class(t_bitset), intent(inout) :: this
    type(t_bitset), intent(in) :: other
    integer :: i, same
    same = min(this%wiu,other%wiu)
    if (this%wiu < other%wiu) then
      call ensure_capacity(this,other%wiu)
      this%wiu = other%wiu
    end if
    do i = 0, same-1
      this%words(i) = xor(this%words(i),other%words(i))
    end do
    if (same < other%wiu) then
      this%words(same:other%wiu-1) = other%words(same:other%wiu-1)
    end if
    call recalculate_wiu(this)
    call check_invariants(this)
  end

  subroutine bitset_and_not(this,other)
    class(t_bitset), intent(inout) :: this
    type(t_bitset), intent(in) :: other
    integer :: i
    do i = min(this%wiu,other%wiu)-1, 0, -1
      this%words(i) = and(this%words(i),not(other%words(i)))
    end do
    call recalculate_wiu(this)
    call check_invariants(this)
  end

  function bitset_hashcode(this) result(ret)
    class(t_bitset), intent(in) :: this
    integer(8) :: h
    integer :: ret, i
    h = 1234_8
    do i = this%wiu-1, 0, -1
      h = xor(h,this%words(i)*int(i+1,8))
    end do
    ret = int(xor(lshift(h,32),h),4)
  end

  integer function size_of(this)
    class(t_bitset), intent(in) :: this
    size_of = size(this%words,1)*BITS_PER_WORD
  end
end module mod_bitset

program random_tournament
  use mod_bitset
  implicit none
  type(t_bitset) :: a(0:2000), dpl(0:2000), dpr(0:2000), tmp
  integer :: n, i, j, l, r
  character(2000) :: s
  read(*,*) n
  do i = 0, n-1
    call dpl(i)%set(i)
    call dpr(i)%set(i)
    if (i == 0) cycle
    read(*,*) s
    do j = 0, i-1
      call a(i)%set(j,val=s(j+1:j+1) == "1")
      call a(j)%set(i,val=s(j+1:j+1) == "0")
    end do
  end do
  do i = 1, n-1
    do l = 0, n-1-i
      r = l+i
      tmp = a(r)%subset(0,n)
      call tmp%and(dpl(l))
      call tmp%and(dpr(r-1))
      tmp = tmp%subset(l,r)
      call dpl(l)%set(r,val=.not.tmp%is_empty())
      tmp = a(l)%subset(0,n)
      call tmp%and(dpl(l+1))
      call tmp%and(dpr(r))
      tmp = tmp%subset(l+1,r+1)
      call dpr(r)%set(l,val=.not.tmp%is_empty())
    end do
  end do
  j = 0
  do i = 0, n-1
    if (dpl(0)%get(i) .and. dpr(n-1)%get(i)) j = j+1
  end do
  write(*,'(i0)') j
end program random_tournament