diff --git a/CHANGELOG.md b/CHANGELOG.md index 319e80071..071c90da1 100644 --- a/CHANGELOG.md +++ b/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` diff --git a/doc/specs/index.md b/doc/specs/index.md index 7a7a6f143..fbe498b75 100644 --- a/doc/specs/index.md +++ b/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 diff --git a/doc/specs/stdlib_array.md b/doc/specs/stdlib_array.md new file mode 100644 index 000000000..8acaa20b3 --- /dev/null +++ b/doc/specs/stdlib_array.md @@ -0,0 +1,101 @@ +--- +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. +Provides similar functionality like the built-in `where` or the intrinsic procedures `merge` and `pack` when working with logical mask. +The built-in / intrinsics are usually preferable to `trueloc`, unless the access to the index array is required. + +#### Syntax + +`loc = [[trueloc(function)]] (array[, lbound])` + +#### Class + +Pure function. + +#### 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)`. + +#### Return value + +Returns an array of default integer size, with a maximum length of `size(array)` elements. + +#### Examples + +```fortran +program demo_trueloc + 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_trueloc +``` + + +### `falseloc` + +#### Status + +Experimental + +#### Description + +Turn a logical mask into an index array by selecting all false values. +Provides similar functionality like the built-in `where` or the intrinsic procedures `merge` and `pack` when working with logical mask. +The built-in / intrinsics are usually preferable to `falseloc`, unless the access to the index array is required. + +#### Syntax + +`loc = [[falseloc(function)]] (array[, lbound])` + +#### Class + +Pure function. + +#### 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)`. + +#### Return value + +Returns an array of default integer size, with a maximum length of `size(array)` elements. + +#### Examples + +```fortran +program demo_falseloc + 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_falseloc +``` diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index d3a107e54..6c4774f63 100644 --- a/src/CMakeLists.txt +++ b/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 diff --git a/src/Makefile.manual b/src/Makefile.manual index f8e001377..1100021e4 100644 --- a/src/Makefile.manual +++ b/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 \ diff --git a/src/stdlib_array.f90 b/src/stdlib_array.f90 new file mode 100644 index 000000000..c5e4fa004 --- /dev/null +++ b/src/stdlib_array.f90 @@ -0,0 +1,68 @@ +! SPDX-Identifier: MIT + +!> Module for index manipulation and general array handling +!> +!> The specification of this module is available [here](../page/specs/stdlib_array.html). +module stdlib_array + implicit none + private + + public :: trueloc, falseloc + +contains + + !> Version: experimental + !> + !> Return the positions of the true elements in array. + !> [Specification](../page/specs/stdlib_array.html#trueloc) + 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)) + + call logicalloc(loc, array, .true., lbound) + end function trueloc + + !> Version: experimental + !> + !> Return the positions of the false elements in array. + !> [Specification](../page/specs/stdlib_array.html#falseloc) + 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)) + + call logicalloc(loc, array, .false., lbound) + end function falseloc + + !> Return the positions of the truthy elements in array + pure subroutine logicalloc(loc, array, truth, lbound) + !> Locations of truthy elements + integer, intent(out) :: 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 + 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 subroutine logicalloc + +end module stdlib_array diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt index 4e40b4f1b..1e824a69d 100644 --- a/src/tests/CMakeLists.txt +++ b/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) diff --git a/src/tests/Makefile.manual b/src/tests/Makefile.manual index 83d93c992..7e60bd23a 100644 --- a/src/tests/Makefile.manual +++ b/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 $@ diff --git a/src/tests/array/CMakeLists.txt b/src/tests/array/CMakeLists.txt new file mode 100644 index 000000000..49e971e7a --- /dev/null +++ b/src/tests/array/CMakeLists.txt @@ -0,0 +1 @@ +ADDTEST(logicalloc) diff --git a/src/tests/array/Makefile.manual b/src/tests/array/Makefile.manual new file mode 100644 index 000000000..2a59ac3e0 --- /dev/null +++ b/src/tests/array/Makefile.manual @@ -0,0 +1,4 @@ +PROGS_SRC = test_logicalloc.f90 + + +include ../Makefile.manual.test.mk diff --git a/src/tests/array/test_logicalloc.f90 b/src/tests/array/test_logicalloc.f90 new file mode 100644 index 000000000..9be52b6f9 --- /dev/null +++ b/src/tests/array/test_logicalloc.f90 @@ -0,0 +1,368 @@ +! SPDX-Identifier: MIT + +module test_logicalloc + use stdlib_array, only : trueloc, falseloc + use stdlib_kinds, only : dp, i8 => int64 + use stdlib_strings, only : to_string + 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-empty", test_trueloc_empty), & + new_unittest("trueloc-all", test_trueloc_all), & + new_unittest("trueloc-where", test_trueloc_where), & + new_unittest("trueloc-merge", test_trueloc_merge), & + new_unittest("trueloc-pack", test_trueloc_pack), & + new_unittest("falseloc-empty", test_falseloc_empty), & + new_unittest("falseloc-all", test_falseloc_all), & + new_unittest("falseloc-where", test_falseloc_where), & + new_unittest("falseloc-merge", test_falseloc_merge), & + new_unittest("falseloc-pack", test_falseloc_pack) & + ] + end subroutine collect_logicalloc + + subroutine test_trueloc_empty(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:), bvec(:) + + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + + bvec = avec + bvec(trueloc(bvec < 0)) = 0.0 + + call check(error, all(bvec == avec)) + deallocate(avec, bvec) + if (allocated(error)) exit + end do + end subroutine test_trueloc_empty + + subroutine test_trueloc_all(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:) + + do ndim = 100, 12000, 100 + allocate(avec(-ndim/2:ndim)) + + call random_number(avec) + + avec(trueloc(avec > 0, lbound(avec, 1))) = 0.0 + + call check(error, all(avec == 0.0)) + deallocate(avec) + if (allocated(error)) exit + end do + end subroutine test_trueloc_all + + subroutine test_trueloc_where(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:), bvec(:), cvec(:) + real(dp) :: tl, tw + + tl = 0.0_dp + tw = 0.0_dp + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + avec(:) = avec - 0.5 + + bvec = avec + tl = tl - timing() + bvec(trueloc(bvec > 0)) = 0.0 + tl = tl + timing() + + cvec = avec + tw = tw - timing() + where(cvec > 0) cvec = 0.0 + tw = tw + timing() + + call check(error, all(bvec == cvec)) + deallocate(avec, bvec, cvec) + if (allocated(error)) exit + end do + call report("trueloc", tl, "where", tw) + 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(:) + real(dp) :: tl, tm + + tl = 0.0_dp + tm = 0.0_dp + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + avec(:) = avec - 0.5 + + bvec = avec + tl = tl - timing() + bvec(trueloc(bvec > 0)) = 0.0 + tl = tl + timing() + + cvec = avec + tm = tm - timing() + cvec(:) = merge(0.0, cvec, cvec > 0) + tm = tm + timing() + + call check(error, all(bvec == cvec)) + deallocate(avec, bvec, cvec) + if (allocated(error)) exit + end do + call report("trueloc", tl, "merge", tm) + end subroutine test_trueloc_merge + + subroutine test_trueloc_pack(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:), bvec(:), cvec(:) + real(dp) :: tl, tp + + tl = 0.0_dp + tp = 0.0_dp + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + avec(:) = avec - 0.5 + + bvec = avec + tl = tl - timing() + bvec(trueloc(bvec > 0)) = 0.0 + tl = tl + timing() + + cvec = avec + tp = tp - timing() + block + integer :: i + cvec(pack([(i, i=1, size(cvec))], cvec > 0)) = 0.0 + end block + tp = tp + timing() + + call check(error, all(bvec == cvec)) + deallocate(avec, bvec, cvec) + if (allocated(error)) exit + end do + call report("trueloc", tl, "pack", tp) + end subroutine test_trueloc_pack + + subroutine test_falseloc_empty(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:), bvec(:) + + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + + bvec = avec + bvec(falseloc(bvec > 0)) = 0.0 + + call check(error, all(bvec == avec)) + deallocate(avec, bvec) + if (allocated(error)) exit + end do + end subroutine test_falseloc_empty + + subroutine test_falseloc_all(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:) + + do ndim = 100, 12000, 100 + allocate(avec(-ndim/2:ndim)) + + call random_number(avec) + + avec(falseloc(avec < 0, lbound(avec, 1))) = 0.0 + + call check(error, all(avec == 0.0)) + deallocate(avec) + if (allocated(error)) exit + end do + end subroutine test_falseloc_all + + subroutine test_falseloc_where(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:), bvec(:), cvec(:) + real(dp) :: tl, tw + + tl = 0.0_dp + tw = 0.0_dp + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + avec(:) = avec - 0.5 + + bvec = avec + tl = tl - timing() + bvec(falseloc(bvec > 0)) = 0.0 + tl = tl + timing() + + cvec = avec + tw = tw - timing() + where(.not.(cvec > 0)) cvec = 0.0 + tw = tw + timing() + + call check(error, all(bvec == cvec)) + deallocate(avec, bvec, cvec) + if (allocated(error)) exit + end do + call report("falseloc", tl, "where", tw) + 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(:) + real(dp) :: tl, tm + + tl = 0.0_dp + tm = 0.0_dp + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + avec(:) = avec - 0.5 + + bvec = avec + tl = tl - timing() + bvec(falseloc(bvec > 0)) = 0.0 + tl = tl + timing() + + cvec = avec + tm = tm - timing() + cvec(:) = merge(cvec, 0.0, cvec > 0) + tm = tm + timing() + + call check(error, all(bvec == cvec)) + deallocate(avec, bvec, cvec) + if (allocated(error)) exit + end do + call report("falseloc", tl, "merge", tm) + end subroutine test_falseloc_merge + + subroutine test_falseloc_pack(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ndim + real, allocatable :: avec(:), bvec(:), cvec(:) + real(dp) :: tl, tp + + tl = 0.0_dp + tp = 0.0_dp + do ndim = 100, 12000, 100 + allocate(avec(ndim)) + + call random_number(avec) + avec(:) = avec - 0.5 + + bvec = avec + tl = tl - timing() + bvec(falseloc(bvec > 0)) = 0.0 + tl = tl + timing() + + cvec = avec + tp = tp - timing() + block + integer :: i + cvec(pack([(i, i=1, size(cvec))], cvec < 0)) = 0.0 + end block + tp = tp + timing() + + call check(error, all(bvec == cvec)) + deallocate(avec, bvec, cvec) + if (allocated(error)) exit + end do + call report("falseloc", tl, "pack", tp) + end subroutine test_falseloc_pack + + subroutine report(l1, t1, l2, t2) + character(len=*), intent(in) :: l1, l2 + real(dp), intent(in) :: t1, t2 + character(len=*), parameter :: fmt = "f6.4" + + !$omp critical + print '(2x, "[Timing]", *(1x, g0))', & + l1//":", to_string(t1, fmt)//"s", & + l2//":", to_string(t2, fmt)//"s", & + "ratio:", to_string(t1/t2, "f4.1") + !$omp end critical + end subroutine report + + function timing() result(time) + real(dp) :: time + + integer(i8) :: time_count, time_rate, time_max + call system_clock(time_count, time_rate, time_max) + time = real(time_count, dp)/real(time_rate, dp) + end function timing + +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