math.f90

Go to the documentation of this file.

! Copyright (c) 2008-2020, UCHICAGO ARGONNE, LLC.
!
! The UChicago Argonne, LLC as Operator of Argonne National
! Laboratory holds copyright in the Software. The copyright holder
! reserves all rights except those expressly granted to licensees,
! and U.S. Government license rights.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the disclaimer below.
!
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions and the disclaimer (as noted below)
! in the documentation and/or other materials provided with the
! distribution.
!
! 3. Neither the name of ANL 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
! UCHICAGO ARGONNE, LLC, THE U.S. DEPARTMENT OF
! ENERGY 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.
!
! Additional BSD Notice
! ---------------------
! 1. This notice is required to be provided under our contract with
! the U.S. Department of Energy (DOE). This work was produced at
! Argonne National Laboratory under Contract
! No. DE-AC02-06CH11357 with the DOE.
!
! 2. Neither the United States Government nor UCHICAGO ARGONNE,
! LLC nor any of their employees, makes any warranty,
! express or implied, or assumes any liability or responsibility for the
! accuracy, completeness, or usefulness of any information, apparatus,
! product, or process disclosed, or represents that its use would not
! infringe privately-owned rights.
!
! 3. Also, reference herein to any specific commercial products, process,
! or services by trade name, trademark, manufacturer or otherwise does
! not necessarily constitute or imply its endorsement, recommendation,
! or favoring by the United States Government or UCHICAGO ARGONNE LLC.
! The views and opinions of authors expressed
! herein do not necessarily state or reflect those of the United States
! Government or UCHICAGO ARGONNE, LLC, and shall
! not be used for advertising or product endorsement purposes.
!
module math
  use num_types, only : rp, dp, sp, qp, i4, xp
  use comm, only : neko_comm, mpi_real_precision, mpi_extra_precision
  use mpi_f08, only : mpi_min, mpi_max, mpi_sum, mpi_in_place, mpi_integer, &
       mpi_allreduce
  use utils, only : nonlinear_index
  implicit none
  private
 
  real(kind=rp), public, parameter :: neko_eps = epsilon(1.0_rp)
 
  real(kind=rp), public, parameter :: neko_m_ln2 = log(2.0_rp)
 
  real(kind=rp), public, parameter :: pi = 4._rp*atan(1._rp)
 
  interface abscmp
     module procedure sabscmp, dabscmp, qabscmp
  end interface abscmp
 
  interface sort
     module procedure sortrp, sorti4
  end interface sort
 
  interface swap
     module procedure swapdp, swapi4
  end interface swap
 
  interface reord
     module procedure reorddp, reordi4
  end interface reord
 
  interface flipv
     module procedure flipvdp, flipvi4
  end interface flipv
 
  interface relcmp
     module procedure srelcmp, drelcmp, qrelcmp
  end interface relcmp
 
  public :: abscmp, rzero, izero, row_zero, rone, copy, cmult, cadd, cfill, &
       glsum, glmax, glmin, chsign, vlmax, vlmin, invcol1, invcol3, invers2, &
       vcross, vdot2, vdot3, vlsc3, vlsc2, add2, add3, add4, sub2, sub3, &
       add2s1, add2s2, addsqr2s2, cmult2, invcol2, col2, col3, subcol3, &
       add3s2, add4s3, add5s4, subcol4, addcol3, addcol4, addcol3s2, ascol5, &
       p_update, x_update, glsc2, glsc3, glsc4, sort, masked_copy_0, &
       cfill_mask, relcmp, glimax, glimin, swap, reord, flipv, cadd2, &
       masked_gather_copy_0, face_masked_gather_copy_0, absval, matinv3, &
       matinv39, &
       pwmax2, pwmax3, cpwmax2, cpwmax3, pwmin2, pwmin3, cpwmin2, cpwmin3, &
       masked_scatter_copy_0, cdiv, cdiv2, glsubnorm, &
       masked_copy, masked_gather_copy, masked_scatter_copy, sabscmp, dabscmp, &
       math_dstepf, math_stepf, cwrap
 
