module mod_bitset
  implicit none
  integer, private, parameter :: address_bits_per_word = 6
  integer, private, parameter :: bits_per_word = lshift(1, address_bits_per_word)
  integer, private, parameter :: bit_index_mask = bits_per_word - 1
  integer(8), private, parameter :: word_mask = -1

  type t_bitset
    integer(8), private, allocatable :: words(:) ! 0-indexed, [start, end)
    integer, private :: words_in_use = 0
  contains
    procedure, private :: flip0
    procedure, private :: flip1
    generic :: flip => flip0, flip1
    procedure, private :: set0
    procedure, private :: set1
    procedure, private :: setval0
    procedure, private :: setval1
    generic :: set => set0, set1, setval0, setval1
    procedure, private :: clear0
    procedure, private :: clear1
    procedure, private :: clear2
    generic :: clear => clear0, clear1, clear2
    procedure, private :: get0
    procedure, private :: get1
    generic :: get => get0, get1
    procedure :: next_set_bit => next_set_bit
    procedure :: next_clear_bit => next_clear_bit
    procedure :: previous_set_bit => previous_set_bit
    procedure :: previous_clear_bit => previous_clear_bit
    procedure :: length => length
    procedure :: is_empty => is_empty
    procedure :: is_not_empty => is_not_empty
    procedure :: intersects => intersects
    procedure :: cardinality => cardinality
    procedure :: and => and0
    procedure :: or => or0
    procedure :: xor => xor0
    procedure :: and_not => and_not0
    procedure :: size => size0
  end type

  interface bitset
    module procedure :: newb0, newb3
  end interface bitset

  interface slshift
    module procedure :: slshift0, slshift1
  end interface slshift

  interface urshift
    module procedure :: urshift0, urshift1
  end interface urshift

