psblas3/openacc/psb_l_oacc_vect_mod.F90

module psb_l_oacc_vect_mod
  use iso_c_binding
  use openacc
  use psb_const_mod
  use psb_error_mod
  use psb_l_vect_mod
  use psb_i_vect_mod
  use psb_i_oacc_vect_mod

  integer(psb_ipk_), parameter, private :: is_host = -1
  integer(psb_ipk_), parameter, private :: is_sync = 0 
  integer(psb_ipk_), parameter, private :: is_dev  = 1 

  type, extends(psb_l_base_vect_type) :: psb_l_vect_oacc
    integer     :: state = is_host

  contains
    procedure, pass(x) :: get_nrows   => l_oacc_get_nrows
    procedure, nopass :: get_fmt      => l_oacc_get_fmt

    procedure, pass(x) :: all         => l_oacc_vect_all
    procedure, pass(x) :: zero        => l_oacc_zero
    procedure, pass(x) :: asb_m       => l_oacc_asb_m
    procedure, pass(x) :: sync        => l_oacc_sync
    procedure, pass(x) :: sync_space  => l_oacc_sync_space
    procedure, pass(x) :: bld_x       => l_oacc_bld_x
    procedure, pass(x) :: bld_mn      => l_oacc_bld_mn
    procedure, pass(x) :: free        => l_oacc_vect_free
    procedure, pass(x) :: ins_a       => l_oacc_ins_a
    procedure, pass(x) :: ins_v       => l_oacc_ins_v
    procedure, pass(x) :: is_host     => l_oacc_is_host
    procedure, pass(x) :: is_dev      => l_oacc_is_dev
    procedure, pass(x) :: is_sync     => l_oacc_is_sync
    procedure, pass(x) :: set_host    => l_oacc_set_host
    procedure, pass(x) :: set_dev     => l_oacc_set_dev
    procedure, pass(x) :: set_sync    => l_oacc_set_sync
    procedure, pass(x) :: set_scal    => l_oacc_set_scal

    procedure, pass(x) :: gthzv_x     => l_oacc_gthzv_x
    procedure, pass(x) :: gthzbuf_x   => l_oacc_gthzbuf
    procedure, pass(y) :: sctb        => l_oacc_sctb
    procedure, pass(y) :: sctb_x      => l_oacc_sctb_x
    procedure, pass(y) :: sctb_buf    => l_oacc_sctb_buf

    procedure, pass(x) :: get_size    => l_oacc_get_size

    final ::  l_oacc_final_vect_free
  end type psb_l_vect_oacc


