#:include "common.fypp"
submodule(stdlib_bitsets) stdlib_bitsets_64
implicit none
contains
elemental module function all_64( self ) result(all)
! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise.
logical :: all
class(bitset_64), intent(in) :: self
intrinsic :: btest
integer(bits_kind) :: pos
do pos=0, self % num_bits - 1
if ( .not. btest(self % block, pos) ) then
all = .false.
return
end if
end do
all = .true.
end function all_64
elemental module subroutine and_64(set1, set2)
!
! Sets the bits in SET1 to the bitwise AND of the original bits in SET1
! and SET2. It is required that SET1 have the same number of bits as
! SET2 otherwise the result is undefined.
!
type(bitset_64), intent(inout) :: set1
type(bitset_64), intent(in) :: set2
! The set2 extent includes the entire extent of set1.
! The (zeroed) region past the end of set1 is unaffected by
! the iand.
set1 % block = iand( set1 % block, &
set2 % block )
end subroutine and_64
elemental module subroutine and_not_64(set1, set2)
!
! Sets the bits in SET1 to the bitwise and of the original bits in SET1
! with the bitwise negation of SET2. SET1 and SET2 must have the same
! number of bits otherwise the result is undefined.
!
type(bitset_64), intent(inout) :: set1
type(bitset_64), intent(in) :: set2
! The not with iand means that the zero'ed regions past the end of each set
! do not interact with the in set regions
set1 % block = iand( set1 % block, not( set2 % block ) )
end subroutine and_not_64
elemental module function any_64(self) result(any)
! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise.
logical :: any
class(bitset_64), intent(in) :: self
if ( self % block /= 0 ) then
any = .true.
return
else
any = .false.
end if
end function any_64
#:for k1 in INT_KINDS
module subroutine assign_log${k1}$_64( self, logical_vector )
! Used to define assignment from an array of type logical for bitset_64
type(bitset_64), intent(out) :: self
logical(${k1}$), intent(in) :: logical_vector(:)
integer(bits_kind) :: log_size
integer(bits_kind) :: index
log_size = size( logical_vector, kind=bits_kind )
if ( log_size > 64 ) then
error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // &
"SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64."
end if
self % num_bits = log_size
self % block = 0
do index=0, log_size-1
if ( logical_vector(index+1) ) then
self % block = ibset( self % block, index )
end if
end do
end subroutine assign_log${k1}$_64
pure module subroutine log${k1}$_assign_64( logical_vector, set )
! Used to define assignment to an array of type logical for bitset_64
logical(${k1}$), intent(out), allocatable :: logical_vector(:)
type(bitset_64), intent(in) :: set
integer(bits_kind) :: index
allocate( logical_vector( set % num_bits ) )
do index=0, set % num_bits-1
if ( set % value( index ) == 1 ) then
logical_vector(index+1) = .true.
else
logical_vector(index+1) = .false.
end if
end do
end subroutine log${k1}$_assign_64
#:endfor
elemental module function bit_count_64(self) result(bit_count)
! Returns the number of non-zero bits in SELF.
integer(bits_kind) :: bit_count
class(bitset_64), intent(in) :: self
integer(bits_kind) :: pos
bit_count = 0
do pos = 0, self % num_bits - 1
if ( btest( self % block, pos ) ) bit_count = bit_count + 1
end do
end function bit_count_64
elemental module subroutine clear_bit_64(self, pos)
!
! Sets to zero the POS position in SELF. If POS is less than zero or
! greater than BITS(SELF)-1 it is ignored.
!
class(bitset_64), intent(inout) :: self
integer(bits_kind), intent(in) :: pos
if ( pos < 0 .OR. (pos > self % num_bits-1) ) &
return
self % block = ibclr( self % block, pos )
end subroutine clear_bit_64
pure module subroutine clear_range_64(self, start_pos, stop_pos)
!
! Sets to zero all bits from the START_POS to STOP_POS positions in SELF.
! If STOP_POS < START_POS then no bits are modified. Positions outside
! the range 0 to BITS(SELF)-1 are ignored.
!
class(bitset_64), intent(inout) :: self
integer(bits_kind), intent(in) :: start_pos, stop_pos
integer(bits_kind) :: true_first, true_last
true_first = max( 0_bits_kind, start_pos )
true_last = min( self % num_bits-1, stop_pos )
if ( true_last < true_first ) return
call mvbits( all_zeros, &
true_first, &
true_last - true_first + 1, &
self % block, &
true_first )
end subroutine clear_range_64
elemental module function eqv_64(set1, set2) result(eqv)
!
! Returns .TRUE. if all bits in SET1 and SET2 have the same value,
! .FALSE. otherwise. The sets must have the same number of bits
! otherwise the results are undefined.
!
logical :: eqv
type(bitset_64), intent(in) :: set1, set2
eqv = set1 % block == set2 % block
end function eqv_64
module subroutine extract_64(new, old, start_pos, stop_pos, status)
! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset
! OLD. If START_POS is greater than STOP_POS the new bitset is empty.
! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1
! then if STATUS is present it has the value INDEX_INVALID_ERROR,
! otherwise processing stops with an informative message.
type(bitset_64), intent(out) :: new
type(bitset_64), intent(in) :: old
integer(bits_kind), intent(in) :: start_pos, stop_pos
integer, intent(out), optional :: status
integer(bits_kind) :: bits, i, k
character(*), parameter :: procedure = 'EXTRACT'
if ( start_pos < 0 ) then
call error_handler( 'had a START_POS less than 0.', &
index_invalid_error, status, &
module_name, procedure )
return
end if
if ( stop_pos >= old % num_bits ) then
call error_handler( 'had a STOP_POS greater than BITS(OLD)-1.', &
index_invalid_error, status, &
module_name, procedure )
return
end if
bits = stop_pos - start_pos + 1
if ( bits <= 0 ) then
new % num_bits = 0
new % block = 0
return
else
new % num_bits = bits
do i=0, bits-1
k = start_pos + i
if ( btest( old % block, k ) ) &
new % block = ibset(new % block, i)
end do
end if
if ( present(status) ) status = success
end subroutine extract_64
elemental module subroutine flip_bit_64(self, pos)
!
! Flips the value at the POS position in SELF, provided the position is
! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is
! changed.
!
class(bitset_64), intent(inout) :: self
integer(bits_kind), intent(in) :: pos
if ( pos < 0 .OR. pos > self % num_bits-1 ) return
if ( btest( self % block, pos ) ) then
self % block = ibclr( self % block, pos )
else
self % block = ibset( self % block, pos )
end if
end subroutine flip_bit_64
pure module subroutine flip_range_64(self, start_pos, stop_pos)
!
! Flips all valid bits from the START_POS to the STOP_POS positions in
! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than
! 0 or greater than BITS(SELF)-1 are ignored.
!
class(bitset_64), intent(inout) :: self
integer(bits_kind), intent(in) :: start_pos, stop_pos
integer(bits_kind) :: end_bit, start_bit
start_bit = max( 0_bits_kind, start_pos )
end_bit = min( stop_pos , self % num_bits-1 )
call mvbits( not(self % block), &
start_bit, &
end_bit - start_bit + 1, &
self % block, &
start_bit )
end subroutine flip_range_64
module subroutine from_string_64(self, string, status)
! Initializes the bitset `self` treating `string` as a binary literal
! `status` may have the values:
! `success` - if no problems were found,
! `alloc_fault` - if allocation of the bitset failed
! `char_string_too_large_error` - if `string` was too large, or
! `char_string_invalid_error` - if string had an invalid character.
class(bitset_64), intent(out) :: self
character(*), intent(in) :: string
integer, intent(out), optional :: status
character(*), parameter :: procedure = 'FROM_STRING'
integer(int64) :: bit
integer(int64) :: bits
character(1) :: char
bits = len(string, kind=int64)
if ( bits > 64 ) then
call error_handler( 'STRING was too long for a ' // &
'BITSET_64 SELF.', &
char_string_too_large_error, status, &
module_name, procedure )
return
end if
self % num_bits = bits
do bit = 1, bits
char = string(bit:bit)
if ( char == '0' ) then
call self % clear( int(bits-bit, kind=bits_kind) )
else if ( char == '1' ) then
call self % set( int(bits-bit, kind=bits_kind) )
else
call error_handler( 'STRING had a character other than ' // &
'0 or 1.', &
char_string_invalid_error, status, &
module_name, procedure )
return
end if
end do
if ( present(status) ) status = success
end subroutine from_string_64
elemental module function ge_64(set1, set2) result(ge)
!
! Returns .TRUE. if the bits in SET1 and SET2 are the same or the
! highest order different bit is set to 1 in SET1 and to 0 in set2.
! .FALSE. otherwise. The sets must have the same number of bits
! otherwise the results are undefined.
!
logical :: ge
type(bitset_64), intent(in) :: set1, set2
ge = bge( set1 % block, set2 % block )
end function ge_64
elemental module function gt_64(set1, set2) result(gt)
!
! Returns .TRUE. if the bits in SET1 and SET2 differ and the
! highest order different bit is set to 1 in SET1 and to 0 in set2.
! .FALSE. otherwise. The sets must have the same number of bits
! otherwise the results are undefined.
!
logical :: gt
type(bitset_64), intent(in) :: set1, set2
gt = bgt( set1 % block, set2 % block )
end function gt_64
module subroutine init_zero_64(self, bits, status)
!
! Creates the bitset, `self`, of size `bits`, with all bits initialized to
! zero. `bits` must be non-negative. If an error occurs and `status` is
! absent then processing stops with an informative stop code. `status`
! will have one of the values:
! * `success` - if no problems were found,
! * `array_size_invalid_error` - if `bits` is either negative or larger
! than 64 with `self` of class `bitset_64`, or
! * `alloc_fault` - if memory allocation failed
!
class(bitset_64), intent(out) :: self
integer(bits_kind), intent(in) :: bits
integer, intent(out), optional :: status
character(*), parameter :: procedure = "INIT"
if ( bits < 0 ) then
call error_handler( 'BITS had a negative value.', &
array_size_invalid_error, status, &
module_name, procedure )
return
end if
if ( bits > 64 ) then
call error_handler( 'BITS had a value greater than 64.', &
array_size_invalid_error, status, &
module_name, procedure )
return
end if
self % num_bits = bits
self % block = all_zeros
if ( present(status) ) status = success
end subroutine init_zero_64
module subroutine input_64(self, unit, status)
!
! Reads the components of the bitset, `self`, from the unformatted I/O
! unit, `unit`, assuming that the components were written using `output`.
! If an error occurs and `status` is absent then processing stops with
! an informative stop code. `status` has one of the values:
! * `success` - if no problem was found
! * `alloc_fault` - if it failed during allocation of memory for `self`, or
! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative
! or greater than 64 for a `bitset_64` input.
! * `read_failure` - if it failed during the reads from `unit`
!
class(bitset_64), intent(out) :: self
integer, intent(in) :: unit
integer, intent(out), optional :: status
integer(bits_kind) :: bits
integer :: ierr
character(len=120) :: message
character(*), parameter :: procedure = 'INPUT'
integer :: stat
read(unit, iostat=ierr, iomsg=message) bits
if (ierr /= 0) then
call error_handler( 'Failure on a READ statement for UNIT.', &
read_failure, status, module_name, procedure )
return
end if
if ( bits < 0 ) then
call error_handler( 'BITS in UNIT had a negative value.', &
array_size_invalid_error, status, &
module_name, procedure )
return
end if
if ( bits > 64 ) then
call error_handler( 'BITS in UNIT had a value greater than 64.', &
array_size_invalid_error, status, &
module_name, procedure )
return
end if
call self % init(bits, stat)
if (stat /= success) then
call error_handler( 'Allocation failure for SELF.', &
alloc_fault, status, module_name, procedure )
return
end if
if (bits < 1) return
read(unit, iostat=ierr, iomsg=message) self % block
if (ierr /= 0) then
call error_handler( 'Failure on a READ statement for UNIT.', &
read_failure, status, module_name, procedure )
return
end if
if ( present(status) ) status = success
end subroutine input_64
elemental module function le_64(set1, set2) result(le)
!
! Returns .TRUE. if the bits in SET1 and SET2 are the same or the
! highest order different bit is set to 0 in SET1 and to 1 in set2.
! .FALSE. otherwise. The sets must have the same number of bits
! otherwise the results are undefined.
!
logical :: le
type(bitset_64), intent(in) :: set1, set2
le = ble( set1 % block, set2 % block )
end function le_64
elemental module function lt_64(set1, set2) result(lt)
!
! Returns .TRUE. if the bits in SET1 and SET2 differ and the
! highest order different bit is set to 0 in SET1 and to 1 in set2.
! .FALSE. otherwise. The sets must have the same number of bits
! otherwise the results are undefined.
!
logical :: lt
type(bitset_64), intent(in) :: set1, set2
lt = blt( set1 % block, set2 % block )
end function lt_64
elemental module function neqv_64(set1, set2) result(neqv)
!
! Returns .TRUE. if all bits in SET1 and SET2 have the same value,
! .FALSE. otherwise. The sets must have the same number of bits
! otherwise the results are undefined.
!
logical :: neqv
type(bitset_64), intent(in) :: set1, set2
neqv = set1 % block /= set2 % block
end function neqv_64
elemental module function none_64(self) result(none)
!
! Returns .TRUE. if none of the bits in SELF have the value 1.
!
logical :: none
class(bitset_64), intent(in) :: self
none = .true.
if (self % block /= 0) then
none = .false.
return
end if
end function none_64
elemental module subroutine not_64(self)
!
! Sets the bits in SELF to their logical complement
!
class(bitset_64), intent(inout) :: self
integer(bits_kind) :: bit
if ( self % num_bits == 0 ) return
do bit=0, self % num_bits - 1
if ( btest( self % block, bit ) ) then
self % block = ibclr( self % block, bit )
else
self % block = ibset( self % block, bit )
end if
end do
end subroutine not_64
elemental module subroutine or_64(set1, set2)
!
! Sets the bits in SET1 to the bitwise OR of the original bits in SET1
! and SET2. If SET1 has fewer bits than SET2 then the additional bits
! in SET2 are ignored. If SET1 has more bits than SET2, then the
! absent SET2 bits are treated as if present with zero value.
!
type(bitset_64), intent(inout) :: set1
type(bitset_64), intent(in) :: set2
if ( set1 % num_bits >= set2 % num_bits ) then
set1 % block = ior( set1 % block, &
set2 % block )
else
! The set1 extent ends before set2 => set2 bits must not affect bits in
! set1 beyond its extent => set those bits to zero while keeping proper
! values of other bits in set2
set1 % block = &
ior( set1 % block, &
ibits( set2 % block, &
0, &
set1 % num_bits ) )
end if
end subroutine or_64
module subroutine output_64(self, unit, status)
!
! Writes the components of the bitset, SELF, to the unformatted I/O
! unit, UNIT, in a unformatted sequence compatible with INPUT. If
! STATUS is absent an error results in an error stop with an
! informative stop code. If STATUS is present it has the default
! value of SUCCESS, or the value WRITE_FAILURE if the write failed.
!
class(bitset_64), intent(in) :: self
integer, intent(in) :: unit
integer, intent(out), optional :: status
integer :: ierr
character(len=120) :: message
character(*), parameter :: procedure = "OUTPUT"
write(unit, iostat=ierr, iomsg=message) self % num_bits
if (ierr /= 0) go to 999
if (self % num_bits < 1) return
write(unit, iostat=ierr, iomsg=message) self % block
if (ierr /= 0) go to 999
return
999 call error_handler( 'Failure on a WRITE statement for UNIT.', &
write_failure, status, module_name, procedure )
end subroutine output_64
module subroutine read_bitset_string_64(self, string, status)
!
! Uses the bitset literal in the default character `string`, to define
! the bitset, `self`. The literal may be preceded by an an arbitrary
! sequence of blank characters. If `status` is absent an error results
! in an error stop with an informative stop code. If `status`
! is present it has one of the values
! * `success` - if no problems occurred,
! * `alloc_fault` - if allocation of memory for SELF failed,
! * `array_size_invalid_error - if `bits(self)` in `string` is greater
! than 64 for a `bitset_64`,
! * `char_string_invalid_error` - if the bitset literal has an invalid
! character,
! * `char_string_too_small_error - if the string ends before all the bits
! are read.
! * `integer_overflow_error` - if the bitset literal has a `bits(self)`
! value too large to be represented,
!
class(bitset_64), intent(out) :: self
character(len=*), intent(in) :: string
integer, intent(out), optional :: status
integer(bits_kind) :: bit, bits
integer(bits_kind) :: digits, pos
character(*), parameter :: procedure = "READ_BITSET"
integer :: stat
pos = 1
find_start: do pos=1, len(string)
if ( string(pos:pos) /= ' ' ) exit
end do find_start
if ( pos > len(string) - 8 ) go to 999
if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999
pos = pos + 1
bits = 0
digits = 0
do
select case( iachar( string(pos:pos) ) )
case(ia0:ia9)
digits = digits + 1
if ( digits == max_digits .AND. bits > overflow_bits ) &
go to 996
if ( digits > max_digits ) go to 996
bits = bits*10 + iachar( string(pos:pos) ) - ia0
if ( bits < 0 ) go to 996
case(iachar('b'), iachar('B'))
exit
case default
go to 999
end select
pos = pos + 1
end do
if ( bits > 64 ) then
call error_handler( 'BITS in STRING was greater than 64.', &
char_string_too_large_error, status, &
module_name, procedure )
return
end if
if ( bits + pos > len(string) ) then
call error_handler( 'STRING was too small for the number of ' // &
'bits specified by STRING.', &
char_string_too_small_error, status, &
module_name, procedure )
return
end if
call self % init( bits, stat )
if (stat /= success) then
call error_handler( 'There was an allocation fault for SELF.', &
alloc_fault, status, module_name, procedure )
return
end if
pos = pos + 1
bit = bits - 1
do
if ( string(pos:pos) == '0' ) then
call self % clear( bit ) ! this may not be needed
else if ( string(pos:pos) == '1' ) then
call self % set( bit )
else
go to 999
end if
pos = pos + 1
bit = bit - 1
if ( bit < 0 ) exit
end do
if ( present(status) ) status = success
return
996 call error_handler( 'There was an integer overflow in reading' // &
'size of bitset literal from UNIT', &
integer_overflow_error, status, &
module_name, procedure )
return
999 call error_handler( 'There was an invalid character in STRING', &
char_string_invalid_error, status, &
module_name, procedure )
end subroutine read_bitset_string_64
module subroutine read_bitset_unit_64(self, unit, advance, status)
!
! Uses the bitset literal at the current position in the formatted
! file with I/O unit, `unit`, to define the bitset, `self`. The literal
! may be preceded by an arbitrary sequence of blank characters.
! If `advance` is present it must be either 'YES' or 'NO'. If absent
! it has the default value of 'YES' to determine whether advancing
! I/O occurs. If `status` is absent an error results in an error stop
! with an informative stop code. If `status` is present it has one of
! the values:
! * `success` - if no problem occurred,
! * `alloc_fault` - if allocation of `self` failed,
! * `array_size_invalid_error` - if `bits(self)` in the bitset literal
! is greater than 64 for a `bitset_64`.
! * `char_string_invalid_error` - if the read of the bitset literal found
! an invalid character,
! * `eof_failure` - if a `read` statement reaches an end-of-file before
! completing the read of the bitset literal,
! * `integer_overflow_error` - if the bitset literal has a `bits(self)`
! value too large to be represented,
! * `read_failure` - if a `read` statement fails,
!
class(bitset_64), intent(out) :: self
integer, intent(in) :: unit
character(*), intent(in), optional :: advance
integer, intent(out), optional :: status
integer(bits_kind) :: bit, bits, digits
integer :: ierr
character(len=128) :: message
character(*), parameter :: procedure = "READ_BITSET"
character(len=1) :: char
do
read( unit, &
advance='NO', &
FMT='(A1)', &
err=997, &
end=998, &
iostat=ierr, &
iomsg=message ) char
select case( char )
case( ' ' )
cycle
case( 's', 'S' )
exit
case default
go to 999
end select
end do
bits = 0
digits = 0
do
read( unit, &
advance='NO', &
FMT='(A1)', &
err=998, &
end=999, &
iostat=ierr, &
iomsg=message ) char
if ( char == 'b' .or. char == 'B' ) exit
select case( char )
case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' )
digits = digits + 1
if ( digits == max_digits .AND. bits > overflow_bits ) &
go to 996
if ( digits > max_digits ) go to 996
bits = 10*bits + iachar(char) - iachar('0')
if ( bits < 0 ) go to 996
case default
go to 999
end select
end do
if ( bits < 0 .OR. digits == 0 .OR. digits > max_digits ) go to 999
if ( bits > 64 ) then
call error_handler( 'BITS in UNIT was greater than 64.', &
array_size_invalid_error, status, &
module_name, procedure )
return
end if
call self % init( bits )
do bit = 1, bits-1
read( unit, &
advance='NO', &
FMT='(A1)', &
err=997, &
end=998, &
iostat=ierr, &
iomsg=message ) char
if ( char == '0' ) then
call self % clear( bits-bit )
else if ( char == '1' ) then
call self % set( bits-bit )
else
go to 999
end if
end do
read( unit, &
advance=optval(advance, 'YES'), &
FMT='(A1)', &
err=997, &
end=998, &
iostat=ierr, &
iomsg=message ) char
if ( char == '0' ) then
call self % clear( bits-bit )
else if ( char == '1' ) then
call self % set( bits-bit )
else
go to 999
end if
if ( present(status) ) status = success
return
996 call error_handler( 'Integer overflow in reading size of ' // &
'bitset literal from UNIT.', &
read_failure, status, module_name, procedure )
return
997 call error_handler( 'Failure on read of UNIT.', &
read_failure, status, module_name, procedure )
return
998 call error_handler( 'End of File of UNIT before finishing a ' // &
'bitset literal.', &
eof_failure, status, module_name, procedure )
return
999 call error_handler( 'Invalid character in bitset literal in UNIT ', &
char_string_invalid_error, status, &
module_name, procedure )
end subroutine read_bitset_unit_64
elemental module subroutine set_bit_64(self, pos)
!
! Sets the value at the POS position in SELF, provided the position is
! valid. If the position is less than 0 or greater than BITS(SELF)-1
! then SELF is unchanged.
!
class(bitset_64), intent(inout) :: self
integer(bits_kind), intent(in) :: pos
integer(block_kind) :: dummy
if ( pos < 0 .OR. pos > self % num_bits-1 ) return
dummy = ibset( self % block, pos )
self % block = dummy
end subroutine set_bit_64
pure module subroutine set_range_64(self, start_pos, stop_pos)
!
! Sets all valid bits to 1 from the START_POS to the STOP_POS positions
! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside
! the range 0 to BITS(SELF)-1 are ignored.
!
class(bitset_64), intent(inout) :: self
integer(bits_kind), intent(in) :: start_pos, stop_pos
integer(bits_kind) :: end_bit, start_bit
start_bit = max( 0_bits_kind, start_pos )
end_bit = min( stop_pos, self % num_bits-1 )
if ( end_bit < start_bit ) return
! FIRST and LAST are in the same block
call mvbits( all_ones, &
start_bit, &
end_bit - start_bit + 1, &
self % block, &
start_bit )
end subroutine set_range_64
elemental module function test_64(self, pos) result(test)
!
! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS
! is negative or greater than BITS(SELF) - 1 the result is .FALSE..
!
logical :: test
class(bitset_64), intent(in) :: self
integer(bits_kind), intent(in) :: pos
if ( pos < 0 .or. pos >= self % num_bits ) then
test = .false.
else
test = btest( self % block, pos )
end if
end function test_64
module subroutine to_string_64(self, string, status)
!
! Represents the value of SELF as a binary literal in STRING
! Status may have the values SUCCESS or ALLOC_FAULT
!
class(bitset_64), intent(in) :: self
character(len=:), allocatable, intent(out) :: string
integer, intent(out), optional :: status
character(*), parameter :: procedure = 'TO_STRING'
integer :: bit, bit_count, pos, stat
bit_count = self % num_bits
allocate( character(len=bit_count)::string, stat=stat )
if ( stat > 0 ) then
call error_handler( 'There was an allocation fault for STRING.', &
alloc_fault, status, module_name, procedure )
return
end if
do bit=0, bit_count-1
pos = bit_count - bit
if ( btest( self % block, bit ) ) then
string( pos:pos ) = '1'
else
string( pos:pos ) = '0'
end if
end do
if ( present(status) ) status = success
end subroutine to_string_64
elemental module function value_64(self, pos) result(value)
!
! Returns 1 if the POS position is set, 0 otherwise. If POS is negative
! or greater than BITS(SELF) - 1 the result is 0.
!
integer :: value
class(bitset_64), intent(in) :: self
integer(bits_kind), intent(in) :: pos
if ( pos < 0 .or. pos >= self % num_bits ) then
value = 0
else
if ( btest( self % block, pos ) ) then
value = 1
else
value = 0
end if
end if
end function value_64
module subroutine write_bitset_string_64(self, string, status)
!
! Writes a bitset literal to the allocatable default character STRING,
! representing the individual bit values in the bitset_t, SELF.
! If STATUS is absent an error results in an error stop with an
! informative stop code. If STATUS is present it has the default
! value of SUCCESS, or the value ALLOC_FAULT if allocation of
! the output string failed.
!
class(bitset_64), intent(in) :: self
character(len=:), allocatable, intent(out) :: string
integer, intent(out), optional :: status
integer(bits_kind) :: bit, &
bit_count, &
count_digits, &
pos
integer :: stat
character(*), parameter :: procedure = 'WRITE_BITSET'
bit_count = bits(self)
call digit_count( self % num_bits, count_digits )
allocate( character(len=count_digits+bit_count+2)::string, stat=stat )
if ( stat > 0 ) then
call error_handler( 'There was an allocation fault for STRING.', &
alloc_fault, status, module_name, procedure )
return
end if
write( string, "('S', i0)" ) self % num_bits
string( count_digits + 2:count_digits + 2 ) = "B"
do bit=0, bit_count-1
pos = count_digits + 2 + bit_count - bit
if ( btest( self % block, bit ) ) then
string( pos:pos ) = '1'
else
string( pos:pos ) = '0'
end if
end do
if ( present(status) ) status = success
contains
subroutine digit_count( bits, digits )
integer(bits_kind), intent(in) :: bits
integer(bits_kind), intent(out) :: digits
integer(bits_kind) :: factor
factor = bits
if ( factor <= 0 ) then
digits = 1
return
end if
do digits = 1, 127
factor = factor / 10
if ( factor == 0 ) return
end do
end subroutine digit_count
end subroutine write_bitset_string_64
module subroutine write_bitset_unit_64(self, unit, advance, status)
!
! Writes a bitset literal to the I/O unit, UNIT, representing the
! individual bit values in the bitset_t, SELF. By default or if
! ADVANCE is present with the value 'YES', advancing output is used.
! If ADVANCE is present with the value 'NO', then the current record
! is not advanced by the write. If STATUS is absent an error results
! in an error stop with an informative stop code. If STATUS is
! present it has the default value of SUCCESS, the value
! ALLOC_FAULT if allocation of the output string failed, or
! WRITE_FAILURE if the WRITE statement outputting the literal failed.
!
class(bitset_64), intent(in) :: self
integer, intent(in) :: unit
character(len=*), intent(in), optional :: advance
integer, intent(out), optional :: status
integer :: ierr
character(:), allocatable :: string
character(len=120) :: message
character(*), parameter :: procedure = "WRITE_BITSET"
call self % write_bitset(string, status)
if ( present(status) ) then
if (status /= success ) return
end if
write( unit, &
FMT='(A)', &
advance=optval(advance, 'YES'), &
iostat=ierr, &
iomsg=message ) &
string
if (ierr /= 0) then
call error_handler( 'Failure on a WRITE statement for UNIT.', &
write_failure, status, module_name, procedure )
return
endif
end subroutine write_bitset_unit_64
elemental module subroutine xor_64(set1, set2)
!
! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1
! and SET2. SET1 and SET2 must have the same number of bits otherwise
! the result is undefined.
!
type(bitset_64), intent(inout) :: set1
type(bitset_64), intent(in) :: set2
set1 % block = ieor( set1 % block, &
set2 % block )
end subroutine xor_64
end submodule stdlib_bitsets_64