contains

  integer function slshift0(i, n) result(res)
    integer, intent(in) :: i
    integer, intent(in) :: n
    integer :: m
    m = and(n, 31)
    res = lshift(i, m)
  end

  integer(8) function slshift1(i, n) result(res)
    integer(8), intent(in) :: i
    integer, intent(in) :: n
    integer :: m
    m = and(n, 63)
    res = lshift(i, m)
  end

  integer function urshift0(i, n) result(res)
    integer, intent(in) :: i
    integer, intent(in) :: n
    integer :: m
    m = and(n, 31)
    if (m == 0) then
      res = i
    else
      res = rshift(ibclr(rshift(i, 1), 31), m - 1)
    end if
  end

  integer(8) function urshift1(i, n) result(res)
    integer(8), intent(in) :: i
    integer, intent(in) :: n
    integer :: m
    m = and(n, 63)
    if (m == 0) then
      res = i
    else
      res = rshift(ibclr(rshift(i, 1), 63), m - 1)
    end if
  end

  integer function number_of_leading_zeros(i) result(res)
    integer(8), intent(in) :: i
    integer :: x
    if (i == 0) then
      res = 64
      return
    end if
    res = 1
    x = int(urshift(i, 32))
    if (x == 0) then
      res = res + 32
      x = int(i)
    end if
    if (urshift(x, 16) == 0) then
      res = res + 16
      x = lshift(x, 16)
    end if
    if (urshift(x, 24) == 0) then
      res = res + 8
      x = lshift(x, 8)
    end if
    if (urshift(x, 28) == 0) then
      res = res + 4
      x = lshift(x, 4)
    end if
    if (urshift(x, 30) == 0) then
      res = res + 2
      x = lshift(x, 2)
    end if
    res = res - urshift(x, 31)
  end

  integer function number_of_trailing_zeros(i) result(res)
    integer(8), intent(in) :: i
    integer :: x, y
    if (i == 0) then
      res = 64
      return
    end if
    res = 63
    y = int(i)
    if (y /= 0) then
      res = res - 32
      x = y
    else
      x = int(urshift(i, 32))
    end if
    y = lshift(x, 16)
    if (y /= 0) then
      res = res - 16
      x = y
    end if
    if (y /= 0) then
      res = res - 8
      x = y
    end if
    if (y /= 0) then
      res = res - 4
      x = y
    end if
    if (y /= 0) then
      res = res - 2
      x = y
    end if
    res = res - urshift(lshift(x, 1), 31)
  end

  integer function words_index(bit_index) result(res)
    integer, intent(in) :: bit_index
    res = rshift(bit_index, address_bits_per_word)
  end

  subroutine assert(flag, message)
    logical, intent(in) :: flag
    character(*), intent(in), optional :: message
    if (flag) return
    write(*,*) "*** Error occurred ***"
    if (present(message)) write(*,'(a)') message
    stop
  end

  subroutine check_invariants(this)
    type(t_bitset), intent(in) :: this
    integer :: u, n
    u = this%words_in_use
    n = size(this%words)
    if (u /= 0) call assert(this%words(u - 1) /= 0, "At check_invariants() (1)")
    call assert(u >= 0 .and. u <= n, "At check_invariants() (2)")
    if (u /= n) call assert(this%words(u) == 0, "At check_invariants() (3)")
  end

  subroutine recalculate_words_in_use(this)
    type(t_bitset), intent(inout) :: this
    integer :: i
    do i = this%words_in_use - 1, 0, -1
      if (this%words(i) /= 0) then
        this%words_in_use = i + 1
        return
      end if
    end do
    this%words_in_use = 0
  end

  subroutine init_words(this, nbits)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: nbits
    if (allocated(this%words)) deallocate(this%words)
    allocate(this%words(0:words_index(nbits - 1)))
    this%words = 0
  end

  type(t_bitset) function newb0() result(res)
    call init_words(res, bits_per_word)
  end

  type(t_bitset) function newb1(nbits) result(res)
    integer, intent(in) :: nbits
    call assert(nbits >= 0, "nbits < 0 at newb1()")
    call init_words(res, nbits)
  end

  type(t_bitset) function newb2(words) result(res)
    integer(8), intent(in) :: words(:)
    allocate(res%words(0:size(words) - 1))
    res%words = words
    res%words_in_use = size(words)
    call check_invariants(res)
  end

  type(t_bitset) function newb3(longs) result(res)
    integer(8), intent(in) :: longs(:)
    integer :: i
    do i = size(longs), 1, -1
      if (longs(i) /= 0) then
        res = newb2(longs(1:i))
        return
      end if
    end do
    res = newb0()
  end

  subroutine ensure_capacity(this, words_required)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: words_required
    integer :: request
    integer(8), allocatable :: copy(:)
    if (size(this%words) >= words_required) return
    request = max(2 * size(this%words), words_required)
    allocate(copy(size(this%words)))
    copy = this%words
    deallocate(this%words)
    allocate(this%words(0:request - 1))
    this%words = 0
    this%words(0:size(copy) - 1) = copy
  end

  subroutine expand_to(this, word_index)
    type(t_bitset), intent(inout) :: this
    integer, intent(in) :: word_index
    integer :: words_required
    words_required = word_index + 1
    if (this%words_in_use < words_required) then
      call ensure_capacity(this, words_required)
      this%words_in_use = words_required
    end if
  end

  subroutine check_range(from_index, to_index)
    integer, intent(in) :: from_index, to_index
    call assert(0 <= from_index .and. from_index <= to_index, "At check_range()")
  end

  subroutine flip0(this, bit_index)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: bit_index
    integer :: word_index
    call assert(bit_index >= 0, "bit_index < 0 at flip0()")
    word_index = words_index(bit_index)
    call expand_to(this, word_index)
    this%words(word_index) = xor(this%words(word_index), slshift(1_8, bit_index))
    call recalculate_words_in_use(this)
    call check_invariants(this)
  end

  subroutine flip1(this, from_index, to_index)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: from_index, to_index
    integer :: start_word_index, end_word_index, idx
    integer(8) :: first_word_mask, last_word_mask

    call check_range(from_index, to_index)
    if (from_index == to_index) return

    start_word_index = words_index(from_index)
    end_word_index = words_index(to_index - 1)
    call expand_to(this, end_word_index)

    first_word_mask = slshift(word_mask, from_index)
    last_word_mask = urshift(word_mask, -to_index)
    if (start_word_index == end_word_index) then
      idx = start_word_index
      this%words(idx) = xor(this%words(idx), and(first_word_mask, last_word_mask))
    else
      idx = start_word_index
      this%words(idx) = xor(this%words(idx), first_word_mask)

      do idx = start_word_index + 1, end_word_index - 1
        this%words(idx) = xor(this%words(idx), word_mask)
      end do

      idx = end_word_index
      this%words(idx) = xor(this%words(idx), last_word_mask)
    end if

    call recalculate_words_in_use(this)
    call check_invariants(this)
  end

  subroutine set0(this, bit_index)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: bit_index
    integer :: word_index
    call assert(bit_index >= 0, "bit_index < 0 at set0()")
    word_index = words_index(bit_index)
    call expand_to(this, word_index)
    this%words(word_index) = or(this%words(word_index), slshift(1_8, bit_index))
    call check_invariants(this)
  end

  subroutine clear0(this, bit_index)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: bit_index
    integer :: word_index
    call assert(bit_index >= 0, "bit_index < 0 at clear0()")
    word_index = words_index(bit_index)
    if (word_index >= this%words_in_use) return
    this%words(word_index) = and(this%words(word_index), not(slshift(1_8, bit_index)))
    call recalculate_words_in_use(this)
    call check_invariants(this)
  end

  subroutine setval0(this, bit_index, val)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: bit_index
    logical, intent(in) :: val
    if (val) then
      call set0(this, bit_index)
    else
      call clear0(this, bit_index)
    end if
  end

  subroutine set1(this, from_index, to_index)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: from_index, to_index
    integer :: start_word_index, end_word_index, idx
    integer(8) :: first_word_mask, last_word_mask

    call check_range(from_index, to_index)
    if (from_index == to_index) return

    start_word_index = words_index(from_index)
    end_word_index = words_index(to_index - 1)
    call expand_to(this, end_word_index)

    first_word_mask = slshift(word_mask, from_index)
    last_word_mask = urshift(word_mask, -to_index)
    if (start_word_index == end_word_index) then
      idx = start_word_index
      this%words(idx) = or(this%words(idx), and(first_word_mask, last_word_mask))
    else
      idx = start_word_index
      this%words(idx) = or(this%words(idx), first_word_mask)

      do idx = start_word_index + 1, end_word_index - 1
        this%words(idx) = word_mask
      end do

      idx = end_word_index
      this%words(idx) = or(this%words(idx), last_word_mask)
    end if

    call check_invariants(this)
  end

  subroutine clear1(this, from_index, to_index_)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: from_index, to_index_
    integer :: to_index
    integer :: start_word_index, end_word_index, idx
    integer(8) :: first_word_mask, last_word_mask
    to_index = to_index_

    call check_range(from_index, to_index)
    if (from_index == to_index) return

    start_word_index = words_index(from_index)
    if (start_word_index >= this%words_in_use) return

    end_word_index = words_index(to_index - 1)
    if (end_word_index >= this%words_in_use) then
      to_index = length(this)
      end_word_index = this%words_in_use - 1
    end if

    first_word_mask = slshift(word_mask, from_index)
    last_word_mask = urshift(word_mask, -to_index)
    if (start_word_index == end_word_index) then
      idx = start_word_index
      this%words(idx) = and(this%words(idx), not(and(first_word_mask, last_word_mask)))
    else
      idx = start_word_index
      this%words(idx) = and(this%words(idx), not(first_word_mask))

      do idx = start_word_index + 1, end_word_index - 1
        this%words(idx) = 0
      end do

      idx = end_word_index
      this%words(idx) = and(this%words(idx), not(last_word_mask))
    end if

    call recalculate_words_in_use(this)
    call check_invariants(this)
  end

  subroutine setval1(this, from_index, to_index, val)
    class(t_bitset), intent(inout) :: this
    integer, intent(in) :: from_index, to_index
    logical, intent(in) :: val
    if (val) then
      call set1(this, from_index, to_index)
    else
      call clear1(this, from_index, to_index)
    end if
  end

  subroutine clear2(this)
    class(t_bitset), intent(out) :: this
    this%words(0:this%words_in_use - 1) = 0
    this%words_in_use = 0
  end

  logical function get0(this, bit_index) result(res)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: bit_index
    integer :: word_index
    call assert(bit_index >= 0, "bit_index < 0 at get0()")
    call check_invariants(this)
    word_index = words_index(bit_index)
    if (word_index >= this%words_in_use) then
      res = .false.
      return
    end if
    res = and(this%words(word_index), slshift(1_8, bit_index)) /= 0
  end

  type(t_bitset) function get1(this, from_index, to_index_) result(res)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: from_index, to_index_
    integer :: to_index, len
    integer :: target_words, source_index, idx
    logical :: word_aligned
    integer(8) :: last_word_mask
    to_index = to_index_

    call check_range(from_index, to_index)
    call check_invariants(this)
    len = length(this)
    if (len <= from_index .or. from_index == to_index) then
      res = newb0()
      return
    end if

    if (to_index > len) to_index = len
    res = newb1(to_index - from_index)
    target_words = words_index(to_index - from_index - 1) + 1
    source_index = words_index(from_index)
    word_aligned = and(from_index, bit_index_mask) == 0

    do idx = 0, target_words - 2
      if (word_aligned) then
        res%words(idx) = this%words(source_index)
      else
        res%words(idx) = or(urshift(this%words(source_index), from_index), slshift(this%words(source_index + 1), -from_index))
      end if
      source_index = source_index + 1
    end do

    last_word_mask = urshift(word_mask, -to_index)
    if (and(to_index - 1, bit_index_mask) < and(from_index, bit_index_mask)) then
      res%words(target_words - 1) = or(urshift(this%words(source_index), from_index), &
        slshift(and(this%words(source_index + 1), last_word_mask), -from_index))
    else
      res%words(target_words - 1) = urshift(and(this%words(source_index), last_word_mask), from_index)
    end if

    res%words_in_use = target_words
    call recalculate_words_in_use(res)
    call check_invariants(res)
  end

  integer function next_set_bit(this, from_index) result(res)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: from_index
    integer :: u
    integer(8) :: word
    call assert(from_index >= 0, "from_index < 0 at next_set_bit()")
    call check_invariants(this)
    u = words_index(from_index)
    if (u >= this%words_in_use) then
      res = -1
      return
    end if
    word = and(this%words(u), slshift(word_mask, from_index))
    do
      if (word /= 0) then
        res = (u * bits_per_word) + number_of_trailing_zeros(word)
        return
      end if
      u = u + 1
      if (u == this%words_in_use) then
        res = -1
        return
      end if
      word = this%words(u)
    end do
  end

  integer function next_clear_bit(this, from_index) result(res)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: from_index
    integer :: u
    integer(8) :: word
    call assert(from_index >= 0, "from_index < 0 at next_clear_bit()")
    call check_invariants(this)
    u = words_index(from_index)
    if (u >= this%words_in_use) then
      res = from_index
      return
    end if
    word = and(not(this%words(u)), slshift(word_mask, from_index))
    do
      if (word /= 0) then
        res = (u * bits_per_word) + number_of_trailing_zeros(word)
        return
      end if
      u = u + 1
      if (u == this%words_in_use) then
        res = this%words_in_use * bits_per_word
        return
      end if
      word = not(this%words(u))
    end do
  end

  integer function previous_set_bit(this, from_index) result(res)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: from_index
    integer :: u
    integer(8) :: word
    if (from_index < 0) then
      call assert(from_index == -1, "from_index < -1 at previous_set_bit()")
      res = -1
      return
    end if
    call check_invariants(this)
    u = words_index(from_index)
    if (u >= this%words_in_use) then
      res = length(this) - 1
      return
    end if
    word = and(this%words(u), urshift(word_mask, -(from_index + 1)))
    do
      if (word /= 0) then
        res = (u + 1) * bits_per_word - 1 - number_of_leading_zeros(word)
        return
      end if
      if (u == 0) then
        res = -1
        return
      end if
      u = u - 1
      word = this%words(u)
    end do
  end

  integer function previous_clear_bit(this, from_index) result(res)
    class(t_bitset), intent(in) :: this
    integer, intent(in) :: from_index
    integer :: u
    integer(8) :: word
    if (from_index < 0) then
      call assert(from_index == -1, "from_index < -1 at previous_clear_bit()")
      res = -1
      return
    end if
    call check_invariants(this)
    u = words_index(from_index)
    if (u >= this%words_in_use) then
      res = from_index
      return
    end if
    word = and(not(this%words(u)), urshift(word_mask, -(from_index + 1)))
    do
      if (word /= 0) then
        res = (u + 1) * bits_per_word - 1 - number_of_leading_zeros(word)
        return
      end if
      if (u == 0) then
        res = -1
        return
      end if
      u = u - 1
      word = not(this%words(u))
    end do
  end

  integer function length(this) result(res)
    class(t_bitset), intent(in) :: this
    integer :: u, n
    u = this%words_in_use
    if (u == 0) then
      res = 0
    else
      n = number_of_leading_zeros(this%words(u - 1))
      res = bits_per_word * (u - 1) + (bits_per_word - n)
    end if
  end

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

  logical function is_not_empty(this) result(res)
    class(t_bitset), intent(in) :: this
    res = this%words_in_use > 0
  end

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

  integer function cardinality(this) result(res)
    class(t_bitset), intent(in) :: this
    res = sum(popcnt(this%words(0:this%words_in_use - 1)))
  end

  subroutine and0(this, other)
    class(t_bitset), intent(inout) :: this
    type(t_bitset), intent(in) :: other
    integer :: i
    do while (this%words_in_use > other%words_in_use)
      this%words_in_use = this%words_in_use - 1
      this%words(this%words_in_use) = 0
    end do
    do i = 0, this%words_in_use - 1
      this%words(i) = and(this%words(i), other%words(i))
    end do
    call recalculate_words_in_use(this)
    call check_invariants(this)
  end

  subroutine or0(this, other)
    class(t_bitset), intent(inout) :: this
    type(t_bitset), intent(in) :: other
    integer :: u, i
    u = min(this%words_in_use, other%words_in_use)
    do i = 0, u - 1
      this%words(i) = or(this%words(i), other%words(i))
    end do
    if (u < other%words_in_use) then
      call ensure_capacity(this, other%words_in_use)
      this%words_in_use = other%words_in_use
      this%words(u:this%words_in_use - 1) = other%words(u:other%words_in_use - 1)
    end if
    call check_invariants(this)
  end

  subroutine xor0(this, other)
    class(t_bitset), intent(inout) :: this
    type(t_bitset), intent(in) :: other
    integer :: u, i
    u = min(this%words_in_use, other%words_in_use)
    do i = 0, u - 1
      this%words(i) = xor(this%words(i), other%words(i))
    end do
    if (u < other%words_in_use) then
      call ensure_capacity(this, other%words_in_use)
      this%words_in_use = other%words_in_use
      this%words(u:this%words_in_use - 1) = other%words(u:other%words_in_use - 1)
    end if
    call recalculate_words_in_use(this)
    call check_invariants(this)
  end

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

  integer function size0(this) result(res)
    class(t_bitset), intent(in) :: this
    res = size(this%words) * 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
    a(i) = bitset()
    dpl(i) = bitset()
    dpr(i) = bitset()
    call dpl(i)%set(i)
    call dpr(i)%set(i)
  end do
  do i = 1, n - 1
    read(*,'(a)') s
    do j = 0, i - 1
      call a(i)%set(j, s(j + 1:j + 1) == '1')
      call a(j)%set(i, s(j + 1:j + 1) == '0')
    end do
  end do
  do i = 1, n - 1
    do l = 0, n - i - 1
      r = l + i
      tmp = a(r)%get(0, n)
      call tmp%and(dpl(l))
      call tmp%and(dpr(r - 1))
      tmp = tmp%get(l, r)
      call dpl(l)%set(r, tmp%is_not_empty())
      tmp = a(l)%get(0, n)
      call tmp%and(dpl(l + 1))
      call tmp%and(dpr(r))
      tmp = tmp%get(l + 1, r + 1)
      call dpr(r)%set(l, tmp%is_not_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

Measured memory_bytes: 5104