Swap

doc/specs/stdlib_math.md

@@ -61,6 +61,38 @@ Here inputs are of type `real` and kind `sp`
 {!example/math/example_clip_real.f90!}
 ```
 
+<!-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -->
+### `swap` function
+
+#### Description
+
+Swaps the values in `lhs` and `rhs`.
+
+#### Syntax
+
+`call` [[stdlib_math(module):swap(interface)]] ` (lhs, rhs)`
+
+#### Status
+
+Experimental
+
+#### Class
+
+Elemental function.
+
+#### Argument(s)
+
+`lhs`: scalar or array of any of the intrinsic types `integer`, `real`, `complex`, `logical`, `character` type. This argument is `intent(inout)`.
+`rhs`: scalar or array of any of the intrinsic types `integer`, `real`, `complex`, `logical`, `character` type. This argument is `intent(inout)`.
+
+Note: All arguments must have same `type` and same `kind`.
+
+#### Example
+
+```fortran
+{!example/math/example_math_swap.f90!}
+```
+
 ### `gcd` function
 
 #### Description

example/math/CMakeLists.txt

@@ -15,4 +15,5 @@ ADD_EXAMPLE(math_argpi)
 ADD_EXAMPLE(math_deg2rad)
 ADD_EXAMPLE(math_rad2deg)
 ADD_EXAMPLE(math_is_close)
+ADD_EXAMPLE(math_swap)
 ADD_EXAMPLE(meshgrid)

example/math/example_math_swap.f90

@@ -0,0 +1,33 @@
+program example_math_swap
+    use stdlib_math, only: swap
+    implicit none
+
+    block
+        integer :: x, y
+        x = 9
+        y = 18
+        call swap(x,y)
+    end block
+
+    block
+        real :: x, y
+        x = 4.0
+        y = 8.0
+        call swap(x,y)
+    end block
+
+    block
+        real :: x(3), y(3)
+        x = [1.0,2.0,3.0]
+        y = [4.0,5.0,6.0]
+        call swap(x,y)
+    end block
+
+    block
+        character(5) :: x, y
+        x = 'abcde'
+        y = 'fghij'
+        call swap(x,y)
+    end block
+
+end program example_math_swap  

src/stdlib_math.fypp

@@ -8,7 +8,7 @@ module stdlib_math
 
     implicit none
     private
-    public :: clip, gcd, linspace, logspace
+    public :: clip, swap, gcd, linspace, logspace
     public :: EULERS_NUMBER_SP, EULERS_NUMBER_DP
 #:if WITH_QP
     public :: EULERS_NUMBER_QP
@@ -42,6 +42,17 @@ module stdlib_math
     #:endfor
     end interface clip
 
+    interface swap
+      #:for k1, t1 in INT_KINDS_TYPES + REAL_KINDS_TYPES
+      module procedure :: swap_${k1}$
+      #:endfor
+      #:for k1, t1 in CMPLX_KINDS_TYPES
+      module procedure :: swap_c${k1}$
+      #:endfor
+      module procedure :: swap_bool
+      module procedure :: swap_str
+    end interface
+
     !> Returns the greatest common divisor of two integers
     !> ([Specification](../page/specs/stdlib_math.html#gcd))
     !>
@@ -509,5 +520,35 @@ contains
     end function gcd_${k1}$
 
     #:endfor
+
+    #:for k1, t1 in INT_KINDS_TYPES + REAL_KINDS_TYPES
+    elemental subroutine swap_${k1}$(lhs, rhs)
+        ${t1}$, intent(inout) :: lhs, rhs
+        ${t1}$ :: temp
+        temp = lhs; lhs = rhs; rhs = temp
+    end subroutine
+
+    #:endfor
+
+    #:for k1, t1 in CMPLX_KINDS_TYPES
+    elemental subroutine swap_c${k1}$(lhs, rhs)
+        ${t1}$, intent(inout) :: lhs, rhs
+        ${t1}$ :: temp
+        temp = lhs; lhs = rhs; rhs = temp
+    end subroutine
+
+    #:endfor
+
+    elemental subroutine swap_bool(lhs, rhs)
+        logical, intent(inout) :: lhs, rhs
+        logical :: temp
+        temp = lhs; lhs = rhs; rhs = temp
+    end subroutine
+
+    elemental subroutine swap_str(lhs,rhs)
+        character(*), intent(inout) :: lhs, rhs
+        character(len=max(len(lhs),len(rhs))) :: temp
+        temp = lhs ; lhs = rhs ; rhs = temp
+    end subroutine
 
 end module stdlib_math

test/math/test_stdlib_math.fypp

@@ -4,7 +4,7 @@
 
 module test_stdlib_math
     use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
-    use stdlib_math, only: clip, arg, argd, argpi, arange, is_close, all_close, diff, &
+    use stdlib_math, only: clip, swap, arg, argd, argpi, arange, is_close, all_close, diff, &
                            arange, deg2rad, rad2deg
     use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
     implicit none
@@ -38,6 +38,15 @@ contains
             new_unittest("clip-real-quad", test_clip_rqp), &
             new_unittest("clip-real-quad-bounds", test_clip_rqp_bounds) &
 
+            !> Tests swap
+            #:for k1, t1 in INT_KINDS_TYPES + REAL_KINDS_TYPES
+            , new_unittest("swap_${k1}$", test_swap_${k1}$) &
+            #:endfor
+            #:for k1, t1 in CMPLX_KINDS_TYPES
+            , new_unittest("swap_c${k1}$", test_swap_c${k1}$) &
+            #:endfor
+            , new_unittest("swap_str", test_swap_str) &
+
             !> Tests for arg/argd/argpi
             #:for k1 in CMPLX_KINDS
             , new_unittest("arg-cmplx-${k1}$", test_arg_${k1}$) &
@@ -246,6 +255,55 @@ contains
 
     end subroutine test_clip_rqp_bounds
 
+    #:for k1, t1 in INT_KINDS_TYPES + REAL_KINDS_TYPES
+    subroutine test_swap_${k1}$(error)
+        type(error_type), allocatable, intent(out) :: error
+        ${t1}$ :: x(3), y(3)
+
+        x = [${t1}$ :: 1, 2, 3]
+        y = [${t1}$ :: 4, 5, 6]
+
+        call swap(x,y)
+
+        call check(error, all( x == [${t1}$ :: 4, 5, 6] ) )
+        if (allocated(error)) return
+        call check(error, all( y == [${t1}$ :: 1, 2, 3] ) )
+        if (allocated(error)) return
+    end subroutine test_swap_${k1}$
+    #:endfor
+
+    #:for k1, t1 in CMPLX_KINDS_TYPES
+    subroutine test_swap_c${k1}$(error)
+        type(error_type), allocatable, intent(out) :: error
+        ${t1}$ :: x(3), y(3)
+
+        x = cmplx( [1, 2, 3] , [4, 5, 6] )
+        y = cmplx( [4, 5, 6] , [1, 2, 3] )
+
+        call swap(x,y)
+
+        call check(error, all( x == cmplx( [4, 5, 6] , [1, 2, 3] ) ) )
+        if (allocated(error)) return
+        call check(error, all( y == cmplx( [1, 2, 3] , [4, 5, 6] ) ) )
+        if (allocated(error)) return
+    end subroutine test_swap_c${k1}$
+    #:endfor
+
+    subroutine test_swap_str(error)
+        type(error_type), allocatable, intent(out) :: error
+        character(5) :: x(2), y(2)
+
+        x = ['abcde','fghij'] 
+        y = ['fghij','abcde']
+
+        call swap(x,y)
+
+        call check(error, all( x == ['fghij','abcde'] ) )
+        if (allocated(error)) return
+        call check(error, all( y == ['abcde','fghij']  ) )
+        if (allocated(error)) return
+    end subroutine test_swap_str
+
     #:for k1 in CMPLX_KINDS
     subroutine test_arg_${k1}$(error)
         type(error_type), allocatable, intent(out) :: error