Implement trueloc/falseloc

CHANGELOG.md

@@ -2,6 +2,9 @@
 
 Features available from the latest git source
 
+- new module `stdlib_array`
+ [#603](https://github.com/fortran-lang/stdlib/pull/603)
+ - new procedures `trueloc`, `falseloc`
 - new module `stdlib_distribution_uniform`
  [#272](https://github.com/fortran-lang/stdlib/pull/272)
 - new module `stdlib_selection`

doc/specs/index.md

@@ -11,6 +11,7 @@ This is and index/directory of the specifications (specs) for each new module/fe
 
 ## Experimental Features & Modules
 
+ - [array](./stdlib_array.html) - Procedures for index manipulation and array handling
  - [ascii](./stdlib_ascii.html) - Procedures for handling ASCII characters
  - [bitsets](./stdlib_bitsets.html) - Bitset data types and procedures
  - [error](./stdlib_error.html) - Catching and handling errors

doc/specs/stdlib_array.md

@@ -0,0 +1,81 @@
+---
+title: array
+---
+
+# The `stdlib_array` module
+
+[TOC]
+
+## Introduction
+
+Module for index manipulation and array handling tasks.
+
+## Procedures and methods provided
+
+
+### `trueloc`
+
+#### Status
+
+Experimental
+
+#### Description
+
+Turn a logical mask into an index array by selecting all true values.
+
+#### Syntax
+
+`call [[trueloc(function)]] (array[, lbound])`
+
+#### Arguments
+
+`array`: List of default logical arrays. This argument is `intent(in)`.
+
+`lbound`: Lower bound of the array to index. This argument is `optional` and `intent(in)`.
+
+#### Examples
+
+```fortran
+program demo
+ use stdlib_array, only : trueloc
+ implicit none
+ real, allocatable :: array(:)
+ allocate(array(500))
+ call random_number(array)
+ array(trueloc(array > 0.5)) = 0.0
+end program demo
+```
+
+
+### `falseloc`
+
+#### Status
+
+Experimental
+
+#### Description
+
+Turn a logical mask into an index array by selecting all false values.
+
+#### Syntax
+
+`call [[falseloc(function)]] (array[, lbound])`
+
+#### Arguments
+
+`array`: List of default logical arrays. This argument is `intent(in)`.
+
+`lbound`: Lower bound of the array to index. This argument is `optional` and `intent(in)`.
+
+#### Examples
+
+```fortran
+program demo
+ use stdlib_array, only : falseloc
+ implicit none
+ real, allocatable :: array(:)
+ allocate(array(-200:200))
+ call random_number(array)
+ array(falseloc(array < 0.5), lbound(array)) = 0.0
+end program demo
+```

src/CMakeLists.txt

@@ -71,6 +71,7 @@ list(
 fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
 
 set(SRC
+ stdlib_array.f90
  stdlib_error.f90
  stdlib_logger.f90
  stdlib_system.F90

src/Makefile.manual

@@ -46,6 +46,7 @@ SRCFYPP = \
  stdlib_version.fypp
 
 SRC = f18estop.f90 \
+ stdlib_array.f90 \
  stdlib_error.f90 \
  stdlib_specialfunctions.f90 \
  stdlib_specialfunctions_legendre.f90 \

src/stdlib_array.f90

@@ -0,0 +1,60 @@
+! SPDX-Identifier: MIT
+
+!> Module for index manipulation and general array handling
+module stdlib_array
+ implicit none
+ private
+
+ public :: trueloc, falseloc
+
+contains
+
+ !> Return the positions of the true elements in array
+ pure function trueloc(array, lbound) result(loc)
+ !> Mask of logicals
+ logical, intent(in) :: array(:)
+ !> Lower bound of array to index
+ integer, intent(in), optional :: lbound
+ !> Locations of true elements
+ integer :: loc(count(array))
+
+ loc = logicalloc(array, .true., lbound)
+ end function trueloc
+
+ !> Return the positions of the false elements in array
+ pure function falseloc(array, lbound) result(loc)
+ !> Mask of logicals
+ logical, intent(in) :: array(:)
+ !> Lower bound of array to index
+ integer, intent(in), optional :: lbound
+ !> Locations of false elements
+ integer :: loc(count(.not.array))
+
+ loc = logicalloc(array, .false., lbound)
+ end function falseloc
+
+ !> Return the positions of the truthy elements in array
+ pure function logicalloc(array, truth, lbound) result(loc)
+ !> Mask of logicals
+ logical, intent(in) :: array(:)
+ !> Truthy value
+ logical, intent(in) :: truth
+ !> Lower bound of array to index
+ integer, intent(in), optional :: lbound
+ !> Locations of truthy elements
+ integer :: loc(count(array.eqv.truth))
+ integer :: i, pos, offset
+
+ offset = 0
+ if (present(lbound)) offset = lbound - 1
+
+ i = 0
+ do pos = 1, size(array)
+ if (array(pos).eqv.truth) then
+ i = i + 1
+ loc(i) = pos + offset
+ end if
+ end do
+ end function logicalloc
+
+end module stdlib_array

src/tests/CMakeLists.txt

@@ -15,6 +15,7 @@ list(
  "-I${PROJECT_SOURCE_DIR}/src"
 )
 
+add_subdirectory(array)
 add_subdirectory(ascii)
 add_subdirectory(bitsets)
 add_subdirectory(io)

src/tests/Makefile.manual

@@ -12,6 +12,7 @@ testdrive.F90:
 $(FETCH) https://github.com/fortran-lang/test-drive/raw/v0.4.0/src/testdrive.F90 > $@
 
 all test clean::
+$(MAKE) -f Makefile.manual --directory=array $@
 $(MAKE) -f Makefile.manual --directory=ascii $@
 $(MAKE) -f Makefile.manual --directory=bitsets $@
 $(MAKE) -f Makefile.manual --directory=io $@

src/tests/array/CMakeLists.txt

@@ -0,0 +1 @@
+ADDTEST(logicalloc)

src/tests/array/Makefile.manual

@@ -0,0 +1,4 @@
+PROGS_SRC = test_logicalloc.f90
+
+
+include ../Makefile.manual.test.mk

src/tests/array/test_logicalloc.f90

@@ -0,0 +1,154 @@
+! SPDX-Identifier: MIT
+
+module test_logicalloc
+ use stdlib_array, only : trueloc, falseloc
+ use stdlib_string_type, only : string_type, len
+ use testdrive, only : new_unittest, unittest_type, error_type, check
+ implicit none
+ private
+
+ public :: collect_logicalloc
+
+contains
+
+ !> Collect all exported unit tests
+ subroutine collect_logicalloc(testsuite)
+ !> Collection of tests
+ type(unittest_type), allocatable, intent(out) :: testsuite(:)
+
+ testsuite = [ &
+ new_unittest("trueloc-where", test_trueloc_where), &
+ new_unittest("trueloc-merge", test_trueloc_merge), &
+ new_unittest("falseloc-where", test_falseloc_where), &
+ new_unittest("falseloc-merge", test_falseloc_merge) &
+ ]
+ end subroutine collect_logicalloc
+
+ subroutine test_trueloc_where(error)
+ !> Error handling
+ type(error_type), allocatable, intent(out) :: error
+
+ integer :: ndim
+ real, allocatable :: avec(:), bvec(:), cvec(:)
+
+ do ndim = 100, 12000, 100
+ allocate(avec(ndim))
+
+ call random_number(avec)
+ avec(:) = avec - 0.5
+
+ bvec = avec
+ bvec(trueloc(bvec > 0)) = 0.0
+
+ cvec = avec
+ where(cvec > 0) cvec = 0.0
+
+ call check(error, all(bvec == cvec))
+ deallocate(avec, bvec, cvec)
+ if (allocated(error)) exit
+ end do
+ end subroutine test_trueloc_where
+
+ subroutine test_trueloc_merge(error)
+ !> Error handling
+ type(error_type), allocatable, intent(out) :: error
+
+ integer :: ndim
+ real, allocatable :: avec(:), bvec(:), cvec(:)
+
+ do ndim = 100, 12000, 100
+ allocate(avec(ndim))
+
+ call random_number(avec)
+ avec(:) = avec - 0.5
+
+ bvec = avec
+ bvec(trueloc(bvec > 0)) = 0.0
+
+ cvec = avec
+ cvec(:) = merge(0.0, cvec, cvec > 0)
+
+ call check(error, all(bvec == cvec))
+ deallocate(avec, bvec, cvec)
+ if (allocated(error)) exit
+ end do
+ end subroutine test_trueloc_merge
+
+ subroutine test_falseloc_where(error)
+ !> Error handling
+ type(error_type), allocatable, intent(out) :: error
+
+ integer :: ndim
+ real, allocatable :: avec(:), bvec(:), cvec(:)
+
+ do ndim = 100, 12000, 100
+ allocate(avec(ndim))
+
+ call random_number(avec)
+ avec(:) = avec - 0.5
+
+ bvec = avec
+ bvec(falseloc(bvec > 0)) = 0.0
+
+ cvec = avec
+ where(.not.(cvec > 0)) cvec = 0.0
+
+ call check(error, all(bvec == cvec))
+ deallocate(avec, bvec, cvec)
+ if (allocated(error)) exit
+ end do
+ end subroutine test_falseloc_where
+
+ subroutine test_falseloc_merge(error)
+ !> Error handling
+ type(error_type), allocatable, intent(out) :: error
+
+ integer :: ndim
+ real, allocatable :: avec(:), bvec(:), cvec(:)
+
+ do ndim = 100, 12000, 100
+ allocate(avec(ndim))
+
+ call random_number(avec)
+ avec(:) = avec - 0.5
+
+ bvec = avec
+ bvec(falseloc(bvec > 0)) = 0.0
+
+ cvec = avec
+ cvec(:) = merge(cvec, 0.0, cvec > 0)
+
+ call check(error, all(bvec == cvec))
+ deallocate(avec, bvec, cvec)
+ if (allocated(error)) exit
+ end do
+ end subroutine test_falseloc_merge
+
+end module test_logicalloc
+
+
+program tester
+ use, intrinsic :: iso_fortran_env, only : error_unit
+ use testdrive, only : run_testsuite, new_testsuite, testsuite_type
+ use test_logicalloc, only : collect_logicalloc
+ implicit none
+ integer :: stat, is
+ type(testsuite_type), allocatable :: testsuites(:)
+ character(len=*), parameter :: fmt = '("#", *(1x, a))'
+
+ stat = 0
+
+ testsuites = [ &
+ new_testsuite("logicalloc", collect_logicalloc) &
+ ]
+
+ do is = 1, size(testsuites)
+ write(error_unit, fmt) "Testing:", testsuites(is)%name
+ call run_testsuite(testsuites(is)%collect, error_unit, stat)
+ end do
+
+ if (stat > 0) then
+ write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
+ error stop
+ end if
+end program