stdlib_array.fypp

! SPDX-Identifier: MIT

#:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES

!> Module for index manipulation and general array handling
!>
!> The specification of this module is available [here](../page/specs/stdlib_array.html).
module stdlib_array
    use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
    implicit none
    private

    public :: trueloc, falseloc

    !> Helper class to allocate t_array as an abstract type.
    type, public :: t_array_wrapper
        class(t_array), allocatable :: array
    contains
        #:for k1, t1 in KINDS_TYPES
            #:for rank in RANKS
                generic :: allocate_array => allocate_array_${t1[0]}$${k1}$_${rank}$
                procedure :: allocate_array_${t1[0]}$${k1}$_${rank}$
            #:endfor
        #:endfor
    end type

    type, abstract, public :: t_array
        character(:), allocatable :: name
    end type

    #:for k1, t1 in KINDS_TYPES
        #:for rank in RANKS
            type, extends(t_array), public :: t_array_${t1[0]}$${k1}$_${rank}$
                ${t1}$, allocatable :: values${ranksuffix(rank)}$
            end type
        #:endfor
    #:endfor

contains

    #:for k1, t1 in KINDS_TYPES
        #:for rank in RANKS
            !> Allocate an instance of the array within the wrapper.
            subroutine allocate_array_${t1[0]}$${k1}$_${rank}$ (wrapper, array, stat, msg)
                class(t_array_wrapper), intent(out) :: wrapper
                ${t1}$, intent(in) :: array${ranksuffix(rank)}$
                integer, intent(out) :: stat
                character(len=:), allocatable, intent(out) :: msg

                allocate (t_array_${t1[0]}$${k1}$_${rank}$ :: wrapper%array, stat=stat)
                if (stat /= 0) then
                    msg = 'Failed to allocate array.'; return
                end if

                select type (typed_array => wrapper%array)
                class is (t_array_${t1[0]}$${k1}$_${rank}$)
                    typed_array%values = array
                class default
                    msg = 'Failed to allocate values.'; stat = 1; return
                end select
            end
        #:endfor
    #:endfor

    !> 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

    !> 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

    !> 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
end