Implement trueloc/falseloc

Author: awvwgk

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