contains
 
  pure function sabscmp(x, y, tol)
    real(kind=sp), intent(in) :: x
    real(kind=sp), intent(in) :: y
    real(kind=sp), intent(in), optional :: tol
    logical :: sabscmp
 
    if (present(tol)) then
       sabscmp = abs(x - y) .lt. tol
    else
       sabscmp = abs(x - y) .lt. neko_eps
    end if
 
  end function sabscmp
 
  pure function dabscmp(x, y, tol)
    real(kind=dp), intent(in) :: x
    real(kind=dp), intent(in) :: y
    real(kind=dp), intent(in), optional :: tol
    logical :: dabscmp
 
    if (present(tol)) then
       dabscmp = abs(x - y) .lt. tol
    else
       dabscmp = abs(x - y) .lt. neko_eps
    end if
 
  end function dabscmp
 
  pure function qabscmp(x, y, tol)
    real(kind=qp), intent(in) :: x
    real(kind=qp), intent(in) :: y
    real(kind=qp), intent(in), optional :: tol
    logical :: qabscmp
 
    if (present(tol)) then
       qabscmp = abs(x - y) .lt. tol
    else
       qabscmp = abs(x - y) .lt. neko_eps
    end if
 
  end function qabscmp
 
  pure function srelcmp(x, y, eps)
    real(kind=sp), intent(in) :: x
    real(kind=sp), intent(in) :: y
    real(kind=sp), intent(in), optional :: eps
    logical :: srelcmp
    if (present(eps)) then
       srelcmp = abs(x - y) .le. eps*abs(y)
    else
       srelcmp = abs(x - y) .le. neko_eps*abs(y)
    end if
 
  end function srelcmp
 
  pure function drelcmp(x, y, eps)
    real(kind=dp), intent(in) :: x
    real(kind=dp), intent(in) :: y
    real(kind=dp), intent(in), optional :: eps
    logical :: drelcmp
    if (present(eps)) then
       drelcmp = abs(x - y) .le. eps*abs(y)
    else
       drelcmp = abs(x - y) .le. neko_eps*abs(y)
    end if
 
  end function drelcmp
 
 
  pure function qrelcmp(x, y, eps)
    real(kind=qp), intent(in) :: x
    real(kind=qp), intent(in) :: y
    real(kind=qp), intent(in), optional :: eps
    logical :: qrelcmp
    if (present(eps)) then
       qrelcmp = abs(x - y)/abs(y) .lt. eps
    else
       qrelcmp = abs(x - y)/abs(y) .lt. neko_eps
    end if
 
  end function qrelcmp
 
  subroutine rzero(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = 0.0_rp
    end do
  end subroutine rzero
 
  subroutine izero(a, n)
    integer, intent(in) :: n
    integer, dimension(n), intent(inout) :: a
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = 0
    end do
  end subroutine izero
 
  subroutine row_zero(a, m, n, e)
    integer, intent(in) :: m, n, e
    real(kind=rp), intent(inout) :: a(m,n)
    integer :: j
 
    do concurrent(j = 1:n)
       a(e,j) = 0.0_rp
    end do
  end subroutine row_zero
 
  subroutine rone(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = 1.0_rp
    end do
  end subroutine rone
 
  subroutine copy(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(inout) :: a
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i)
    end do
 
  end subroutine copy
 
  subroutine masked_copy_0(a, b, mask, n, n_mask)
    integer, intent(in) :: n, n_mask
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(inout) :: a
    integer, dimension(0:n_mask) :: mask
    integer :: i, j
 
    do concurrent(i = 1:n_mask)
       j = mask(i)
       a(j) = b(j)
    end do
 
  end subroutine masked_copy_0
 
  subroutine masked_copy(a, b, mask, n, n_mask)
    integer, intent(in) :: n, n_mask
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(inout) :: a
    integer, dimension(n_mask) :: mask
    integer :: i, j
 
    do concurrent(i = 1:n_mask)
       j = mask(i)
       a(j) = b(j)
    end do
 
  end subroutine masked_copy
 
  subroutine masked_gather_copy_0(a, b, mask, n, n_mask)
    integer, intent(in) :: n, n_mask
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n_mask), intent(inout) :: a
    integer, dimension(0:n_mask) :: mask
    integer :: i, j
 
    do concurrent(i = 1:n_mask)
       j = mask(i)
       a(i) = b(j)
    end do
 
  end subroutine masked_gather_copy_0
 
  subroutine face_masked_gather_copy_0(a, b, mask, facet, lx, ly, lz, n_mask)
    integer, intent(in) :: lx, ly, lz, n_mask
    real(kind=rp), dimension(n_mask), intent(inout) :: a
    real(kind=rp), dimension(:, :, :, :), intent(in) :: b
    integer, dimension(0:n_mask), intent(in) :: mask
    integer, dimension(0:n_mask), intent(in) :: facet
    integer :: l
    integer :: idx(4)
 
    do l = 1, n_mask
       idx = nonlinear_index(mask(l), lx, ly, lz)
 
       select case (facet(l))
       case (1, 2)
          a(l) = b(idx(2), idx(3), facet(l), idx(4))
       case (3, 4)
          a(l) = b(idx(1), idx(3), facet(l), idx(4))
       case (5, 6)
          a(l) = b(idx(1), idx(2), facet(l), idx(4))
       end select
    end do
 
  end subroutine face_masked_gather_copy_0
 
  subroutine masked_gather_copy(a, b, mask, n, n_mask)
    integer, intent(in) :: n, n_mask
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n_mask), intent(inout) :: a
    integer, dimension(n_mask) :: mask
    integer :: i, j
 
    do concurrent(i = 1:n_mask)
       j = mask(i)
       a(i) = b(j)
    end do
 
  end subroutine masked_gather_copy
 
  subroutine masked_scatter_copy_0(a, b, mask, n, n_mask)
    integer, intent(in) :: n, n_mask
    real(kind=rp), dimension(n_mask), intent(in) :: b
    real(kind=rp), dimension(n), intent(inout) :: a
    integer, dimension(0:n_mask) :: mask
    integer :: i, j
 
    do concurrent(i = 1:n_mask)
       j = mask(i)
       a(j) = b(i)
    end do
 
  end subroutine masked_scatter_copy_0
 
  subroutine masked_scatter_copy(a, b, mask, n, n_mask)
    integer, intent(in) :: n, n_mask
    real(kind=rp), dimension(n_mask), intent(in) :: b
    real(kind=rp), dimension(n), intent(inout) :: a
    integer, dimension(n_mask) :: mask
    integer :: i, j
 
    do concurrent(i = 1:n_mask)
       j = mask(i)
       a(j) = b(i)
    end do
 
  end subroutine masked_scatter_copy
 
  subroutine cfill_mask(a, c, n, mask, n_mask)
    integer, intent(in) :: n, n_mask
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: c
    integer, dimension(n_mask), intent(in) :: mask
    integer :: i
 
    do concurrent(i = 1:n_mask)
       a(mask(i)) = c
    end do
 
  end subroutine cfill_mask
 
  subroutine cmult(a, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c * a(i)
    end do
  end subroutine cmult
 
  subroutine cmult2(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c * b(i)
    end do
 
  end subroutine cmult2
 
  subroutine cdiv(a, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c / a(i)
    end do
  end subroutine cdiv
 
  subroutine cdiv2(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c / b(i)
    end do
  end subroutine cdiv2
 
  subroutine cadd(a, s, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: s
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + s
    end do
  end subroutine cadd
 
  subroutine cadd2(a, b, s, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: s
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i) + s
    end do
  end subroutine cadd2
 
  subroutine cfill(a, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c
    end do
  end subroutine cfill
 
  subroutine cwrap(a, min_val, max_val, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: min_val, max_val
    integer :: i
 
    if (n .lt. 1 .or. max_val .le. min_val) return
 
    do concurrent(i = 1:n)
       a(i) = modulo(a(i) - min_val, max_val - min_val) + min_val
    end do
  end subroutine cwrap
 
  function glsum(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n) :: a
    real(kind=rp) :: glsum
    real(kind=xp) :: tmp
    integer :: i, ierr
    tmp = 0.0_rp
    do i = 1, n
       tmp = tmp + a(i)
    end do
    call mpi_allreduce(mpi_in_place, tmp, 1, &
         mpi_extra_precision, mpi_sum, neko_comm, ierr)
    glsum = tmp
 
  end function glsum
 
  function glmax(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n) :: a
    real(kind=rp) :: tmp, glmax
    integer :: i, ierr
 
    tmp = -huge(0.0_rp)
    do i = 1, n
       tmp = max(tmp,a(i))
    end do
    call mpi_allreduce(tmp, glmax, 1, &
         mpi_real_precision, mpi_max, neko_comm, ierr)
  end function glmax
 
  function glimax(a, n)
    integer, intent(in) :: n
    integer, dimension(n) :: a
    integer :: tmp, glimax
    integer :: i, ierr
 
    tmp = -huge(0)
    do i = 1, n
       tmp = max(tmp,a(i))
    end do
    call mpi_allreduce(tmp, glimax, 1, &
         mpi_integer, mpi_max, neko_comm, ierr)
  end function glimax
 
  function glmin(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n) :: a
    real(kind=rp) :: tmp, glmin
    integer :: i, ierr
 
    tmp = huge(0.0_rp)
    do i = 1, n
       tmp = min(tmp,a(i))
    end do
    call mpi_allreduce(tmp, glmin, 1, &
         mpi_real_precision, mpi_min, neko_comm, ierr)
  end function glmin
 
  function glimin(a, n)
    integer, intent(in) :: n
    integer, dimension(n) :: a
    integer :: tmp, glimin
    integer :: i, ierr
 
    tmp = huge(0)
    do i = 1, n
       tmp = min(tmp,a(i))
    end do
    call mpi_allreduce(tmp, glimin, 1, &
         mpi_integer, mpi_min, neko_comm, ierr)
  end function glimin
 
 
 
 
  subroutine chsign(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = -a(i)
    end do
 
  end subroutine chsign
 
  function vlmax(vec,n) result(tmax)
    integer :: n, i
    real(kind=rp), intent(in) :: vec(n)
    real(kind=rp) :: tmax
    tmax = real(-99d20, rp)
    do i = 1, n
       tmax = max(tmax, vec(i))
    end do
  end function vlmax
 
  function vlmin(vec,n) result(tmin)
    integer, intent(in) :: n
    real(kind=rp), intent(in) :: vec(n)
    real(kind=rp) :: tmin
    integer :: i
    tmin = real(99.0e20, rp)
    do i = 1, n
       tmin = min(tmin, vec(i))
    end do
  end function vlmin
 
  subroutine invcol1(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = 1.0_xp / real(a(i), xp)
    end do
 
  end subroutine invcol1
 
  subroutine invcol3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b, c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = real(b(i), xp) / c(i)
    end do
 
  end subroutine invcol3
 
  subroutine invers2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = 1.0_xp / real(b(i), xp)
    end do
 
  end subroutine invers2
 
  subroutine vcross(u1, u2, u3, v1, v2, v3, w1, w2, w3, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: v1, v2, v3
    real(kind=rp), dimension(n), intent(in) :: w1, w2, w3
    real(kind=rp), dimension(n), intent(out) :: u1, u2, u3
    integer :: i
 
    do concurrent(i = 1:n)
       u1(i) = v2(i)*w3(i) - v3(i)*w2(i)
       u2(i) = v3(i)*w1(i) - v1(i)*w3(i)
       u3(i) = v1(i)*w2(i) - v2(i)*w1(i)
    end do
 
  end subroutine vcross
 
  subroutine vdot2(dot, u1, u2, v1, v2, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: u1, u2
    real(kind=rp), dimension(n), intent(in) :: v1, v2
    real(kind=rp), dimension(n), intent(out) :: dot
    integer :: i
    do concurrent(i = 1:n)
       dot(i) = u1(i)*v1(i) + u2(i)*v2(i)
    end do
 
  end subroutine vdot2
 
  subroutine vdot3(dot, u1, u2, u3, v1, v2, v3, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: u1, u2, u3
    real(kind=rp), dimension(n), intent(in) :: v1, v2, v3
    real(kind=rp), dimension(n), intent(out) :: dot
    integer :: i
 
    do concurrent(i = 1:n)
       dot(i) = u1(i)*v1(i) + u2(i)*v2(i) + u3(i)*v3(i)
    end do
 
  end subroutine vdot3
 
  function vlsc3(u, v, w, n) result(s)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: u, v, w
    real(kind=rp) :: s
    integer :: i
 
    s = 0.0_rp
    do i = 1, n
       s = s + u(i)*v(i)*w(i)
    end do
 
  end function vlsc3
 
  function vlsc2(u, v, n) result(s)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: u, v
    real(kind=rp) :: s
    integer :: i
 
    s = 0.0_rp
    do i = 1, n
       s = s + u(i)*v(i)
    end do
 
  end function vlsc2
 
  subroutine add2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + b(i)
    end do
 
  end subroutine add2
 
  subroutine add3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i) + c(i)
    end do
 
  end subroutine add3
 
  subroutine add4(a, b, c, d, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(out) :: a
    real(kind=rp), dimension(n), intent(in) :: d
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i) + c(i) + d(i)
    end do
 
  end subroutine add4
 
  subroutine sub2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) - b(i)
    end do
 
  end subroutine sub2
 
  subroutine sub3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i) - c(i)
    end do
 
  end subroutine sub3
 
 
  subroutine add2s1(a, b, c1, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: c1
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c1 * a(i) + b(i)
    end do
 
  end subroutine add2s1
 
  subroutine add2s2(a, b, c1, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: c1
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + c1 * b(i)
    end do
 
  end subroutine add2s2
 
  subroutine addsqr2s2(a, b, c1, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: c1
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + c1 * ( b(i) * b(i) )
    end do
 
  end subroutine addsqr2s2
 
  subroutine invcol2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = real(a(i), xp) / b(i)
    end do
 
  end subroutine invcol2
 
 
  subroutine col2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) * b(i)
    end do
 
  end subroutine col2
 
  subroutine col3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i) * c(i)
    end do
 
  end subroutine col3
 
  subroutine subcol3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) - b(i) * c(i)
    end do
 
  end subroutine subcol3
 
  subroutine add3s2(a, b, c, c1, c2 ,n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), intent(in) :: c1, c2
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c1 * b(i) + c2 * c(i)
    end do
 
  end subroutine add3s2
 
  subroutine add4s3(a, b, c, d, c1, c2, c3, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), dimension(n), intent(in) :: d
    real(kind=rp), intent(in) :: c1, c2, c3
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = c1 * b(i) + c2 * c(i) + c3 * d(i)
    end do
 
  end subroutine add4s3
 
  subroutine add5s4(a, b, c, d, e, c1, c2, c3, c4, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), dimension(n), intent(in) :: d
    real(kind=rp), dimension(n), intent(in) :: e
    real(kind=rp), intent(in) :: c1, c2, c3, c4
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + c1 * b(i) + c2 * c(i) + c3 * d(i) + c4 * e(i)
    end do
 
  end subroutine add5s4
 
  subroutine subcol4(a, b, c, d, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), dimension(n), intent(in) :: d
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) - b(i) * c(i) * d(i)
    end do
 
  end subroutine subcol4
 
  subroutine addcol3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + b(i) * c(i)
    end do
 
  end subroutine addcol3
 
  subroutine addcol4(a, b, c, d, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), dimension(n), intent(in) :: d
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + b(i) * c(i) * d(i)
    end do
 
  end subroutine addcol4
 
  subroutine addcol3s2(a, b, c, s, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), intent(in) :: s
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + s * b(i) * c(i)
    end do
 
  end subroutine addcol3s2
 
  subroutine ascol5(a, b, c, d, e, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), dimension(n), intent(in) :: d
    real(kind=rp), dimension(n), intent(in) :: e
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i)*c(i) - d(i)*e(i)
    end do
 
  end subroutine ascol5
 
  subroutine p_update(a, b, c, c1, c2, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), intent(in) :: c1, c2
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = b(i) + c1*(a(i)-c2*c(i))
    end do
 
  end subroutine p_update
 
  subroutine x_update(a, b, c, c1, c2, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), intent(in) :: c1, c2
    integer :: i
 
    do concurrent(i = 1:n)
       a(i) = a(i) + c1*b(i)+c2*c(i)
    end do
 
  end subroutine x_update
 
  function glsc2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp) :: glsc2
    real(kind=xp) :: tmp
    integer :: i, ierr
 
    tmp = 0.0_xp
    do i = 1, n
       tmp = tmp + a(i) * b(i)
    end do
 
    call mpi_allreduce(mpi_in_place, tmp, 1, &
         mpi_extra_precision, mpi_sum, neko_comm, ierr)
    glsc2 = tmp
  end function glsc2
 
  function glsc3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp) :: glsc3
    real(kind=xp) :: tmp
    integer :: i, ierr
 
    tmp = 0.0_xp
    do i = 1, n
       tmp = tmp + a(i) * b(i) * c(i)
    end do
 
    call mpi_allreduce(mpi_in_place, tmp, 1, &
         mpi_extra_precision, mpi_sum, neko_comm, ierr)
    glsc3 = tmp
 
  end function glsc3
  function glsc4(a, b, c, d, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), dimension(n), intent(in) :: c
    real(kind=rp), dimension(n), intent(in) :: d
    real(kind=rp) :: glsc4
    real(kind=xp) :: tmp
    integer :: i, ierr
 
    tmp = 0.0_xp
    do i = 1, n
       tmp = tmp + a(i) * b(i) * c(i) * d(i)
    end do
 
    call mpi_allreduce(mpi_in_place, tmp, 1, &
         mpi_extra_precision, mpi_sum, neko_comm, ierr)
    glsc4 = tmp
 
  end function glsc4
 
  function glsubnorm(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(in) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp) :: glsubnorm
    real(kind=xp) :: tmp
    integer :: i, ierr
 
    tmp = 0.0_xp
    do i = 1, n
       tmp = tmp + (a(i) - b(i))**2
    end do
 
    call mpi_allreduce(mpi_in_place, tmp, 1, &
         mpi_extra_precision, mpi_sum, neko_comm, ierr)
    glsubnorm = sqrt(tmp)
 
  end function glsubnorm
 
  subroutine sortrp(a, ind, n)
    integer, intent(in) :: n
    real(kind=rp), intent(inout) :: a(n)
    integer, intent(out) :: ind(n)
    real(kind=rp) :: aa
    integer :: j, ir, i, ii, l
 
    do j = 1, n
       ind(j) = j
    end do
 
    if (n .le. 1) return
 
 
    l = n/2+1
    ir = n
    do while (.true.)
       if (l .gt. 1) then
          l = l-1
          aa = a(l)
          ii = ind(l)
       else
          aa = a(ir)
          ii = ind(ir)
          a(ir) = a(1)
          ind(ir) = ind(1)
          ir = ir - 1
          if (ir .eq. 1) then
             a(1) = aa
             ind(1) = ii
             return
          end if
       end if
       i = l
       j = l+l
       do while (j .le. ir)
          if (j .lt. ir) then
             if ( a(j) .lt. a(j+1) ) j = j + 1
          end if
          if (aa .lt. a(j)) then
             a(i) = a(j)
             ind(i) = ind(j)
             i = j
             j = j+j
          else
             j = ir+1
          end if
       end do
       a(i) = aa
       ind(i) = ii
    end do
  end subroutine sortrp
 
  subroutine sorti4(a, ind, n)
    integer, intent(in) :: n
    integer(i4), intent(inout) :: a(n)
    integer, intent(out) :: ind(n)
    integer(i4) :: aa
    integer :: j, ir, i, ii, l
 
    do j = 1, n
       ind(j) = j
    end do
 
    if (n .le. 1) return
 
    l = n/2+1
    ir = n
    do while (.true.)
       if (l .gt. 1) then
          l = l - 1
          aa = a(l)
          ii = ind(l)
       else
          aa = a(ir)
          ii = ind(ir)
          a(ir) = a( 1)
          ind(ir) = ind( 1)
          ir = ir - 1
          if (ir .eq. 1) then
             a(1) = aa
             ind(1) = ii
             return
          end if
       end if
       i = l
       j = l + l
       do while (j .le. ir)
          if (j .lt. ir) then
             if ( a(j) .lt. a(j + 1) ) j = j + 1
          end if
          if (aa .lt. a(j)) then
             a(i) = a(j)
             ind(i) = ind(j)
             i = j
             j = j + j
          else
             j = ir + 1
          end if
       end do
       a(i) = aa
       ind(i) = ii
    end do
  end subroutine sorti4
 
  subroutine swapdp(b, ind, n)
    integer, intent(in) :: n
    real(kind=rp), intent(inout) :: b(n)
    integer, intent(in) :: ind(n)
    real(kind=rp) :: temp(n)
    integer :: i, jj
 
    do i = 1, n
       temp(i) = b(i)
    end do
    do i = 1, n
       jj = ind(i)
       b(i) = temp(jj)
    end do
  end subroutine swapdp
 
  subroutine swapi4(b, ind, n)
    integer, intent(in) :: n
    integer(i4), intent(inout) :: b(n)
    integer, intent(in) :: ind(n)
    integer(i4) :: temp(n)
    integer :: i, jj
 
    do i = 1, n
       temp(i) = b(i)
    end do
    do i = 1, n
       jj = ind(i)
       b(i) = temp(jj)
    end do
  end subroutine swapi4
 
  subroutine reorddp(b, ind, n)
    integer, intent(in) :: n
    real(kind=rp), intent(inout) :: b(n)
    integer, intent(in) :: ind(n)
    real(kind=rp) :: temp(n)
    integer :: i, jj
 
    do i = 1, n
       temp(i) = b(i)
    end do
    do i = 1, n
       jj = ind(i)
       b(jj) = temp(i)
    end do
  end subroutine reorddp
 
  subroutine reordi4(b, ind, n)
    integer, intent(in) :: n
    integer(i4), intent(inout) :: b(n)
    integer, intent(in) :: ind(n)
    integer(i4) :: temp(n)
    integer :: i, jj
 
    do i = 1, n
       temp(i) = b(i)
    end do
    do i = 1, n
       jj = ind(i)
       b(jj) = temp(i)
    end do
  end subroutine reordi4
 
  subroutine flipvdp(b, ind, n)
    integer, intent(in) :: n
    real(kind=rp), intent(inout) :: b(n)
    integer, intent(inout) :: ind(n)
    real(kind=rp) :: temp(n)
    integer :: tempind(n)
    integer :: i, jj
 
    do i = 1, n
       jj = n+1-i
       temp(jj) = b(i)
       tempind(jj) = ind(i)
    end do
    do i = 1,n
       b(i) = temp(i)
       ind(i) = tempind(i)
    end do
  end subroutine flipvdp
 
  subroutine flipvi4(b, ind, n)
    integer, intent(in) :: n
    integer(i4), intent(inout) :: b(n)
    integer, intent(inout) :: ind(n)
    integer(i4) :: temp(n)
    integer :: tempind(n)
    integer :: i, jj
 
    do i = 1, n
       jj = n+1-i
       temp(jj) = b(i)
       tempind(jj) = ind(i)
    end do
    do i = 1,n
       b(i) = temp(i)
       ind(i) = tempind(i)
    end do
  end subroutine flipvi4
 
  subroutine absval(a, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    integer :: i
    do i = 1, n
       a(i) = abs(a(i))
    end do
  end subroutine absval
 
  ! ========================================================================== !
  ! Point-wise operations
 
  subroutine pwmax2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do i = 1, n
       a(i) = max(a(i), b(i))
    end do
  end subroutine pwmax2
 
  subroutine pwmax3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b, c
    integer :: i
 
    do i = 1, n
       a(i) = max(b(i), c(i))
    end do
  end subroutine pwmax3
 
  subroutine cpwmax2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: b
    integer :: i
 
    do i = 1, n
       a(i) = max(a(i), b)
    end do
  end subroutine cpwmax2
 
  subroutine cpwmax3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: c
    integer :: i
 
    do i = 1, n
       a(i) = max(b(i), c)
    end do
  end subroutine cpwmax3
 
  subroutine pwmin2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    integer :: i
 
    do i = 1, n
       a(i) = min(a(i), b(i))
    end do
  end subroutine pwmin2
 
  subroutine pwmin3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b, c
    integer :: i
 
    do i = 1, n
       a(i) = min(b(i), c(i))
    end do
  end subroutine pwmin3
 
  subroutine cpwmin2(a, b, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), intent(in) :: b
    integer :: i
 
    do i = 1, n
       a(i) = min(a(i), b)
    end do
  end subroutine cpwmin2
 
  subroutine cpwmin3(a, b, c, n)
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: a
    real(kind=rp), dimension(n), intent(in) :: b
    real(kind=rp), intent(in) :: c
    integer :: i
 
    do i = 1, n
       a(i) = min(b(i), c)
    end do
  end subroutine cpwmin3
 
  ! M33INV and M44INV by David G. Simpson pure function version from
  ! https://fortranwiki.org/fortran/show/Matrix+inversion
  ! Invert 3x3 matrix
  function matinv39(a11, a12, a13, a21, a22, a23, a31, a32, a33) &
       result(b)
    real(kind=rp), intent(in) :: a11, a12, a13, a21, a22, a23, a31, a32, a33
    real(xp) :: a(3,3) !! Matrix
    real(rp) :: b(3,3) !! Inverse matrix
    a(1,1) = a11
    a(1,2) = a12
    a(1,3) = a13
    a(2,1) = a21
    a(2,2) = a22
    a(2,3) = a23
    a(3,1) = a31
    a(3,2) = a32
    a(3,3) = a33
    b = matinv3(a)
  end function matinv39
 
  function matinv3(A) result(B)
    !! Performs a direct calculation of the inverse of a 3×3 matrix.
    real(kind=xp), intent(in) :: a(3,3) !! Matrix
    real(kind=xp) :: b(3,3) !! Inverse matrix
    real(kind=xp) :: detinv
 
    ! Calculate the inverse determinant of the matrix
    ! first index x,y,z, second r, s, t
    detinv = 1.0_xp / real(a(1,1)*a(2,2)*a(3,3) - a(1,1)*a(2,3)*a(3,2) &
         - a(1,2)*a(2,1)*a(3,3) + a(1,2)*a(2,3)*a(3,1)&
         + a(1,3)*a(2,1)*a(3,2) - a(1,3)*a(2,2)*a(3,1), xp)
    ! Calculate the inverse of the matrix
    ! first index r, s, t, second x, y, z
    b(1,1) = +detinv * (a(2,2)*a(3,3) - a(2,3)*a(3,2))
    b(2,1) = -detinv * (a(2,1)*a(3,3) - a(2,3)*a(3,1))
    b(3,1) = +detinv * (a(2,1)*a(3,2) - a(2,2)*a(3,1))
    b(1,2) = -detinv * (a(1,2)*a(3,3) - a(1,3)*a(3,2))
    b(2,2) = +detinv * (a(1,1)*a(3,3) - a(1,3)*a(3,1))
    b(3,2) = -detinv * (a(1,1)*a(3,2) - a(1,2)*a(3,1))
    b(1,3) = +detinv * (a(1,2)*a(2,3) - a(1,3)*a(2,2))
    b(2,3) = -detinv * (a(1,1)*a(2,3) - a(1,3)*a(2,1))
    b(3,3) = +detinv * (a(1,1)*a(2,2) - a(1,2)*a(2,1))
  end function matinv3
 
  function math_stepf(x) result(val)
    real(kind=rp), intent(in) :: x
    real(kind=rp) :: val
    real(kind=rp), parameter :: xdmin = 0.0001_rp
    real(kind=rp), parameter :: xdmax = 0.9999_rp
    real(kind=rp) :: g
 
    if (x <= xdmin) then
       ! Below the lower bound, the function is 0
       val = 0.0_rp
    else if (x >= xdmax) then
       ! Above the upper bound, the function is 1
       val = 1.0_rp
    else
       ! g(x) = 1/(x-1) + 1/x
       g = (1.0_rp / (x - 1.0_rp)) + (1.0_rp / x)
 
       ! The sigmoid: S(x) = 1 / (1 + exp(g))
       val = 1.0_rp / (1.0_rp + exp(g))
    end if
  end function math_stepf
 
  function math_dstepf(x) result(val)
    real(kind=rp), intent(in) :: x
    real(kind=rp) :: val
    real(kind=rp), parameter :: xdmin = 0.0001_rp
    real(kind=rp), parameter :: xdmax = 0.9999_rp
    real(kind=rp) :: arg, g, dg, s_val
 
    if (x <= xdmin .or. x >= xdmax) then
       val = 0.0_rp
    else
       ! The step function is S(x) = 1 / (1 + exp(g(x)))
       ! where g(x) = 1/(x-1) + 1/x
       ! S'(x) = -S(x) * (1 - S(x)) * g'(x)
 
       g = (1.0_rp / (x - 1.0_rp)) + (1.0_rp / x)
 
       ! Derivative of g(x)
       dg = -(1.0_rp / ((x - 1.0_rp)**2)) - (1.0_rp / (x**2))
 
       ! Recompute S(x) locally
       s_val = 1.0_rp / (1.0_rp + exp(g))
 
       val = -s_val * (1.0_rp - s_val) * dg
    end if
  end function math_dstepf
 
end module math