diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml index 39f79e394..2c2e1b12a 100644 --- a/.github/workflows/CI.yml +++ b/.github/workflows/CI.yml @@ -21,7 +21,7 @@ jobs: fail-fast: false matrix: os: [ubuntu-latest, macos-latest] - gcc_v: [7, 8, 9] # Version of GFortran we want to use. + gcc_v: [7, 8, 9, 10] # Version of GFortran we want to use. env: FC: gfortran-${{ matrix.gcc_v }} GCC_V: ${{ matrix.gcc_v }} @@ -54,7 +54,9 @@ jobs: - name: Install GFortran macOS if: contains( matrix.os, 'macos') - run: brew install gcc@${GCC_V} || brew upgrade gcc@${GCC_V} || true + run: | + brew install gcc@${GCC_V} || brew upgrade gcc@${GCC_V} || true + brew link gcc@${GCC_V} - name: Configure with CMake run: cmake -Wdev -DCMAKE_BUILD_TYPE=Release -DCMAKE_MAXIMUM_RANK=4 -S . -B build @@ -71,15 +73,71 @@ jobs: working-directory: build - name: Test in-tree builds - if: contains( matrix.gcc_v, '9') # Only test one compiler on each platform + if: contains( matrix.gcc_v, '10') # Only test one compiler on each platform run: | cmake -DCMAKE_MAXIMUM_RANK=4 . cmake --build . cmake --build . --target test - name: Test manual makefiles - if: contains(matrix.os, 'ubuntu') && contains(matrix.gcc_v, '9') + if: contains(matrix.os, 'ubuntu') && contains(matrix.gcc_v, '10') run: | make -f Makefile.manual FYPPFLAGS="-DMAXRANK=4" make -f Makefile.manual test make -f Makefile.manual clean + + intel-build: + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-20.04] + fc: [ifort] + env: + FC: ${{ matrix.fc }} + + steps: + - name: Checkout code + uses: actions/checkout@v1 + + - name: Set up Python 3.x + uses: actions/setup-python@v1 + with: + python-version: 3.x + + - name: Install CMake Linux + if: contains(matrix.os, 'ubuntu') + run: ci/install_cmake.sh + + - name: Add Intel repository + if: contains(matrix.os, 'ubuntu') + run: | + wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB + sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB + rm GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB + echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list + sudo apt-get update + + - name: Install Intel oneAPI compiler + if: contains(matrix.os, 'ubuntu') + run: | + sudo apt-get install intel-oneapi-compiler-fortran + source /opt/intel/oneapi/setvars.sh + printenv >> $GITHUB_ENV + + - name: Install fypp + run: pip install --upgrade fypp + + - name: Configure with CMake + run: cmake -Wdev -DCMAKE_BUILD_TYPE=Release -DCMAKE_MAXIMUM_RANK=4 -S . -B build + + - name: Build and compile + run: cmake --build build + + - name: catch build fail + run: cmake --build build --verbose --parallel 1 + if: failure() + + - name: test + run: ctest --parallel --output-on-failure + working-directory: build diff --git a/.github/workflows/ci_windows.yml b/.github/workflows/ci_windows.yml index d8b7d4b8a..bb6a23fd5 100644 --- a/.github/workflows/ci_windows.yml +++ b/.github/workflows/ci_windows.yml @@ -41,3 +41,82 @@ jobs: with: name: WindowsCMakeTestlog path: build/Testing/Temporary/LastTest.log + + msys2-build: + runs-on: windows-latest + strategy: + fail-fast: false + matrix: + include: [ + { msystem: MSYS, arch: x86_64 }, + { msystem: MINGW64, arch: x86_64 }, + { msystem: MINGW32, arch: i686 } + ] + defaults: + run: + shell: msys2 {0} + steps: + - uses: actions/checkout@v2 + + - name: Setup MinGW native environment + uses: msys2/setup-msys2@v2 + if: contains(matrix.msystem, 'MINGW') + with: + msystem: ${{ matrix.msystem }} + update: false + install: >- + git + mingw-w64-${{ matrix.arch }}-gcc + mingw-w64-${{ matrix.arch }}-gcc-fortran + mingw-w64-${{ matrix.arch }}-python + mingw-w64-${{ matrix.arch }}-python-pip + mingw-w64-${{ matrix.arch }}-cmake + mingw-w64-${{ matrix.arch }}-ninja + + - name: Setup msys POSIX environment + uses: msys2/setup-msys2@v2 + if: contains(matrix.msystem, 'MSYS') + with: + msystem: MSYS + update: false + install: >- + git + gcc + gcc-fortran + python + python-pip + cmake + ninja + + - name: Install fypp + run: pip install fypp + + - run: >- + cmake -G Ninja + -DCMAKE_SH="CMAKE_SH-NOTFOUND" + -Wdev + -B build + -DCMAKE_BUILD_TYPE=Debug + -DCMAKE_Fortran_FLAGS_DEBUG="-Wall -Wextra -Wimplicit-interface -fPIC -g -fcheck=all -fbacktrace" + -DCMAKE_MAXIMUM_RANK=4 + env: + FC: gfortran + CC: gcc + CXX: g++ + + - name: CMake build + run: cmake --build build --parallel + + - name: catch build fail + run: cmake --build build --verbose --parallel 1 + if: failure() + + - name: CTest + run: ctest --output-on-failure --parallel -V -LE quadruple_precision + working-directory: build + + - uses: actions/upload-artifact@v1 + if: failure() + with: + name: WindowsCMakeTestlog + path: build/Testing/Temporary/LastTest.log diff --git a/.github/workflows/doc-deployment.yml b/.github/workflows/doc-deployment.yml index 6c8c25aa6..69fc1dec8 100644 --- a/.github/workflows/doc-deployment.yml +++ b/.github/workflows/doc-deployment.yml @@ -20,24 +20,29 @@ env: jobs: Build-API-Docs: runs-on: macos-latest + env: + GCC_V: 10 steps: - uses: actions/checkout@v2 with: fetch-depth: 0 # Full history to get tag and commit info - name: Install GFortran macOS - run: brew install gcc || brew upgrade gcc || true + run: | + brew install gcc@${GCC_V} || brew upgrade gcc@${GCC_V} || true + brew link gcc@${GCC_V} + gfortran-${GCC_V} --version - name: Install Dependencies run: | pip3 install --prefer-binary --no-clean --disable-pip-version-check --progress-bar off lxml fypp brew install -f --force-bottle --keep-tmp ford type -a ford ford --version - gfortran --version + gfortran-${GCC_V} --version - name: Skip graph and search unless deploying if: github.ref != 'refs/heads/master' && ! startsWith( github.ref, 'refs/tags/' ) run: | sed -i .bak 's/^[[:blank:]]*graph: *[Tt]rue/graph: false/' "${FORD_FILE}" - echo "::set-env name=MAYBE_SKIP_SEARCH::--no-search" + echo "MAYBE_SKIP_SEARCH=--no-search" >> $GITHUB_ENV - name: Build Docs run: | git fetch --all --tags diff --git a/README.md b/README.md index 90b3451ae..1931149e5 100644 --- a/README.md +++ b/README.md @@ -66,6 +66,25 @@ Alternatively, you can build using provided Makefiles: make -f Makefile.manual ``` +## Limiting the maximum rank of generated procedures + +Stdlib's preprocessor (fypp) by default generates specific procedures for arrays of all ranks, up to rank 15. +This can result in long compilation times and, on some computers, exceeding available memory. +If you know that you won't need all 15 ranks, you can specify the maximum rank for which the specific procedures will be generated. +For example, with CMake: + +```sh +cmake -B build -DCMAKE_MAXIMUM_RANK=4 +cmake --build build +cmake --build build --target test +``` +or as follows with `make`: + +```sh +make -f Makefile.manual FYPPFLAGS=-DMAXRANK=4 +``` +Note that currently the minimum value for maximum rank is 4. + ## Documentation Documentation is a work in progress (see issue #4) but is currently available at https://stdlib.fortran-lang.org. diff --git a/doc/specs/index.md b/doc/specs/index.md index a827b392c..91dbc3099 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -11,9 +11,11 @@ This is and index/directory of the specifications (specs) for each new module/fe ## Experimental Features & Modules + - [bitsets](./stdlib_bitsets.html) - Bitset data types and procedures - [error](./stdlib_error.html) - Catching and handling errors - [IO](./stdlib_io.html) - Input/output helper & convenience - [linalg](./stdlib_linalg.html) - Linear Algebra + - [logger](./stdlib_logger.html) - Runtime logging system - [optval](./stdlib_optval.html) - Fallback value for optional arguments - [quadrature](./stdlib_quadrature.html) - Numerical integration - [stats](./stdlib_stats.html) - Descriptive Statistics diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md new file mode 100644 index 000000000..ca9d517d5 --- /dev/null +++ b/doc/specs/stdlib_bitsets.md @@ -0,0 +1,2005 @@ +--- +title: Bitsets +--- + +# The `stdlib_bitsets` module + +[TOC] + +## Introduction + +The `stdlib_bitsets` module implements bitset types. A bitset is a +compact representation of a sequence of `bits` binary values. It can +equivalently be considered as a sequence of logical values or as a +subset of the integers 0 ... `bits-1`. For example, the value `1110` +can be considered as defining the subset of integers [1, 2, 3]. +The bits are indexed from 0 to `bits(bitset)-1`. +A bitset is used when space savings are critical in applications +that require a large number of closely related logical values. +It may also improve performance by reducing memory traffic. To +implement bitsets the module +defines three bitset types, multiple constants, a character string +literal that can be read to and from strings and formatted files, a +simple character string literal that can be read to and from strings, +assignments, procedures, methods, and operators. Note that the module +assumes two's complement integers, but all current Fortran 95 and later +processors use such integers. + +Note that the module defines a number of "binary" procedures, +procedures with two bitset arguments. These arguments must be of the +same type and should have the same number of `bits`. For reasons of +performance the module does not enforce the `bits` constraint, but +failure to obey that constraint results in undefined behavior. This +undefined behavior includes undefined values for those bits that +exceed the defined number of `bits` in the smaller bitset. The +undefined behavior may also include a "segmentation fault" for +attempting to address bits in the smaller bitset, beyond the defined +number of `bits`. Other problems are also possible. + + +## The module's constants + +The module defines several public integer constants, almost all +intended to serve as error codes in reporting problems through an +optional `stat` argument. One constant, `bits_kind` is +the integer kind value for indexing bits and reporting counts of +bits. The other constants that are error codes are summarized below: + +|Error Code|Summary| +|----------|-------| +|`success`|No problems found| +|`alloc_fault`|Failure with a memory allocation| +|`array_size_invalid_error`|Attempt to define either negative bits or more than 64 bits in a `bitset_64`| +|`char_string_invalid_error`|Invalid character found in a character string| +|`char_string_too_large_error`|Character string was too large to be encoded in the bitset| +|`char_string_too_small_error`|Character string was too small to hold the expected number of bits| +|`index_invalid_error`|Index to a bitstring was less than zero or greater than the number of bits| +|`integer_overflow_error`|Attempt to define an integer value bigger than `huge(0_bits_kind)`| +|`read_failure`|Failure on a `read` statement| +|`eof_failure`|An unexpected "End-of-File" on a `read` statement| +|`write_failure`|Failure on a `write` statement| + + +## The `stdlib_bitsets` derived types + +The `stdlib_bitsets` module defines three derived types, +`bitset_type`, `bitset_64`, and `bitset_large`. `bitset_type` is an abstract +type that serves as the ancestor of `bitset_64` and +`bitset_large`. `bitset_type` defines one method, `bits`, and all of its +other methods are deferred to its extensions. `bitset_64` is a bitset +that can handle up to 64 bits. `bitset_large` is a bitset that can handle +up `huge(0_bits_kind)` bits. All attributes of the bitset types are +private. The various types each define a sequence of binary values: 0 +or 1. In some cases it is useful to associate a logical value, `test`, +for each element of the sequence, where `test` is `.true.` if the value +is 1 and `.false.` otherwise. The number of such values in an entity +of that type is to be termed, `bits`. The bits are ordered in terms of +position, that, in turn, is indexed from 0 to `bits-1`. `bitset_type` is +used only as a `class` to define entities that can be either a `bitset_64` or +a `bitset_large`. The syntax for using the types are: + +`class([[stdlib_bitsets(module):bitset_type(type)]]) :: variable` + +`type([[stdlib_bitsets(module):bitset_64(type)]]) :: variable` + +and + +`type([[stdlib_bitsets(module):bitset_large(type)]]) :: variable` + +## The *bitset-literal* + +A bitset value may be represented as a *bitset-literal-constant* +character string in source code or as a *bitset-literal* in +formatted files and non-constant strings. + +*bitset-literal-constant* is ' *bitset-literal* ' + or " *bitset-literal* " + +*bitset-literal* is *bitsize-literal* *binary-literal* + +*bitsize-literal* is S *digit* [ *digit* ] ... + +*binary-literal* is B *binary-digit* [ *binary-digit* ] ... + +*digit* is 0 + or 1 + or 2 + or 3 + or 4 + or 5 + or 6 + or 7 + or 8 + or 9 + + +*binary-digit* is 0 + or 1 + +The *bitset-literal* consists of two parts: a *bitsize-literal* and a +*binary-literal*. The sequence of decimal digits that is part of the +*bitsize-literal* is interpreted as the decimal value of `bits`. +The *binary-literal* value is interpreted as a sequence of bit +values and there must be as many binary digits in the literal as there +are `bits`. The sequence of binary digits are treated as if they were +an unsigned integer with the i-th digit corresponding to the `bits-i` +bit position. + +## The *binary-literal* + +In defining the *bitset-literal* we also defined a +*binary-literal*. While not suitable for file I/0, the +*binary-literal* is suitable for transfer to and from character +strings. In that case the length of the string is the number of bits +and all characters in the string must be either "0" or "1". + +## Summary of the module's operations + +The `stdlib_bitsets` module defines a number of operations: + +* "unary" methods of class `bitset_type`, +* "binary" procedure overloads of type `bitset_64` or `bitset_large`, +* assignments, and +* "binary" comparison operators of type `bitset_64` or `bitset_large`. + +Each category will be discussed separately. + +### Table of the `bitset_type` methods + +The `bitset_type` class has a number of methods. All except one, `bits`, +are deferred. The methods consist of all procedures with one argument +of class `bitset_type`. The procedures with two arguments of type +`bitset_64` or `bitset_large` are not methods and are +summarized in a separate table of procedures. The methods are +summarized below: + +|Method name|Class|Summary| +|-----------|-----|-------| +|`all`|function|`.true.` if all bits are 1, `.false.` otherwise| +|`any`|function|`.true.` if any bits are 1, `.false.` otherwise| +|`bit_count`|function|returns the number of bits that are 1| +|`bits`|function|returns the number of bits in the bitset| +|`clear`|subroutine|sets a sequence of one or more bits to 0| +|`flip`|subroutine|flips the value of a sequence of one or more bits| +|`from_string`|subroutine|reads the bitset from a string treating it as a binary literal| +|`init`|subroutine|creates a new bitset of size `bits` with no bits set| +|`input`|subroutine|reads a bitset from an unformatted I/O unit| +|`none`|function|`.true.` if no bits are 1, `.false.` otherwise| +|`not`|subroutine|performs a logical `not` operation on all the bits| +|`output`|subroutine|writes a bitset to an unformatted I/O unit| +|`read_bitset`|subroutine|reads a bitset from a bitset literal in a character string or formatted I/O unit| +|`set`|subroutine|sets a sequence of one or more bits to 1| +|`test`|function|`.true.` if the bit at `pos` is 1, `.false.` otherwise| +|`to_string`|subroutine|represents the bitset as a binary literal| +|`value`|function|1 if the bit at `pos` is 1, 0 otherwise| +|`write_bitset`|subroutine|writes a bitset as a bitset literal to a character string or formatted I/O unit| + +### Table of the non-member procedure overloads + +The procedures with two arguments of type `bitset_large` or +`bitset_64` must have both arguments of the same known type which +prevents them from being methods. The bitwise "logical" procedures, +`and`, `and_not`, `or`, and `xor` also require that the two bitset +arguments have the same number of bits, otherwise the results are +undefined. These procedures are summarized in the following table: + +|Procedure name|Class|Summary| +|--------------|-----|-------| +|`and`|elemental subroutine|Sets `self` to the bitwise `and` of the original bits in `self` and `set2`| +|`and_not`|elemental subroutine|Sets `self` to the bitwise `and` of the original bits in `self` and the negation of `set2`| +|`extract`|subroutine|creates a new bitset, `new`, from a range in `old`| +|`or`|elemental subroutine|Sets `self` to the bitwise `or` of the original bits in `self` and `set2`| +|`xor`|elemental subroutine|Sets `self` to the bitwise exclusive `or` of the original bits in `self` and `set2`| + + +### Assignments + +The module defines an assignment operation, `=`, that creates a +duplicate of an original bitset. It also defines assignments to and +from rank one arrays of logical type of kinds `int8`, `int16`, +`int32`, and `int64`. In the assignment to and from logical arrays +array index, `i`, is mapped to bit position, `pos=i-1`, and `.true.` +is mapped to a set bit, and `.false.` is mapped to an unset bit. + + +#### Example + +```fortran + program demo_assignment + use stdlib_bitsets + logical(int8) :: logical1(64) = .true. + logical(int32), allocatable :: logical2(:) + type(bitset_64) :: set0, set1 + set0 = logical1 + if ( set0 % bits() /= 64 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size.' + else if ( .not. set0 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization with logical(int8) succeeded.' + end if + set1 = set0 + if ( set1 == set0 ) & + write(*,*) 'Initialization by assignment succeeded' + logical2 = set1 + if ( all( logical2 ) ) then + write(*,*) 'Initialization of logical(int32) succeeded.' + end if + end program demo_assignment +``` + +### Table of the non-member comparison operations +The comparison operators with two arguments of type `bitset_large` or +`bitset_64` must have both arguments of the same known type which +prevents them from being methods. The operands must also have the same +number of bits otherwise the results are undefined. These operators +are summarized in the following table: + +|Operator|Description| +|--------|-----------| +|`==`, `.eq.`|`.true.` if all bits in `set1` and `set2` have the same value, `.false.` otherwise| +|`/=`, `.ne.`|`.true.` if any bits in `set1` and `set2` differ in value, `.false.` otherwise| +|`>`, `.gt.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`>=`, `.ge.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`<`, `.lt.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| +|`<=`, `.le.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| + + +## Specification of the `stdlib_bitsets` methods and procedures + +### `all` - determine whether all bits are set in `self` + +#### Status + +Experimental + +#### Description + +Determines whether all bits are set to 1 in `self`. + +#### Syntax + +`result = self % [[bitset_type(type):all(bound)]]()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result value + +The result is a default logical scalar. +The result is `.true.` if all bits in `self` are set, +otherwise it is `.false.`. + +#### Example + +```fortran + program demo_all + use stdlib_bitsets + character(*), parameter :: & + bits_all = '111111111111111111111111111111111' + type(bitset_64) :: set0 + call set0 % from_string( bits_all ) + if ( .not. set0 % all() ) then + error stop "FROM_STRING failed to interpret" // & + "BITS_ALL's value properly." + else + write(*,*) "FROM_STRING transferred BITS_ALL properly" // & + " into set0." + end if + end program demo_all +``` + +### `and` - bitwise `and` of the bits of two bitsets + +#### Status + +Experimental + +#### Description + +Sets the bits in `set1` to the bitwise `and` of the original bits in +`set1` and `set2`. Note that `set1` and `set2` must have the same +number of bits, otherwise the result is undefined. + +#### Syntax + +`call [[stdlib_bitsets(module):and(interface)]](set1, set2)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`set1`: shall be a `bitset_64` or `bitset_large` scalar variable. It +is an `intent(inout)` argument. On return the values of the bits in +`set1` are the bitwise `and` of the original bits in `set1` with the +corresponding bits in `set2`. + +`set2`: shall be a scalar expression of the same type as `set1`. It is +an `intent(in)` argument. Note that `set2` must also have the same +number of bits as `set1`. + +#### Example + +```fortran + program demo_and + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call and( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of AND worked.' + call set0 % not() + call and( set0, set1 ) ! all none + if ( none(set0) ) write(*,*) 'Second test of AND worked.' + call set1 % not() + call and( set0, set1 ) ! none all + if ( none(set0) ) write(*,*) 'Third test of AND worked.' + call set0 % not() + call and( set0, set1 ) ! all all + if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' + end program demo_and +``` + +### `and_not` - Bitwise `and` of one bitset with the negation of another + +#### Status + +Experimental + +#### Description + +Sets the bits of `set1` to bitwise `and` of the bits of `set1` with +the bitwise negation of the corresponding bits of `set2`. Note that +`set1` and `set2` must have the same number of bits, otherwise the +result is undefined. + +#### Syntax + +`call [[stdlib_bitsets(module):and_not(interface)]](set1, set2)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(inout)` argument. On return the values of the bits in +`set1` are the bitwise `and` of the original bits in `set1` with the +corresponding negation of the bits in `set2`. + +`set2`: shall be a scalar expression of the same type as `set1`. It is +an `intent(in)` argument. Note that it should also have the same +number of bits as `set1`, otherwise the result is undefined. + +#### Example + +```fortran + program demo_and_not + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call and_not( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of AND_NOT worked.' + call set0 % not() + call and_not( set0, set1 ) ! all none + if ( all(set0) ) write(*,*) 'Second test of AND_NOT worked.' + call set0 % not() + call set1 % not() + call and_not( set0, set1 ) ! none all + if ( none(set0) ) write(*,*) 'Third test of AND_NOT worked.' + call set0 % not() + call and_not( set0, set1 ) ! all all + if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' + end program demo_and_not +``` + +### `any` - determine whether any bits are set + +#### Status + +Experimental + +#### Description + +Determines whether any bits are set in `self`. + +#### Syntax + +`result = self % [[bitset_type(type):any(bound)]]()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result value + +The result is a default logical scalar. The result is `.true.` if any bits in `self` are set, otherwise it +is `.false.`. + +#### Example + +```fortran + program demo_any + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_64) :: set0 + call set0 % from_string( bits_0 ) + if ( .not. set0 % any() ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % set(5) + if ( set0 % any() ) then + write(*,*) "ANY interpreted SET0's value properly." + end if + end program demo_any +``` + +### `bit_count` - return the number of bits that are set + +#### Status + +Experimental + +#### Description + +Returns the number of bits that are set to one in `self`. + +#### Syntax + +`result = self % [[bitset_type(type):bit_count(bound)]] ()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result value + +The result is an integer scalar of kind `bits_kind`, +equal to the number of bits that are set in `self`. + +#### Example + +```fortran + program demo_bit_count + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_64) :: set0 + call set0 % from_string( bits_0 ) + if ( set0 % bit_count() == 0 ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % set(5) + if ( set0 % bit_count() == 1 ) then + write(*,*) "BIT_COUNT interpreted SET0's value properly." + end if + end program demo_bit_count +``` + +#### `bits` - returns the number of bits + +#### Status + +Experimental + +#### Description + +Reports the number of bits in `self`. + +#### Syntax + +`result = self % [[bitset_type(type):bits(bound)]] ()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result value + +The result is an integer scalar of kind `bits_kind`, equal to +the number of defined bits in `self`. + +#### Example + +```fortran + program demo_bits + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_64) :: set0 + call set0 % from_string( bits_0 ) + if ( set0 % bits() == 19 ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's size properly." + end if + end program demo_bits +``` + +### `clear` - clears a sequence of one or more bits + +#### Status + +Experimental + +#### Description + +* If only `pos` is present, clears the bit with position `pos` in +`self`. + +* If `start_pos` and `end_pos` are present with `end_pos >= start_pos` +clears the bits with positions from `start_pos` to `end_pos` in `self`. + +* if `start_pos` and `end_pos` are present with `end_pos < start_pos` +`self` is unmodified. + +Note: Positions outside the range 0 to `bits(set) -1` are ignored. + +#### Syntax + +`call self % [[bitset_type(type):clear(bound)]](pos)` + +or + +`call self % [[bitset_type(type):clear(bound)]](start_pos, end_pos)` + +#### Class + +Elemental subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_type`. It is an + `intent(inout)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +`start_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`end_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +#### Example + +```fortran + program demo_clear + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + call set0 % not() + if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' + call set0 % clear(165) + if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' + call set0 % clear(0,164) + if ( set0 % none() ) write(*,*) 'All bits are cleared.' + end program demo_clear +``` + +### `extract` - create a new bitset from a range in an old bitset + +#### Status + +Experimental + +#### Description + +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. + +#### Syntax + +`call [[stdlib_bitsets(module):extract(interface)]](new, old, start_pos, stop_pos, status )` + +#### Class + +Subroutine + +#### Arguments + +`new`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(out)` argument. It will be the new bitset. + +`old`: shall be a scalar expression of the same type as `new`. It is +an `intent(in)` argument. It will be the source bitset. + +`start_pos`: shall be a scalar integer expression of the kind +`bits_kind`. It is an `intent(in)` argument. + +`stop_pos`: shall be a scalar integer expression of the kind +`bits_kind`. It is an `intent(in)` argument. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present it shall have one of the values: + +* `success` - no problems found + +* `index_invalid_error` - `start_pos` was less than zero or `stop_pos` + was greater than `bits(old)-1`. + +#### Example + +```fortran + program demo_extract + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set0 % set(100,150) + call extract( set1, set0, 100, 150) + if ( set1 % bits() == 51 ) & + write(*,*) 'SET1 has the proper size.' + if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' + end program demo_extract +``` + +### `flip` - flip the values of a sequence of one or more bits + +#### Status + +Experimental + +#### Description + +Flip the values of a sequence of one or more bits. + +* If only `pos` is present flip the bit value with position `pos` in + + `self`. +* If `start_pos` and `end_pos` are present with `end_pos >= start_pos` +flip the bit values with positions from `start_pos` to `end_pos` in +`self`. + +* If `end_pos < start_pos` then `self` is unmodified. + + +#### Syntax + +`call self % [[bitset_type(type):flip(bound)]] (pos)` + +or + +`call self % [[bitset_type(type):flip(bound)]] (start_pos, end_pos)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`self`: shall be a scalar class `bitset_type` variable It is an +`intent(inout)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +`start_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`end_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +#### Example + +```fortran + program demo_flip + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' + call set0 % flip(165) + if ( set0 % test(165) ) write(*,*) 'Bit 165 is flipped.' + call set0 % flip(0,164) + if ( set0 % all() ) write(*,*) 'All bits are flipped.' + end program demo_flip +``` + +### `from_string` - initializes a bitset from a binary literal + +#### Status + +Experimental + +#### Description + +Initializes the bitset `self` from `string`, treating `string` as a +binary literal. + +#### Syntax + +`call self % [[bitset_type(type):from_string(bound)]](string[, status])` + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar class `bitset_type` variable. It is an +`intent(out)` argument. + +`string`: shall be a scalar default character expression. It is an +`intent(in)` argument. It shall consist only of the characters "0", +and "1". + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present, on return its value shall be +one of the error codes defined in this module. If absent, and its +value would not have been `success`, then processing will stop with an +informative text as its stop code. It shall have one of the error +codes: + +* `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. + + +#### Example + +```fortran + program demo_from_string + use stdlib_bitsets + character(*), parameter :: & + bits_all = '111111111111111111111111111111111' + type(bitset_64) :: set0 + call set0 % from_string( bits_all ) + if ( bits(set0) /= 33 ) then + error stop "FROM_STRING failed to interpret " // & + 'BITS_ALL's size properly." + else if ( .not. set0 % all() ) then + error stop "FROM_STRING failed to interpret" // & + "BITS_ALL's value properly." + else + write(*,*) "FROM_STRING transferred BITS_ALL properly" // & + " into set0." + end if + end program demo_from_string +``` + +### `init` - `bitset_type` initialization routines + +#### Status + +Experimental + +#### Description + +`bitset_type` initialization routine. + +#### Syntax + +`call self % [[bitset_type(type):init(bound)]] (bits [, status])` + +#### Class + +Subroutine. + +#### Arguments + +`self`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(out)` argument. + +`bits`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument that if present +specifies the number of bits in `set`. A negative value, or a value +greater than 64 if `self` is of type `bitset_64`, is an error. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument that, if present, returns an error code +indicating any problem found in processing `init`, and if absent and +an error was found result in stopping processing with an informative +stop code. It can have any of the following error codes: + +* `success` - no problem found + +* `alloc_fault` - `self` was of type `bitset_large` and memory + allocation failed + +* `array_size_invalid_error` - bits was present with either a negative + value, or a value greater than 64 when `self` was of type + `bitset_64`. + +#### Example + +```fortran + program demo_init + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + if ( set0 % bits() == 166 ) & + write(*,*) 'SET0 has the proper size.' + if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' + end program demo_init +``` + +### `input` - reads a bitset from an unformatted file + +#### Status + +Experimental + +#### Description + +Reads a bitset from its binary representation in an unformatted +file. + +#### Syntax + +`call self % [[bitset_type(type):input(bound)]] (unit [, status])` + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_64` or +`bitset_large`. It is an `intent(out)` argument. + +`unit`: shall be a scalar default integer expression. It is an +`intent(in)` argument. Its value must be that of a logical unit +number for an open unformatted file with `read` or `readwrite` +access positioned at the start of a bitset value written by a +`bitset_type` `output` subroutine by the same processor. + +`status` (optional): shall be a scalar default integer variable. If +present its value shall be of one of the error codes defined in this +module. If absent and it would have had a value other than `success` +processing will stop with an informative stop code. Allowed error code +values for this `status` are: + +* `success` - no problem found + +* `alloc_fault` - `self` was of type `bitset_large` and allocation of + memory failed. + +* `array_size_invalid_error` - if the number of bits read from `unit` + is either negative or greater than 64, if class of `self` is + `bitset_64`. + +* `read_failure` - failure during a read statement + +#### Example + +```fortran + program demo_input + character(*), parameter :: & + bits_0 = '000000000000000000000000000000000', & + bits_1 = '000000000000000000000000000000001', & + bits_33 = '100000000000000000000000000000000' + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % from_string( bits_0 ) + call set1 % from_string( bits_1 ) + call set2 % from_string( bits_33 ) + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop 'Transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + end program demo_input +``` + +### `none` - determines whether no bits are set + +#### Status + +Experimental + +#### Description + +Determines whether no bits are set in `self`. + +#### Syntax + +`result = self % [[bitset_type(type):none(bound)]] ()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an + `intent(in)` argument. + +#### Result value + +The result is a default logical scalar. +The result is `.true.` if no bits in `self` are set, otherwise it is +`.false.`. + +#### Example + +```fortran + program demo_none + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_large) :: set0 + call set0 % from_string( bits_0 ) + if ( set0 % none() ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % set(5) + if ( .not. set0 % none() ) then + write(*,*) "NONE interpreted SET0's value properly." + end if + end program demo_none +``` + +### `not` - Performs the logical complement on a bitset + +#### Status + +Experimental + +#### Description + +Performs the logical complement on the bits of `self`. + +#### Syntax + +`call self % [[bitset_type(type):not(bound)]] ()` + +#### Class + +Elemental subroutine. + +#### Argument + +`self` shall be a scalar variable of class `bitset_type`. It is an +`intent(inout)` argument. On return its bits shall be the logical +complement of their values on input. + +#### Example + +```fortran + program demo_not + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init( 155 ) + if ( set0 % none() ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % not() + if ( set0 % all() ) then + write(*,*) "ALL interpreted SET0's value properly." + end if + end program demo_not +``` + +### `or` - Bitwise OR of the bits of two bitsets + +#### Status + +Experimental + +#### Description + +Replaces the original bits of `set1` with the bitwise `or` of those +bits with the bits of `set2`. Note `set1` and `set2` must have the +same number of bits, otherwise the result is undefined. + +#### Syntax + +`call [[stdlib_bitsets(module):or(interface)]](set1, set2)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(inout)` argument. On return the values of the bits in +`setf` are the bitwise `or` of the original bits in `set1` with the +corresponding bits in `set2`. + +`set2`: shall be a scalar expression of the same type as `set1`. It is +an `intent(in)` argument. Note `bits(set2)` must equal `bits(set1)` +otherwise the results are undefined. + +#### Example + +```fortran + program demo_or + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call or( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of OR worked.' + call set0 % not() + call or( set0, set1 ) ! all none + if ( all(set0) ) write(*,*) 'Second test of OR worked.' + call set0 % not() + call set1 % not() + call or( set0, set1 ) ! none all + if ( all(set0) ) write(*,*) 'Third test of OR worked.' + call set0 % not() + call or( set0, set1 ) ! all all + if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' + end program demo_or +``` + +### `output` - Writes a binary representation of a bitset to a file + +#### Status + +Experimental + +#### Description + +Writes a binary representation of a bitset to an unformatted file. + +#### Syntax + +`call self % [[bitset_type(type):output(bound)]] (unit[, status])` + +#### Class + +Subroutine. + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_64` or +`bitset_large`. It is an `intent(in)` argument. + +`unit`: shall be a scalar default integer expression. It is an +`intent(in)` argument. Its value must be that of an I/O unit number +for an open unformatted file with `write` or `readwrite` access. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present on return it will have the value +of `success` or `write_failure`. If absent and it would not have the +value of `success` then processing will stop with an informative stop +code. The two code values have the meaning: + +* `success` - no problem found + +* `write_failure` - a failure occurred in a write statement. + +#### Example + +```fortran + program demo_output + character(*), parameter :: & + bits_0 = '000000000000000000000000000000000', & + bits_1 = '000000000000000000000000000000001', & + bits_33 = '100000000000000000000000000000000' + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % from_string( bits_0 ) + call set1 % from_string( bits_1 ) + call set2 % from_string( bits_33 ) + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop 'Transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + end program demo_output +``` + +### `read_bitset` - initializes `self` with the value of a *bitset_literal* + +#### Status + +Experimental + +#### Description + +Reads a *bitset-literal* and initializes `self` with the corresponding +value. + + +#### Syntax + +`call self % [[bitset_type(type):read_bitset(bound)]](string[, status])` + +or + +`call self % [[bitset_type(type):read_bitset(bound)]](unit[, advance, status])` + + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_type`. It is an +`intent(out)` argument. Upon a successful return it is initialized with +the value of a *bitset-literal*. + +`string` (optional): shall be a scalar default character +expression. It is an `intent(in)` argument. It will consist of a left +justified *bitset-literal*, terminated by either the end of the string +or a blank. + +`unit` (optional): shall be a scalar default integer expression. It is +an `intent(in)` argument. Its value must be that of an I/O unit number +for an open formatted file with `read` or `readwrite` access +positioned at the start of a *bitset-literal*. + +`advance` (optional): shall be a scalar default character +expression. It is an `intent(in)` argument. It is the `advance` +specifier for the final read of `unit`. If present it should have +the value `'yes'` or `'no'`. If absent it has the default value of +`'yes'`. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present on return it shall have the +value of one of the error codes of this module. If absent and it would +not have had the value `success` processing will stop with a message +as its error code. The possible error codes are: + +* `success` - no problems found; + +* `alloc_fault` - if `self` is of class `bitset_large` and allocation + of the bits failed; + +* `array_size_invalid_error` - if the *bitset-literal* has a bits + value greater than 64 and `self` is of class `bitset_64`; + +* `char_string_invalid_error` - if the `bitset-literal` has an invalid + character; + +* `char_string_too_small_error` - if `string` ends before all the bits + are read; + +* `eof_failure` - if a `read` statement reached an end-of-file before + completing the read of the bitset literal, + +* `integer_overflow_error` - if the *bitset-literal* has a `bits` + value larger than `huge(0_bits_kind)`; or + +* `read_failure` - if a read statement failed. + +#### Example + +```fortran + program demo_read_bitset + character(*), parameter :: & + bits_0 = 'S33B000000000000000000000000000000000', & + bits_1 = 'S33B000000000000000000000000000000001', & + bits_33 = 'S33B100000000000000000000000000000000' + character(:), allocatable :: test_0, test_1, test_2 + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % read_bitset( bits_0, status ) + call set1 % read_bitset( bits_1, status ) + call set2 % read_bitset( bits_2, status ) + call set0 % write_bitset( test_0, status ) + call set1 % write_bitset( test_1, status ) + call set2 % write_bitset( test_2, status ) + if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & + bits_2 == test_2 ) then + write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' + end if + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then + write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' + end if + end program demo_read_bitset +``` + +### `set` - sets a sequence of one or more bits to 1 + +#### Status + +Experimental + +#### Description + +Sets a sequence of one or more bits in `self` to 1. + +* If `start_pos` and `end_pos` are absent sets the bit at position +`pos` in `self` to 1. + +* If `start_pos` and `end_pos` are present with `end_pos >= start_pos` +set the bits at positions from `start_pos` to `end_pos` in `self` to 1. + +* If `start_pos` and `end_pos` are present with `end_pos < start_pos` +`self` is unchanged. + +* Positions outside the range 0 to `bits(self)` are ignored. + + +#### Syntax + +`call self % [[bitset_type(type):set(bound)]] (POS)` + +or + +`call self % [[bitset_type(type):set(bound)]] (START_POS, END_POS)` + +#### Class + +Elemental subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_type`. It is an + `intent(inout)` argument. + +`pos` (optional): shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`start_pos` (optional): shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`end_pos` (optional): shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +#### Example + +```fortran + program demo_set + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' + call set0 % set(165) + if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' + call set0 % set(0,164) + if ( set0 % all() ) write(*,*) 'All bits are set.' + end program demo_set +``` + +### `test` - determine whether a bit is set + +#### Status + +Experimental + +#### Descriptions + +Determine whether the bit at position `pos` is set to 1 in `self`. + + +#### Syntax + +`result = self % [[bitset_type(type):test(bound)]](pos)` + +#### Class + +Elemental function. + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +#### Result value + +The result is a default logical scalar. +The result is `.true.` if the bit at `pos` in `self` is set, +otherwise it is `.false.`. If `pos` is outside the range +`0... bits(self)-1` the result is `.false.`. + +#### Example + +```fortran + program demo_test + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + call set0 % not() + if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' + call set0 % clear(165) + if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' + call set0 % set(165) + if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' + end program demo_test +``` + +### `to_string` - represent a bitset as a binary literal + +### Status + +Experimental + +#### Description + +Represents the value of `self` as a binary literal in `string`. + +#### Syntax + +`call self % [[bitset_type(type):to_string(bound)]](string[, status])` + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`string`: shall be a scalar default character variable of allocatable +length. It is an `intent(out)` argument. On return it shall have a +*binary-literal* representation of the bitset `self`. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present it shall have either the value +`success` or `alloc_fault`. If absent and it would have had the value +`alloc_fault` then processing will stop with an informative test as +the stop code. The values have the following meanings: + +`success` - no problem found. + +`alloc_fault` - allocation of `string` failed. + + +#### Example + +```fortran + program demo_to_string + use stdlib_bitsets + character(*), parameter :: & + bits_all = '111111111111111111111111111111111' + type(bitset_64) :: set0 + character(:), allocatable :: new_string + call set0 % init(33) + call set0 % not() + call set0 % to_string( new_string ) + if ( new_string == bits_all ) then + write(*,*) "TO_STRING transferred BITS0 properly" // & + " into NEW_STRING." + end if + end program demo_to_string +``` + +### `value` - determine the value of a bit + +#### Status + +Experimental + +#### Description + +Determines the value of the bit at position, `pos`, in `self`. + +#### Syntax + +`result = self % [[bitset_type(type):value(bound)]](pos)` + +#### Class + +Elemental function. + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +#### Result value + +The result is a default integer scalar. +The result is one if the bit at `pos` in `self` is set, otherwise it +is zero. If `pos` is outside the range `0... bits(set)-1` the result +is zero. + +#### Example + +```fortran + program demo_value + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + call set0 % not() + if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' + call set0 % clear(165) + if ( set0 % value(165) == 0 ) write(*,*) 'Bit 165 is cleared.' + call set0 % set(165) + if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' + end program demo_value +``` + +### `write_bitset` - writes a *bitset-literal* + +#### Status + +Experimental + +#### Description + +Writes a *bitset-literal* representing `self`'s current value to a +character string or formatted file. + + +#### Syntax + +`call self % [[bitset_type(type):write_bitset(bound)]](string[, status])` + +or + +`call self % [[bitset_type(type):write_bitset(bound)]] (unit[, advance, status])` + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`string` (optional): shall be a scalar default character variable of +allocatable length. It is an `intent(out)` argument. + +`unit` (optional): shall be a scalar default logical expression. It is +an `intent(in)` argument. Its value must be that of a I/O unit number +for an open formatted file with `write` or `readwrite` access. + +`advance` (optional): shall be a scalar default character +expression. It is an `intent(in)` argument. It is the `advance` +specifier for the write to `unit`. If present it must have the value +`'yes'` or `'no'`. It has the default value of `'yes'`. + +* if `advance` is not present or is present with a value of `'no'` + then the bitset's *bitset-literal* is written to `unit` + followed by a blank, and the current record is not advanced. + +* If `advance` is present with a value of `'yes'` then the + bitset's *bitset-literal* is written to `unit` and the + record is immediately advanced. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present on return it shall have the +value of one of the module's error codes. If absent and a problem was +found processing will stop with an informative stop code. It may have +the following error code values: + +* `success` - no problem was found + +* `alloc_fault` - allocation of the string failed + +* `write_failure` - the `write` to the `unit` failed + +#### Example + +```fortran + program demo_write_bitset + character(*), parameter :: & + bits_0 = 'S33B000000000000000000000000000000000', & + bits_1 = 'S33B000000000000000000000000000000001', & + bits_33 = 'S33B100000000000000000000000000000000' + character(:), allocatable :: test_0, test_1, test_2 + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % read_bitset( bits_0, status ) + call set1 % read_bitset( bits_1, status ) + call set2 % read_bitset( bits_2, status ) + call set0 % write_bitset( test_0, status ) + call set1 % write_bitset( test_1, status ) + call set2 % write_bitset( test_2, status ) + if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & + bits_2 == test_2 ) then + write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' + end if + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then + write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' + end if + end program demo_write_bitset +``` + +### `xor` - bitwise exclusive `or` + +#### Status + +Experimental + +#### Description + +Replaces `set1`'s bitset with the bitwise exclusive `or` of the +original bits of `set1` and `set2`. Note `set1` and `set2` must have +the samee number of bits, otherwise the result is undefined. + +#### Syntax + +`result = [[stdlib_bitsets(module):xor(interface)]] (set1, set2)` + +#### Class + +Elemental subroutine + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(inout)` argument. On return the values of the bits in +`set1` are the bitwise exclusive `or` of the original bits in `set1` +with the corresponding bits in `set2`. + +`set2` shall be a scalar expression of the same type as `set1`. It is + an `intent(in)` argument. Note `set1` and `set2` must have the +samee number of bits, otherwise the result is undefined. + +#### Example + +```fortran + program demo_xor + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call xor( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of XOR worked.' + call set0 % not() + call xor( set0, set1 ) ! all none + if ( all(set0) ) write(*,*) 'Second test of XOR worked.' + call set0 % not() + call set1 % not() + call xor( set0, set1 ) ! none all + if ( all(set0) ) write(*,*) 'Third test of XOR worked.' + call set0 % not() + call xor( set0, set1 ) ! all all + if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' + end program demo_xor +``` + +## Specification of the `stdlib_bitsets` operators + +### `==` - compare two bitsets to determine whether the bits have the same value + +#### Status + +Experimental + +#### Description + +Returns `.true.` if all bits in `set1` and `set2` have the same value, +`.false.` otherwise. + +#### Syntax + +`result = set1 [[stdlib_bitsets(module):==(interface)]] set2` + +or + +`result = set1 .EQ. set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result value + +The result is a default logical scalar. +The result is `.true.` if the bits in both bitsets are set +to the same value, otherwise the result is `.false.`. + +#### Example + +```fortran + program demo_equality + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & + set1 == set2 ) then + write(*,*) 'Passed 64 bit equality tests.' + else + error stop 'Failed 64 bit equality tests.' + end if + end program demo_equality +``` + +### `/=` - compare two bitsets to determine whether any bits differ in value + +#### Status + +Experimental + +#### Description + +Returns `.true.` if any bits in `self` and `set2` differ in value, +`.false.` otherwise. + +#### Syntax + +`result = set1 [[stdlib_bitsets(module):/=(interface)]] set2` + +or + +`result = set1 .NE. set2` + +#### Class + +Elemental function + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result value + +The result is a default logical scalar. +The result is `.true.` if any bits in both bitsets differ, otherwise +the result is `.false.`. + +#### Example + +```fortran + program demo_inequality + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 /= set1 .and. set0 /= set2 .and. set1 /= set2 .and. & + .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & + set2 /= set2 ) then + write(*,*) 'Passed 64 bit inequality tests.' + else + error stop 'Failed 64 bit inequality tests.' + end if + end program demo_inequality +``` + +### `>=` - compare two bitsets to determine whether the first is greater than or equal to the second + +#### Status + +Experimental + +#### Description + +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 be the same size otherwise the +results are undefined. + +#### Syntax + +`result = set1 [[stdlib_bitsets(module):>=(interface)]] set2` + +or + +`result = set1 .GE. set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result value + +The result is a default logical scalar. +The result is `.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. + +#### Example + +```fortran + program demo_ge + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set1 >= set0 .and. set2 >= set1 .and. set2 >= set0 .and. & + set0 >= set0 .and. set1 >= set1 .and. set2 >= set2 .and. & + .not. set0 >= set1 .and. .not. set0 >= set2 .and. .not. & + set1 >= set2 ) then + write(*,*) 'Passed 64 bit greater than or equals tests.' + else + error stop 'Failed 64 bit greater than or equals tests.' + end if + end program demo_ge +``` + +### `>` - compare two bitsets to determine whether the first is greater than the other + +#### Status + +Experimental + +#### Description + +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 be the same size otherwise the +results are undefined. + +#### Syntax + +`result = set1 [[stdlib_bitsets(module):>(interface)]] set2` + +or + +`result = set1 .GT. set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result value + +The result is a default logical scalar. +The result is `.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. + +#### Example + +```fortran + program demo_gt + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set1 > set0 .and. set2 > set1 .and. set2 > set0 .and. & + .not. set0 > set0 .and. .not. set0 > set1 .and. .not. & + set1 > set2 ) then + write(*,*) 'Passed 64 bit greater than tests.' + else + error stop 'Failed 64 bit greater than tests.' + end if + end program demo_gt +``` + +### `<=` - compare two bitsets to determine whether the first is less than or equal to the other + +#### Status + +Experimental + +#### Description + +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 be the same size otherwise the +results are undefined. + +#### Syntax + +`result = set1 [[stdlib_bitsets(module):<=(interface)]] set2` + +or + +`result = set1 .LE. set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result value + +The result is a default logical scalar. +The result is `.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. + +#### Example + +```fortran + program demo_le + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 <= set1 .and. set1 <= set2 .and. set0 <= set2 .and. & + set0 <= set0 .and. set1 <= set1 .and. set2 <= set2 .and. & + .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & + set2 <= set1 ) then + write(*,*) 'Passed 64 bit less than or equal tests.' + else + error stop 'Failed 64 bit less than or equal tests.' + end if + end program demo_le +``` + +### `<` - compare two bitsets to determine whether the first is less than the other + +#### Status + +Experimental + +#### Description + +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 be the same size otherwise the +results are undefined. + +#### Syntax + +`result = set1 [[stdlib_bitsets(module):<(interface)]] set2` + +or + +`result = set1 .LT. set2 + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result value + +The result is a default logical scalar. +The result is `.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. + +#### Example + +```fortran + program demo_lt + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 < set1 .and. set1 < set2 .and. set0 < set2 .and. & + .not. set0 < set0 .and. .not. set2 < set0 .and. .not. & + set2 < set1 ) then + write(*,*) 'Passed 64 bit less than tests.' + else + error stop 'Failed 64 bit less than tests.' + end if + end program demo_lt +``` diff --git a/doc/specs/stdlib_logger.md b/doc/specs/stdlib_logger.md index 83ed7f2cf..60a823406 100644 --- a/doc/specs/stdlib_logger.md +++ b/doc/specs/stdlib_logger.md @@ -8,19 +8,20 @@ title: logger ## Introduction This module defines a derived type, its methods, a variable, and -constants to be used for the reporting of errors and other -information. The derived type, `logger_type`, is to be used to define -both global and local logger variables. The `logger_type` methods serve -to configure the loggers and use the logger variables to report -messages to a variable specific list of I/O units termed -`log_units`. The variable, `global_logger`, of type `logger_type`, is -intended to serve as the default global logger. The constants serve as -error flags returned by the optional integer `stat` argument. +constants to be used for the reporting of errors, displaying messages, +and other information. The derived type, `logger_type`, is to be used +to define both global and local logger variables. The `logger_type` +methods serve to configure the loggers and use the logger variables to +report messages to a variable specific list of I/O units termed +`log_units`. The variable, `global_logger`, of type `logger_type`, +is intended to serve as the default global logger. The constants serve +as error flags returned by the optional integer `stat` argument. The logger variables have the option to: * change which units receive the log messages; * report which units receive the log messages; +* select which types of messages are logged; * precede messages by a blank line; * precede messages by a time stamp of the form `yyyy-mm-dd hh:mm:ss.sss`; @@ -29,11 +30,17 @@ The logger variables have the option to: that prompted the log message; * follow a message with the `iostat` and `iomsg` of the I/O error report that prompted the log message; -* label a message with one of `'INFO: '`, `'WARN: '`, +* label a message with one of `'DEBUG: '`, `'INFO: '`, `'WARN: '`, `'ERROR: '`, or `'I/O ERROR: '`; * indent subsequent lines of the messages; and * format the text to fit within a maximum column width. +While every effort has been made to make the code process and +asynchronous I/O safe, it is always best to have each process write to +its own dedicated logger file. +For thread parallelism (e.g., with OpenMP), it is advised to put the +logger call in a guarding region (e.g., in an OpenMP critical region). + Note: Loggers of type `logger_type` normally report their messages to I/O units in the internal list termed `log_units`. However if `log_units` is empty then the messages go to the `output_unit` of the intrinsic @@ -58,6 +65,18 @@ Error Code | Description `unopened_in_error` | the unit was not opened `write_fault` | one of the writes to `log_units` failed +The module also defines eight distinct public integer constants for +selecting the messages that are logged. These constants, termed +severity levels, are (sorted following their increasing order of +severity): `all_level`, `debug_level`, `information_level`, +`warning_level`, `error_level`, `io_error_level`, `text_error_level`, +and `none_level`. +All log messages with a level (e.g., `debug_level`) lower than a +specified severity level (e.g., `information_level`) will be ignored. +The levels `error_level` and `io_error_level` have the same severity. +The default severity level is `information_level`. + + ## The derived type: logger_type ### Status @@ -75,14 +94,15 @@ significant events encountered during the execution of a program. ### Private attributes -| Attribute | Type | Description | Initial value -|------------------|---------------|-------------------------------------------------|-------------- -| `add_blank_line` | Logical | Flag to precede output with a blank line | `.false.` -| `indent_lines` | Logical | Flag to indent subsequent lines by four columns | `.true.` -| `log_units` | Integer array | List of I/O units used for output | empty -| `max_width` | Integer | Maximum column width of output | 0 -| `time_stamp` | Logical | Flag to precede output by a time stamp | `.true.` -| `units` | Integer | Count of the number of active output units | 0 +| Attribute | Type | Description | Initial value | +|------------------|---------------|-------------------------------------------------|---------------------| +| `add_blank_line` | Logical | Flag to precede output with a blank line | `.false.` | +| `indent_lines` | Logical | Flag to indent subsequent lines by four columns | `.true.` | +| `level` | Integer | Severity level | `information_level` | +| `log_units` | Integer array | List of I/O units used for output | Unallocated | +| `max_width` | Integer | Maximum column width of output | 0 | +| `time_stamp` | Logical | Flag to precede output by a time stamp | `.true.` | +| `units` | Integer | Count of the number of active output units | 0 | ## The `stdlib_logger` variable @@ -104,6 +124,7 @@ Method | Class | Description [`add_log_unit`](./stdlib_logger.html#add_log_unit-add-a-unit-to-the-array-self-log_units) | Subroutine | Adds an existing unit to the `log_units` list [`configuration`](./stdlib_logger.html#configuration-report-a-loggers-configuration) | Subroutine | Reports the details of the logging configuration [`configure`](./stdlib_logger.html#configure-configure-the-logging-process) | Subroutine | Configures the details of the logging process +[`log_debug`](./stdlib_logger.html#log_debug-writes-the-string-message-to-self-log_units) | Subroutine | Sends a message prepended by `'DEBUG: '` [`log_error`](./stdlib_logger.html#log_error-writes-the-string-message-to-self-log_units) | Subroutine | Sends a message prepended by `'ERROR: '` optionally followed by a `stat` or `errmsg` [`log_information`](./stdlib_logger.html#log_information-writes-the-string-message-to-self-log_units) | Subroutine | Sends a message prepended by `'INFO: '` [`log_io_error`](./stdlib_logger.html#log_io_error-write-the-string-message-to-self-log_units) | Subroutine | Sends a message prepended by `'I/O ERROR: '` optionally followed by an `iostat` or `iomsg` @@ -277,7 +298,7 @@ Reports the configuration of a logger. #### Syntax -`call self % [[logger_type(type):configuration(bound)]]( [ add_blankline, indent, max_width, time_stamp, log_units ] )` +`call self % [[logger_type(type):configuration(bound)]]( [ add_blankline, indent, level, max_width, time_stamp, log_units ] )` #### Class @@ -285,7 +306,7 @@ Pure subroutine #### Arguments -`self`: shall be a scalar variable of type `logger_type`. It is an +`self`: shall be a scalar expression of type `logger_type`. It is an `intent(in)` argument. It shall be the logger whose configuration is reported. `add_blank_line` (optional): shall be a scalar default logical @@ -296,6 +317,10 @@ Pure subroutine is an `intent(out)` argument. A value of `.true.` indents subsequent lines by four spaces, and `.false.` otherwise. +`level` (optional): shall be a scalar default integer variable. It is an + `intent(out)` argument. The value corresponds to the severity level for + ignoring a message. + `max_width` (optional): shall be a scalar default integer variable. It is an `intent(out)` argument. A positive value bigger than four defines the maximum width of the output, otherwise there @@ -309,7 +334,8 @@ Pure subroutine `log_units` (optional): shall be a rank one allocatable array variable of type default integer. It is an `intent(out)` argument. On return it shall be the elements of the `self`'s `log_units` - array. + array. If there were no elements in `self`'s `log_units`, a + zero-sized array is returned. #### Example @@ -347,7 +373,7 @@ Configures the logging process for self. #### Syntax -`call self % [[logger_type(type):configure(bound)]]( [ add_blank_line, indent, max_width, time_stamp ] )` +`call self % [[logger_type(type):configure(bound)]]( [ add_blank_line, indent, level, max_width, time_stamp ] )` #### Class @@ -367,6 +393,10 @@ Pure subroutine indent subsequent lines by four spaces, and to `.false.` to not indent. +`level` (optional): shall be a scalar default integer expression. It is + an `intent(in)` argument. Set the severity level for ignoring a log + message. + `max_width` (optional): shall be a scalar default integer expression. It is an `intent(in)` argument. Set to a positive value bigger than four to define the maximum width of the output, @@ -388,6 +418,77 @@ program demo_configure end program demo_configure ``` +### `log_debug` - Writes the string `message` to `self % log_units` + +#### Status + +Experimental + +#### Description + +Writes the string `message` to `self % log_units` with optional additional text. + +#### Syntax + +`call self % [[logger_type(type):log_debug(bound)]]( message [, module, procedure ] )` + +#### Behavior + +If time stamps are active, a time stamp is written, followed +by `module` and `procedure` if present, and then +`message` is written with the prefix `'DEBUG: '`. + +It is ignored if the `level` of `self` is higher than `debug_level`. + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar variable of type `logger_type`. It is an +`intent(in)` argument. It is the logger used to send the message. + +`message`: shall be a scalar default character expression. It is an + `intent(in)` argument. + +* Note `message` may have embedded new_line calls. + +`module` (optional): shall be a scalar default character + expression. It is an `intent(in)` argument. It should be the name of + the module containing the `log_information` call. + +`procedure` (optional): shall be a scalar default character + expression. It is an `intent(in)` argument. It should be the name of + the procedure containing the `log_information` call. + +#### Example + +```fortran +module example_mod + use stdlib_logger + + real, allocatable :: a(:) + + type(logger_type) :: logger + contains + + subroutine example_sub( selection ) + integer, intent(out) :: selection + character(128) :: errmsg, message + integer :: stat + write(*,'(a)') "Enter an integer to select a widget" + read(*,'(i0)') selection + write( message, '(a, i0)' ) & + "The user selected ", selection + call logger % log_DEBUG( message, & + module = 'EXAMPLE_MOD', procedure = 'EXAMPLE_SUB' ) + + end subroutine example_sub + +end module example_mod +``` + ### `log_error` - Writes the string `message` to `self % log_units` #### Status @@ -409,17 +510,21 @@ followed by `module` and `procedure` if present, then `message` is written with the prefix `'ERROR: '`, and then if `stat` or `errmsg` are present they are written. +It is ignored if the `level` of `self` is higher than `error_level`. + #### Class Subroutine #### Arguments -`self`: shall be a scalar expression of type `logger_type`. It is an +`self`: shall be a scalar variable of type `logger_type`. It is an `intent(in)` argument. It is the logger used to send the message. `message`: shall be a scalar default character expression. It is an - `intent(in)` argument. +`intent(in)` argument. + +* Note `message` may have embedded new_line calls. `module` (optional): shall be a scalar default character expression. It is an `intent(in)` argument. It should be the name of @@ -490,18 +595,22 @@ If time stamps are active, a time stamp is written, followed by `module` and `procedure` if present, and then `message` is written with the prefix `'INFO: '`. +It is ignored if the `level` of `self` is higher than `information_level`. + #### Class Subroutine #### Arguments -`self`: shall be a scalar expression of type `logger_type`. It is an +`self`: shall be a scalar variable of type `logger_type`. It is an `intent(in)` argument. It is the logger used to send the message. `message`: shall be a scalar default character expression. It is an `intent(in)` argument. +* Note `message` may have embedded new_line calls. + `module` (optional): shall be a scalar default character expression. It is an `intent(in)` argument. It should be the name of the module containing the `log_information` call. @@ -556,6 +665,8 @@ written. Then `message` is written with the prefix `'I/O ERROR: '`. Then if `iostat` or `iomsg` are present they are written. +It is ignored if the `level` of `self` is higher than `io_error_level`. + #### Syntax `call self % [[logger_type(type):log_io_error(bound)]]( message [, module, procedure, iostat, iomsg ] )` @@ -565,12 +676,14 @@ written. Subroutine #### Arguments -`self`: shall be a scalar expression of type `logger_type`. It is an +`self`: shall be a scalar variable of type `logger_type`. It is an `intent(in)` argument. It is the logger used to send the message. `message`: shall be a scalar default character expression. It is an `intent(in)` argument. +* Note `message` may have embedded new_line calls. + `module` (optional): shall be a scalar default character expression. It is an `intent(in)` argument. It should be the name of the module containing the `log_io_error` call. @@ -631,6 +744,8 @@ If time stamps are active, a time stamp is written, then `module` and `procedure` are written if present, followed by `prefix \\ ': '`, if present, and finally `message`. +No severity level is applied to `log_message`. + #### Syntax `call self % [[logger_type(type):log_message(bound)]]( message [, module, procedure, prefix ] )` @@ -641,12 +756,14 @@ Subroutine #### Arguments -`self`: shall be a scalar expression of type `logger_type`. It is an +`self`: shall be a scalar variable of type `logger_type`. It is an `intent(in)` argument. It is the logger used to send the message. `message`: shall be a scalar default character expression. It is an `intent(in)` argument. +* Note `message` may have embedded new_line calls. + `module` (optional): shall be a scalar default character expression. It is an `intent(in)` argument. It should be the name of the module containing the `log_message` call. @@ -705,6 +822,8 @@ written with `column`. Then `line` is written. Then a caret, '^', is written below `line` at the column indicated by `column`. Then `summary` is written below the caret. +It is ignored if the `level` of `self` is higher than `text_error_level`. + #### Syntax `call self % [[logger_type(type):log_text_error(bound)]]( line, column, summary [, filename, line_number, caret, stat ] )` @@ -715,7 +834,7 @@ Subroutine #### Arguments -`self`: shall be a scalar expression of type `logger_type`. It is an +`self`: shall be a scalar variable of type `logger_type`. It is an `intent(in)` argument. It is the logger used to send the message. `line`: shall be a scalar default character expression. It is an @@ -861,12 +980,14 @@ Subroutine #### Arguments -`self`: shall be a scalar expression of type `logger_type`. It is an +`self`: shall be a scalar variable of type `logger_type`. It is an `intent(in)` argument. It is the logger used to send the message. `message`: shall be a scalar default character expression. It is an `intent(in)` argument. +* Note `message` may have embedded new_line calls. + `module`: (optional) shall be a scalar default character expression. It is an `intent(in)` argument. It should be the name of the module containing the `log_warning` call. @@ -924,7 +1045,7 @@ Subroutine #### Arguments -`self`: shall be a scalar expression of type `logger_type`. It is an +`self`: shall be a scalar variable of type `logger_type`. It is an `intent(inout)` argument. It is the logger whose `log_units` is to be modified. diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index f17389d56..1704e12ab 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -14,6 +14,9 @@ set(fppFiles stdlib_stats_cov.fypp stdlib_stats_mean.fypp stdlib_stats_moment.fypp + stdlib_stats_moment_all.fypp + stdlib_stats_moment_mask.fypp + stdlib_stats_moment_scalar.fypp stdlib_stats_var.fypp stdlib_quadrature.fypp stdlib_quadrature_trapz.fypp diff --git a/src/Makefile.manual b/src/Makefile.manual index 8b54c2144..dd6f12708 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -82,4 +82,7 @@ stdlib_quadrature.f90: stdlib_quadrature.fypp stdlib_stats.f90: stdlib_stats.fypp stdlib_stats_mean.f90: stdlib_stats_mean.fypp stdlib_stats_moment.f90: stdlib_stats_moment.fypp +stdlib_stats_moment_all.f90: stdlib_stats_moment_all.fypp +stdlib_stats_moment_mask.f90: stdlib_stats_moment_mask.fypp +stdlib_stats_moment_scalar.f90: stdlib_stats_moment_scalar.fypp stdlib_stats_var.f90: stdlib_stats_var.fypp diff --git a/src/stdlib_ascii.f90 b/src/stdlib_ascii.f90 index c1b159bc7..220e241a2 100644 --- a/src/stdlib_ascii.f90 +++ b/src/stdlib_ascii.f90 @@ -60,6 +60,9 @@ module stdlib_ascii character(len=*), public, parameter :: lowercase = letters(27:) !! a .. z character(len=*), public, parameter :: whitespace = " "//TAB//VT//CR//LF//FF !! ASCII _whitespace + character(len=26), parameter, private :: lower_case = 'abcdefghijklmnopqrstuvwxyz' + character(len=26), parameter, private :: upper_case = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + contains !> Checks whether `c` is an ASCII letter (A .. Z, a .. z). @@ -135,7 +138,9 @@ pure logical function is_punctuation(c) pure logical function is_graphical(c) character(len=1), intent(in) :: c !! The character to test. integer :: ic - ic = iachar(c) ! '!' '~' + ic = iachar(c) + !The character is graphical if it's between '!' and '~' in the ASCII table, + !that is: printable but not a space is_graphical = (int(z'21') <= ic) .and. (ic <= int(z'7E')) end function @@ -144,14 +149,17 @@ pure logical function is_graphical(c) pure logical function is_printable(c) character(len=1), intent(in) :: c !! The character to test. integer :: ic - ic = iachar(c) ! '~' - is_printable = c >= ' ' .and. ic <= int(z'7E') + ic = iachar(c) + !The character is printable if it's between ' ' and '~' in the ASCII table + is_printable = ic >= iachar(' ') .and. ic <= int(z'7E') end function !> Checks whether `c` is a lowercase ASCII letter (a .. z). pure logical function is_lower(c) character(len=1), intent(in) :: c !! The character to test. - is_lower = (c >= 'a') .and. (c <= 'z') + integer :: ic + ic = iachar(c) + is_lower = ic >= iachar('a') .and. ic <= iachar('z') end function !> Checks whether `c` is an uppercase ASCII letter (A .. Z). @@ -159,7 +167,7 @@ pure logical function is_upper(c) character(len=1), intent(in) :: c !! The character to test. integer :: ic ic = iachar(c) - is_upper = (ic >= iachar('A')) .and. (ic <= iachar('Z')) + is_upper = ic >= iachar('A') .and. ic <= iachar('Z') end function !> Checks whether or not `c` is a whitespace character. That includes the @@ -169,7 +177,7 @@ pure logical function is_white(c) character(len=1), intent(in) :: c !! The character to test. integer :: ic ic = iachar(c) ! TAB, LF, VT, FF, CR - is_white = (ic == iachar(' ')) .or. (ic >= int(z'09') .and. ic <= int(z'0D')); + is_white = ic == iachar(' ') .or. (ic >= int(z'09') .and. ic <= int(z'0D')) end function !> Checks whether or not `c` is a blank character. That includes the @@ -178,31 +186,39 @@ pure logical function is_blank(c) character(len=1), intent(in) :: c !! The character to test. integer :: ic ic = iachar(c) ! TAB - is_blank = (ic == iachar(' ')) .or. (ic == int(z'09')); + is_blank = ic == iachar(' ') .or. ic == int(z'09') end function !> Returns the corresponding lowercase letter, if `c` is an uppercase ! ASCII character, otherwise `c` itself. pure function to_lower(c) result(t) character(len=1), intent(in) :: c !! A character. - character(len=1) :: t - integer :: diff - diff = iachar('A')-iachar('a') - t = c - ! if uppercase, make lowercase - if (is_upper(t)) t = achar(iachar(t) - diff) + character(len=1) :: t + integer :: k + + k = index( upper_case, c ) + + if ( k > 0 ) then + t = lower_case(k:k) + else + t = c + endif end function !> Returns the corresponding uppercase letter, if `c` is a lowercase ! ASCII character, otherwise `c` itself. pure function to_upper(c) result(t) character(len=1), intent(in) :: c !! A character. - character(len=1) :: t - integer :: diff - diff = iachar('A')-iachar('a') - t = c - ! if lowercase, make uppercase - if (is_lower(t)) t = achar(iachar(t) + diff) + character(len=1) :: t + integer :: k + + k = index( lower_case, c ) + + if ( k > 0 ) then + t = upper_case(k:k) + else + t = c + endif end function end module diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp new file mode 100644 index 000000000..ad52517ab --- /dev/null +++ b/src/stdlib_bitsets.fypp @@ -0,0 +1,2085 @@ +#:include "common.fypp" +module stdlib_bitsets +!! Implements zero based bitsets of size up to `huge(0_int32)`. +!! The current code uses 64 bit integers to store the bits and uses all 64 bits. +!! The code assumes two's complement integers, and treats negative integers as +!! having the sign bit set. +!!([Specification](../page/specs/stdlib_bitsets.html)) + + use :: stdlib_kinds, only: & + bits_kind => int32, & ! If changed change also max_digits, and + block_kind => int64, & ! overflow_bits + int8, & + int16, & + int32, & + int64 + + use, intrinsic :: & + iso_fortran_env, only: & + error_unit + + implicit none + + private + + integer(bits_kind), parameter :: & + block_size = bit_size(0_block_kind) + + public :: max_digits, overflow_bits + integer, parameter :: & + max_digits = 10 ! bits_kind == int32 +! max_digits = 19 ! bits_kind == int64 + + integer(bits_kind), parameter :: & + overflow_bits = 2_bits_kind**30/5 ! bits_kind == int32 +! overflow_bits = 2_bits_kind**62/5 ! bits_kind == int64 + + integer(block_kind), parameter :: all_zeros = 0_block_kind + integer(block_kind), parameter :: all_ones = not(all_zeros) + + character(*), parameter :: module_name = "STDLIB_BITSETS" + integer, parameter :: & + ia0 = iachar('0'), & + ia9 = iachar('9') + + integer, parameter, public :: success = 0 +!! Error flag indicating no errors + integer, parameter, public :: alloc_fault = 1 +!! Error flag indicating a memory allocation failure + integer, parameter, public :: array_size_invalid_error = 2 +!! Error flag indicating an invalid bits value + integer, parameter, public :: char_string_invalid_error = 3 +!! Error flag indicating an invalid character string + integer, parameter, public :: char_string_too_large_error = 4 +!! Error flag indicating a too large character string + integer, parameter, public :: char_string_too_small_error = 5 +!! Error flag indicating a too small character string + integer, parameter, public :: eof_failure = 6 +!! Error flag indicating unexpected End-of-File on a READ + integer, parameter, public :: index_invalid_error = 7 +!! Error flag indicating an invalid index + integer, parameter, public :: integer_overflow_error = 8 +!! Error flag indicating integer overflow + integer, parameter, public :: read_failure = 9 +!! Error flag indicating failure of a READ statement + integer, parameter, public :: write_failure = 10 +!! Error flag indicating a failure on a WRITE statement + + public :: bits_kind +! Public constant + + public :: & + bitset_type, & + bitset_large, & + bitset_64 + +! Public types + + public :: & + assignment(=), & + and, & + and_not, & + bits, & + extract, & + operator(==), & + operator(/=), & + operator(>), & + operator(>=), & + operator(<), & + operator(<=), & + or, & + xor +!! Public procedures + + public :: error_handler + + type, abstract :: bitset_type +!! version: experimental +!! +!! Parent type for bitset_64 and bitset_large ([Specification](../page/specs/stdlib_bitsets.html#the-stdlib_bitsets-derived-types)) + + private + integer(bits_kind) :: num_bits + + contains + + procedure(all_abstract), deferred, pass(self) :: all + procedure(any_abstract), deferred, pass(self) :: any + procedure(bit_count_abstract), deferred, pass(self) :: bit_count + procedure, pass(self) :: bits + procedure(clear_bit_abstract), deferred, pass(self) :: clear_bit + procedure(clear_range_abstract), deferred, pass(self) :: clear_range + generic :: clear => clear_bit, clear_range + procedure(flip_bit_abstract), deferred, pass(self) :: flip_bit + procedure(flip_range_abstract), deferred, pass(self) :: flip_range + generic :: flip => flip_bit, flip_range + procedure(from_string_abstract), deferred, pass(self) :: from_string + procedure(init_zero_abstract), deferred, pass(self) :: init_zero + generic :: init => init_zero + procedure(input_abstract), deferred, pass(self) :: input + procedure(none_abstract), deferred, pass(self) :: none + procedure(not_abstract), deferred, pass(self) :: not + procedure(output_abstract), deferred, pass(self) :: output + procedure(read_bitset_string_abstract), deferred, pass(self) :: & + read_bitset_string + procedure(read_bitset_unit_abstract), deferred, pass(self) :: & + read_bitset_unit + generic :: read_bitset => read_bitset_string, read_bitset_unit + procedure(set_bit_abstract), deferred, pass(self) :: set_bit + procedure(set_range_abstract), deferred, pass(self) :: set_range + generic :: set => set_bit, set_range + procedure(test_abstract), deferred, pass(self) :: test + procedure(to_string_abstract), deferred, pass(self) :: to_string + procedure(value_abstract), deferred, pass(self) :: value + procedure(write_bitset_string_abstract), deferred, pass(self) :: & + write_bitset_string + procedure(write_bitset_unit_abstract), deferred, pass(self) :: & + write_bitset_unit + generic :: write_bitset => write_bitset_string, write_bitset_unit + + end type bitset_type + + + abstract interface + + elemental function all_abstract( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. +!! +!!#### Example +!! +!!```fortran +!! program demo_all +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_all +!!``` + import :: bitset_type + logical :: all + class(bitset_type), intent(in) :: self + end function all_abstract + + elemental function any_abstract(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. +!! +!!#### Example +!! +!!```fortran +!! program demo_any +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( .not. set0 % any() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % any() ) then +!! write(*,*) "ANY interpreted SET0's value properly." +!! end if +!! end program demo_any +!!``` + import :: bitset_type + logical :: any + class(bitset_type), intent(in) :: self + end function any_abstract + + elemental function bit_count_abstract(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. +!! +!!#### Example +!! +!!```fortran +!! program demo_bit_count +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % bit_count() == 0 ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % bit_count() == 1 ) then +!! write(*,*) "BIT_COUNT interpreted SET0's value properly." +!! end if +!! end program demo_bit_count +!!``` + import :: bitset_type, bits_kind + integer(bits_kind) :: bit_count + class(bitset_type), intent(in) :: self + end function bit_count_abstract + + elemental subroutine clear_bit_abstract(self, pos) +!! Version: experimental +!! +!! Sets to zero the `pos` position in `self`. If `pos` is less than zero or +!! greater than `bits(self)-1` it is ignored. +!! +!!#### Example +!! +!!```fortran +!! program demo_clear +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % clear(0,164) +!! if ( set0 % none() ) write(*,*) 'All bits are cleared.' +!! end program demo_clear +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_abstract + + pure subroutine clear_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `set`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_abstract + + elemental subroutine flip_bit_abstract(self, pos) +!! Version: experimental +!! +!! 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. +!! +!!#### Example +!! +!!```fortran +!! program demo_flip +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % flip(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is flipped.' +!! call set0 % flip(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are flipped.' +!! end program demo_flip +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_abstract + + pure subroutine flip_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! 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. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_abstract + + subroutine from_string_abstract(self, string, status) +!! Version: experimental +!! +!! 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. +!! +!!#### Example +!! +!!```fortran +!! program demo_from_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_from_string +!!``` + import :: bitset_type + class(bitset_type), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_abstract + + subroutine init_zero_abstract(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, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`, or +!! +!!#### Example +!! +!!```fortran +!! program demo_init +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % bits() == 166 ) & +!! write(*,*) `SET0 has the proper size.' +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! end program demo_init +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_abstract + + subroutine input_abstract(self, unit, status) +!! Version: experimental +!! +!! 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 allocating 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` +!! +!!#### Example +!! +!!```fortran +!! program demo_input +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_input +!!``` + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_abstract + + elemental function none_abstract(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. +!! +!!#### Example +!! +!!```fortran +!! program demo_none +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_large) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( .not. set0 % none() ) then +!! write(*,*) "NONE interpreted SET0's value properly." +!! end if +!! end program demo_none +!!``` + import :: bitset_type + logical :: none + class(bitset_type), intent(in) :: self + end function none_abstract + + elemental subroutine not_abstract(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement +!! +!!#### Example +!! +!!```fortran +!! program demo_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init( 155 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % not() +!! if ( set0 % all() ) then +!! write(*,*) "ALL interpreted SET0's value properly." +!! end if +!! end program demo_not +!!``` + import :: bitset_type + class(bitset_type), intent(inout) :: self + end subroutine not_abstract + + subroutine output_abstract(self, unit, status) +!! Version: experimental +!! +!! 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. +!! +!!#### Example +!! +!!```fortran +!! program demo_output +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_output +!!``` + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_abstract + + subroutine read_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! 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, +!! +!!#### Example +!! +!!```fortran +!! program demo_read_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_read_bitset +!!``` + import :: bitset_type + class(bitset_type), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_abstract + + subroutine read_bitset_unit_abstract(self, unit, advance, status) +!! Version: experimental +!! +!! 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 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 reached 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, +! + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_abstract + + elemental subroutine set_bit_abstract(self, pos) +!! Version: experimental +!! +!! 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. +!! +!!#### Example +!! +!!```fortran +!! program demo_set +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! call set0 % set(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are set.' +!! end program demo_set +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_abstract + + pure subroutine set_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_abstract + + elemental function test_abstract(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self) - 1` the result is `.false.`. +!! +!!#### Example +!! +!!```fortran +!! program demo_test +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! end program demo_test +!!``` + import :: bitset_type, bits_kind + logical :: test + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_abstract + + subroutine to_string_abstract(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. +!! +!!#### Example +!! +!!```fortran +!! program demo_to_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! character(:), allocatable :: new_string +!! call set0 % init(33) +!! call set0 % not() +!! call set0 % to_string( new_string ) +!! if ( new_string == bits_all ) then +!! write(*,*) "TO_STRING transferred BITS0 properly" // & +!! " into NEW_STRING." +!! end if +!! end program demo_to_string +!!``` + import :: bitset_type + class(bitset_type), intent(in) :: self + character(:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_abstract + + elemental function value_abstract(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. +!! +!!#### Example +!! +!!```fortran +!! program demo_value +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( set0 % value(165) == 0 ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' +!! end program demo_value +!!``` + import :: bitset_type, bits_kind + integer :: value + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_abstract + + subroutine write_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_type`, `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. +!! +!!#### Example +!! +!!```fortran +!! program demo_write_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_write_bitset +!!``` + import :: bitset_type + class(bitset_type), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_abstract + + subroutine write_bitset_unit_abstract(self, unit, advance, & + status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the `bitset_t`, `self`. If an error occurs then +!! processing stops with a message to `error_unit`. 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, +!! `write_failure` if the `write` statement outputting the literal failed. + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_abstract + + end interface + + type, extends(bitset_type) :: bitset_large +!! Version: experimental +!! +!! Type for bitsets with more than 64 bits ([Specification](../page/specs/stdlib_bitsets.html#the-stdlib_bitsets-derived-types)) + + private + integer(block_kind), private, allocatable :: blocks(:) + + contains + + procedure, pass(self) :: all => all_large + procedure, pass(self) :: any => any_large + procedure, pass(self) :: bit_count => bit_count_large + procedure, pass(self) :: clear_bit => clear_bit_large + procedure, pass(self) :: clear_range => clear_range_large + procedure, pass(self) :: flip_bit => flip_bit_large + procedure, pass(self) :: flip_range => flip_range_large + procedure, pass(self) :: from_string => from_string_large + procedure, pass(self) :: init_zero => init_zero_large + procedure, pass(self) :: input => input_large + procedure, pass(self) :: none => none_large + procedure, pass(self) :: not => not_large + procedure, pass(self) :: output => output_large + procedure, pass(self) :: & + read_bitset_string => read_bitset_string_large + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_large + procedure, pass(self) :: set_bit => set_bit_large + procedure, pass(self) :: set_range => set_range_large + procedure, pass(self) :: test => test_large + procedure, pass(self) :: to_string => to_string_large + procedure, pass(self) :: value => value_large + procedure, pass(self) :: & + write_bitset_string => write_bitset_string_large + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_large + + end type bitset_large + + + interface + + elemental module function all_large( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_large), intent(in) :: self + end function all_large + + elemental module function any_large(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_large), intent(in) :: self + end function any_large + + elemental module function bit_count_large(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + end function bit_count_large + + elemental module subroutine clear_bit_large(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `pos` position in `self`. If `pos` is less than +!! zero or greater than `bits(self)-1` it is ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_large + + pure module subroutine clear_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! 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(set)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_large + + elemental module subroutine flip_bit_large(self, pos) +!! Version: experimental +!! +!! Flips the bit 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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_large + + pure module subroutine flip_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! 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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_large + + module subroutine from_string_large(self, string, status) +!! Version: experimental +!! +!! 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_large), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_large + + module subroutine init_zero_large(self, bits, status) +!! Version: experimental +!! +!! 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, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`, or + class(bitset_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_large + + module subroutine input_large(self, unit, status) +!! Version: experimental +!! +!! 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 allocating 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_large), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_large + + elemental module function none_large(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_large), intent(in) :: self + end function none_large + + elemental module subroutine not_large(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement + class(bitset_large), intent(inout) :: self + end subroutine not_large + + module subroutine output_large(self, unit, status) +!! Version: experimental +!! +!! 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_large), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_large + + module subroutine read_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! 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_large), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_large + + module subroutine read_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! 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 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 reached 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_large), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_large + + elemental module subroutine set_bit_large(self, pos) +!! Version: experimental +!! +!! 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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_large + + pure module subroutine set_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_large + + elemental module function test_large(self, pos) result(test) +!! Version: experimental +!! +!! 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_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_large + + module subroutine to_string_large(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_large + + elemental module function value_large(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. + integer :: value + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_large + + module subroutine write_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the bitset_large, `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_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_large + + module subroutine write_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `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_large), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_large + + end interface + + + interface assignment(=) +!! Version: experimental +!! +!! Used to define assignment for `bitset_large`. +!! ([Specification](../page/specs/stdlib_bitsets.html#-compare-two-bitsets-to-determine-whether-the-bits-have-the-same-value)) +!! +!!#### Example +!! +!!```fortran +!! program demo_assignment +!! use stdlib_bitsets +!! logical(int8) :: logical1(64) = .true. +!! logical(int32), allocatable :: logical2(:) +!! type(bitset_64) :: set0, set1 +!! set0 = logical1 +!! if ( set0 % bits() /= 64 ) then +!! error stop procedure // & +!! ' initialization with logical(int8) failed to set' // & +!! ' the right size.' +!! else if ( .not. set0 % all() ) then +!! error stop procedure // ' initialization with' // & +!! ' logical(int8) failed to set the right values.' +!! else +!! write(*,*) 'Initialization with logical(int8) succeeded.' +!! end if +!! set1 = set0 +!! if ( set1 == set0 ) & +!! write(*,*) 'Initialization by assignment succeeded' +!! logical2 = set1 +!! if ( all( logical2 ) ) then +!! write(*,*) 'Initialization of logical(int32) succeeded.' +!! end if +!! end program demo_assignment +!!``` + + pure module subroutine assign_large( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_large`. + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine assign_large + + #:for k1 in INT_KINDS + pure module subroutine assign_log${k1}$_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(${k1}$)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(${k1}$), intent(in) :: logical_vector(:) + end subroutine assign_log${k1}$_large + + pure module subroutine log${k1}$_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(${k1}$)` from a +!! `bitset_large`. + logical(${k1}$), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine log${k1}$_assign_large + #:endfor + + end interface assignment(=) + + + type, extends(bitset_type) :: bitset_64 +!! Version: experimental +!! +!! Type for bitsets with no more than 64 bits ([Specification](../page/specs/stdlib_bitsets.html#the-stdlib_bitsets-derived-types)) + private + integer(block_kind), private :: block = 0 + + contains + + procedure, pass(self) :: all => all_64 + procedure, pass(self) :: any => any_64 + procedure, pass(self) :: bit_count => bit_count_64 + procedure, pass(self) :: clear_bit => clear_bit_64 + procedure, pass(self) :: clear_range => clear_range_64 + procedure, pass(self) :: flip_bit => flip_bit_64 + procedure, pass(self) :: flip_range => flip_range_64 + procedure, pass(self) :: from_string => from_string_64 + procedure, pass(self) :: init_zero => init_zero_64 + procedure, pass(self) :: input => input_64 + procedure, pass(self) :: none => none_64 + procedure, pass(self) :: not => not_64 + procedure, pass(self) :: output => output_64 + procedure, pass(self) :: read_bitset_string => read_bitset_string_64 + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_64 + procedure, pass(self) :: set_bit => set_bit_64 + procedure, pass(self) :: set_range => set_range_64 + procedure, pass(self) :: test => test_64 + procedure, pass(self) :: to_string => to_string_64 + procedure, pass(self) :: value => value_64 + procedure, pass(self) :: write_bitset_string => write_bitset_string_64 + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_64 + + end type bitset_64 + + + interface + + elemental module function all_64( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_64), intent(in) :: self + end function all_64 + + elemental module function any_64(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_64), intent(in) :: self + end function any_64 + + elemental module function bit_count_64(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_64), intent(in) :: self + end function bit_count_64 + + elemental module subroutine clear_bit_64(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `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 + end subroutine clear_bit_64 + + pure module subroutine clear_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! 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(set)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_64 + + elemental module subroutine flip_bit_64(self, pos) +!! Version: experimental +!! +!! Flips the bit 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 + end subroutine flip_bit_64 + + pure module subroutine flip_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! 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 + end subroutine flip_range_64 + + module subroutine from_string_64(self, string, status) +!! Version: experimental +!! +!! 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 + end subroutine from_string_64 + + module subroutine init_zero_64(self, bits, status) +!! Version: experimental +!! +!! 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, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`. + class(bitset_64), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_64 + + module subroutine input_64(self, unit, status) +!! Version: experimental +!! +!! 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 allocating 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 + end subroutine input_64 + + elemental module function none_64(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_64), intent(in) :: self + end function none_64 + + elemental module subroutine not_64(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement. + class(bitset_64), intent(inout) :: self + end subroutine not_64 + + module subroutine output_64(self, unit, status) +!! Version: experimental +!! +!! 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 + end subroutine output_64 + + module subroutine read_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! 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 + end subroutine read_bitset_string_64 + + module subroutine read_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! 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 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 reached 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 + end subroutine read_bitset_unit_64 + + elemental module subroutine set_bit_64(self, pos) +!! Version: experimental +!! +!! 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 + end subroutine set_bit_64 + + pure module subroutine set_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < 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 + end subroutine set_range_64 + + elemental module function test_64(self, pos) result(test) +!! Version: experimental +!! +!! 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 + end function test_64 + + module subroutine to_string_64(self, string, status) +!! Version: experimental +!! +!! 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 + end subroutine to_string_64 + + elemental module function value_64(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set)-1` the result is 0. + integer :: value + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_64 + + module subroutine write_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_64`, `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 + end subroutine write_bitset_string_64 + + module subroutine write_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `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 + end subroutine write_bitset_unit_64 + + end interface + + + interface assignment(=) + + pure module subroutine assign_64( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_64`. + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine assign_64 + + #:for k1 in INT_KINDS + module subroutine assign_log${k1}$_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(${k1}$)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(${k1}$), intent(in) :: logical_vector(:) + end subroutine assign_log${k1}$_64 + + pure module subroutine log${k1}$_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(${k1}$)` from a +!! `bitset_64`. + logical(${k1}$), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine log${k1}$_assign_64 + #:endfor + + end interface assignment(=) + + + interface and +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. +!! ([Specification](../page/specs/stdlib_bitsets.html#and-bitwise-and-of-the-bits-of-two-bitsets)) +!! +!!#### Example +!! +!!```fortran +!! program demo_and +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all none +!! if ( none(set0) ) write(*,*) 'Second test of AND worked.' +!! call set1 % not() +!! call and( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' +!! end program demo_and +!!``` + elemental module subroutine and_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_large + + elemental module subroutine and_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_64 + + end interface and + + + interface and_not +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` +!! with the bitwise negation of `set2`. The sets must have the same +!! number of bits otherwise the result is undefined. +!! +!! ([Specification](../page/specs/stdlib_bitsets.html#and_not-bitwise-and-of-one-bitset-with-the-negation-of-another)) +!! +!!#### Example +!! +!!```fortran +!! program demo_and_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and_not( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of AND_NOT worked.' +!! call set0 % not() +!! call set1 % not() +!! call and_not( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' +!! end program demo_and_not +!!``` + + elemental module subroutine and_not_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_not_large + + elemental module subroutine and_not_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_not_64 + + end interface and_not + + interface extract +!! Version: experimental +!! +!! 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` and `new` is undefined, otherwise processing stops +!! with an informative message. +!! ([Specification](../page/specs/stdlib_bitsets.html#extract-create-a-new-bitset-from-a-range-in-an-old-bitset)) +!! +!!#### Example +!! +!!```fortran +!! program demo_extract +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set0 % set(100,150) +!! call extract( set1, set0, 100, 150) +!! if ( set1 % bits() == 51 ) & +!! write(*,*) 'SET1 has the proper size.' +!! if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' +!! end program demo_extract +!!``` + + module subroutine extract_large(new, old, start_pos, stop_pos, status) + type(bitset_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + end subroutine extract_large + + module subroutine extract_64(new, old, start_pos, stop_pos, status) + 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 + end subroutine extract_64 + + end interface extract + + + interface or +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. +!! ([Specification](../page/specs/stdlib_bitsets.html#or-bitwise-or-of-the-bits-of-two-bitsets)) +!! +!!#### Example +!! +!!```fortran +!! program demo_or +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call or( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of OR worked.' +!! call set0 % not() +!! call set1 % not() +!! call or( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' +!! end program demo_or +!!``` + elemental module subroutine or_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine or_large + + elemental module subroutine or_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine or_64 + + end interface or + + + interface xor +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#xor-bitwise-exclusive-or)) +!! +!!#### Example +!! +!!```fortran +!! program demo_xor +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call xor( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of XOR worked.' +!! call set0 % not() +!! call set1 % not() +!! call xor( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' +!! end program demo_xor +!!``` + elemental module subroutine xor_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine xor_large + + elemental module subroutine xor_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine xor_64 + + end interface xor + + + interface operator(==) +!! Version: experimental +!! +!! 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 result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#-compare-two-bitsets-to-determine-whether-the-bits-have-the-same-value)) +!! +!!#### Example +!! +!!```fortran +!! program demo_equality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & +!! .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & +!! set1 == set2 ) then +!! write(*,*) 'Passed 64 bit equality tests.' +!! else +!! error stop 'Failed 64 bit equality tests.' +!! end if +!! end program demo_equality +!!``` + elemental module function eqv_large(set1, set2) result(eqv) + logical :: eqv + type(bitset_large), intent(in) :: set1, set2 + end function eqv_large + + elemental module function eqv_64(set1, set2) result(eqv) + logical :: eqv + type(bitset_64), intent(in) :: set1, set2 + end function eqv_64 + + end interface operator(==) + + + interface operator(/=) +!! Version: experimental +!! +!! Returns `.true.` if not all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#-compare-two-bitsets-to-determine-whether-any-bits-differ-in-value)) +!! +!!#### Example +!! +!!```fortran +!! program demo_inequality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 /= set1 .and. set0 /= set2 .and. set1 /= set2 .and. & +!! .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & +!! set2 /= set2 ) then +!! write(*,*) 'Passed 64 bit inequality tests.' +!! else +!! error stop 'Failed 64 bit inequality tests.' +!! end if +!! end program demo_inequality +!!``` + elemental module function neqv_large(set1, set2) result(neqv) + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + end function neqv_large + + elemental module function neqv_64(set1, set2) result(neqv) + logical :: neqv + type(bitset_64), intent(in) :: set1, set2 + end function neqv_64 + + end interface operator(/=) + + + interface operator(>) +!! Version: experimental +!! +!! 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 result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#gt-compare-two-bitsets-to-determine-whether-the-first-is-greater-than-the-other)) +!! +!!#### Example +!! +!!```fortran +!! program demo_gt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 > set0 .and. set2 > set1 .and. set2 > set0 .and. & +!! .not. set0 > set0 .and. .not. set0 > set1 .and. .not. & +!! set1 > set2 ) then +!! write(*,*) 'Passed 64 bit greater than tests.' +!! else +!! error stop 'Failed 64 bit greater than tests.' +!! end if +!! end program demo_gt +!!``` + elemental module function gt_large(set1, set2) result(gt) + logical :: gt + type(bitset_large), intent(in) :: set1, set2 + end function gt_large + + elemental module function gt_64(set1, set2) result(gt) + logical :: gt + type(bitset_64), intent(in) :: set1, set2 + end function gt_64 + + end interface operator(>) + + + interface operator(>=) +!! Version: experimental +!! +!! 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 result is undefined. +!! ([Specification](../page/specs/stdlib_bitsets.html#gt-compare-two-bitsets-to-determine-whether-the-first-is-greater-than-or-equal-to-the-second)) +!! +!!#### Example +!! +!!```fortran +!! program demo_ge +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 >= set0 .and. set2 >= set1 .and. set2 >= set0 .and. & +!! set0 >= set0 .and. set1 >= set1 .and. set2 >= set2 .and. & +!! .not. set0 >= set1 .and. .not. set0 >= set2 .and. .not. & +!! set1 >= set2 ) then +!! write(*,*) 'Passed 64 bit greater than or equals tests.' +!! else +!! error stop 'Failed 64 bit greater than or equals tests.' +!! end if +!! end program demo_ge +!!``` + elemental module function ge_large(set1, set2) result(ge) + logical :: ge + type(bitset_large), intent(in) :: set1, set2 + end function ge_large + + elemental module function ge_64(set1, set2) result(ge) + logical :: ge + type(bitset_64), intent(in) :: set1, set2 + end function ge_64 + + end interface operator(>=) + + + interface operator(<) +!! Version: experimental +!! +!! 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 result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#lt-compare-two-bitsets-to-determine-whether-the-first-is-less-than-the-other)) +!! +!!#### Example +!! +!!```fortran +!! program demo_lt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 < set1 .and. set1 < set2 .and. set0 < set2 .and. & +!! .not. set0 < set0 .and. .not. set2 < set0 .and. .not. & +!! set2 < set1 ) then +!! write(*,*) 'Passed 64 bit less than tests.' +!! else +!! error stop 'Failed 64 bit less than tests.' +!! end if +!! end program demo_lt +!!``` + elemental module function lt_large(set1, set2) result(lt) + logical :: lt + type(bitset_large), intent(in) :: set1, set2 + end function lt_large + + elemental module function lt_64(set1, set2) result(lt) + logical :: lt + type(bitset_64), intent(in) :: set1, set2 + end function lt_64 + + end interface operator(<) + + + interface operator(<=) +!! Version: experimental +!! +!! 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 result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#lt-compare-two-bitsets-to-determine-whether-the-first-is-less-than-or-equal-to-the-other)) +!! +!!#### Example +!! +!!```fortran +!! program demo_le +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 <= set1 .and. set1 <= set2 .and. set0 <= set2 .and. & +!! set0 <= set0 .and. set1 <= set1 .and. set2 <= set2 .and. & +!! .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & +!! set2 <= set1 ) then +!! write(*,*) 'Passed 64 bit less than or equal tests.' +!! else +!! error stop 'Failed 64 bit less than or equal tests.' +!! end if +!! end program demo_le +!!``` + elemental module function le_large(set1, set2) result(le) + logical :: le + type(bitset_large), intent(in) :: set1, set2 + end function le_large + + elemental module function le_64(set1, set2) result(le) + logical :: le + type(bitset_64), intent(in) :: set1, set2 + end function le_64 + + end interface operator(<=) + + interface error_handler + module subroutine error_handler( message, error, status, & + module, procedure ) + character(*), intent(in) :: message + integer, intent(in) :: error + integer, intent(out), optional :: status + character(*), intent(in), optional :: module + character(*), intent(in), optional :: procedure + end subroutine error_handler + end interface error_handler + +contains + + elemental function bits(self) +!! Version: experimental +!! +!! Returns the number of bit positions in `self`. + integer(bits_kind) :: bits + class(bitset_type), intent(in) :: self + + bits = self % num_bits + + return + end function bits + + module subroutine error_handler( message, error, status, module, procedure ) + character(*), intent(in) :: message + integer, intent(in) :: error + integer, intent(out), optional :: status + character(*), intent(in), optional :: module + character(*), intent(in), optional :: procedure + + if ( present(status) ) then + status = error + else + if ( present(module) ) then + if ( present(procedure) ) then + write(error_unit, '(a)') trim(module) // ' % ' // & + trim(procedure) // ': ' // trim(message) + else + write(error_unit, '(a)') trim(module) // ' % N/A: ' // & + trim(message) + end if + else if ( present(procedure) ) then + write(error_unit, '(a)') trim(procedure) // ': ' // & + trim(message) + else + write(error_unit, '(a)') trim(message) + end if + select case(error) + case( alloc_fault ) + error stop 'A memory allocation failed.' + case( array_size_invalid_error ) + error stop "An array size was invalid." + case( char_string_invalid_error ) + error stop "A character string had an invalid character." + case( char_string_too_large_error ) + error stop "A character string was too large." + case( char_string_too_small_error ) + error stop "A character string was too small." + case( eof_failure ) + error stop "An End-Of-File failure occurred on a READ " // & + "statement." + case( index_invalid_error ) + error stop "An index was invalid." + case( integer_overflow_error ) + error stop "An integer overflow error occurred." + case( read_failure ) + error stop "A failure occurred in a READ statement." + case( write_failure ) + error stop "A failure occurred on a WRITE statement." + end select + end if + end subroutine error_handler + + +end module stdlib_bitsets diff --git a/src/stdlib_bitsets_64.fypp b/src/stdlib_bitsets_64.fypp new file mode 100644 index 000000000..3cdd0b17a --- /dev/null +++ b/src/stdlib_bitsets_64.fypp @@ -0,0 +1,1122 @@ +#: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 + + + pure module subroutine assign_64( set1, set2 ) +! Used to define assignment for bitset_64 + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + set1 % block = set2 % block + + end subroutine assign_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 + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + end if + 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 + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + 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 diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp new file mode 100644 index 000000000..2bcd1c659 --- /dev/null +++ b/src/stdlib_bitsets_large.fypp @@ -0,0 +1,1347 @@ +#:include "common.fypp" +submodule(stdlib_bitsets) stdlib_bitsets_large + implicit none + +contains + + + elemental module function all_large( self ) result(all) +! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. + logical :: all + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block, full_blocks, pos + + all = .true. + full_blocks = bits(self)/block_size + do block = 1_bits_kind, full_blocks + if ( self % blocks(block) /= -1_block_kind ) then + all = .false. + return + end if + end do + + if ( full_blocks == size(self % blocks) ) return + + do pos=0_bits_kind, modulo( bits(self), block_size )-1 + if ( .not. btest(self % blocks(full_blocks+1), pos) ) then + all = .false. + return + end if + end do + + end function all_large + + + elemental module subroutine and_large(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_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) + set1 % blocks(block_) = iand( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine and_large + + + elemental module subroutine and_not_large(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_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size( set1 % blocks, kind=bits_kind ) + set1 % blocks(block_) = & + iand( set1 % blocks(block_), not( set2 % blocks(block_) ) ) + end do + + end subroutine and_not_large + + + elemental module function any_large(self) result(any) +! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. + logical :: any + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind) + if ( self % blocks(block_) /= 0 ) then + any = .true. + return + end if + end do + any = .false. + + end function any_large + + + pure module subroutine assign_large( set1, set2 ) +! Used to define assignment for bitset_large + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + allocate( set1 % blocks( size( set2 % blocks, kind=bits_kind ) ) ) + set1 % blocks(:) = set2 % blocks(:) + + end subroutine assign_large + + #:for k1 in INT_KINDS + pure module subroutine assign_log${k1}$_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(${k1}$), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + self % num_bits = log_size + if ( log_size == 0 ) then + blocks = 0 + else + blocks = (log_size-1)/block_size + 1 + end if + allocate( self % blocks( blocks ) ) + self % blocks(:) = 0 + + do index=0_bits_kind, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_log${k1}$_large + + + pure module subroutine log${k1}$_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(${k1}$), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0_bits_kind, 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_large + #:endfor + + + elemental module function bit_count_large(self) result(bit_count) +! Returns the number of non-zero bits in SELF. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block_, pos + + bit_count = 0 + do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind) - 1 + do pos = 0, block_size-1 + if ( btest( self % blocks(block_), pos ) ) & + bit_count = bit_count + 1 + end do + + end do + + do pos = 0_bits_kind, self % num_bits - (block_-1)*block_size - 1 + if ( btest( self % blocks(block_), pos ) ) bit_count = bit_count + 1 + end do + + end function bit_count_large + + + elemental module subroutine clear_bit_large(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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer :: clear_block, block_bit + + if ( pos < 0 .OR. (pos > self % num_bits-1) ) return + clear_block = pos / block_size + 1 + block_bit = pos - (clear_block - 1) * block_size + self % blocks(clear_block) = & + ibclr( self % blocks(clear_block), block_bit ) + + end subroutine clear_bit_large + + + pure module subroutine clear_range_large(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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, first_block, last_block, & + 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 + + first_block = true_first / block_size + 1 + last_block = true_last / block_size + 1 + if ( first_block == last_block ) then +! TRUE_FIRST and TRUE_LAST are in the same block + call mvbits( all_zeros, & + true_first - (first_block-1)*block_size, & + true_last - true_first + 1, & + self % blocks(first_block), & + true_first - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = true_first - (first_block-1)*block_size + call mvbits( all_zeros, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = true_last - (last_block-1)*block_size + call mvbits( all_zeros, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do intermediate blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_zeros + end do + + end subroutine clear_range_large + + + elemental module function eqv_large(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_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block, common_blocks + + eqv = .false. + common_blocks = size(set1 % blocks, kind=bits_kind) + do block = 1, common_blocks + if ( set1 % blocks(block) /= set2 % blocks(block) ) return + end do + eqv = .true. + + end function eqv_large + + + module subroutine extract_large(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_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + + integer(bits_kind) :: bits, blocks, ex_block, i, j, k, old_block + 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 + allocate( new % blocks(0) ) + return + end if + + blocks = ((bits-1) / block_size) + 1 + + new % num_bits = bits + allocate( new % blocks(blocks) ) + new % blocks(:) = 0 + + do i=0_bits_kind, bits-1 + ex_block = i / block_size + 1 + j = i - (ex_block-1) * block_size + old_block = (start_pos + i) / block_size + 1 + k = (start_pos + i) - (old_block-1) * block_size + if ( btest( old % blocks(old_block), k ) ) then + new % blocks(ex_block) = ibset(new % blocks(ex_block), j) + end if + end do + + if ( present(status) ) status = success + + end subroutine extract_large + + + elemental module subroutine flip_bit_large(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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: flip_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + flip_block = pos / block_size + 1 + block_bit = pos - (flip_block - 1) * block_size + if ( btest( self % blocks(flip_block), block_bit ) ) then + self % blocks(flip_block) = ibclr( self % blocks(flip_block), & + block_bit ) + else + self % blocks(flip_block) = ibset( self % blocks(flip_block), & + block_bit ) + end if + + end subroutine flip_bit_large + + + pure module subroutine flip_range_large(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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & + 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_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if (first_block == last_block) then +! FIRST and LAST are in the same block + call mvbits( not(self % blocks(first_block)), & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( not(self % blocks(first_block) ), & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( not( self % blocks(last_block) ), & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = not( self % blocks(block_) ) + end do + + end subroutine flip_range_large + + module subroutine from_string_large(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_large), 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 > huge(0_bits_kind) ) then + call error_handler( 'STRING was too long for a ' // & + 'BITSET_LARGE SELF.', & + char_string_too_large_error, status, & + module_name, procedure ) + return + end if + + call init_zero_large( self, int(bits, kind=bits_kind), status ) + + if ( present(status) ) then + if ( status /= success ) return + end if + + do bit = 1_bits_kind, 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_large + + + elemental module function ge_large(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_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( bgt(set1 % blocks(block_), set2 % blocks(block_) ) ) then + ge = .true. + return + else + ge = .false. + return + end if + end do + ge = .true. + + end function ge_large + + + elemental module function gt_large(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_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( bgt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then + gt = .true. + return + else + gt = .false. + return + end if + end do + gt = .false. + + end function gt_large + + + module subroutine init_zero_large(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_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + + character(len=120) :: message + character(*), parameter :: procedure = "INIT" + integer :: blocks, ierr + + message = '' + 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 == 0) then + self % num_bits = 0 + allocate( self % blocks(0), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + return + else + blocks = ((bits-1) / block_size) + 1 + end if + + self % num_bits = bits + allocate( self % blocks(blocks), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + + self % blocks(:) = all_zeros + + if ( present(status) ) status = success + + return + +998 call error_handler( 'Allocation failure for SELF.', & + alloc_fault, status, & + module_name, procedure ) + + end subroutine init_zero_large + + + module subroutine input_large(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_large), 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 + + 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 % blocks(:) + 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_large + + + elemental module function le_large(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_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( blt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then + le = .true. + return + else + le = .false. + return + end if + end do + + le = .true. + + end function le_large + + + elemental module function lt_large(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_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( blt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then + lt = .true. + return + else + lt = .false. + return + end if + end do + lt = .false. + + end function lt_large + + + elemental module function neqv_large(set1, set2) result(neqv) +! +! Returns .TRUE. if any bits in SET1 and SET2 differ in value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + neqv = .true. + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) + if ( set1 % blocks(block_) /= set2 % blocks(block_) ) return + end do + neqv = .false. + + end function neqv_large + + + elemental module function none_large(self) result(none) +! +! Returns .TRUE. if none of the bits in SELF have the value 1. +! + logical :: none + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block + + none = .true. + do block = 1_bits_kind, size(self % blocks, kind=bits_kind) + if (self % blocks(block) /= 0) then + none = .false. + return + end if + end do + + end function none_large + + + elemental module subroutine not_large(self) +! +! Sets the bits in SELF to their logical complement +! + class(bitset_large), intent(inout) :: self + + integer(bits_kind) :: bit, full_blocks, block + integer :: remaining_bits + + if ( self % num_bits == 0 ) return + full_blocks = self % num_bits / block_size + do block = 1_bits_kind, full_blocks + self % blocks(block) = not( self % blocks(block) ) + end do + remaining_bits = self % num_bits - full_blocks * block_size + + do bit=0, remaining_bits - 1 + if ( btest( self % blocks( block ), bit ) ) then + self % blocks( block ) = ibclr( self % blocks(block), bit ) + else + self % blocks( block ) = ibset( self % blocks(block), bit ) + end if + end do + + end subroutine not_large + + + elemental module subroutine or_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise OR 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_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1, size( set1 % blocks, kind=bits_kind ) + set1 % blocks(block_) = ior( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine or_large + + + module subroutine output_large(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_large), 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 % blocks(:) + 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_large + + + module subroutine read_bitset_string_large(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_large), 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_bits_kind, len(string, kind=bits_kind) + 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 + call error_handler( 'There was an invalid character ' // & + 'in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) + return + end select + + pos = pos + 1 + end do + + 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 ) + 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_large + + + module subroutine read_bitset_unit_large(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_large), 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=997, & + end=998, & + 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 + + call self % init( bits, status ) + if ( present(status) ) then + call error_handler( 'There was an allocation fault for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if + 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 + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + end if + + 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_large + + + elemental module subroutine set_bit_large(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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: set_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + set_block = pos / block_size + 1 + block_bit = pos - (set_block - 1) * block_size + self % blocks(set_block) = ibset( self % blocks(set_block), block_bit ) + + end subroutine set_bit_large + + + pure module subroutine set_range_large(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_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & + 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_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if ( first_block == last_block ) then +! FIRST and LAST are in the same block + call mvbits( all_ones, & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( all_ones, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( all_ones, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_ones + end do + + end subroutine set_range_large + + + elemental module function test_large(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_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + test = .false. + else + bit_block = pos / block_size + 1 + test = btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) + end if + + end function test_large + + + module subroutine to_string_large(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_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'TO_STRING' + integer(bits_kind) :: bit, bit_count, pos + integer :: 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_bits_kind, bit_count-1 + pos = bit_count - bit + if ( self % test( bit) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + end subroutine to_string_large + + + elemental module function value_large(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_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + value = 0 + else + bit_block = pos / block_size + 1 + if ( btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) ) then + value = 1 + else + value = 0 + end if + end if + + end function value_large + + + module subroutine write_bitset_string_large(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_large), 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_bits_kind, bit_count-1 + pos = count_digits + 2 + bit_count - bit + if ( self % test( 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_large + + + module subroutine write_bitset_unit_large(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_large), 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 + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + 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_large + + + elemental module subroutine xor_large(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_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) + set1 % blocks(block_) = ieor( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine xor_large + +end submodule stdlib_bitsets_large diff --git a/src/stdlib_logger.f90 b/src/stdlib_logger.f90 index 4ffd85c13..70f83b94b 100644 --- a/src/stdlib_logger.f90 +++ b/src/stdlib_logger.f90 @@ -68,6 +68,28 @@ module stdlib_logger unopened_in_error = 7, & write_failure = 8 + integer, parameter, public :: & + debug_level = 10, & + information_level = 20, & + warning_level = 30, & + error_level = 40, & + io_error_level = 40, & + text_error_level = 50, & + all_level = -10 + min( & + debug_level, & + information_level, & + warning_level, & + error_level, & + io_error_level, & + text_error_level), & + none_level = 10 + max( & + debug_level, & + information_level, & + warning_level, & + error_level, & + io_error_level, & + text_error_level) + character(*), parameter :: module_name = 'stdlib_logger' type :: logger_type @@ -76,12 +98,13 @@ module stdlib_logger !! Public derived type ([Specification](../page/specs/stdlib_logger.html#the-derived-type-logger_type)) private - logical :: add_blank_line = .false. - logical :: indent_lines = .true. - integer, allocatable :: log_units(:) - integer :: max_width = 0 - logical :: time_stamp = .true. - integer :: units = 0 + logical :: add_blank_line = .false. + logical :: indent_lines = .true. + integer :: level = information_level + integer, allocatable :: log_units(:) + integer :: max_width = 0 + logical :: time_stamp = .true. + integer :: units = 0 contains @@ -91,6 +114,7 @@ module stdlib_logger procedure, public, pass(self) :: add_log_unit procedure, public, pass(self) :: configuration procedure, public, pass(self) :: configure + procedure, public, pass(self) :: log_debug procedure, public, pass(self) :: log_error procedure, public, pass(self) :: log_information procedure, public, pass(self) :: log_io_error @@ -121,8 +145,8 @@ subroutine add_log_file( self, filename, unit, action, position, status, & !! array. `action`, if present, is the `action` specifier of the `open` !! statement, and has the default value of `"write"`. `position`, if present, !! is the `position` specifier, and has the default value of `"REWIND"`. -!! `status`, if present, is the `status` specifier of the `open` statement, and -!! has the default value of `"REPLACE"`. `stat`, if present, has the value +!! `status`, if present, is the `status` specifier of the `open` statement, +!! and has the default value of `"REPLACE"`. `stat`, if present, has the value !! `success` if `filename` could be opened, `read_only_error` if `action` is !! `"read"`, and `open_failure` otherwise. !!([Specification](../page/specs/stdlib_logger.html#add_log_file-open-a-file-and-add-its-unit-to-self-log_units)) @@ -141,7 +165,8 @@ subroutine add_log_file( self, filename, unit, action, position, status, & integer, intent(out), optional :: stat !! The error status on exit with the possible values !! * `success` - no errors found -!! * `Rrea_only_error` - file unopened as `action1 was `"read"` for an output file +!! * `read_only_error` - file unopened as `action1 was `"read"` for an output +!! file !! * `open_failure` - the `open` statement failed @@ -236,8 +261,8 @@ subroutine add_log_unit( self, unit, stat ) !! version: experimental !! Adds `unit` to the log file units in `log_units`. `unit` must be an `open` -!! file, of `form` `"formatted"`, with `"sequential"` `access`, and an `action` of -!! `"write"` or `"readwrite"`, otherwise either `stat`, if preseent, has a +!! file, of `form` `"formatted"`, with `"sequential"` `access`, and an `action` +!! of `"write"` or `"readwrite"`, otherwise either `stat`, if present, has a !! value other than `success` and `unit` is not entered into `log_units`, !! or, if `stat` is not presecn, processing stops. !!([Specification](../page/specs/stdlib_logger.html#add_log_unit-add-a-unit-to-the-array-self-log_units)) @@ -263,7 +288,7 @@ subroutine add_log_unit( self, unit, stat ) !! integer :: iostat, unit, stat !! ... !! open( newunit=unit, 'error_log.txt', form='formatted', & -!! status='replace', position='rewind', err=999, & +!! status='replace', position='rewind', err=999, & !! action='read', iostat=iostat, iomsg=iomsg ) !! ... !! call global_logger % add_log_unit( unit, stat ) @@ -377,7 +402,7 @@ end subroutine validate_unit end subroutine add_log_unit - pure subroutine configuration( self, add_blank_line, indent, & + pure subroutine configuration( self, add_blank_line, indent, level, & max_width, time_stamp, log_units ) !! version: experimental @@ -387,12 +412,13 @@ pure subroutine configuration( self, add_blank_line, indent, & !! starts with a blank line, and `.false.` implying no blank line. !! 2. `indent` is a logical flag with `.true.` implying that subsequent columns !! will be indented 4 spaces and `.false.` implying no indentation. -!! 3. `max_width` is the maximum number of columns of output text with +!! 3. `level` is the lowest level for printing a message +!! 4. `max_width` is the maximum number of columns of output text with !! `max_width` == 0 => no bounds on output width. -!! 4. `time_stamp` is a logical flag with `.true.` implying that the output +!! 5. `time_stamp` is a logical flag with `.true.` implying that the output !! will have a time stamp, and `.false.` implying that there will be no !! time stamp. -!! 5. `log_units` is an array of the I/O unit numbers to which log output +!! 6. `log_units` is an array of the I/O unit numbers to which log output !! will be written. !!([Specification](../page/specs/stdlib_logger.html#configuration-report-a-loggers-configuration)) @@ -402,6 +428,8 @@ pure subroutine configuration( self, add_blank_line, indent, & !! A logical flag to add a preceding blank line logical, intent(out), optional :: indent !! A logical flag to indent subsequent lines + integer, intent(out), optional :: level +!! The minimum level for printing a message integer, intent(out), optional :: max_width !! The maximum number of columns for most outputs logical, intent(out), optional :: time_stamp @@ -432,14 +460,21 @@ pure subroutine configuration( self, add_blank_line, indent, & if ( present(add_blank_line) ) add_blank_line = self % add_blank_line if ( present(indent) ) indent = self % indent_lines + if ( present(level) ) level = self % level if ( present(max_width) ) max_width = self % max_width if ( present(time_stamp) ) time_stamp = self % time_stamp - if ( present(log_units) ) log_units = self % log_units(1:self % units) + if ( present(log_units) ) then + if ( self % units .gt. 0 ) then + log_units = self % log_units(1:self % units) + else + allocate(log_units(0)) + end if + end if end subroutine configuration - pure subroutine configure( self, add_blank_line, indent, max_width, & + pure subroutine configure( self, add_blank_line, indent, level, max_width, & time_stamp ) !! version: experimental @@ -451,10 +486,11 @@ pure subroutine configure( self, add_blank_line, indent, max_width, & !! 2. `indent` is a logical flag with `.true.` implying that subsequent lines !! will be indented 4 spaces and `.false.` implying no indentation. `indent` !! has a startup value of `.true.`. -!! 3. `max_width` is the maximum number of columns of output text with +!! 3. `level` is the lowest level for printing a message +!! 4. `max_width` is the maximum number of columns of output text with !! `max_width == 0` => no bounds on output width. `max_width` has a startup !! value of 0. -!! 4. `time_stamp` is a logical flag with `.true.` implying that the output +!! 5. `time_stamp` is a logical flag with `.true.` implying that the output !! will have a time stamp, and `.false.` implying that there will be no !! time stamp. `time_stamp` has a startup value of `.true.`. !!([Specification](../page/specs/stdlib_logger.html#configure-configure-the-logging-process)) @@ -469,10 +505,12 @@ pure subroutine configure( self, add_blank_line, indent, max_width, & class(logger_type), intent(inout) :: self logical, intent(in), optional :: add_blank_line logical, intent(in), optional :: indent + integer, intent(in), optional :: level integer, intent(in), optional :: max_width logical, intent(in), optional :: time_stamp if ( present(add_blank_line) ) self % add_blank_line = add_blank_line + if ( present(level) ) self % level = level if ( present(indent) ) self % indent_lines = indent if ( present(max_width) ) then if ( max_width <= 4 ) then @@ -499,8 +537,8 @@ subroutine final_logger( self ) do unit=1, self % units flush( self % log_units(unit), iomsg=message, iostat=iostat ) if ( iostat /= 0 ) then - write(error_unit, '(a, i0)' ) 'In the logger_type finalizer ' // & - 'an error occurred in flushing unit = ', & + write(error_unit, '(a, i0)' ) 'In the logger_type ' // & + 'finalizer an error occurred in flushing unit = ', & self % log_units(unit) write(error_unit, '(a, i0)') 'With iostat = ', iostat write(error_unit, '(a)') 'With iomsg = ' // trim(message) @@ -510,23 +548,24 @@ subroutine final_logger( self ) end subroutine final_logger - subroutine format_output_string( self, unit, string, procedure_name, & - col_indent ) + subroutine format_output_string( self, string, col_indent, len_buffer, buffer ) !! version: experimental !! Writes the STRING to UNIT ensuring that the number of characters !! does not exceed MAX_WIDTH and that the lines after the first !! one are indented four characters. - class(logger_type), intent(in) :: self - integer, intent(in) :: unit - character(*), intent(in) :: string - character(*), intent(in) :: procedure_name - character(*), intent(in) :: col_indent + class(logger_type), intent(in) :: self + character(*), intent(in) :: string + character(*), intent(in) :: col_indent + integer, intent(out) :: len_buffer + character(len=:), allocatable, intent(out) :: buffer - integer :: count, indent_len, index, iostat, length, remain - character(256) :: iomsg + integer :: count, indent_len, index_, length, remain + integer, parameter :: new_len = len(new_line('a')) length = len_trim(string) + allocate( character(2*length) :: buffer ) + len_buffer = 0 indent_len = len(col_indent) call format_first_line() @@ -544,104 +583,166 @@ subroutine format_output_string( self, unit, string, procedure_name, & subroutine format_first_line() - if ( length <= self % max_width .or. self % max_width == 0 ) then - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - string(1:length) + if ( self % max_width == 0 .or. & + ( length <= self % max_width .and. & + index( string(1:length), new_line('a')) == 0 ) ) then + buffer(1:length) = string(1:length) + len_buffer = length remain = 0 return else - do index=self % max_width, 1, -1 - if ( string(index:index) == ' ' ) exit - end do + index_ = index( string(1:min(length, self % max_width)), & + new_line('a') ) + if ( index_ == 0 ) then + do index_=self % max_width, 1, -1 + if ( string(index_:index_) == ' ' ) exit + end do + end if - if ( index == 0 ) then - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & + if ( index_ == 0 ) then + buffer(1:self % max_width) = & string(1:self % max_width) + len_buffer = self % max_width count = self % max_width remain = length - count return else - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - string(1:index-1) - count = index + buffer(1:index_-1) = string(1:index_-1) + len_buffer = index_-1 + count = index_ remain = length - count return end if end if -999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) - end subroutine format_first_line subroutine format_subsequent_line() + integer :: new_len_buffer + character(:), allocatable :: dummy if ( remain <= self % max_width ) then - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - string(count+1:length) + new_len_buffer = len_buffer + length - count + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // string(count+1:length) + len_buffer = new_len_buffer count = length remain = 0 return else - do index=count+self % max_width, count+1, -1 - if ( string(index:index) == ' ' ) exit - end do + index_ = count + index(string(count+1:count+self % max_width),& + new_line('a')) + if(index_ == count) then + do index_=count+self % max_width, count+1, -1 + if ( string(index_:index_) == ' ' ) exit + end do + end if - if ( index == count ) then - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - string(count+1:count+self % max_width) + if ( index_ == count ) then + new_len_buffer = len_buffer + self % max_width + & + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // string(count+1:count+self % max_width) + len_buffer = new_len_buffer count = count + self % max_width remain = length - count return else - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - string(count+1:index) - count = index + new_len_buffer = len_buffer + index_ - 1 & + - count + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // string(count+1:index_-1) + len_buffer = new_len_buffer + count = index_ remain = length - count return end if end if -999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) - end subroutine format_subsequent_line subroutine indent_format_subsequent_line() - - if ( remain <= self % max_width - indent_len ) then - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - col_indent // string(count+1:length) + integer :: new_len_buffer + character(:), allocatable :: dummy + + if ( index( string(count+1:length), new_line('a')) == 0 .and. & + remain <= self % max_width - indent_len ) then + new_len_buffer = len_buffer + length & + - count + new_len + indent_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // col_indent // string(count+1:length) + len_buffer = new_len_buffer count = length remain = 0 return else - do index=count+self % max_width-indent_len, count+1, -1 - if ( string(index:index) == ' ' ) exit - end do + index_ = count + index( string(count+1: & + min ( length, count+self % max_width - indent_len) ), & + new_line('a')) + if(index_ == count) then + do index_=count+self % max_width-indent_len, count+1, -1 + if ( string(index_:index_) == ' ' ) exit + end do + end if - if ( index == count ) then - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - col_indent // & + if ( index_ == count ) then + new_len_buffer = len_buffer + self % max_width & + + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1: new_len_buffer ) = & + new_line('a') // col_indent // & string(count+1:count+self % max_width-indent_len) + len_buffer = new_len_buffer count = count + self % max_width - indent_len remain = length - count return else - write( unit, '(a)', err=999, iostat=iostat, iomsg=iomsg ) & - col_indent // string(count+1:index) - count = index + new_len_buffer = len_buffer + index_ - count - 1 & + + new_len + indent_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1: new_len_buffer ) = & + new_line('a') // col_indent // string(count+1:index_-1) + len_buffer = new_len_buffer + count = index_ remain = length - count return end if end if -999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) - end subroutine indent_format_subsequent_line end subroutine format_output_string @@ -664,18 +765,22 @@ subroutine handle_write_failure( unit, procedure_name, iostat, iomsg ) write( output_unit, '(a)' ) 'write failure in ' // module_name // & ' % ' // trim(procedure_name) // '.' - write( output_unit, '(a, i0)' ) 'unit = ', unit - inquire( unit, named=named ) - - if ( named ) then - inquire( unit, name=name ) - write( output_unit, '(a, a)' ) 'name = ', trim(name) + if ( unit == -999 ) then + write( output_unit, '(a, i0)' ) 'unit = internal file' else - write( output_unit, '(a)' ) 'unit is unnamed' + write( output_unit, '(a, i0)' ) 'unit = ', unit + inquire( unit, named=named ) + + if ( named ) then + inquire( unit, name=name ) + write( output_unit, '(a, a)' ) 'name = ', trim(name) + else + write( output_unit, '(a)' ) 'unit is unnamed' + end if + inquire( unit, action=action ) + write( output_unit, '(a, a)' ) 'action = ', trim(action) end if - inquire( unit, action=action ) - write( output_unit, '(a, a)' ) 'action = ', trim(action) write( output_unit, '(a, i0)' ) 'iostat = ', iostat write( output_unit, '(a, a )' ) 'iomsg = ', trim(iomsg) error stop 'write failure in ' // module_name // '.' @@ -683,6 +788,66 @@ subroutine handle_write_failure( unit, procedure_name, iostat, iomsg ) end subroutine handle_write_failure + subroutine log_debug( self, message, module, procedure ) +!! version: experimental + +!! Writes the string `message` to `self % log_units` with optional additional +!! text. +!!([Specification](../page/specs/stdlib_logger.html#log_debug-writes-the-string-message-to-self-log_units)) +!! +!!##### Behavior +!! +!! If time stamps are active, a time stamp is written, followed by +!! `module` and `procedure` if present, and then `message` is +!! written with the prefix 'DEBUG: '. +!! +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! real, allocatable :: a(:) +!! ... +!! type(logger_type) :: alogger +!! ... +!! contains +!! ... +!! subroutine example_sub( selection ) +!! integer, intent(out) :: selection +!! integer :: stat +!! write(*,'(a)') "Enter an integer to select a widget" +!! read(*,'(i0)') selection +!! write( message, `(a, i0)' ) & +!! "The user selected ", selection +!! call alogger % log_debug( message, & +!! module = 'EXAMPLE_MOD', & +!! procedure = 'EXAMPLE_SUB' ) +!! ... +!! end subroutine example_sub +!! ... +!! end module example_mod +!! + + class(logger_type), intent(in) :: self +!! The logger used to send the message + character(len=*), intent(in) :: message +!! A string to be written to log_unit + character(len=*), intent(in), optional :: module +!! The name of the module containing the current invocation of `log_information` + character(len=*), intent(in), optional :: procedure +!! The name of the procedure containing the current invocation of +!! `log_information` + + if ( self % level > debug_level ) return + + call self % log_message( message, & + module = module, & + procedure = procedure, & + prefix = 'DEBUG' ) + + end subroutine log_debug + + subroutine log_error( self, message, module, procedure, stat, errmsg ) !! version: experimental @@ -732,57 +897,48 @@ subroutine log_error( self, message, module, procedure, stat, errmsg ) character(len=*), intent(in) :: message !! A string to be written to log_unit character(len=*), intent(in), optional :: module -!! The name of the module contining the current invocation of `log_error` +!! The name of the module containing the current invocation of `log_error` character(len=*), intent(in), optional :: procedure -!! The name of the procedure contining the current invocation of `log_error` +!! The name of the procedure containing the current invocation of `log_error` integer, intent(in), optional :: stat !! The value of the `stat` specifier returned by a Fortran statement character(len=*), intent(in), optional :: errmsg !! The value of the `errmsg` specifier returned by a Fortran statement - integer :: unit integer :: iostat - character(*), parameter :: procedure_name = 'log_error' + character(28) :: dummy character(256) :: iomsg + character(*), parameter :: procedure_name = 'log_error' + character(:), allocatable :: suffix - call self % log_message( message, & - module = module, & - procedure = procedure, & - prefix = 'ERROR') + if ( self % level > error_level ) return - if ( self % units == 0 ) then - call write_log_error( output_unit ) + if ( present(stat) ) then + write( dummy, '(a, i0)', err=999, iostat=iostat, iomsg=iomsg ) & + new_line('a') // "With stat = ", stat else - do unit=1, self % units - call write_log_error( self % log_units(unit) ) - end do + dummy = ' ' end if - contains - - subroutine write_log_error( unit ) - integer, intent(in) :: unit - - if ( present(stat) ) then - write( unit, '("With stat = ", i0)', err=999, & - iostat=iostat, iomsg=iomsg ) stat - end if - - if ( present(errmsg) ) then - if ( len_trim(errmsg) > 0 ) then - call format_output_string( self, unit, & - 'With errmsg = "' // & - trim(errmsg) // '"', & - procedure_name, & - ' ' ) - end if + if ( present(errmsg) ) then + if ( len_trim(errmsg) > 0 ) then + suffix = trim(dummy) // & + new_line('a') // 'With errmsg = "' // trim(errmsg) // '"' + else + suffix = dummy end if + else + suffix = dummy + end if - return + call self % log_message( trim(message) // suffix, & + module = module, & + procedure = procedure, & + prefix = 'ERROR') -999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) + return - end subroutine write_log_error +999 call handle_write_failure( -999, procedure_name, iostat, iomsg ) end subroutine log_error @@ -832,9 +988,12 @@ subroutine log_information( self, message, module, procedure ) character(len=*), intent(in) :: message !! A string to be written to log_unit character(len=*), intent(in), optional :: module -!! The name of the module contining the current invocation of `log_information` +!! The name of the module containing the current invocation of `log_information` character(len=*), intent(in), optional :: procedure -!! The name of the procedure contining the current invocation of `log_information` +!! The name of the procedure containing the current invocation of +!! `log_information` + + if ( self % level > information_level ) return call self % log_message( message, & module = module, & @@ -884,57 +1043,48 @@ subroutine log_io_error( self, message, module, procedure, iostat, & character(len=*), intent(in) :: message !! A string to be written to LOG_UNIT character(len=*), intent(in), optional :: module -!! The name of the module contining the current invocation of REPORT_ERROR +!! The name of the module containing the current invocation of REPORT_ERROR character(len=*), intent(in), optional :: procedure -!! The name of the procedure contining the current invocation of REPORT_ERROR +!! The name of the procedure containing the current invocation of REPORT_ERROR integer, intent(in), optional :: iostat !! The value of the IOSTAT specifier returned by a Fortran I/O statement character(len=*), intent(in), optional :: iomsg !! The value of the IOMSG specifier returned by a Fortran I/O statement - integer :: unit - integer :: iostat2 - character(*), parameter :: procedure_name = 'log_error' + character(28) :: dummy character(256) :: iomsg2 + integer :: iostat2 + character(*), parameter :: procedure_name = 'log_io_error' + character(:), allocatable :: suffix - call self % log_message( message, & - module = module, & - procedure = procedure, & - prefix = 'I/O ERROR' ) + if ( self % level > io_error_level ) return - if ( self % units == 0 ) then - call write_log_io_error( output_unit ) + if ( present(iostat) ) then + write( dummy, '(a, i0)', err=999, iostat=iostat2, iomsg=iomsg2 ) & + new_line('a') // "With iostat = ", iostat else - do unit=1, self % units - call write_log_io_error( self % log_units(unit) ) - end do + dummy = ' ' end if - contains - - subroutine write_log_io_error( unit ) - integer, intent(in) :: unit - - if ( present(iostat) ) then - write( unit, '("With iostat = ", i0)', err=999, & - iostat=iostat2, iomsg=iomsg2 ) iostat - end if - - if ( present(iomsg) ) then - if ( len_trim(iomsg) > 0 ) then - call format_output_string( self, unit, & - 'With iomsg = "' // & - trim(iomsg) // '"', & - procedure_name, & - ' ' ) - end if + if ( present(iomsg) ) then + if ( len_trim(iomsg) > 0 ) then + suffix = trim(dummy) // & + new_line('a') // 'With iomsg = "' // trim(iomsg) // '"' + else + suffix = trim(dummy) end if + else + suffix = trim(dummy) + end if - return + call self % log_message( trim(message) // suffix, & + module = module, & + procedure = procedure, & + prefix = 'I/O ERROR' ) -999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) + return - end subroutine write_log_io_error +999 call handle_write_failure( -999, procedure_name, iostat2, iomsg2 ) end subroutine log_io_error @@ -981,17 +1131,19 @@ subroutine log_message( self, message, module, procedure, prefix ) character(len=*), intent(in) :: message !! A string to be written to log_unit character(len=*), intent(in), optional :: module -!! The name of the module contining the current invocation of `log_message` +!! The name of the module containing the current invocation of `log_message` character(len=*), intent(in), optional :: procedure -!! The name of the procedure contining the current invocation of `log_message` +!! The name of the procedure containing the current invocation of `log_message` character(len=*), intent(in), optional :: prefix !! To be prepended to message as `prefix // ': ' // message`. integer :: unit integer :: iostat + integer :: len_buffer character(*), parameter :: procedure_name = 'log_message' character(256) :: iomsg character(:), allocatable :: d_and_t, m_and_p, pref + character(:), allocatable :: buffer if ( present(prefix) ) then pref = prefix // ': ' @@ -1017,32 +1169,43 @@ subroutine log_message( self, message, module, procedure, prefix ) m_and_p = '' end if + call format_output_string( self, & + d_and_t // m_and_p // pref // & + trim( message ), & + ' ', & + len_buffer, & + buffer) + if ( self % units == 0 ) then - call write_log_message( output_unit ) + if ( self % add_blank_line ) then + write( output_unit, '(a)', err=999, iostat=iostat, & + iomsg=iomsg) & + new_line('a') // buffer(1:len_buffer) + else + write( output_unit, '(a)', err=999, iostat=iostat, & + iomsg=iomsg ) & + buffer(1:len_buffer) + end if else - do unit=1, self % units - call write_log_message( self % log_units(unit) ) - end do + if ( self % add_blank_line ) then + do unit=1, self % units + write( self % log_units(unit), '(a)', err=999, iostat=iostat, & + iomsg=iomsg ) new_line('a') // & + buffer(1:len_buffer) + end do + else + do unit=1, self % units + write( self % log_units(unit), '(a)', err=999, iostat=iostat, & + iomsg=iomsg ) & + buffer(1:len_buffer) + end do + end if end if - contains - - subroutine write_log_message( unit ) - integer, intent(in) :: unit - - if ( self % add_blank_line ) write( unit, *, err=999, & - iostat=iostat, iomsg=iomsg ) - call format_output_string( self, unit, & - d_and_t // m_and_p // pref // & - trim( message ), & - procedure_name, ' ' ) - - return - -999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) + return - end subroutine write_log_message +999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) end subroutine log_message @@ -1058,8 +1221,8 @@ subroutine log_text_error( self, line, column, summary, filename, & !! !! If time stamps are active first a time stamp is written. Then if !! `filename` or `line_number` or `column` are present they are written. -!! Then `line` is written. Then the symbol `caret` is written below `line` at the -!! column indicated by `column`. Then `summary` is written. +!! Then `line` is written. Then the symbol `caret` is written below `line` +!! at the column indicated by `column`. Then `summary` is written. ! !!##### Example !! @@ -1104,16 +1267,17 @@ subroutine log_text_error( self, line, column, summary, filename, & integer, intent(out), optional :: stat !! Integer flag that an error has occurred. Has the value `success` if no !! error hass occurred, `index_invalid_error` if `column` is less than zero or -!! greater than `len(line)`, and `write_failure` if any of the `write` statements -!! has failed. +!! greater than `len(line)`, and `write_failure` if any of the `write` +!! statements has failed. - character(1) :: acaret - character(5) :: num - character(:), allocatable :: fmt - character(128) :: iomsg - integer :: iostat - integer :: lun - character(*), parameter :: procedure_name = 'LOG_TEXT_ERROR' + character(1) :: acaret + character(128) :: iomsg + integer :: iostat + integer :: lun + character(*), parameter :: procedure_name = 'LOG_TEXT_ERROR' + character(len=:), allocatable :: buffer + + if ( self % level > text_error_level ) return acaret = optval(caret, '^') @@ -1130,57 +1294,82 @@ subroutine log_text_error( self, line, column, summary, filename, & end if end if - write(num, '(i0)') column-1 - fmt = '(' // trim(num) // 'x, a)' - + call write_log_text_error_buffer( ) if ( self % units == 0 ) then - call write_log_text_error( output_unit ) + write( output_unit, '(a)' ) buffer else do lun=1, self % units - call write_log_text_error( self % log_units(lun) ) - + write( self % log_units(lun), '(a)' ) buffer end do end if contains - subroutine write_log_text_error( unit ) - integer, intent(in) :: unit - - if ( self % add_blank_line ) write( unit, * ) - - if ( self % time_stamp ) write( unit, '(a)' ) time_stamp() + subroutine write_log_text_error_buffer( ) + integer :: i + character(:), allocatable :: location, marker if ( present(filename) ) then if ( present(line_number) ) then - write( unit, '(a,":", i0, ":", i0)', err=999, & + allocate( character(len_trim(filename)+15) :: location ) + write( location, fmt='(a, ":", i0, ":", i0)', err=999, & iomsg=iomsg, iostat=iostat ) & trim(filename) , line_number, column else - write( unit, '(a, i0)', err=999, iomsg=iomsg, & + allocate( character(len_trim(filename)+45) :: location ) + write( location, fmt='(a, i0)', err=999, iomsg=iomsg, & iostat=iostat ) & - "Error found in file: '" // trim(filename) // "'" & - // ', at column: ', column + "Error found in file: '" // trim(filename) // & + "', at column: ", column end if else if ( present(line_number) ) then - write( unit, '(a, i0, a, i0)', err=999, iomsg=iomsg, & - iostat=iostat ) & + allocate( character(54) :: location ) + write( location, fmt='(a, i0, a, i0)', err=999, & + iomsg=iomsg, iostat=iostat ) & 'Error found at line number: ', line_number, & ', and column: ', column else - write( unit, '("Error found in line at column:", i0)' ) & + allocate( character(36) :: location ) + write( location, & + fmt='("Error found in line at column:", i0)' ) & column end if end if - write( unit, * ) - write( unit, '(a)', err=999, iomsg=iomsg, iostat=iostat ) line - write( unit, fmt, err=999, iomsg=iomsg, iostat=iostat ) & - acaret - write( unit, '(a)', err=999, iomsg=iomsg, iostat=iostat ) & - 'Error: ' // trim(summary) + allocate( character(column) :: marker ) + do i=1, column-1 + marker(i:i) = ' ' + end do + marker(column:column) = acaret + if ( self % add_blank_line ) then + if ( self % time_stamp ) then + buffer = new_line('a') // time_stamp() // & + new_line('a') // trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + else + buffer = new_line('a') // trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + end if + else + if ( self % time_stamp ) then + buffer = time_stamp() // & + new_line('a') // trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + else + buffer = trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + end if + end if if ( present(stat) ) stat = success @@ -1189,14 +1378,12 @@ subroutine write_log_text_error( unit ) 999 if ( present( stat ) ) then stat = write_failure return - else - call handle_write_failure( unit, procedure_name, iostat, & + call handle_write_failure( -999, procedure_name, iostat, & iomsg ) - end if - end subroutine write_log_text_error + end subroutine write_log_text_error_buffer end subroutine log_text_error @@ -1240,7 +1427,8 @@ end function log_units_assigned subroutine log_warning( self, message, module, procedure ) !! version: experimental -!! Writes the string `message` to `self % log_units` with optional additional text. +!! Writes the string `message` to `self % log_units` with optional additional +!! text. !!([Specification](../page/specs/stdlib_logger.html#log_warning-write-the-string-message-to-log_units)) !!##### Behavior @@ -1280,9 +1468,11 @@ subroutine log_warning( self, message, module, procedure ) character(len=*), intent(in) :: message !! A string to be written to LOG_UNIT character(len=*), intent(in), optional :: module -!! The name of the module contining the current invocation of `log_warning` +!! The name of the module containing the current invocation of `log_warning` character(len=*), intent(in), optional :: procedure -!! The name of the procedure contining the current invocation of `log_warning` +!! The name of the procedure containing the current invocation of `log_warning` + + if ( self % level > warning_level ) return call self % log_message( message, & module = module, & @@ -1297,10 +1487,10 @@ subroutine remove_log_unit( self, unit, close_unit, stat ) !! Remove the I/O unit from the self % log_units list. If `close_unit` is !! present and `.true.` then the corresponding file is closed. If `unit` is -!! not in `log_units` then nothing is done. If `stat` is present it, by default, -!! has the value `success`. If closing the `unit` fails, then if `stat` is -!! present it has the value `close_failure`, otherwise processing stops -!! with an informative message. +!! not in `log_units` then nothing is done. If `stat` is present it, by +!! default, has the value `success`. If closing the `unit` fails, then if +!! `stat` is present it has the value `close_failure`, otherwise processing +!! stops with an informative message. !!([Specification](../page/specs/stdlib_logger.html#remove_log_unit-remove-unit-from-self-log_units)) class(logger_type), intent(inout) :: self diff --git a/src/stdlib_stats_moment.fypp b/src/stdlib_stats_moment.fypp index ab1b77a5d..7283cc576 100644 --- a/src/stdlib_stats_moment.fypp +++ b/src/stdlib_stats_moment.fypp @@ -11,93 +11,6 @@ submodule (stdlib_stats) stdlib_stats_moment contains - #:for k1, t1 in RC_KINDS_TYPES - #:for rank in RANKS - #:set RName = rname("moment_all",rank, t1, k1) - module function ${RName}$(x, order, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - ${t1}$, intent(in), optional :: center - logical, intent(in), optional :: mask - ${t1}$ :: res - - real(${k1}$) :: n - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._${k1}$, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), ${k1}$) - - if (present(center)) then - res = sum((x - center)**order) / n - else - res = sum((x - mean(x))**order) / n - end if - - end function ${RName}$ - #:endfor - #:endfor - - - #:for k1, t1 in INT_KINDS_TYPES - #:for rank in RANKS - #:set RName = rname("moment_all",rank, t1, k1, 'dp') - module function ${RName}$(x, order, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - real(dp), intent(in), optional :: center - logical, intent(in), optional :: mask - real(dp) :: res - - real(dp) :: n - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), dp) - - if (present(center)) then - res = sum((real(x, dp) - center)**order) / n - else - res = sum((real(x, dp) - mean(x))**order) / n - end if - - end function ${RName}$ - #:endfor - #:endfor - - - #:for k1, t1 in RC_KINDS_TYPES - #:for rank in REDRANKS - #:set RName = rname("moment_scalar",rank, t1, k1) - module function ${RName}$(x, order, dim, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - integer, intent(in) :: dim - ${t1}$, intent(in) :: center - logical, intent(in), optional :: mask - ${t1}$ :: res${reduced_shape('x', rank, 'dim')}$ - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._${k1}$, ieee_quiet_nan) - return - end if - - if (dim >= 1 .and. dim <= ${rank}$) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function ${RName}$ - #:endfor - #:endfor - - #:for k1, t1 in RC_KINDS_TYPES #:for rank in RANKS #:set RName = rname("moment",rank, t1, k1) @@ -146,33 +59,6 @@ contains #:endfor - #:for k1, t1 in INT_KINDS_TYPES - #:for rank in REDRANKS - #:set RName = rname("moment_scalar",rank, t1, k1, 'dp') - module function ${RName}$(x, order, dim, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res${reduced_shape('x', rank, 'dim')}$ - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) - return - end if - - if (dim >= 1 .and. dim <= ${rank}$) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function ${RName}$ - #:endfor - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES #:for rank in RANKS #:set RName = rname("moment",rank, t1, k1, 'dp') @@ -221,201 +107,4 @@ contains #:endfor #:endfor - - #:for k1, t1 in RC_KINDS_TYPES - #:for rank in RANKS - #:set RName = rname("moment_mask_all",rank, t1, k1) - module function ${RName}$(x, order, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - ${t1}$, intent(in), optional :: center - logical, intent(in) :: mask${ranksuffix(rank)}$ - ${t1}$ :: res - - real(${k1}$) :: n - - n = real(count(mask, kind = int64), ${k1}$) - - if (present(center)) then - res = sum((x - center)**order, mask) / n - else - res = sum((x - mean(x, mask))**order, mask) / n - end if - - end function ${RName}$ - #:endfor - #:endfor - - - #:for k1, t1 in INT_KINDS_TYPES - #:for rank in RANKS - #:set RName = rname("moment_mask_all",rank, t1, k1, 'dp') - module function ${RName}$(x, order, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - real(dp),intent(in), optional :: center - logical, intent(in) :: mask${ranksuffix(rank)}$ - real(dp) :: res - - real(dp) :: n - - n = real(count(mask, kind = int64), dp) - - if (present(center)) then - res = sum((real(x, dp) - center)**order, mask) / n - else - res = sum((real(x, dp) - mean(x,mask))**order, mask) / n - end if - - end function ${RName}$ - #:endfor - #:endfor - - - #:for k1, t1 in RC_KINDS_TYPES - #:for rank in REDRANKS - #:set RName = rname("moment_mask_scalar",rank, t1, k1) - module function ${RName}$(x, order, dim, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - integer, intent(in) :: dim - ${t1}$, intent(in) :: center - logical, intent(in) :: mask${ranksuffix(rank)}$ - ${t1}$ :: res${reduced_shape('x', rank, 'dim')}$ - - if (dim >= 1 .and. dim <= ${rank}$) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function ${RName}$ - #:endfor - #:endfor - - - #:for k1, t1 in RC_KINDS_TYPES - #:for rank in RANKS - #:set RName = rname("moment_mask",rank, t1, k1) - module function ${RName}$(x, order, dim, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - integer, intent(in) :: dim - ${t1}$, intent(in), optional :: center${reduced_shape('x', rank, 'dim')}$ - logical, intent(in) :: mask${ranksuffix(rank)}$ - ${t1}$ :: res${reduced_shape('x', rank, 'dim')}$ - - integer :: i - real(${k1}$) :: n${reduced_shape('x', rank, 'dim')}$ - ${t1}$, allocatable :: mean_${ranksuffix(rank-1)}$ - - n = real(count(mask, dim), ${k1}$) - - res = 0 - select case(dim) - #:for fi in range(1, rank+1) - case(${fi}$) - if (present(center)) then - do i = 1, size(x, ${fi}$) - res = res + merge( (x${select_subarray(rank, [(fi, 'i')])}$ -& - center)**order,& - #:if t1[0] == 'r' - 0._${k1}$,& - #:else - cmplx(0,0,kind=${k1}$),& - #:endif - mask${select_subarray(rank, [(fi, 'i')])}$) - end do - else - allocate(mean_, source = mean(x, ${fi}$, mask)) - do i = 1, size(x, ${fi}$) - res = res + merge( (x${select_subarray(rank, [(fi, 'i')])}$ - mean_)**order,& - #:if t1[0] == 'r' - 0._${k1}$,& - #:else - cmplx(0,0,kind=${k1}$),& - #:endif - mask${select_subarray(rank, [(fi, 'i')])}$) - end do - deallocate(mean_) - end if - #:endfor - case default - call error_stop("ERROR (moment): wrong dimension") - end select - res = res / n - - end function ${RName}$ - #:endfor - #:endfor - - - #:for k1, t1 in INT_KINDS_TYPES - #:for rank in REDRANKS - #:set RName = rname("moment_mask_scalar",rank, t1, k1, 'dp') - module function ${RName}$(x, order, dim, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask${ranksuffix(rank)}$ - real(dp) :: res${reduced_shape('x', rank, 'dim')}$ - - if (dim >= 1 .and. dim <= ${rank}$) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function ${RName}$ - #:endfor - #:endfor - - - #:for k1, t1 in INT_KINDS_TYPES - #:for rank in RANKS - #:set RName = rname("moment_mask",rank, t1, k1, 'dp') - module function ${RName}$(x, order, dim, center, mask) result(res) - ${t1}$, intent(in) :: x${ranksuffix(rank)}$ - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in), optional :: center${reduced_shape('x', rank, 'dim')}$ - logical, intent(in) :: mask${ranksuffix(rank)}$ - real(dp) :: res${reduced_shape('x', rank, 'dim')}$ - - integer :: i - real(dp) :: n${reduced_shape('x', rank, 'dim')}$ - real(dp), allocatable :: mean_${ranksuffix(rank-1)}$ - - n = real(count(mask, dim), dp) - - res = 0 - select case(dim) - #:for fi in range(1, rank+1) - case(${fi}$) - if (present(center)) then - do i = 1, size(x, ${fi}$) - res = res + merge((real(x${select_subarray(rank, [(fi, 'i')])}$, dp) -& - center)**order,& - 0._dp, mask${select_subarray(rank, [(fi, 'i')])}$) - end do - else - allocate(mean_, source = mean(x, ${fi}$, mask)) - do i = 1, size(x, ${fi}$) - res = res + merge((real(x${select_subarray(rank, [(fi, 'i')])}$, dp) - mean_)& - **order,& - 0._dp, mask${select_subarray(rank, [(fi, 'i')])}$) - end do - deallocate(mean_) - end if - #:endfor - case default - call error_stop("ERROR (moment): wrong dimension") - end select - res = res / n - - end function ${RName}$ - #:endfor - #:endfor - end submodule diff --git a/src/stdlib_stats_moment_all.fypp b/src/stdlib_stats_moment_all.fypp new file mode 100644 index 000000000..34aef0d56 --- /dev/null +++ b/src/stdlib_stats_moment_all.fypp @@ -0,0 +1,123 @@ +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set REDRANKS = range(2, MAXRANK + 1) +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +submodule (stdlib_stats) stdlib_stats_moment_all + + use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan + use stdlib_error, only: error_stop + use stdlib_optval, only: optval + implicit none + +contains + + #:for k1, t1 in RC_KINDS_TYPES + #:for rank in RANKS + #:set RName = rname("moment_all",rank, t1, k1) + module function ${RName}$(x, order, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + ${t1}$, intent(in), optional :: center + logical, intent(in), optional :: mask + ${t1}$ :: res + + real(${k1}$) :: n + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._${k1}$, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), ${k1}$) + + if (present(center)) then + res = sum((x - center)**order) / n + else + res = sum((x - mean(x))**order) / n + end if + + end function ${RName}$ + #:endfor + #:endfor + + + #:for k1, t1 in INT_KINDS_TYPES + #:for rank in RANKS + #:set RName = rname("moment_all",rank, t1, k1, 'dp') + module function ${RName}$(x, order, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + real(dp), intent(in), optional :: center + logical, intent(in), optional :: mask + real(dp) :: res + + real(dp) :: n + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + + if (present(center)) then + res = sum((real(x, dp) - center)**order) / n + else + res = sum((real(x, dp) - mean(x))**order) / n + end if + + end function ${RName}$ + #:endfor + #:endfor + + + #:for k1, t1 in RC_KINDS_TYPES + #:for rank in RANKS + #:set RName = rname("moment_mask_all",rank, t1, k1) + module function ${RName}$(x, order, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + ${t1}$, intent(in), optional :: center + logical, intent(in) :: mask${ranksuffix(rank)}$ + ${t1}$ :: res + + real(${k1}$) :: n + + n = real(count(mask, kind = int64), ${k1}$) + + if (present(center)) then + res = sum((x - center)**order, mask) / n + else + res = sum((x - mean(x, mask))**order, mask) / n + end if + + end function ${RName}$ + #:endfor + #:endfor + + + #:for k1, t1 in INT_KINDS_TYPES + #:for rank in RANKS + #:set RName = rname("moment_mask_all",rank, t1, k1, 'dp') + module function ${RName}$(x, order, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + real(dp),intent(in), optional :: center + logical, intent(in) :: mask${ranksuffix(rank)}$ + real(dp) :: res + + real(dp) :: n + + n = real(count(mask, kind = int64), dp) + + if (present(center)) then + res = sum((real(x, dp) - center)**order, mask) / n + else + res = sum((real(x, dp) - mean(x,mask))**order, mask) / n + end if + + end function ${RName}$ + #:endfor + #:endfor + +end submodule diff --git a/src/stdlib_stats_moment_mask.fypp b/src/stdlib_stats_moment_mask.fypp new file mode 100644 index 000000000..a56d4d1b3 --- /dev/null +++ b/src/stdlib_stats_moment_mask.fypp @@ -0,0 +1,116 @@ +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set REDRANKS = range(2, MAXRANK + 1) +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +submodule (stdlib_stats) stdlib_stats_moment_mask + + use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan + use stdlib_error, only: error_stop + use stdlib_optval, only: optval + implicit none + +contains + + #:for k1, t1 in RC_KINDS_TYPES + #:for rank in RANKS + #:set RName = rname("moment_mask",rank, t1, k1) + module function ${RName}$(x, order, dim, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + integer, intent(in) :: dim + ${t1}$, intent(in), optional :: center${reduced_shape('x', rank, 'dim')}$ + logical, intent(in) :: mask${ranksuffix(rank)}$ + ${t1}$ :: res${reduced_shape('x', rank, 'dim')}$ + + integer :: i + real(${k1}$) :: n${reduced_shape('x', rank, 'dim')}$ + ${t1}$, allocatable :: mean_${ranksuffix(rank-1)}$ + + n = real(count(mask, dim), ${k1}$) + + res = 0 + select case(dim) + #:for fi in range(1, rank+1) + case(${fi}$) + if (present(center)) then + do i = 1, size(x, ${fi}$) + res = res + merge( (x${select_subarray(rank, [(fi, 'i')])}$ -& + center)**order,& + #:if t1[0] == 'r' + 0._${k1}$,& + #:else + cmplx(0,0,kind=${k1}$),& + #:endif + mask${select_subarray(rank, [(fi, 'i')])}$) + end do + else + allocate(mean_, source = mean(x, ${fi}$, mask)) + do i = 1, size(x, ${fi}$) + res = res + merge( (x${select_subarray(rank, [(fi, 'i')])}$ - mean_)**order,& + #:if t1[0] == 'r' + 0._${k1}$,& + #:else + cmplx(0,0,kind=${k1}$),& + #:endif + mask${select_subarray(rank, [(fi, 'i')])}$) + end do + deallocate(mean_) + end if + #:endfor + case default + call error_stop("ERROR (moment): wrong dimension") + end select + res = res / n + + end function ${RName}$ + #:endfor + #:endfor + + + #:for k1, t1 in INT_KINDS_TYPES + #:for rank in RANKS + #:set RName = rname("moment_mask",rank, t1, k1, 'dp') + module function ${RName}$(x, order, dim, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in), optional :: center${reduced_shape('x', rank, 'dim')}$ + logical, intent(in) :: mask${ranksuffix(rank)}$ + real(dp) :: res${reduced_shape('x', rank, 'dim')}$ + + integer :: i + real(dp) :: n${reduced_shape('x', rank, 'dim')}$ + real(dp), allocatable :: mean_${ranksuffix(rank-1)}$ + + n = real(count(mask, dim), dp) + + res = 0 + select case(dim) + #:for fi in range(1, rank+1) + case(${fi}$) + if (present(center)) then + do i = 1, size(x, ${fi}$) + res = res + merge((real(x${select_subarray(rank, [(fi, 'i')])}$, dp) -& + center)**order,& + 0._dp, mask${select_subarray(rank, [(fi, 'i')])}$) + end do + else + allocate(mean_, source = mean(x, ${fi}$, mask)) + do i = 1, size(x, ${fi}$) + res = res + merge((real(x${select_subarray(rank, [(fi, 'i')])}$, dp) - mean_)& + **order,& + 0._dp, mask${select_subarray(rank, [(fi, 'i')])}$) + end do + deallocate(mean_) + end if + #:endfor + case default + call error_stop("ERROR (moment): wrong dimension") + end select + res = res / n + + end function ${RName}$ + #:endfor + #:endfor + +end submodule diff --git a/src/stdlib_stats_moment_scalar.fypp b/src/stdlib_stats_moment_scalar.fypp new file mode 100644 index 000000000..137ff6d79 --- /dev/null +++ b/src/stdlib_stats_moment_scalar.fypp @@ -0,0 +1,110 @@ +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set REDRANKS = range(2, MAXRANK + 1) +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +submodule (stdlib_stats) stdlib_stats_moment_scalar + + use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan + use stdlib_error, only: error_stop + use stdlib_optval, only: optval + implicit none + +contains + + #:for k1, t1 in RC_KINDS_TYPES + #:for rank in REDRANKS + #:set RName = rname("moment_scalar",rank, t1, k1) + module function ${RName}$(x, order, dim, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + integer, intent(in) :: dim + ${t1}$, intent(in) :: center + logical, intent(in), optional :: mask + ${t1}$ :: res${reduced_shape('x', rank, 'dim')}$ + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._${k1}$, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= ${rank}$) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function ${RName}$ + #:endfor + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + #:for rank in REDRANKS + #:set RName = rname("moment_scalar",rank, t1, k1, 'dp') + module function ${RName}$(x, order, dim, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res${reduced_shape('x', rank, 'dim')}$ + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= ${rank}$) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function ${RName}$ + #:endfor + #:endfor + + + #:for k1, t1 in RC_KINDS_TYPES + #:for rank in REDRANKS + #:set RName = rname("moment_mask_scalar",rank, t1, k1) + module function ${RName}$(x, order, dim, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + integer, intent(in) :: dim + ${t1}$, intent(in) :: center + logical, intent(in) :: mask${ranksuffix(rank)}$ + ${t1}$ :: res${reduced_shape('x', rank, 'dim')}$ + + if (dim >= 1 .and. dim <= ${rank}$) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function ${RName}$ + #:endfor + #:endfor + + + #:for k1, t1 in INT_KINDS_TYPES + #:for rank in REDRANKS + #:set RName = rname("moment_mask_scalar",rank, t1, k1, 'dp') + module function ${RName}$(x, order, dim, center, mask) result(res) + ${t1}$, intent(in) :: x${ranksuffix(rank)}$ + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask${ranksuffix(rank)}$ + real(dp) :: res${reduced_shape('x', rank, 'dim')}$ + + if (dim >= 1 .and. dim <= ${rank}$) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function ${RName}$ + #:endfor + #:endfor + +end submodule diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt index 9e341d380..c3b09e34d 100644 --- a/src/tests/CMakeLists.txt +++ b/src/tests/CMakeLists.txt @@ -7,6 +7,7 @@ macro(ADDTEST name) endmacro(ADDTEST) add_subdirectory(ascii) +add_subdirectory(bitsets) add_subdirectory(io) add_subdirectory(linalg) add_subdirectory(logger) diff --git a/src/tests/Makefile.manual b/src/tests/Makefile.manual index 9b0227232..89325cd56 100644 --- a/src/tests/Makefile.manual +++ b/src/tests/Makefile.manual @@ -2,6 +2,7 @@ all: $(MAKE) -f Makefile.manual --directory=ascii + $(MAKE) -f Makefile.manual --directory=bitsets $(MAKE) -f Makefile.manual --directory=io $(MAKE) -f Makefile.manual --directory=logger $(MAKE) -f Makefile.manual --directory=optval @@ -10,6 +11,7 @@ all: test: $(MAKE) -f Makefile.manual --directory=ascii test + $(MAKE) -f Makefile.manual --directory=bitsets test $(MAKE) -f Makefile.manual --directory=io test $(MAKE) -f Makefile.manual --directory=logger test $(MAKE) -f Makefile.manual --directory=optval test @@ -18,6 +20,7 @@ test: clean: $(MAKE) -f Makefile.manual --directory=ascii clean + $(MAKE) -f Makefile.manual --directory=bitsets clean $(MAKE) -f Makefile.manual --directory=io clean $(MAKE) -f Makefile.manual --directory=logger clean $(MAKE) -f Makefile.manual --directory=optval clean diff --git a/src/tests/bitsets/CMakeLists.txt b/src/tests/bitsets/CMakeLists.txt new file mode 100644 index 000000000..519015e20 --- /dev/null +++ b/src/tests/bitsets/CMakeLists.txt @@ -0,0 +1,3 @@ +ADDTEST(stdlib_bitset_64) +ADDTEST(stdlib_bitset_large) + diff --git a/src/tests/bitsets/Makefile.manual b/src/tests/bitsets/Makefile.manual new file mode 100644 index 000000000..0ecba442e --- /dev/null +++ b/src/tests/bitsets/Makefile.manual @@ -0,0 +1,3 @@ +PROGS_SRC = test_stdlib_bitset_64.f90 test_stdlib_bitset_large.f90 + +include ../Makefile.manual.test.mk diff --git a/src/tests/bitsets/test_stdlib_bitset_64.f90 b/src/tests/bitsets/test_stdlib_bitset_64.f90 new file mode 100644 index 000000000..566db8ec1 --- /dev/null +++ b/src/tests/bitsets/test_stdlib_bitset_64.f90 @@ -0,0 +1,752 @@ +program test_stdlib_bitset_64 + use :: stdlib_kinds, only : int8, int16, int32, int64 + use stdlib_bitsets + character(*), parameter :: & + bitstring_0 = '000000000000000000000000000000000', & + bitstring_33 = '100000000000000000000000000000000', & + bitstring_all = '111111111111111111111111111111111' + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + integer :: status + character(:), allocatable :: string0 + + call test_string_operations() + + call test_io() + + call test_initialization() + + call test_bitset_inquiry() + + call test_bit_operations() + + call test_bitset_comparisons() + + call test_bitset_operations() + +contains + + subroutine test_string_operations() + character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' + + write(*,'(/a)') 'Test string operations: from_string, ' // & + 'read_bitset, to_string, and write_bitset' + + call set0 % from_string( bitstring_0 ) + if ( bits(set0) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_0 size properly.' + else if ( .not. set0 % none() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else if ( set0 % any() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_0 properly into set0' + end if + + call set1 % from_string( bitstring_all ) + if ( bits(set1) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_all size properly.' + else if ( set1 % none() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % any() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % all() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_all properly ' // & + 'into set1' + end if + + call set3 % read_bitset( bitstring_0, status ) + if ( status /= success ) then + write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' + else + error stop procedure // ' read_bitset_string did not fail ' // & + 'with bitstring_0 as expected.' + end if + + call set3 % read_bitset( 's33b' // bitstring_0, status ) + + if ( bits(set3) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_0 size properly.' + else if ( .not. set3 % none() ) then + error stop procedure // ' failed to interpret "s33b" // ' // & + 'bitstring_0 value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_0 properly into set3' + end if + + call set4 % read_bitset( 's33b' // bitstring_all ) + if ( bits(set4) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all size properly.' + else if ( set4 % none() ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all value properly.' + else if ( .not. set4 % any() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else if ( .not. set4 % all() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_all properly into set4.' + end if + + call set0 % to_string( string0 ) + if ( bitstring_0 /= string0 ) then + error stop procedure // ' to_string failed to convert set0 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set0 value' + end if + + call set1 % to_string( string0 ) + if ( bitstring_all /= string0 ) then + error stop procedure // ' to_string failed to convert set1 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set1 value' + end if + + call set0 % write_bitset( string0 ) + if ( ('S33B' // bitstring_0) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set0 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set0 value' + end if + + call set1 % write_bitset( string0 ) + if ( ('S33B' // bitstring_all) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set1 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set1 value' + end if + + return + end subroutine test_string_operations + + subroutine test_io() + character(*), parameter:: procedure = 'TEST_IO' + + integer :: unit + + write(*,*) + write(*,*) 'Test bitset I/O: input, read_bitset, output, and ' // & + 'write_bitset' + + call set2 % from_string( bitstring_33 ) + open( newunit=unit, file='test64_1.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit) + call set1 % write_bitset(unit) + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test64_1.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit) + call set5 % read_bitset(unit) + call set4 % read_bitset(unit) + + if ( set4 /= set0 .or. set5 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + 'bitset literals failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'plain write_bitset_unit and read_bitset_unit succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test64_2.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test64_2.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + + if ( set5 /= set0 .or. set4 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals with advance == "no" failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'write_bitset_unit and read_bitset_unit with ' // & + 'advance=="no" succeeded.' + end if + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', access='stream', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', access='stream', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' stream output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'stream output and input succeeded.' + end if + + end subroutine test_io + + subroutine test_initialization() + character(*), parameter:: procedure = 'TEST_INITIALIZATION' + logical(int8) :: log1(64) = .true. + logical(int16) :: log2(31) = .false. + logical(int32) :: log3(15) = .true. + logical(int64) :: log4(33) = .false. + logical(int8), allocatable :: log5(:) + logical(int16), allocatable :: log6(:) + logical(int32), allocatable :: log7(:) + logical(int64), allocatable :: log8(:) + + write(*,*) + write(*,*) 'Test initialization: assignment, extract, and init' + + set5 = log1 + if ( set5 % bits() /= 64 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization with logical(int8) succeeded.' + end if + + set5 = log2 + if ( set5 % bits() /= 31 ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int16) succeeded.' + end if + + set5 = log3 + if ( set5 % bits() /= 15 ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int32) succeeded.' + end if + + set5 = log4 + if ( set5 % bits() /= 33 ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int64) succeeded.' + end if + + set5 = log1 + call extract( set4, set5, 1_bits_kind, 33_bits_kind ) + if ( set4 % bits() /= 33 ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with extract succeeded.' + end if + + set4 = set5 + if ( set4 % bits() /= 64 ) then + write(*,*) 'Bits = ', set4 % bits() + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with simple assignment succeeded.' + end if + + log5 = set5 + if ( size(log5) /= 64 ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log5) ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int8) succeeded.' + end if + + log6 = set5 + if ( size(log6) /= 64 ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log6) ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int16) succeeded.' + end if + + log7 = set5 + if ( size(log7) /= 64 ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log7) ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int32) succeeded.' + end if + + log8 = set5 + if ( size(log8) /= 64 ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log8) ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int64) succeeded.' + end if + + end subroutine test_initialization + + subroutine test_bitset_inquiry() + character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' + integer(bits_kind) :: i + + write(*,*) + write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' + + if ( set0 % none() ) then + if ( .not. set0 % any() ) then + write(*,*) 'As expected set0 has no bits set' + else + error stop procedure // ' set0 had some bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have none set which ' // & + 'was unexpected' + end if + + call set0 % not() + if ( set0 % all() ) then + if ( set0 % any() ) then + write(*,*) 'As expected set0 now has all bits set' + else + error stop procedure // ' set0 had no bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have all bits set ' // & + 'which was unexpected' + end if + + if ( set1 % any() ) then + if ( set1 % all() ) then + write(*,*) 'As expected set1 has all bits set' + else + error stop procedure // ' set1 did not have all bits set ' // & + 'which was unexpected.' + end if + else + error stop procedure // ' set1 had no bits set ' // & + 'which was unexpected' + end if + + call set0 % not() + do i=0, set0 % bits() - 1 + if ( set0 % test(i) ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if + end do + + write(*,*) 'As expected set0 had no bits set.' + + do i=0, set1 % bits() - 1 + if ( .not. set1 % test(i) ) then + error stop procedure // ' against expectations set1 has ' // & + 'at least 1 bit unset.' + end if + end do + + write(*,*) 'As expected set1 had all bits set.' + + do i=0, set0 % bits() - 1 + if ( set0 % value(i) /= 0 ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if + end do + + write(*,*) 'As expected set0 had no bits set.' + + do i=0, set1 % bits() - 1 + if ( set1 % value(i) /= 1 ) then + error stop procedure // ' against expectations set1 has ' // & + 'at least 1 bit unset.' + end if + end do + + write(*,*) 'As expected set1 had all bits set.' + + if ( set0 % bits() == 33 ) then + write(*,*) 'set0 has 33 bits as expected.' + else + error stop procedure // 'set0 unexpectedly does not have 33 bits.' + end if + + end subroutine test_bitset_inquiry + + subroutine test_bit_operations() + character(*), parameter:: procedure = 'TEST_BIT_OPERATIONS' + + write(*,*) + write(*,*) 'Test bit operations: clear, flip, not, and set' + + if ( .not. set1 % all() ) then + error stop procedure // ' set1 is not all set.' + end if + + call set1 % clear(0_bits_kind) + if ( .not. set1 % test(0_bits_kind) ) then + if ( set1 % test(1_bits_kind) ) then + write(*,*) 'Cleared one bit in set1 as expected.' + else + error stop procedure // ' cleared more than one bit in set1.' + end if + else + error stop procedure // ' did not clear the first bit in set1.' + end if + + call set1 % clear(1_bits_kind, 32_bits_kind) + if ( set1 % none() ) then + write(*,*) 'Cleared remaining bits in set1 as expected.' + else + error stop procedure // ' did not clear remaining bits ' // & + 'in set1.' + end if + + call set1 % flip(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then + write(*,*) 'Flipped one bit in set1 as expected.' + else + error stop procedure // ' flipped more than one bit in set1.' + end if + else + error stop procedure // ' did not flip the first bit in set1.' + end if + + call set1 % flip(1_bits_kind, 32_bits_kind) + if ( set1 % all() ) then + write(*,*) 'Flipped remaining bits in set1 as expected.' + else + error stop procedure // ' did not flip remaining bits ' // & + 'in set1.' + end if + + call set1 % not() + if ( set1 % none() ) then + write(*,*) 'Unset bits in set1 as expected.' + else + error stop procedure // ' did not unset bits in set1.' + end if + + call set1 % set(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then + write(*,*) 'Set first bit in set1 as expected.' + else + error stop procedure // ' set more than one bit in set1.' + end if + else + error stop procedure // ' did not set the first bit in set1.' + end if + + call set1 % set(1_bits_kind, 32_bits_kind) + if ( set1 % all() ) then + write(*,*) 'Set the remaining bits in set1 as expected.' + else + error stop procedure // ' did not set the remaining bits ' // & + 'in set1.' + end if + + end subroutine test_bit_operations + + subroutine test_bitset_comparisons() + character(*), parameter:: procedure = 'TEST_BITSET_COMPARISON' + + write(*,*) + write(*,*) 'Test bitset comparisons: ==, /=, <, <=, >, and >=' + + if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & + set1 == set2 ) then + write(*,*) 'Passed 64 bit equality tests.' + else + error stop procedure // ' failed 64 bit equality tests.' + end if + + if ( set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & + .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & + set2 /= set2 ) then + write(*,*) 'Passed 64 bit inequality tests.' + else + error stop procedure // ' failed 64 bit inequality tests.' + end if + + if ( set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & + .not. set0 > set1 .and. .not. set1 > set1 .and. .not. & + set2 > set1 ) then + write(*,*) 'Passed 64 bit greater than tests.' + else + error stop procedure // ' failed 64 bit greater than tests.' + end if + + if ( set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & + .not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. & + set2 >= set1 ) then + write(*,*) 'Passed 64 bit greater than or equal tests.' + else + error stop procedure // ' failed 64 bit greater than or ' // & + 'equal tests.' + end if + + if ( set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & + .not. set1 < set0 .and. .not. set0 < set0 .and. .not. & + set1 < set2 ) then + write(*,*) 'Passed 64 bit less than tests.' + else + error stop procedure // ' failed 64 bit less than tests.' + end if + + if ( set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & + .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & + set1 <= set2 ) then + write(*,*) 'Passed 64 bit less than or equal tests.' + else + error stop procedure // ' failed 64 bit less than or ' // & + 'equal tests.' + end if + + end subroutine test_bitset_comparisons + + subroutine test_bitset_operations() + character(*), parameter:: procedure = 'TEST_BITSET_OPERATIONS' + + write(*,*) + write(*,*) 'Test bitset operations: and, and_not, or, and xor' + + call set0 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and( set0, set4 ) ! all all + if ( set0 % all() ) then + write(*,*) 'First test of AND worked.' + else + error stop procedure // ' first test of AND failed.' + end if + + call set4 % from_string( bitstring_0 ) + call set3 % from_string( bitstring_all ) + call and( set3, set4 ) ! all none + if ( set3 % none() ) then + write(*,*) 'Second test of AND worked.' + else + error stop procedure // ' second test of AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Third test of AND worked.' + else + error stop procedure // ' third test of AND failed.' + end if + + call set3 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of AND worked.' + else + error stop procedure // ' fourth test of AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and_not( set4, set3 ) ! all all + if ( set4 % none() ) then + write(*,*) 'First test of AND_NOT worked.' + else + error stop procedure // ' first test of AND_NOT failed.' + end if + + call set4 % from_string( bitstring_0 ) + call and_not( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Second test of AND_NOT worked.' + else + error stop procedure // ' second test of AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of AND_NOT worked.' + else + error stop procedure // ' third test of AND_NOT failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'Fourth test of AND_NOT worked.' + else + error stop procedure // ' fourth test of AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call or( set3, set4 ) ! all all + if ( set3 % all() ) then + write(*,*) 'First test of OR worked.' + else + error stop procedure // ' first test of OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call or( set4, set3 ) ! all none + if ( set4 % all() ) then + write(*,*) 'Second test of OR worked.' + else + error stop procedure // ' second test of OR failed.' + end if + + call or( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Third test of OR worked.' + else + error stop procedure // ' third test of OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call or( set4, set3 ) !none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of OR worked.' + else + error stop procedure // ' fourth test of OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'First test of XOR worked.' + else + error stop procedure // ' first test of XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Second test of XOR worked.' + else + error stop procedure // ' second test of XOR failed.' + end if + + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of XOR worked.' + else + error stop procedure // ' third test of XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! all all + if ( set3 % none() ) then + write(*,*) 'Fourth test of XOR worked.' + else + error stop procedure // ' fourth test of XOR failed.' + end if + + end subroutine test_bitset_operations + + +end program test_stdlib_bitset_64 diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 new file mode 100644 index 000000000..f5d5631a0 --- /dev/null +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -0,0 +1,1488 @@ +program test_stdlib_bitset_large + use :: stdlib_kinds, only : int8, int16, int32, int64 + use stdlib_bitsets + implicit none + character(*), parameter :: & + bitstring_0 = '000000000000000000000000000000000', & + bitstring_33 = '100000000000000000000000000000000', & + bitstring_all = '111111111111111111111111111111111' + type(bitset_large) :: set0, set1, set2, set3, set4, set5 + type(bitset_large) :: set10, set11, set12, set13, set14, set15 + integer :: status + character(:), allocatable :: string0 + + call test_string_operations() + + call test_io() + + call test_initialization() + + call test_bitset_inquiry() + + call test_bit_operations() + + call test_bitset_comparisons() + + call test_bitset_operations() + +contains + + subroutine test_string_operations() + character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' + + write(*,'(/a)') 'Test string operations: from_string, ' // & + 'read_bitset, to_string, and write_bitset' + + call set0 % from_string( bitstring_0 ) + if ( bits(set0) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_0 size properly.' + else if ( .not. set0 % none() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else if ( set0 % any() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_0 properly into set0' + end if + + call set10 % from_string( bitstring_0 // bitstring_0 ) + if ( bits(set10) /= 66 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_0 // bitstring_0 size properly.' + else if ( .not. set10 % none() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + '// bitstring_0 value properly.' + else if ( set10 % any() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + '// bitstring_0 value properly.' + else + write(*,*) 'from_string transferred bitstring_0//bitstring_0' // & + ' properly into set10' + end if + + call set1 % from_string( bitstring_all ) + if ( bits(set1) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_all size properly.' + else if ( set1 % none() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % any() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % all() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_1 properly into set1' + end if + + call set11 % from_string( bitstring_all // bitstring_all ) + if ( bits(set11) /= 66 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_all // bitstring_all size properly.' + else if ( set11 % none() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + '// bitstring_all value properly.' + else if ( .not. set11 % any() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + '// bitstring_all value properly.' + else if ( .not. set11 % all() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + '// bitstring_all value properly.' + else + write(*,*) 'from_string transferred bitstring_all // ' // & + 'bitstring_all properly into set11' + end if + + call set3 % read_bitset( bitstring_0, status ) + if ( status /= success ) then + write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' + else + error stop procedure // ' read_bitset_string did not fail ' // & + 'with bitstring_0 as expected.' + end if + + call set13 % read_bitset( bitstring_0 // bitstring_0, status ) + if ( status /= success ) then + write(*,*) 'read_bitset_string failed with bitstring_0 ' // & + '// bitstring_0 as expected.' + end if + + call set3 % read_bitset( 's33b' // bitstring_0, status ) + if ( bits(set3) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_0 size properly.' + else if ( .not. set3 % none() ) then + error stop procedure // ' failed to interpret "s33b" // ' // & + 'bitstring_0 value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_0 properly into set3' + end if + + call set13 % read_bitset( 's66b' // bitstring_0 // bitstring_0, & + status ) + if ( bits(set13) /= 66 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_0 // bitstring_0 size properly.' + else if ( .not. set13 % none() ) then + error stop procedure // ' failed to interpret "s66b" // ' // & + 'bitstring_0 // bitstring_0 value properly.' + else + write(*,*) 'read_bitset_string transferred "s66b" // ' // & + 'bitstring_0 // bitstring_0 properly into set13' + end if + + call set4 % read_bitset( 's33b' // bitstring_all ) + if ( bits(set4) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all size properly.' + else if ( set4 % none() ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all value properly.' + else if ( .not. set4 % any() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else if ( .not. set4 % all() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_all properly into set4.' + end if + + call set14 % read_bitset( 's66b' // bitstring_all & + // bitstring_all ) + if ( bits(set14) /= 66 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_all // bitstring_all ' // & + 'size properly.' + else if ( set14 % none() ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_all // bitstring_all ' // & + 'value properly.' + else if ( .not. set14 % any() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s66b" bitstring_all // bitstring_all ' // & + 'value properly.' + else if ( .not. set14 % all() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s66b" bitstring_all // bitstring_all ' // & + 'value properly.' + else + write(*,*) 'read_bitset_string transferred "s66b" // ' // & + 'bitstring_all // bitstring_all properly into set14.' + end if + + call set0 % to_string( string0 ) + if ( bitstring_0 /= string0 ) then + error stop procedure // ' to_string failed to convert set0 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set0 value' + end if + + call set10 % to_string( string0 ) + if ( bitstring_0 // bitstring_0 /= string0 ) then + error stop procedure // ' to_string failed to convert set10 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set10 value' + end if + + call set1 % to_string( string0 ) + if ( bitstring_all /= string0 ) then + error stop procedure // ' to_string failed to convert set1 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set1 value' + end if + + call set11 % to_string( string0 ) + if ( bitstring_all // bitstring_all /= string0 ) then + error stop procedure // ' to_string failed to convert set11 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set11 value' + end if + + call set0 % write_bitset( string0 ) + if ( ('S33B' // bitstring_0) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set2 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set0 value' + end if + + call set10 % write_bitset( string0 ) + if ( ('S66B' // bitstring_0 // bitstring_0) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set10 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set10 value' + end if + + call set1 % write_bitset( string0 ) + if ( ('S33B' // bitstring_all) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set1 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set1 value' + end if + + call set11 % write_bitset( string0 ) + if ( ('S66B' // bitstring_all // bitstring_all) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set11 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set11 value' + end if + + return + end subroutine test_string_operations + + subroutine test_io() + character(*), parameter:: procedure = 'TEST_IO' + + integer :: unit + + write(*,*) + write(*,*) 'Test bitset I/O: input, read_bitset, output, and ' // & + 'write_bitset' + + call set2 % from_string( bitstring_33 ) + open( newunit=unit, file='test1.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit) + call set1 % write_bitset(unit) + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test1.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit) + call set5 % read_bitset(unit) + call set4 % read_bitset(unit) + if ( set4 /= set0 .or. set5 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'plain write_bitset_unit and read_bitset_unit succeeded.' + end if + + close( unit ) + + call set12 % from_string( bitstring_33 // bitstring_33 ) + open( newunit=unit, file='test2.txt', status='replace', & + form='formatted', action='write' ) + call set12 % write_bitset(unit) + call set11 % write_bitset(unit) + call set10 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test2.txt', status='old', & + form='formatted', action='read' ) + call set13 % read_bitset(unit) + call set15 % read_bitset(unit) + call set14 % read_bitset(unit) + if ( set14 /= set10 .or. set15 /= set11 .or. set3 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals for bits > 64 failed.' + else + write(*,*) 'Transfer bits > 64 to and from units using ' // & + 'plain write_bitset_unit and read_bitset_unit succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test3.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test3.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + if ( set5 /= set0 .or. set4 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals with advance == "no" failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'write_bitset_unit and read_bitset_unit with ' // & + 'advance=="no" succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test4.txt', status='replace', & + form='formatted', action='write' ) + call set12 % write_bitset(unit, advance='no') + call set11 % write_bitset(unit, advance='no') + call set10 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test4.txt', status='old', & + form='formatted', action='read' ) + call set13 % read_bitset(unit, advance='no') + call set14 % read_bitset(unit, advance='no') + call set15 % read_bitset(unit) + if ( set15 /= set10 .or. set14 /= set11 .or. set13 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals for bitss > 64 with advance == "no" failed.' + else + write(*,*) 'Transfer bits > 64 to and from units using ' // & + 'write_bitset_unit and read_bitset_unit with ' // & + 'advance=="no" succeeded.' + end if + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', access='stream', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', access='stream', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' stream output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'stream output and input succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set12 % output(unit) + call set11 % output(unit) + call set10 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set15 % input(unit) + call set14 % input(unit) + call set13 % input(unit) + if ( set13 /= set10 .or. set14 /= set11 .or. set15 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' output and input failed for bits . 64.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded for bits > 64.' + end if + close(unit) + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', access='stream', action='write' ) + call set12 % output(unit) + call set11 % output(unit) + call set10 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', access='stream', action='read' ) + call set15 % input(unit) + call set14 % input(unit) + call set13 % input(unit) + if ( set13 /= set10 .or. set14 /= set11 .or. set15 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' stream output and input failed for bits . 64.' + else + write(*,*) 'Transfer to and from units using ' // & + 'stream output and input succeeded for bits > 64.' + end if + close(unit) + + end subroutine test_io + + subroutine test_initialization() + character(*), parameter:: procedure = 'TEST_INITIALIZATION' + logical(int8) :: log1(64) = .true. + logical(int16) :: log2(31) = .false. + logical(int32) :: log3(15) = .true. + logical(int64) :: log4(33) = .false. + logical(int8) :: log11(66) = .true. + logical(int16) :: log12(99) = .false. + logical(int32) :: log13(132) = .true. + logical(int64) :: log14(165) = .false. + logical(int8), allocatable :: log5(:) + logical(int16), allocatable :: log6(:) + logical(int32), allocatable :: log7(:) + logical(int64), allocatable :: log8(:) + + write(*,*) + write(*,*) 'Test initialization: assignment, extract, and init' + + set5 = log1 + if ( set5 % bits() /= 64 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization with logical(int8) succeeded.' + end if + + set5 = log11 + if ( set5 % bits() /= 66 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size > 64 bits.' + else if ( .not. set5 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization > 64 bits with logical(int8)succeeded.' + end if + + set5 = log2 + if ( set5 % bits() /= 31 ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int16) succeeded.' + end if + + set5 = log12 + if ( set5 % bits() /= 99 ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right size > 64 bits .' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right values > 64 bits .' + else + write(*,*) 'Initialization > 64 bits with logical(int16) ' // & + 'succeeded.' + end if + + set5 = log3 + if ( set5 % bits() /= 15 ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int32) succeeded.' + end if + + set5 = log13 + if ( set5 % bits() /= 132 ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right size > 64 bits .' + else if ( .not. set5 % all() ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right values > 64 bits .' + else + write(*,*) 'Initialization > 64 bits with logical(int32) ' // & + 'succeeded.' + end if + + set5 = log4 + if ( set5 % bits() /= 33 ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int64) succeeded.' + end if + + set5 = log14 + if ( set5 % bits() /= 165 ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right size > 64 bits .' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right values > 64 bits .' + else + write(*,*) 'Initialization > 64 bits with logical(int64) ' // & + 'succeeded.' + end if + + set5 = log1 + call extract( set4, set5, 1_bits_kind, 33_bits_kind ) + if ( set4 % bits() /= 33 ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with extract succeeded.' + end if + + set5 = log11 + call extract( set4, set5, 1_bits_kind, 65_bits_kind ) + if ( set4 % bits() /= 65 ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right size > 64 bits.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right values > 64 bits.' + else + write(*,*) 'Initialization with extract succeeded.' + end if + + set5 = log1 + set4 = set5 + if ( set4 % bits() /= 64 ) then + write(*,*) 'Bits = ', set4 % bits() + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with simple assignment succeeded.' + end if + + set5 = log11 + set4 = set5 + if ( set4 % bits() /= 66 ) then + write(*,*) 'Bits = ', set4 % bits() + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right size > 64 bits.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits with simple assignment ' // & + 'succeeded.' + end if + + set5 = log1 + log5 = set5 + if ( size(log5) /= 64 ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log5) ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int8) succeeded.' + end if + + set5 = log11 + log5 = set5 + if ( size(log5) /= 66 ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log5) ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int8) succeeded.' + end if + + set5 = log1 + log6 = set5 + if ( size(log6) /= 64 ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log6) ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int16) succeeded.' + end if + + set5 = log11 + log6 = set5 + if ( size(log6) /= 66 ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log6) ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int16) succeeded.' + end if + + set5 = log1 + log7 = set5 + if ( size(log7) /= 64 ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log7) ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int32) succeeded.' + end if + + set5 = log11 + log7 = set5 + if ( size(log7) /= 66 ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log7) ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int32) succeeded.' + end if + + set5 = log1 + log8 = set5 + if ( size(log8) /= 64 ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log8) ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int64) succeeded.' + end if + + set5 = log11 + log8 = set5 + if ( size(log8) /= 66 ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log8) ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int64) succeeded.' + end if + + end subroutine test_initialization + + subroutine test_bitset_inquiry() + character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' + integer(bits_kind) :: i + + write(*,*) + write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' + + if ( set0 % none() ) then + if ( .not. set0 % any() ) then + write(*,*) 'As expected set0 has no bits set' + else + error stop procedure // ' set0 had some bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have none set which ' // & + 'was unexpected' + end if + + call set0 % not() + + if ( set0 % all() ) then + if ( set0 % any() ) then + write(*,*) 'As expected set0 now has all bits set' + else + error stop procedure // ' set0 had no bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have all bits set ' // & + 'which was unexpected' + end if + + if ( set1 % any() ) then + if ( set1 % all() ) then + write(*,*) 'As expected set1 has all bits set' + else + error stop procedure // ' set1 did not have all bits set ' // & + 'which was unexpected.' + end if + else + error stop procedure // ' set1 had none bits set ' // & + 'which was unexpected' + end if + + call set0 % not() + do i=0, set0 % bits() - 1 + if ( set0 % test(i) ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if + end do + + write(*,*) 'As expected set0 had no bits set.' + + do i=0, set1 % bits() - 1 + if ( .not. set1 % test(i) ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit unset.' + end if + end do + + write(*,*) 'As expected set1 had all bits set.' + + do i=0, set0 % bits() - 1 + if ( set0 % value(i) /= 0 ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if + end do + + write(*,*) 'As expected set0 had no bits set.' + + do i=0, set1 % bits() - 1 + if ( set1 % value(i) /= 1 ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit unset.' + end if + end do + + write(*,*) 'As expected set1 had all bits set.' + + if ( set0 % bits() == 33 ) then + write(*,*) 'set0 has 33 bits as expected.' + else + error stop procedure // 'set0 unexpectedly does not have 33 bits.' + end if + +! > 64 bit inquiries + call set10 % from_string( bitstring_0 // bitstring_0 // bitstring_0 ) + if ( set10 % none() ) then + if ( .not. set10 % any() ) then + write(*,*) 'As expected set10 has no bits set' + else + error stop procedure // ' set10 had some bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set10 did not have none set which ' // & + 'was unexpected' + end if + + call set10 % not() + + if ( set10 % all() ) then + if ( set10 % any() ) then + write(*,*) 'As expected set10 now has all bits set' + else + error stop procedure // ' set10 had no bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set10 did not have all bits set ' // & + 'which was unexpected' + end if + + call set11 % from_string( bitstring_all // bitstring_all // & + bitstring_all ) + if ( set11 % any() ) then + if ( set11 % all() ) then + write(*,*) 'As expected set11 has all bits set' + else + error stop procedure // ' set11 did not have all bits set ' // & + 'which was unexpected.' + end if + else + error stop procedure // ' set11 had none bits set ' // & + 'which was unexpected' + end if + + call set10 % not() + do i=0, set10 % bits() - 1 + if ( set10 % test(i) ) then + error stop procedure // ' against expectations set10 has ' // & + 'at least 1 bit set.' + end if + end do + + write(*,*) 'As expected set10 had no bits set.' + + do i=0, set11 % bits() - 1 + if ( .not. set11 % test(i) ) then + error stop procedure // ' against expectations set11 has ' // & + 'at least 1 bit unset.' + end if + end do + + write(*,*) 'As expected set11 had all bits set.' + + do i=0, set10 % bits() - 1 + if ( set10 % value(i) /= 0 ) then + error stop procedure // ' against expectations set10 has ' // & + 'at least 1 bit set.' + end if + end do + + write(*,*) 'As expected set10 had no bits set.' + + do i=0, set11 % bits() - 1 + if ( set11 % value(i) /= 1 ) then + error stop procedure // ' against expectations set11 has ' // & + 'at least 1 bit unset.' + end if + end do + + write(*,*) 'As expected set11 had all bits set.' + + if ( set0 % bits() == 33 ) then + write(*,*) 'set0 has 33 bits as expected.' + else + error stop procedure // 'set0 unexpectedly does not have 33 bits.' + end if + + if ( set10 % bits() == 99 ) then + write(*,*) 'set10 has 99 bits as expected.' + else + error stop procedure // 'set10 unexpectedly does not have 99 bits.' + end if + + end subroutine test_bitset_inquiry + + subroutine test_bit_operations() + character(*), parameter:: procedure = 'TEST_BIT_OPERATIONS' + + write(*,*) + write(*,*) 'Test bit operations: clear, flip, not, and set' + + if ( .not. set1 % all() ) then + error stop procedure // ' set1 is not all set.' + end if + + call set1 % clear(0_bits_kind) + if ( .not. set1 % test(0_bits_kind) ) then + if ( set1 % test(1_bits_kind) ) then + write(*,*) 'Cleared one bit in set1 as expected.' + else + error stop procedure // ' cleared more than one bit in set1.' + end if + else + error stop procedure // ' did not clear the first bit in set1.' + end if + + call set1 % clear(1_bits_kind, 32_bits_kind) + if ( set1 % none() ) then + write(*,*) 'Cleared remaining bits in set1 as expected.' + else + error stop procedure // ' did not clear remaining bits ' // & + 'in set1.' + end if + + call set1 % flip(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then + write(*,*) 'Flipped one bit in set1 as expected.' + else + error stop procedure // ' flipped more than one bit in set1.' + end if + else + error stop procedure // ' did not flip the first bit in set1.' + end if + + call set1 % flip(1_bits_kind, 32_bits_kind) + if ( set1 % all() ) then + write(*,*) 'Flipped remaining bits in set1 as expected.' + else + error stop procedure // ' did not flip remaining bits ' // & + 'in set1.' + end if + + call set1 % not() + if ( set1 % none() ) then + write(*,*) 'Unset bits in set1 as expected.' + else + error stop procedure // ' did not unset bits in set1.' + end if + + call set1 % set(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then + write(*,*) 'Set first bit in set1 as expected.' + else + error stop procedure // ' set more than one bit in set1.' + end if + else + error stop procedure // ' did not set the first bit in set1.' + end if + + call set1 % set(1_bits_kind, 32_bits_kind) + if ( set1 % all() ) then + write(*,*) 'Set the remaining bits in set1 as expected.' + else + error stop procedure // ' did not set the remaining bits ' // & + 'in set1.' + end if + + call set11 % init( 166_bits_kind ) + call set11 % not() + if ( .not. set11 % all() ) then + error stop procedure // ' set11 is not all set.' + end if + + call set11 % clear(0_bits_kind) + if ( .not. set11 % test(0_bits_kind) ) then + if ( set11 % test(1_bits_kind) ) then + write(*,*) 'Cleared one bit in set11 as expected.' + else + error stop procedure // ' cleared more than one bit in set11.' + end if + else + error stop procedure // ' did not clear the first bit in set11.' + end if + + call set11 % clear(165_bits_kind) + if ( .not. set11 % test(165_bits_kind) ) then + if ( set11 % test(164_bits_kind) ) then + write(*,*) 'Cleared the last bit in set11 as expected.' + else + error stop procedure // ' cleared more than one bit in set11.' + end if + else + error stop procedure // ' did not clear the last bit in set11.' + end if + + call set11 % clear(1_bits_kind, 164_bits_kind) + if ( set11 % none() ) then + write(*,*) 'Cleared remaining bits in set11 as expected.' + else + error stop procedure // ' did not clear remaining bits ' // & + 'in set11.' + end if + + call set11 % flip(0_bits_kind) + if ( set11 % test(0_bits_kind) ) then + if ( .not. set11 % test(1_bits_kind) ) then + write(*,*) 'Flipped one bit in set11 as expected.' + else + error stop procedure // ' flipped more than one bit in set11.' + end if + else + error stop procedure // ' did not flip the first bit in set11.' + end if + + call set11 % flip(165_bits_kind) + if ( set11 % test(165_bits_kind) ) then + if ( .not. set11 % test(164_bits_kind) ) then + write(*,*) 'Flipped last bit in set11 as expected.' + else + error stop procedure // ' flipped more than one bit in set11.' + end if + else + error stop procedure // ' did not flip the last bit in set11.' + end if + + call set11 % flip(1_bits_kind, 164_bits_kind) + if ( set11 % all() ) then + write(*,*) 'Flipped remaining bits in set11 as expected.' + else + error stop procedure // ' did not flip remaining bits ' // & + 'in set11.' + end if + + call set11 % not() + if ( set11 % none() ) then + write(*,*) 'Unset bits in set11 as expected.' + else + error stop procedure // ' did not unset bits in set11.' + end if + + call set11 % set(0_bits_kind) + if ( set11 % test(0_bits_kind) ) then + if ( .not. set11 % test(1_bits_kind) ) then + write(*,*) 'Set first bit in set11 as expected.' + else + error stop procedure // ' set more than one bit in set11.' + end if + else + error stop procedure // ' did not set the first bit in set11.' + end if + + call set11 % set(165_bits_kind) + if ( set11 % test(165_bits_kind) ) then + if ( .not. set11 % test(164_bits_kind) ) then + write(*,*) 'Set last bit in set11 as expected.' + else + error stop procedure // ' set more than one bit in set11.' + end if + else + error stop procedure // ' did not set the last bit in set11.' + end if + + call set11 % set(1_bits_kind, 164_bits_kind) + if ( set11 % all() ) then + write(*,*) 'Set the remaining bits in set11 as expected.' + else + error stop procedure // ' did not set the remaining bits ' // & + 'in set11.' + end if + + end subroutine test_bit_operations + + subroutine test_bitset_comparisons() + character(*), parameter:: procedure = 'TEST_BITSET_COMPARISON' + + write(*,*) + write(*,*) 'Test bitset comparisons: ==, /=, <, <=, >, and >=' + + if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & + set1 == set2 ) then + write(*,*) 'Passed 64 bit equality tests.' + else + error stop procedure // ' failed 64 bit equality tests.' + end if + + if ( set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & + .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & + set2 /= set2 ) then + write(*,*) 'Passed 64 bit inequality tests.' + else + error stop procedure // ' failed 64 bit inequality tests.' + end if + + if ( set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & + .not. set0 > set1 .and. .not. set1 > set1 .and. .not. & + set2 > set1 ) then + write(*,*) 'Passed 64 bit greater than tests.' + else + error stop procedure // ' failed 64 bit greater than tests.' + end if + + if ( set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & + .not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. & + set2 >= set1 ) then + write(*,*) 'Passed 64 bit greater than or equal tests.' + else + error stop procedure // ' failed 64 bit greater than or ' // & + 'equal tests.' + end if + + if ( set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & + .not. set1 < set0 .and. .not. set0 < set0 .and. .not. & + set1 < set2 ) then + write(*,*) 'Passed 64 bit less than tests.' + else + error stop procedure // ' failed 64 bit less than tests.' + end if + + if ( set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & + .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & + set1 <= set2 ) then + write(*,*) 'Passed 64 bit less than or equal tests.' + else + error stop procedure // ' failed 64 bit less than or ' // & + 'equal tests.' + end if + + call set10 % init(166_bits_kind) + call set11 % init(166_bits_kind) + call set11 % not() + call set12 % init(166_bits_kind) + call set12 % set(165_bits_kind) + call set13 % init(166_bits_kind) + call set13 % set(65_bits_kind) + call set14 % init(166_bits_kind) + call set14 % set(0_bits_kind) + if ( set10 == set10 .and. set11 == set11 .and. set12 == set12 .and. & + set13 == set13 .and. set14 == set14 .and. & + .not. set13 == set14 .and. .not. set12 == set13 .and. & + .not. set10 == set11 .and. .not. set10 == set12 .and. .not. & + set11 == set12 ) then + write(*,*) 'Passed > 64 bit equality tests.' + else + error stop procedure // ' failed > 64 bit equality tests.' + end if + + if ( set10 /= set11 .and. set11 /= set12 .and. set10 /= set12 .and. & + set13 /= set12 .and. set14 /= set13 .and. set14 /= set12 .and. & + .not. set13 /= set13 .and. .not. set12 /= set12 .and. & + .not. set10 /= set10 .and. .not. set11 /= set11 .and. .not. & + set12 /= set12 ) then + write(*,*) 'Passed > 64 bit inequality tests.' + else + error stop procedure // ' failed > 64 bit inequality tests.' + end if + + if ( set11 > set10 .and. set12 > set10 .and. set11 > set12 .and. & + set13 > set14 .and. set12 > set13 .and. set12 > set14 .and. & + .not. set14 > set12 .and. .not. set12 > set11 .and. & + .not. set10 > set11 .and. .not. set11 > set11 .and. .not. & + set12 > set11 ) then + write(*,*) 'Passed > 64 bit greater than tests.' + else + error stop procedure // ' failed > 64 bit greater than tests.' + end if + + if ( set11 >= set10 .and. set11 >= set12 .and. set12 >= set12 .and. & + set13 >= set14 .and. set12 >= set13 .and. set12 >= set14 .and. & + .not. set14 >= set12 .and. .not. set12 >= set11 .and. & + .not. set10 >= set11 .and. .not. set10 >= set11 .and. .not. & + set12 >= set11 ) then + write(*,*) 'Passed > 64 bit greater than or equal tests.' + else + error stop procedure // ' failed 64 bit greater than or ' // & + 'equal tests.' + end if + + if ( set10 < set11 .and. set10 < set11 .and. set12 < set11 .and. & + set14 < set13 .and. set13 < set12 .and. set14 < set12 .and. & + .not. set12 < set14 .and. .not. set11 < set12 .and. & + .not. set11 < set10 .and. .not. set10 < set10 .and. .not. & + set11 < set12 ) then + write(*,*) 'Passed > 64 bit less than tests.' + else + error stop procedure // ' failed > 64 bit less than tests.' + end if + + if ( set10 <= set11 .and. set12 <= set11 .and. set12 <= set12 .and. & + set14 <= set13 .and. set13 <= set12 .and. set14 <= set12 .and. & + .not. set12 <= set14 .and. .not. set11 <= set12 .and. & + .not. set11 <= set10 .and. .not. set12 <= set10 .and. .not. & + set11 <= set12 ) then + write(*,*) 'Passed > 64 bit less than or equal tests.' + else + error stop procedure // ' failed > 64 bit less than or ' // & + 'equal tests.' + end if + + end subroutine test_bitset_comparisons + + subroutine test_bitset_operations() + character(*), parameter:: procedure = 'TEST_BITSET_OPERATIONS' + + write(*,*) + write(*,*) 'Test bitset operations: and, and_not, or, and xor' + + call set0 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and( set0, set4 ) ! all all + if ( set0 % all() ) then + write(*,*) 'First test of < 64 bit AND worked.' + else + error stop procedure // ' first test of < 64 bit AND failed.' + end if + + call set4 % from_string( bitstring_0 ) + call and( set0, set4 ) ! all none + if ( set0 % none() ) then + write(*,*) 'Second test of < 64 bit AND worked.' + else + error stop procedure // ' second test of < 64 bit AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Third test of < 64 bit AND worked.' + else + error stop procedure // ' third test of < 64 bit AND failed.' + end if + + call set3 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of < 64 bit AND worked.' + else + error stop procedure // ' fourth test of < 64 bit AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and_not( set4, set3 ) ! all all + if ( set4 % none() ) then + write(*,*) 'First test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' first test of < 64 bit AND_NOT failed.' + end if + + call set4 % from_string( bitstring_0 ) + call and_not( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Second test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' second test of < 64 bit AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' third test of < 64 bit AND_NOT failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'Fourth test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' fourth test of < 64 bit AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call or( set3, set4 ) ! all all + if ( set3 % all() ) then + write(*,*) 'First test of < 64 bit OR worked.' + else + error stop procedure // ' first test of < 64 bit OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call or( set4, set3 ) ! all none + if ( set4 % all() ) then + write(*,*) 'Second test of < 64 bit OR worked.' + else + error stop procedure // ' second test of < 64 bit OR failed.' + end if + + call or( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Third test of < 64 bit OR worked.' + else + error stop procedure // ' third test of < 64 bit OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call or( set4, set3 ) !none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of < 64 bit OR worked.' + else + error stop procedure // ' fourth test of < 64 bit OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'First test of < 64 bit XOR worked.' + else + error stop procedure // ' first test of < 64 bit XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Second test of < 64 bit XOR worked.' + else + error stop procedure // ' second test of < 64 bit XOR failed.' + end if + + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of < 64 bit XOR worked.' + else + error stop procedure // ' third test of < 64 bit XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! all all + if ( set3 % none() ) then + write(*,*) 'Fourth test of < 64 bit XOR worked.' + else + error stop procedure // ' fourth test of < 64 bit XOR failed.' + end if + + call set0 % init(166_bits_kind) + call set0 % not() + call set4 % init(166_bits_kind) + call set4 % not() + call and( set0, set4 ) ! all all + if ( set0 % all() ) then + write(*,*) 'First test of > 64 bit AND worked.' + else + error stop procedure // ' first test of > 64 bit AND failed.' + end if + + call set4 % init(166_bits_kind) + call and( set0, set4 ) ! all none + if ( set0 % none() ) then + write(*,*) 'Second test of > 64 bit AND worked.' + else + error stop procedure // ' second test of > 64 bit AND failed.' + end if + + call set3 % init(166_bits_kind) + call set3 % not() + call and( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Third test of > 64 bit AND worked.' + else + error stop procedure // ' third test of > 64 bit AND failed.' + end if + + call set3 % init(166_bits_kind) + call and( set4, set3 ) ! none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of > 64 bit AND worked.' + else + error stop procedure // ' fourth test of > 64 bit AND failed.' + end if + + call set3 % not() + call set4 % not() + call and_not( set4, set3 ) ! all all + if ( set4 % none() ) then + write(*,*) 'First test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' first test of > 64 bit AND_NOT failed.' + end if + + call and_not( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Second test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' second test of > 64 bit AND_NOT failed.' + end if + + call and_not( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' third test of > 64 bit AND_NOT failed.' + end if + + call set3 % not() + call and_not( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'Fourth test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' fourth test of > 64 bit AND_NOT failed.' + end if + + call set3 % init(166_bits_kind) + call set3 % not() + call set4 % init(166_bits_kind) + call set4 % not() + call or( set3, set4 ) ! all all + if ( set3 % all() ) then + write(*,*) 'First test of > 64 bit OR worked.' + else + error stop procedure // ' first test of > 64 bit OR failed.' + end if + + call set3 % init(166_bits_kind) + call or( set4, set3 ) ! all none + if ( set4 % all() ) then + write(*,*) 'Second test of > 64 bit OR worked.' + else + error stop procedure // ' second test of > 64 bit OR failed.' + end if + + call or( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Third test of > 64 bit OR worked.' + else + error stop procedure // ' third test of > 64 bit OR failed.' + end if + + call set3 % init(166_bits_kind) + call set4 % init(166_bits_kind) + call or( set4, set3 ) !none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of > 64 bit OR worked.' + else + error stop procedure // ' fourth test of > 64 bit OR failed.' + end if + + call xor( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'First test of > 64 bit XOR worked.' + else + error stop procedure // ' first test of > 64 bit XOR failed.' + end if + + call set4 % not() + call xor( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Second test of > 64 bit XOR worked.' + else + error stop procedure // ' second test of > 64 bit XOR failed.' + end if + + call set4 % not() + call xor( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of > 64 bit XOR worked.' + else + error stop procedure // ' third test of > 64 bit XOR failed.' + end if + + call set4 % not() + call xor( set3, set4 ) ! all all + if ( set3 % none() ) then + write(*,*) 'Fourth test of > 64 bit XOR worked.' + else + error stop procedure // ' fourth test of > 64 bit XOR failed.' + end if + + end subroutine test_bitset_operations + + +end program test_stdlib_bitset_large diff --git a/src/tests/logger/test_stdlib_logger.f90 b/src/tests/logger/test_stdlib_logger.f90 index 99c726e13..649494819 100644 --- a/src/tests/logger/test_stdlib_logger.f90 +++ b/src/tests/logger/test_stdlib_logger.f90 @@ -12,7 +12,7 @@ program test_stdlib_logger implicit none integer, allocatable :: log_units(:) - integer :: max_width, stat + integer :: level, max_width, stat integer :: unit1, unit2, unit3, unit4, unit5, unit6 logical :: add_blank_line, exist, indent, time_stamp @@ -47,7 +47,7 @@ program test_stdlib_logger print * print *, 'running log_text_error' call global % log_text_error( 'This text should be written to UNIT1' // & - 'and UNIT3 and not to OUTPUT_UNIT.', & + ' and UNIT3 and not to OUTPUT_UNIT.', & column = 25, & summary = 'There is no real error here.', & filename = 'dummy.txt', & @@ -71,6 +71,7 @@ program test_stdlib_logger caret = '^', & stat = stat ) + call test_level() contains @@ -126,6 +127,62 @@ subroutine test_logging_configuration() end if + !testing all calls independently + call global % configuration( add_blank_line=add_blank_line ) + + if ( .not. add_blank_line ) then + write(*,*) 'ADD_BLANK_LINE starts off as .FALSE. as expected.' + + else + error stop 'ADD_BLANK_LINE starts off as .TRUE. contrary to ' // & + 'expectations.' + + end if + + call global % configuration( indent=indent ) + + if ( indent ) then + write(*,*) 'INDENT starts off as .TRUE. as expected.' + + else + error stop 'INDENT starts off as .FALSE. contrary to expectations.' + + end if + + call global % configuration( max_width=max_width ) + + if ( max_width == 0 ) then + write(*,*) 'MAX_WIDTH starts off as 0 as expected.' + + else + error stop 'MAX_WIDTH starts off as not equal to 0 contrary ' // & + 'to expectations.' + + end if + + call global % configuration( time_stamp=time_stamp ) + + if ( time_stamp ) then + write(*,*) 'TIME_STAMP starts off as .TRUE. as expected.' + + else + error stop 'TIME_STAMP starts off as .FALSE. contrary to ' // & + 'expectations.' + + end if + + call global % configuration( log_units=log_units ) + + if ( size(log_units) == 0 ) then + write(*,*) 'SIZE(LOG_UNITS) starts off as 0 as expected.' + + else + error stop 'SIZE(LOG_UNITS) starts off as non-zero contrary ' // & + 'to expectations.' + + end if + + call global % log_information( 'This message should be output ' // & 'to OUTPUT_UNIT, unlimited in width, not preceded by ' // & 'a blank line, then by a time stamp, then by MODULE % ' // & @@ -134,6 +191,30 @@ subroutine test_logging_configuration() module = 'N/A', & procedure = 'TEST_STDLIB_LOGGER' ) + call global % log_information( 'This message should be output ' // & + 'to OUTPUT_UNIT, unlimited in width, not preceded by ' // & + 'a blank line, then by a time stamp, then by MODULE % ' // & + 'PROCEDURE, be prefixed by INFO. ' // new_line('a') // & + 'This is a new line of the same log message.', & + module = 'N/A', & + procedure = 'TEST_STDLIB_LOGGER' ) + + call global % log_debug( 'This message should be output ' // & + 'to OUTPUT_UNIT, unlimited in width, not preceded by ' // & + 'a blank line, then by a time stamp, then by MODULE % ' // & + 'PROCEDURE, be prefixed by DEBUG and be indented on ' // & + 'subsequent lines by 4 columns.', & + module = 'N/A', & + procedure = 'TEST_STDLIB_LOGGER' ) + + call global % log_debug( 'This message should be output ' // & + 'to OUTPUT_UNIT, unlimited in width, not preceded by ' // & + 'a blank line, then by a time stamp, then by MODULE % ' // & + 'PROCEDURE, be prefixed by DEBUG. ' // new_line('a') // & + 'This is a new line of the same log message.', & + module = 'N/A', & + procedure = 'TEST_STDLIB_LOGGER' ) + call global % configure( add_blank_line=.true., indent=.false., & max_width=72, time_stamp=.false. ) @@ -142,7 +223,7 @@ subroutine test_logging_configuration() log_units=log_units ) if ( add_blank_line ) then - write(*,*) 'ADD_BLANK_LINE is now .FALSE. as expected.' + write(*,*) 'ADD_BLANK_LINE is now .TRUE. as expected.' else error stop 'ADD_BLANKLINE is now .FALSE. contrary to expectations.' @@ -191,6 +272,13 @@ subroutine test_logging_configuration() module = 'N/A', & procedure = 'TEST_STDLIB_LOGGER' ) + call global % log_message( 'The last word of the first line ' // & + new_line('a')//'should be "line". "Line"' // new_line('a') // & + 'is also the last word for the second line. The following ' // & + 'lines should be limited to 72 columns width.' , & + module = 'N/A', & + procedure = 'TEST_STDLIB_LOGGER' ) + call global % configure( add_blank_line=.false., indent=.true., & max_width=72, time_stamp=.true. ) @@ -202,6 +290,14 @@ subroutine test_logging_configuration() module = 'N/A', & procedure = 'TEST_STDLIB_LOGGER' ) + call global % log_message( 'The last word of the first line ' // & + new_line('a')//'should be "the". "Line"' // new_line('a') // & + 'should be the last word for the second line. The following ' // & + 'lines should be limited to 72 columns width. From the second ' //& + 'line, all lines should be indented by 4 columns.' ,& + module = 'N/A', & + procedure = 'TEST_STDLIB_LOGGER' ) + end subroutine test_logging_configuration @@ -610,4 +706,138 @@ subroutine test_adding_log_units() return end subroutine test_adding_log_units + subroutine test_level() + + print *, 'running test_level' + + call global % configure( level = all_level ) + + call global % configuration( level = level ) + if ( level == all_level ) then + write(*,*) 'LEVEL is all_level as expected.' + + else + error stop 'LEVEL starts off as not equal to all_level ' //& + 'contrary to expectations.' + + end if + + call global % log_message('This message should be always printed, & + & irrespective of the severity level') + + call global % log_debug( 'This message should be printed') + call global % log_information( 'This message should be printed') + call global % log_warning( 'This message should be printed') + call global % log_error( 'This message should be printed') + call global % log_io_error( 'This message should be printed') + + call global % configure( level = debug_level ) + + call global % configuration( level = level ) + if ( level == debug_level ) then + write(*,*) 'LEVEL is debug_level as expected.' + + else + error stop 'LEVEL starts off as not equal to debug_level ' //& + 'contrary to expectations.' + + end if + + call global % log_message('This message should be always printed, & + & irrespective of the severity level') + + call global % log_debug( 'This message should be printed') + call global % log_information( 'This message should be printed') + call global % log_warning( 'This message should be printed') + call global % log_error( 'This message should be printed') + call global % log_io_error( 'This message should be printed') + + call global % configure( level = information_level ) + + call global % configuration( level = level ) + if ( level == information_level ) then + write(*,*) 'LEVEL is information_level as expected.' + + else + error stop 'LEVEL starts off as not equal to information_level ' //& + 'contrary to expectations.' + + end if + + call global % log_message('This message should be always printed, & + & irrespective of the severity level') + + call global % log_debug( 'This message should NOT be printed') + call global % log_information( 'This message should be printed') + call global % log_warning( 'This message should be printed') + call global % log_error( 'This message should be printed') + call global % log_io_error( 'This message should be printed') + + call global % configure( level = warning_level ) + + call global % configuration( level = level ) + if ( level == warning_level ) then + write(*,*) 'LEVEL is warning_level as expected.' + + else + error stop 'LEVEL starts off as not equal to warning_level ' //& + 'contrary to expectations.' + + end if + + call global % log_message('This message should be always printed, & + & irrespective of the severity level') + + call global % log_debug( 'This message should NOT be printed') + call global % log_information( 'This message should NOT be printed') + call global % log_warning( 'This message should be printed') + call global % log_error( 'This message should be printed') + call global % log_io_error( 'This message should be printed') + + call global % configure( level = error_level ) + + call global % configuration( level = level ) + if ( level == error_level ) then + write(*,*) 'LEVEL is error_level as expected.' + + else + error stop 'LEVEL starts off as not equal to error_level ' //& + 'contrary to expectations.' + + end if + + call global % log_message('This message should be always printed, & + & irrespective of the severity level') + + call global % log_debug( 'This message should NOT be printed') + call global % log_information( 'This message should NOT be printed') + call global % log_warning( 'This message should NOT be printed') + call global % log_error( 'This message should be printed') + call global % log_io_error( 'This message should be printed') + + call global % configure( level = none_level ) + + call global % configuration( level = level ) + if ( level == none_level ) then + write(*,*) 'LEVEL is none_level as expected.' + + else + error stop 'LEVEL starts off as not equal to none_level ' //& + 'contrary to expectations.' + + end if + + call global % log_message('This message should be always printed, & + & irrespective of the severity level') + + call global % log_debug( 'This message should NOT be printed') + call global % log_information( 'This message should NOT be printed') + call global % log_warning( 'This message should NOT be printed') + call global % log_error( 'This message should NOT be printed') + call global % log_io_error( 'This message should NOT be printed') + + print *, 'end of test_level' + + end subroutine test_level + end program test_stdlib_logger diff --git a/src/tests/stats/test_mean.f90 b/src/tests/stats/test_mean.f90 index d58495f54..f609555c1 100644 --- a/src/tests/stats/test_mean.f90 +++ b/src/tests/stats/test_mean.f90 @@ -7,7 +7,7 @@ program test_mean implicit none real(sp), parameter :: sptol = 1000 * epsilon(1._sp) -real(dp), parameter :: dptol = 1000 * epsilon(1._dp) +real(dp), parameter :: dptol = 2000 * epsilon(1._dp) real(sp) :: s1(3) = [1.0_sp, 2.0_sp, 3.0_sp]