Use subroutine to implement logicalloc

Author: awvwgk

src/stdlib_array.f90

@@ -18,7 +18,7 @@ pure function trueloc(array, lbound) result(loc)
     !> Locations of true elements
     integer :: loc(count(array))
 
-    loc = logicalloc(array, .true., lbound)
+    call logicalloc(loc, array, .true., lbound)
   end function trueloc
 
   !> Return the positions of the false elements in array
@@ -30,19 +30,19 @@ pure function falseloc(array, lbound) result(loc)
     !> Locations of false elements
     integer :: loc(count(.not.array))
 
-    loc = logicalloc(array, .false., lbound)
+    call logicalloc(loc, array, .false., lbound)
   end function falseloc
 
   !> Return the positions of the truthy elements in array
-  pure function logicalloc(array, truth, lbound) result(loc)
+  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
-    !> Locations of truthy elements
-    integer :: loc(count(array.eqv.truth))
     integer :: i, pos, offset
 
     offset = 0
@@ -55,6 +55,6 @@ pure function logicalloc(array, truth, lbound) result(loc)
         loc(i) = pos + offset
       end if
     end do
-  end function logicalloc
+  end subroutine logicalloc
 
 end module stdlib_array

src/tests/array/test_logicalloc.f90

@@ -2,7 +2,8 @@
 
 module test_logicalloc
   use stdlib_array, only : trueloc, falseloc
-  use stdlib_string_type, only : string_type, len
+  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
@@ -75,23 +76,31 @@ subroutine test_trueloc_where(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)
@@ -100,23 +109,31 @@ subroutine test_trueloc_merge(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_falseloc_empty(error)
@@ -166,23 +183,31 @@ subroutine test_falseloc_where(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)
@@ -191,25 +216,54 @@ subroutine test_falseloc_merge(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 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