gs_cpu.f90

Go to the documentation of this file.

! Copyright (c) 2020-2026, The Neko Authors
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
!   * Redistributions of source code must retain the above copyright
!     notice, this list of conditions and the following disclaimer.
!
!   * Redistributions in binary form must reproduce the above
!     copyright notice, this list of conditions and the following
!     disclaimer in the documentation and/or other materials provided
!     with the distribution.
!
!   * Neither the name of the authors nor the names of its
!     contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module gs_cpu
  use num_types, only : rp
  use gs_bcknd, only : gs_bcknd_t
  use gs_ops, only : gs_op_add, gs_op_mul, gs_op_min, gs_op_max
  use, intrinsic :: iso_c_binding, only : c_ptr
  implicit none
  private
 
  type, public, extends(gs_bcknd_t) :: gs_cpu_t
   contains
     procedure, pass(this) :: init => gs_cpu_init
     procedure, pass(this) :: free => gs_cpu_free
     procedure, pass(this) :: gather => gs_gather_cpu
     procedure, pass(this) :: scatter => gs_scatter_cpu
  end type gs_cpu_t
 
contains
 
  subroutine gs_cpu_init(this, nlocal, nshared, nlcl_blks, nshrd_blks)
    class(gs_cpu_t), intent(inout) :: this
    integer, intent(in) :: nlocal
    integer, intent(in) :: nshared
    integer, intent(in) :: nlcl_blks
    integer, intent(in) :: nshrd_blks
  end subroutine gs_cpu_init
 
  subroutine gs_cpu_free(this)
    class(gs_cpu_t), intent(inout) :: this
  end subroutine gs_cpu_free
 
  subroutine gs_gather_cpu(this, v, m, o, dg, u, n, gd, nb, b, bo, op, shrd)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    class(gs_cpu_t), intent(inout) :: this
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    integer, intent(in) :: o
    integer, intent(in) :: op
    logical, intent(in) :: shrd
 
    select case(op)
    case (gs_op_add)
       call gs_gather_kernel_add(v, m, o, dg, u, n, gd, nb, b, bo)
    case (gs_op_mul)
       call gs_gather_kernel_mul(v, m, o, dg, u, n, gd, nb, b, bo)
    case (gs_op_min)
       call gs_gather_kernel_min(v, m, o, dg, u, n, gd, nb, b, bo)
    case (gs_op_max)
       call gs_gather_kernel_max(v, m, o, dg, u, n, gd, nb, b, bo)
    end select
 
  end subroutine gs_gather_cpu
 
  subroutine gs_gather_kernel_add(v, m, o, dg, u, n, gd, nb, b, bo)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    integer, intent(in) :: o
    integer :: i, j, k, blk_len
    real(kind=rp) :: tmp
 
    !$omp do
    do i = 1, nb
       k = bo(i)
       blk_len = b(i)
       tmp = u(gd(k + 1))
       do j = 2, blk_len
          tmp = tmp + u(gd(k + j))
       end do
       v(dg(k + 1)) = tmp
    end do
    !$omp end do nowait
 
    if (o .lt. 0) then
       !$omp do
       do i = abs(o), m
          v(dg(i)) = u(gd(i))
       end do
       !$omp end do
    else
       !$omp do
       do i = o, m, 2
          v(dg(i)) = u(gd(i)) + u(gd(i+1))
       end do
       !$omp end do
    end if
 
  end subroutine gs_gather_kernel_add
 
  subroutine gs_gather_kernel_mul(v, m, o, dg, u, n, gd, nb, b, bo)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    integer, intent(in) :: o
    integer :: i, j, k, blk_len
    real(kind=rp) :: tmp
 
    !$omp do
    do i = 1, nb
       k = bo(i)
       blk_len = b(i)
       tmp = u(gd(k + 1))
       do j = 2, blk_len
          tmp = tmp * u(gd(k + j))
       end do
       v(dg(k + 1)) = tmp
    end do
    !$omp end do nowait
 
    if (o .lt. 0) then
       !$omp do
       do i = abs(o), m
          v(dg(i)) = u(gd(i))
       end do
       !$omp end do nowait
    else
       !$omp do
       do i = o, m, 2
          v(dg(i)) = u(gd(i)) * u(gd(i+1))
       end do
       !$omp end do nowait
    end if
 
  end subroutine gs_gather_kernel_mul
 
  subroutine gs_gather_kernel_min(v, m, o, dg, u, n, gd, nb, b, bo)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    integer, intent(in) :: o
    integer :: i, j, k, blk_len
    real(kind=rp) :: tmp
 
    !$omp do
    do i = 1, nb
       k = bo(i)
       blk_len = b(i)
       tmp = u(gd(k + 1))
       do j = 2, blk_len
          tmp = min(tmp, u(gd(k + j)))
       end do
       v(dg(k + 1)) = tmp
    end do
    !$omp end do nowait
 
    if (o .lt. 0) then
       !$omp do
       do i = abs(o), m
          v(dg(i)) = u(gd(i))
       end do
       !$omp end do
    else
       !$omp do
       do i = o, m, 2
          v(dg(i)) = min(u(gd(i)), u(gd(i+1)))
       end do
       !$omp end do
    end if
 
  end subroutine gs_gather_kernel_min
 
  subroutine gs_gather_kernel_max(v, m, o, dg, u, n, gd, nb, b, bo)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    integer, intent(in) :: o
    integer :: i, j, k, blk_len
    real(kind=rp) :: tmp
 
    !$omp do
    do i = 1, nb
       k = bo(i)
       blk_len = b(i)
       tmp = u(gd(k + 1))
       do j = 2, blk_len
          tmp = max(tmp, u(gd(k + j)))
       end do
       v(dg(k + 1)) = tmp
    end do
    !$omp end do nowait
 
    if (o .lt. 0) then
       !$omp do
       do i = abs(o), m
          v(dg(i)) = u(gd(i))
       end do
       !$omp end do
    else
       !$omp do
       do i = o, m, 2
          v(dg(i)) = max(u(gd(i)), u(gd(i+1)))
       end do
       !$omp end do
    end if
 
  end subroutine gs_gather_kernel_max
 
  subroutine gs_scatter_cpu(this, v, m, dg, u, n, gd, nb, b, bo, shrd, event)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    class(gs_cpu_t), intent(inout) :: this
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    logical, intent(in) :: shrd
    type(c_ptr) :: event
 
    call gs_scatter_kernel(v, m, dg, u, n, gd, nb, b, bo)
 
  end subroutine gs_scatter_cpu
 
  subroutine gs_scatter_kernel(v, m, dg, u, n, gd, nb, b, bo)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    integer :: i, j, k, blk_len
    real(kind=rp) :: tmp
 
    !$omp do
    do i = 1, nb
       k = bo(i)
       blk_len = b(i)
       tmp = v(dg(k + 1))
       do j = 1, blk_len
          u(gd(k + j)) = tmp
       end do
    end do
    !$omp end do nowait
 
    !$omp do
    do i = (bo(nb) + b(nb) + 1), m
       u(gd(i)) = v(dg(i))
    end do
    !$omp end do
 
  end subroutine gs_scatter_kernel
 
end module gs_cpu