hecmw_solver_las_33.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
 
module hecmw_solver_las_33
  use hecmw_util
  implicit none
 
  private
 
  public :: hecmw_matvec_33
  public :: hecmw_matvec_33_set_async
  public :: hecmw_matvec_33_unset_async
  public :: hecmw_matresid_33
  public :: hecmw_rel_resid_l2_33
  public :: hecmw_tvec_33
  public :: hecmw_ttvec_33
  public :: hecmw_ttmattvec_33
  public :: hecmw_mat_diag_sr_33
 
  ! ! for communication hiding in matvec
  ! integer(kind=kint), save, allocatable :: index_o(:), item_o(:)
  ! real(kind=kreal), save, allocatable :: A_o(:)
  logical, save :: async_matvec_flg = .false.
 
contains
 
  !C
  !C***
  !C*** hecmw_matvec_33
  !C***
  !C
  subroutine hecmw_matvec_33 (hecMESH, hecMAT, X, Y, time_Ax, COMMtime)
    use hecmw_util
    use hecmw_matrix_misc
    implicit none
    type (hecmwst_local_mesh), intent(in) :: hecmesh
    type (hecmwst_matrix), intent(in), target :: hecmat
    real(kind=kreal), intent(in) :: x(:)
    real(kind=kreal), intent(out) :: y(:)
    real(kind=kreal), intent(inout) :: time_ax
    real(kind=kreal), intent(inout), optional :: commtime
 
    real(kind=kreal) :: tcomm
    real(kind=kreal), allocatable :: wk(:)
 
    tcomm = 0.d0
 
    if (hecmw_mat_get_flag_mpcmatvec(hecmat) /= 0) then
      allocate(wk(hecmat%NP * hecmat%NDOF))
      call hecmw_ttmattvec_33(hecmesh, hecmat, x, y, wk, time_ax, tcomm)
      deallocate(wk)
    else
      call hecmw_matvec_33_inner(hecmesh, hecmat, x, y, time_ax, tcomm)
    endif
 
    if (present(commtime)) commtime = commtime + tcomm
  end subroutine hecmw_matvec_33
 
  !C
  !C***
  !C*** hecmw_matvec_33_set_async
  !C***
  !C
  subroutine hecmw_matvec_33_set_async (hecMAT)
    use hecmw_util
    implicit none
    type (hecmwst_matrix), intent(in) :: hecmat
    ! integer(kind=kint) :: i, j, jS, jE, idx, in
 
    ! allocate(index_o(0:hecMAT%N))
    ! index_o(0) = 0
    ! do i = 1, hecMAT%N
    !   jS= hecMAT%indexU(i-1) + 1
    !   jE= hecMAT%indexU(i  )
    !   idx = index_o(i-1)
    !   do j= jS, jE
    !     in  = hecMAT%itemU(j)
    !     if (in <= hecMAT%N) cycle
    !     idx = idx + 1
    !   enddo
    !   index_o(i) = idx
    ! enddo
    ! allocate(item_o(idx))
    ! allocate(A_o(idx*9))
    ! do i = 1, hecMAT%N
    !   jS= hecMAT%indexU(i-1) + 1
    !   jE= hecMAT%indexU(i  )
    !   idx = index_o(i-1)
    !   do j= jS, jE
    !     in  = hecMAT%itemU(j)
    !     if (in <= hecMAT%N) cycle
    !     idx = idx + 1
    !     item_o(idx) = hecMAT%itemU(j) - hecMAT%N
    !     A_o(9*idx-8:9*idx) = hecMAT%AU(9*j-8:9*j)
    !   enddo
    ! enddo
    ! async_matvec_flg = .true.
  end subroutine hecmw_matvec_33_set_async
 
  !C
  !C***
  !C*** hecmw_matvec_33_unset_async
  !C***
  !C
  subroutine hecmw_matvec_33_unset_async
    implicit none
    ! if (allocated(index_o)) deallocate(index_o)
    ! if (allocated(item_o)) deallocate(item_o)
    ! if (allocated(A_o)) deallocate(A_o)
    ! async_matvec_flg = .false.
  end subroutine hecmw_matvec_33_unset_async
 
  !C
  !C***
  !C*** hecmw_matvec_33_inner ( private subroutine )
  !C***
  !C
  subroutine hecmw_matvec_33_inner (hecMESH, hecMAT, X, Y, time_Ax, COMMtime)
    use hecmw_util
    use m_hecmw_comm_f
    use hecmw_matrix_misc
    use hecmw_jad_type
    use hecmw_tuning_fx
    !$ use omp_lib
 
    implicit none
    type (hecmwst_local_mesh), intent(in) :: hecmesh
    type (hecmwst_matrix), intent(in), target :: hecmat
    real(kind=kreal), intent(in) :: x(:)
    real(kind=kreal), intent(out) :: y(:)
    real(kind=kreal), intent(inout) :: time_ax
    real(kind=kreal), intent(inout), optional :: commtime
 
    real(kind=kreal) :: start_time, end_time, tcomm
    integer(kind=kint) :: i, j, js, je, in
    real(kind=kreal) :: yv1, yv2, yv3, x1, x2, x3
 
    integer(kind=kint) :: n, np
    integer(kind=kint), pointer :: indexl(:), iteml(:), indexu(:), itemu(:)
    real(kind=kreal), pointer :: al(:), au(:), d(:)
 
    ! added for turning >>>
    integer, parameter :: numofblockperthread = 100
    logical, save :: isfirst = .true.
    integer, save :: numofthread = 1
    integer, save, allocatable :: startpos(:), endpos(:)
    integer(kind=kint), save :: sectorcachesize0, sectorcachesize1
    integer(kind=kint) :: threadnum, blocknum, numofblock
    integer(kind=kint) :: numofelement, elementcount, blockindex
    real(kind=kreal) :: numofelementperblock
    ! <<< added for turning
 
    if (hecmw_jad_is_initialized().ne.0) then
      tcomm = 0.d0
      start_time = hecmw_wtime()
      call hecmw_jad_matvec(hecmesh, hecmat, x, y, tcomm)
      end_time = hecmw_wtime()
      time_ax = time_ax + end_time - start_time - tcomm
      if (present(commtime)) commtime = commtime + tcomm
    else
 
      n = hecmat%N
      np = hecmat%NP
      indexl => hecmat%indexL
      indexu => hecmat%indexU
      iteml => hecmat%itemL
      itemu => hecmat%itemU
      al => hecmat%AL
      au => hecmat%AU
      d => hecmat%D
 
      ! added for turning >>>
      if (.not. isfirst) then
        numofblock = numofthread * numofblockperthread
        if (endpos(numofblock-1) .ne. n-1) then
          deallocate(startpos, endpos)
          isfirst = .true.
        endif
      endif
      if (isfirst) then
        !$ numOfThread = omp_get_max_threads()
        numofblock = numofthread * numofblockperthread
        allocate (startpos(0 : numofblock - 1), endpos(0 : numofblock - 1))
        numofelement = n + indexl(n) + indexu(n)
        numofelementperblock = dble(numofelement) / numofblock
        blocknum = 0
        elementcount = 0
        startpos(blocknum) = 1
        do i= 1, n
          elementcount = elementcount + 1
          elementcount = elementcount + (indexl(i) - indexl(i-1))
          elementcount = elementcount + (indexu(i) - indexu(i-1))
          if (elementcount > (blocknum + 1) * numofelementperblock) then
            endpos(blocknum) = i
            ! write(9000+hecMESH%my_rank,*) mod(blockNum, numOfThread), &
              !      startPos(blockNum), endPos(blockNum)
            blocknum = blocknum + 1
            startpos(blocknum) = i + 1
            if (blocknum == (numofblock - 1)) exit
          endif
        enddo
        endpos(blocknum) = n
        ! write(9000+hecMESH%my_rank,*) mod(blockNum, numOfThread), &
          !      startPos(blockNum), endPos(blockNum)
        ! for irregular data
        do i= blocknum+1, numofblock-1
          startpos(i) = n
          endpos(i) = n-1
          ! write(9000+hecMESH%my_rank,*) mod(i, numOfThread), &
            !      startPos(i), endPos(i)
        end do
 
        call hecmw_tuning_fx_calc_sector_cache(np, 3, &
          sectorcachesize0, sectorcachesize1)
 
        isfirst = .false.
      endif
      ! <<< added for turning
 
      start_time= hecmw_wtime()
      ! if (async_matvec_flg) then
      !   call hecmw_update_3_R_async (hecMESH, X, NP, ireq)
      ! else
      call hecmw_update_r (hecmesh, x, np, 3)
      ! endif
      end_time= hecmw_wtime()
      if (present(commtime)) commtime = commtime + end_time - start_time
 
      start_time = hecmw_wtime()
 
      !call fapp_start("loopInMatvec33", 1, 0)
      !call start_collection("loopInMatvec33")
 
      !OCL CACHE_SECTOR_SIZE(sectorCacheSize0,sectorCacheSize1)
      !OCL CACHE_SUBSECTOR_ASSIGN(X)
 
      !$OMP PARALLEL DEFAULT(NONE) &
        !$OMP&PRIVATE(i,X1,X2,X3,YV1,YV2,YV3,jS,jE,j,in,threadNum,blockNum,blockIndex) &
        !$OMP&SHARED(D,AL,AU,indexL,itemL,indexU,itemU,X,Y,startPos,endPos,numOfThread,N,async_matvec_flg)
      threadnum = 0
      !$ threadNum = omp_get_thread_num()
      do blocknum = 0 , numofblockperthread - 1
        blockindex = blocknum * numofthread  + threadnum
        do i = startpos(blockindex), endpos(blockindex)
          x1= x(3*i-2)
          x2= x(3*i-1)
          x3= x(3*i  )
          yv1= d(9*i-8)*x1 + d(9*i-7)*x2 + d(9*i-6)*x3
          yv2= d(9*i-5)*x1 + d(9*i-4)*x2 + d(9*i-3)*x3
          yv3= d(9*i-2)*x1 + d(9*i-1)*x2 + d(9*i  )*x3
 
          js= indexl(i-1) + 1
          je= indexl(i  )
          do j= js, je
            in  = iteml(j)
            x1= x(3*in-2)
            x2= x(3*in-1)
            x3= x(3*in  )
            yv1= yv1 + al(9*j-8)*x1 + al(9*j-7)*x2 + al(9*j-6)*x3
            yv2= yv2 + al(9*j-5)*x1 + al(9*j-4)*x2 + al(9*j-3)*x3
            yv3= yv3 + al(9*j-2)*x1 + al(9*j-1)*x2 + al(9*j  )*x3
          enddo
          js= indexu(i-1) + 1
          je= indexu(i  )
          do j= js, je
            in  = itemu(j)
            ! if (async_matvec_flg .and. in > N) cycle
            x1= x(3*in-2)
            x2= x(3*in-1)
            x3= x(3*in  )
            yv1= yv1 + au(9*j-8)*x1 + au(9*j-7)*x2 + au(9*j-6)*x3
            yv2= yv2 + au(9*j-5)*x1 + au(9*j-4)*x2 + au(9*j-3)*x3
            yv3= yv3 + au(9*j-2)*x1 + au(9*j-1)*x2 + au(9*j  )*x3
          enddo
          y(3*i-2)= yv1
          y(3*i-1)= yv2
          y(3*i  )= yv3
        enddo
      enddo
      !$OMP END PARALLEL
 
      !OCL END_CACHE_SUBSECTOR
      !OCL END_CACHE_SECTOR_SIZE
 
      !call stop_collection("loopInMatvec33")
      !call fapp_stop("loopInMatvec33", 1, 0)
 
      end_time = hecmw_wtime()
      time_ax = time_ax + end_time - start_time
 
      ! if (async_matvec_flg) then
      !   START_TIME= HECMW_WTIME()
      !   call hecmw_update_3_R_wait (hecMESH, ireq)
      !   END_TIME= HECMW_WTIME()
      !   if (present(COMMtime)) COMMtime = COMMtime + END_TIME - START_TIME
 
      !   START_TIME = hecmw_Wtime()
 
      !   do i = 1, N
      !     jS= index_o(i-1) + 1
      !     jE= index_o(i  )
      !     if (jS > jE) cycle
      !     YV1= 0.d0
      !     YV2= 0.d0
      !     YV3= 0.d0
      !     do j=jS, jE
      !       in = item_o(j)
      !       X1= X(3*(N+in)-2)
      !       X2= X(3*(N+in)-1)
      !       X3= X(3*(N+in)  )
      !       YV1= YV1 + A_o(9*j-8)*X1 + A_o(9*j-7)*X2 + A_o(9*j-6)*X3
      !       YV2= YV2 + A_o(9*j-5)*X1 + A_o(9*j-4)*X2 + A_o(9*j-3)*X3
      !       YV3= YV3 + A_o(9*j-2)*X1 + A_o(9*j-1)*X2 + A_o(9*j  )*X3
      !     enddo
      !     Y(3*i-2)= Y(3*i-2)+YV1
      !     Y(3*i-1)= Y(3*i-1)+YV2
      !     Y(3*i  )= Y(3*i  )+YV3
      !   enddo
 
      !   END_TIME = hecmw_Wtime()
      !   time_Ax = time_Ax + END_TIME - START_TIME
      ! endif
 
    endif
  end subroutine hecmw_matvec_33_inner
 
  !C
  !C***
  !C*** hecmw_matresid_33
  !C***
  !C
  subroutine hecmw_matresid_33 (hecMESH, hecMAT, X, B, R, time_Ax, COMMtime)
    use hecmw_util
    implicit none
    type (hecmwst_local_mesh), intent(in) :: hecmesh
    type (hecmwst_matrix), intent(in)     :: hecmat
    real(kind=kreal), intent(in) :: x(:), b(:)
    real(kind=kreal), intent(out) :: r(:)
    real(kind=kreal), intent(inout) :: time_ax
    real(kind=kreal), intent(inout), optional :: commtime
 
    integer(kind=kint) :: i
    real(kind=kreal) :: tcomm
 
    tcomm = 0.d0
    call hecmw_matvec_33 (hecmesh, hecmat, x, r, time_ax, tcomm)
    if (present(commtime)) commtime = commtime + tcomm
    !$omp parallel default(none),private(i),shared(hecMAT,R,B)
    !$omp do
    do i = 1, hecmat%N * 3
      r(i) = b(i) - r(i)
    enddo
    !$omp end do
    !$omp end parallel
  end subroutine hecmw_matresid_33
 
  !C
  !C***
  !C*** hecmw_rel_resid_L2_33
  !C***
  !C
  function hecmw_rel_resid_l2_33 (hecMESH, hecMAT, time_Ax, COMMtime)
    use hecmw_util
    use hecmw_solver_misc
    implicit none
    real(kind=kreal) :: hecmw_rel_resid_l2_33
    type ( hecmwst_local_mesh ), intent(in) :: hecmesh
    type ( hecmwst_matrix     ), intent(in) :: hecmat
    real(kind=kreal), intent(inout) :: time_ax
    real(kind=kreal), intent(inout), optional :: commtime
 
    real(kind=kreal), allocatable :: r(:)
    real(kind=kreal) :: bnorm2, rnorm2
    real(kind=kreal) :: tcomm
 
    allocate(r(hecmat%NDOF*hecmat%NP))
 
    tcomm = 0.d0
    call hecmw_innerproduct_r(hecmesh, hecmat%NDOF, &
      hecmat%B, hecmat%B, bnorm2, tcomm)
    if (bnorm2 == 0.d0) then
      bnorm2 = 1.d0
    endif
    call hecmw_matresid_33(hecmesh, hecmat, hecmat%X, hecmat%B, r, time_ax, tcomm)
    call hecmw_innerproduct_r(hecmesh, hecmat%NDOF, r, r, rnorm2, tcomm)
    hecmw_rel_resid_l2_33 = sqrt(rnorm2 / bnorm2)
 
    if (present(commtime)) commtime = commtime + tcomm
 
    deallocate(r)
  end function hecmw_rel_resid_l2_33
 
  !C
  !C***
  !C*** hecmw_Tvec_33
  !C***
  !C
  subroutine hecmw_tvec_33 (hecMESH, X, Y, COMMtime)
    use hecmw_util
    use m_hecmw_comm_f
    implicit none
    type (hecmwst_local_mesh), intent(in) :: hecmesh
    real(kind=kreal), intent(in) :: x(:)
    real(kind=kreal), intent(out) :: y(:)
    real(kind=kreal), intent(inout) :: commtime
 
    real(kind=kreal) :: start_time, end_time
    integer(kind=kint) :: i, j, jj, k, kk
 
    start_time= hecmw_wtime()
    call hecmw_update_r (hecmesh, x, hecmesh%n_node, 3)
    end_time= hecmw_wtime()
    commtime = commtime + end_time - start_time
 
    !$omp parallel default(none),private(i,k,kk,j,jj),shared(hecMESH,X,Y)
    !$omp do
    do i= 1, hecmesh%nn_internal * hecmesh%n_dof
      y(i)= x(i)
    enddo
    !$omp end do
 
    !$omp do
    outer: do i= 1, hecmesh%mpc%n_mpc
      do j= hecmesh%mpc%mpc_index(i-1) + 1, hecmesh%mpc%mpc_index(i)
        if (hecmesh%mpc%mpc_dof(j) > 3) cycle outer
      enddo
      k = hecmesh%mpc%mpc_index(i-1) + 1
      kk = 3 * (hecmesh%mpc%mpc_item(k) - 1) + hecmesh%mpc%mpc_dof(k)
      y(kk) = 0.d0
      do j= hecmesh%mpc%mpc_index(i-1) + 2, hecmesh%mpc%mpc_index(i)
        jj = 3 * (hecmesh%mpc%mpc_item(j) - 1) + hecmesh%mpc%mpc_dof(j)
        y(kk) = y(kk) - hecmesh%mpc%mpc_val(j) * x(jj)
      enddo
    enddo outer
    !$omp end do
    !$omp end parallel
 
  end subroutine hecmw_tvec_33
 
  !C
  !C***
  !C*** hecmw_Ttvec_33
  !C***
  !C
  subroutine hecmw_ttvec_33 (hecMESH, X, Y, COMMtime)
    use hecmw_util
    use m_hecmw_comm_f
    implicit none
    type (hecmwst_local_mesh), intent(in) :: hecmesh
    real(kind=kreal), intent(in) :: x(:)
    real(kind=kreal), intent(out) :: y(:)
    real(kind=kreal), intent(inout) :: commtime
 
    real(kind=kreal) :: start_time, end_time
    integer(kind=kint) :: i, j, jj, k, kk
 
    start_time= hecmw_wtime()
    call hecmw_update_r (hecmesh, x, hecmesh%n_node, 3)
    end_time= hecmw_wtime()
    commtime = commtime + end_time - start_time
 
    !$omp parallel default(none),private(i,k,kk,j,jj),shared(hecMESH,X,Y)
    !$omp do
    do i= 1, hecmesh%nn_internal * hecmesh%n_dof
      y(i)= x(i)
    enddo
    !$omp end do
 
    !$omp do
    outer: do i= 1, hecmesh%mpc%n_mpc
      do j= hecmesh%mpc%mpc_index(i-1) + 1, hecmesh%mpc%mpc_index(i)
        if (hecmesh%mpc%mpc_dof(j) > 3) cycle outer
      enddo
      k = hecmesh%mpc%mpc_index(i-1) + 1
      kk = 3 * (hecmesh%mpc%mpc_item(k) - 1) + hecmesh%mpc%mpc_dof(k)
      y(kk) = 0.d0
      do j= hecmesh%mpc%mpc_index(i-1) + 2, hecmesh%mpc%mpc_index(i)
        jj = 3 * (hecmesh%mpc%mpc_item(j) - 1) + hecmesh%mpc%mpc_dof(j)
        !$omp atomic
        y(jj) = y(jj) - hecmesh%mpc%mpc_val(j) * x(kk)
      enddo
    enddo outer
    !$omp end do
    !$omp end parallel
 
  end subroutine hecmw_ttvec_33
 
  !C
  !C***
  !C*** hecmw_TtmatTvec_33
  !C***
  !C
  subroutine hecmw_ttmattvec_33 (hecMESH, hecMAT, X, Y, W, time_Ax, COMMtime)
    use hecmw_util
    implicit none
    type (hecmwst_local_mesh), intent(in) :: hecmesh
    type (hecmwst_matrix), intent(in)     :: hecmat
    real(kind=kreal), intent(in) :: x(:)
    real(kind=kreal), intent(out) :: y(:), w(:)
    real(kind=kreal), intent(inout) :: time_ax
    real(kind=kreal), intent(inout) :: commtime
 
    call hecmw_tvec_33(hecmesh, x, y, commtime)
    call hecmw_matvec_33_inner(hecmesh, hecmat, y, w, time_ax, commtime)
    call hecmw_ttvec_33(hecmesh, w, y, commtime)
 
  end subroutine hecmw_ttmattvec_33
 
 
  !C
  !C***
  !C*** hecmw_mat_diag_sr_33
  !C***
  !C
  subroutine hecmw_mat_diag_sr_33(hecMESH, hecMAT, COMMtime)
    use hecmw_util
    use m_hecmw_comm_f
    implicit none
    type (hecmwst_local_mesh), intent(in) :: hecmesh
    type (hecmwst_matrix), intent(inout), target :: hecmat
    real(kind=kreal), intent(inout), optional :: commtime
    real(kind=kreal), allocatable :: w(:,:)
    real(kind=kreal), pointer :: d(:)
    integer(kind=kint) :: ip
    real(kind=kreal) :: start_time, end_time
    allocate(w(3*hecmat%NP,3))
    d => hecmat%D
    do ip= 1, hecmat%N
      w(3*ip-2,1)= d(9*ip-8); w(3*ip-2,2)= d(9*ip-7); w(3*ip-2,3)= d(9*ip-6)
      w(3*ip-1,1)= d(9*ip-5); w(3*ip-1,2)= d(9*ip-4); w(3*ip-1,3)= d(9*ip-3)
      w(3*ip  ,1)= d(9*ip-2); w(3*ip  ,2)= d(9*ip-1); w(3*ip  ,3)= d(9*ip  )
    enddo
    start_time= hecmw_wtime()
    call hecmw_update_r (hecmesh, w(:,1), hecmat%NP, 3)
    call hecmw_update_r (hecmesh, w(:,2), hecmat%NP, 3)
    call hecmw_update_r (hecmesh, w(:,3), hecmat%NP, 3)
    end_time= hecmw_wtime()
    if (present(commtime)) commtime = commtime + end_time - start_time
    do ip= hecmat%N+1, hecmat%NP
      d(9*ip-8)= w(3*ip-2,1); d(9*ip-7)= w(3*ip-2,2); d(9*ip-6)= w(3*ip-2,3)
      d(9*ip-5)= w(3*ip-1,1); d(9*ip-4)= w(3*ip-1,2); d(9*ip-3)= w(3*ip-1,3)
      d(9*ip-2)= w(3*ip  ,1); d(9*ip-1)= w(3*ip  ,2); d(9*ip  )= w(3*ip  ,3)
    enddo
    deallocate(w)
  end subroutine hecmw_mat_diag_sr_33
 
end module hecmw_solver_las_33