contains


  subroutine l_oacc_sctb_buf(i, n, idx, beta, y)
    use psb_base_mod
    implicit none
    integer(psb_ipk_) :: i, n
    class(psb_i_base_vect_type) :: idx
    integer(psb_lpk_) :: beta
    class(psb_l_vect_oacc) :: y
    integer(psb_ipk_) :: info

    if (.not.allocated(y%combuf)) then
      call psb_errpush(psb_err_alloc_dealloc_, 'sctb_buf')
      return
    end if

    select type(ii => idx)
    class is (psb_i_vect_oacc)
      if (ii%is_host()) call ii%sync()
      if (y%is_host()) call y%sync()

      !$acc parallel loop
      do i = 1, n
        y%v(ii%v(i)) = beta * y%v(ii%v(i)) + y%combuf(i)
      end do

    class default
      !$acc parallel loop
      do i = 1, n
        y%v(idx%v(i)) = beta * y%v(idx%v(i)) + y%combuf(i)
      end do
    end select
  end subroutine l_oacc_sctb_buf

  subroutine l_oacc_sctb_x(i, n, idx, x, beta, y)
    use psb_base_mod
    implicit none
    integer(psb_ipk_):: i, n
    class(psb_i_base_vect_type) :: idx
    integer(psb_lpk_) :: beta, x(:)
    class(psb_l_vect_oacc) :: y
    integer(psb_ipk_) :: info, ni

    select type(ii => idx)
    class is (psb_i_vect_oacc)
      if (ii%is_host()) call ii%sync()
    class default
      call psb_errpush(info, 'l_oacc_sctb_x')
      return
    end select

    if (y%is_host()) call y%sync()

    !$acc parallel loop
    do i = 1, n
      y%v(idx%v(i)) = beta * y%v(idx%v(i)) + x(i)
    end do

    call y%set_dev()
  end subroutine l_oacc_sctb_x

  subroutine l_oacc_sctb(n, idx, x, beta, y)
    use psb_base_mod
    implicit none
    integer(psb_ipk_) :: n
    integer(psb_ipk_) :: idx(:)
    integer(psb_lpk_) :: beta, x(:)
    class(psb_l_vect_oacc) :: y
    integer(psb_ipk_) :: info
    integer(psb_ipk_) :: i

    if (n == 0) return
    if (y%is_dev()) call y%sync()

    !$acc parallel loop
    do i = 1, n
      y%v(idx(i)) = beta * y%v(idx(i)) + x(i)
    end do

    call y%set_host()
  end subroutine l_oacc_sctb

  subroutine l_oacc_gthzbuf(i, n, idx, x)
    use psb_base_mod
    implicit none
    integer(psb_ipk_) :: i, n
    class(psb_i_base_vect_type) :: idx
    class(psb_l_vect_oacc) :: x
    integer(psb_ipk_) :: info

    info = 0
    if (.not.allocated(x%combuf)) then
      call psb_errpush(psb_err_alloc_dealloc_, 'gthzbuf')
      return
    end if

    select type(ii => idx)
    class is (psb_i_vect_oacc)
      if (ii%is_host()) call ii%sync()
    class default
      call psb_errpush(info, 'l_oacc_gthzbuf')
      return
    end select

    if (x%is_host()) call x%sync()

    !$acc parallel loop
    do i = 1, n
      x%combuf(i) = x%v(idx%v(i))
    end do
  end subroutine l_oacc_gthzbuf

  subroutine l_oacc_gthzv_x(i, n, idx, x, y)
    use psb_base_mod
    implicit none
    integer(psb_ipk_) :: i, n
    class(psb_i_base_vect_type):: idx
    integer(psb_lpk_) :: y(:)
    class(psb_l_vect_oacc):: x
    integer(psb_ipk_) :: info

    info = 0

    select type(ii => idx)
    class is (psb_i_vect_oacc)
      if (ii%is_host()) call ii%sync()
    class default
      call psb_errpush(info, 'l_oacc_gthzv_x')
      return
    end select

    if (x%is_host()) call x%sync()

    !$acc parallel loop
    do i = 1, n
      y(i) = x%v(idx%v(i))
    end do
  end subroutine l_oacc_gthzv_x

  subroutine l_oacc_ins_v(n, irl, val, dupl, x, info)
    use psi_serial_mod
    implicit none
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_), intent(in) :: n, dupl
    class(psb_i_base_vect_type), intent(inout) :: irl
    class(psb_l_base_vect_type), intent(inout) :: val
    integer(psb_ipk_), intent(out) :: info

    integer(psb_ipk_) :: i, isz
    logical :: done_oacc

    info = 0
    if (psb_errstatus_fatal()) return

    done_oacc = .false.
    select type(virl => irl)
    type is (psb_i_vect_oacc)
      select type(vval => val)
      type is (psb_l_vect_oacc)
        if (vval%is_host()) call vval%sync()
        if (virl%is_host()) call virl%sync()
        if (x%is_host()) call x%sync()
        !$acc parallel loop
        do i = 1, n
          x%v(virl%v(i)) = vval%v(i)
        end do
        call x%set_dev()
        done_oacc = .true.
      end select
    end select

    if (.not.done_oacc) then
      select type(virl => irl)
      type is (psb_i_vect_oacc)
        if (virl%is_dev()) call virl%sync()
      end select
      select type(vval => val)
      type is (psb_l_vect_oacc)
        if (vval%is_dev()) call vval%sync()
      end select
      call x%ins(n, irl%v, val%v, dupl, info)
    end if

    if (info /= 0) then
      call psb_errpush(info, 'oacc_vect_ins')
      return
    end if

  end subroutine l_oacc_ins_v

  subroutine l_oacc_ins_a(n, irl, val, dupl, x, info)
    use psi_serial_mod
    implicit none
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_), intent(in) :: n, dupl
    integer(psb_ipk_), intent(in) :: irl(:)
    integer(psb_lpk_), intent(in) :: val(:)
    integer(psb_ipk_), intent(out) :: info

    integer(psb_ipk_) :: i

    info = 0
    if (x%is_dev()) call x%sync()
    call x%psb_l_base_vect_type%ins(n, irl, val, dupl, info)
    call x%set_host()


  end subroutine l_oacc_ins_a

  subroutine l_oacc_bld_mn(x, n)
    use psb_base_mod
    implicit none
    integer(psb_mpk_), intent(in) :: n
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_) :: info

    call x%free(info)
    call x%all(n, info)
    if (info /= 0) then
      call psb_errpush(info, 'l_oacc_bld_mn', i_err=(/n, n, n, n, n/))
    end if
    call x%set_host()
    call x%sync_space()
    
  end subroutine l_oacc_bld_mn


  subroutine l_oacc_bld_x(x, this)
    use psb_base_mod
    implicit none
    integer(psb_lpk_), intent(in) :: this(:)
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_) :: info

    call x%free(info)
    call psb_realloc(size(this), x%v, info)
    if (info /= 0) then
      info = psb_err_alloc_request_
      call psb_errpush(info, 'l_oacc_bld_x', &
           i_err=(/size(this), izero, izero, izero, izero/))
      return
    end if
    x%v(:) = this(:)
    call x%set_host()
    call x%sync_space()

  end subroutine l_oacc_bld_x

  subroutine l_oacc_asb_m(n, x, info)
    use psb_base_mod
    implicit none 
    integer(psb_mpk_), intent(in)        :: n
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_), intent(out)       :: info
    integer(psb_mpk_) :: nd

    info = psb_success_

    if (x%is_dev()) then
      nd = size(x%v)
      if (nd < n) then
        call x%sync()
        call x%psb_l_base_vect_type%asb(n, info)
        if (info == psb_success_) call x%sync()
        call x%set_host()
      end if
    else
      if (size(x%v) < n) then
        call x%psb_l_base_vect_type%asb(n, info)
        if (info == psb_success_) call x%sync()
        call x%set_host()
      end if
    end if
  end subroutine l_oacc_asb_m

  subroutine l_oacc_set_scal(x, val, first, last)
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_lpk_), intent(in)           :: val
    integer(psb_ipk_), optional :: first, last

    integer(psb_ipk_) :: first_, last_
    first_ = 1
    last_  = x%get_nrows()
    if (present(first)) first_ = max(1, first)
    if (present(last))  last_  = min(last, last_)

    !$acc parallel loop
    do i = first_, last_
      x%v(i) = val
    end do
    !$acc end parallel loop

    call x%set_dev()
  end subroutine l_oacc_set_scal

  subroutine l_oacc_zero(x)
    use psi_serial_mod
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x
    call x%set_dev()
    call x%set_scal(lzero)
  end subroutine l_oacc_zero

  function l_oacc_get_nrows(x) result(res)
    implicit none 
    class(psb_l_vect_oacc), intent(in) :: x
    integer(psb_ipk_) :: res

    if (allocated(x%v)) res = size(x%v)
  end function l_oacc_get_nrows

  function l_oacc_get_fmt() result(res)
    implicit none 
    character(len=5) :: res
    res = "lOACC"

  end function l_oacc_get_fmt


  subroutine l_oacc_sync_space(x)
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x
    if (allocated(x%v)) call acc_create(x%v)
  end subroutine l_oacc_sync_space

  subroutine l_oacc_sync(x)
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x
    if (x%is_dev()) then
      call acc_update_self(x%v)
    end if
    if (x%is_host()) then
      call acc_update_device(x%v)
    end if
    call x%set_sync()
  end subroutine l_oacc_sync

  subroutine l_oacc_set_host(x)
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x

    x%state = is_host
  end subroutine l_oacc_set_host

  subroutine l_oacc_set_dev(x)
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x

    x%state = is_dev
  end subroutine l_oacc_set_dev

  subroutine l_oacc_set_sync(x)
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x

    x%state = is_sync
  end subroutine l_oacc_set_sync

  function l_oacc_is_dev(x) result(res)
    implicit none 
    class(psb_l_vect_oacc), intent(in) :: x
    logical  :: res

    res = (x%state == is_dev)
  end function l_oacc_is_dev

  function l_oacc_is_host(x) result(res)
    implicit none 
    class(psb_l_vect_oacc), intent(in) :: x
    logical  :: res

    res = (x%state == is_host)
  end function l_oacc_is_host

  function l_oacc_is_sync(x) result(res)
    implicit none 
    class(psb_l_vect_oacc), intent(in) :: x
    logical  :: res

    res = (x%state == is_sync)
  end function l_oacc_is_sync

  subroutine l_oacc_vect_all(n, x, info)
    use psi_serial_mod
    use psb_realloc_mod
    implicit none 
    integer(psb_ipk_), intent(in)      :: n
    class(psb_l_vect_oacc), intent(out) :: x
    integer(psb_ipk_), intent(out)     :: info

    call psb_realloc(n, x%v, info)
    if (info /= 0) then 
      info = psb_err_alloc_request_
      call psb_errpush(info, 'l_oacc_all', &
           i_err=(/n, n, n, n, n/))
    end if
    call x%set_host()
    call x%sync_space()
  end subroutine l_oacc_vect_all

  subroutine l_oacc_final_vect_free(x)
    implicit none 
    type(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_)     :: info
    info = 0
    if (allocated(x%v)) then
      if (acc_is_present(x%v)) call acc_delete_finalize(x%v) 
      deallocate(x%v, stat=info)
    end if

  end subroutine l_oacc_final_vect_free

  subroutine l_oacc_vect_free(x, info)
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_), intent(out)     :: info
    info = 0
    if (allocated(x%v)) then
      if (acc_is_present(x%v)) call acc_delete_finalize(x%v) 
      deallocate(x%v, stat=info)
    end if
  end subroutine l_oacc_vect_free

  function l_oacc_get_size(x) result(res)
    implicit none 
    class(psb_l_vect_oacc), intent(inout) :: x
    integer(psb_ipk_)   :: res

    if (x%is_dev()) call x%sync()
    res = size(x%v)
  end function l_oacc_get_size

end module psb_l_oacc_vect_mod