hecmw_solver_misc.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_misc
 
contains
 
  !C
  !C***
  !C*** hecmw_innerProduct_I
  !C***
  !C
  subroutine hecmw_innerproduct_i (hecMESH, ndof, X, Y, sum, COMMtime )
    use hecmw_util
    use m_hecmw_comm_f
 
    implicit none
    type (hecmwST_local_mesh) :: hecMESH
    integer(kind=kint) :: ndof
    integer(kind=kint) :: X(:), Y(:)
    integer(kind=kint)        :: sum
    real(kind=kreal), optional :: commtime
 
    integer(kind=kint) :: i
    real(kind=kreal) :: start_time, end_time
 
    sum = 0
    do i = 1, hecmesh%nn_internal * ndof
      sum = sum + x(i)*y(i)
    end do
 
    start_time= hecmw_wtime()
    call hecmw_allreduce_i1 (hecmesh, sum, hecmw_sum)
    end_time= hecmw_wtime()
    if (present(commtime)) commtime = commtime + end_time - start_time
 
  end subroutine hecmw_innerproduct_i
 
  !C
  !C***
  !C*** hecmw_innerProduct_R
  !C***
  !C
  subroutine hecmw_innerproduct_r (hecMESH, ndof, X, Y, sum, COMMtime )
    use hecmw_util
    use m_hecmw_comm_f
 
    implicit none
    type (hecmwST_local_mesh) :: hecMESH
    integer(kind=kint) :: ndof
    real(kind=kreal) :: x(:), y(:)
    real(kind=kreal)          :: sum
    real(kind=kreal), optional :: commtime
 
    integer(kind=kint) :: i
    real(kind=kreal) :: start_time, end_time
 
    !$acc serial
    sum = 0.0d0
    !$acc end serial
 
    !$acc kernels
    !$acc loop reduction(+:sum)
    do i = 1, hecmesh%nn_internal * ndof
      sum = sum + x(i)*y(i)
    end do
    !$acc end kernels
 
    start_time= hecmw_wtime()
    call hecmw_allreduce_r1 (hecmesh, sum, hecmw_sum)
    end_time= hecmw_wtime()
    if (present(commtime)) commtime = commtime + end_time - start_time
 
  end subroutine hecmw_innerproduct_r
 
  !C
  !C***
  !C*** hecmw_absMax_R
  !C***
  !C
  subroutine hecmw_absmax_r (hecMESH, ndof, X, absMax, COMMtime)
    use hecmw_util
    use m_hecmw_comm_f
 
    implicit none
    type (hecmwST_local_mesh) :: hecMESH
    integer(kind=kint) :: ndof
    real(kind=kreal) :: x(:)
    real(kind=kreal)          :: absmax
    real(kind=kreal), optional :: commtime
 
    integer(kind=kint) :: i
    real(kind=kreal) :: start_time, end_time
 
    absmax = 0.0d0
    do i = 1, hecmesh%nn_internal * ndof
      absmax = max(absmax, abs(x(i)))
    end do
 
    start_time= hecmw_wtime()
    call hecmw_allreduce_r1 (hecmesh, absmax, hecmw_max)
    end_time= hecmw_wtime()
    if (present(commtime)) commtime = commtime + end_time - start_time
  end subroutine hecmw_absmax_r
 
 
  !C
  !C***
  !C*** hecmw_innerProduct_R_nocomm
  !C***
  !C
  subroutine hecmw_innerproduct_r_nocomm (hecMESH, ndof, X, Y, sum)
    use hecmw_util
 
    implicit none
    type (hecmwST_local_mesh) :: hecMESH
    integer(kind=kint) :: ndof
    real(kind=kreal) :: x(:), y(:)
    real(kind=kreal)          :: sum
 
    integer(kind=kint) :: i
 
    sum = 0.0d0
    do i = 1, hecmesh%nn_internal * ndof
      sum = sum + x(i)*y(i)
    end do
 
  end subroutine hecmw_innerproduct_r_nocomm
 
  !C
  !C***
  !C*** hecmw_axpy_R
  !C***
  !C
  subroutine hecmw_axpy_r (n, alpha, X, Y)
 
    use hecmw_util
 
    implicit none
    integer(kind=kint) :: n
    real(kind=kreal) :: x(:), y(:)
    real(kind=kreal)          :: alpha
 
    integer(kind=kint) :: i
 
    
#ifdef _OPENACC
    !$acc kernels
    !$acc loop independent
#else
    !$OMP PARALLEL
    !$OMP DO
#endif
    do i = 1, n
      y(i) = alpha * x(i) + y(i) 
    end do
#ifdef _OPENACC
    !$acc end kernels
#else
    !$OMP END DO
    !$OMP END PARALLEL 
#endif
 
  end subroutine hecmw_axpy_r
 
  !C
  !C***
  !C*** hecmw_xpay_R
  !C***
  !C
  subroutine hecmw_xpay_r (n, alpha, X, Y)
 
    use hecmw_util
 
    implicit none
    integer(kind=kint) :: n
    real(kind=kreal) :: x(:), y(:)
    real(kind=kreal)          :: alpha
 
    integer(kind=kint) :: i
    
#ifdef _OPENACC
    !$acc kernels
    !$acc loop independent
#else
    !$OMP PARALLEL
    !$OMP DO
#endif
    do i = 1, n
      y(i) = x(i) + alpha *  y(i) 
    end do
#ifdef _OPENACC
    !$acc end kernels
#else
    !$OMP END DO
    !$OMP END PARALLEL 
#endif
 
  end subroutine hecmw_xpay_r
 
  !C
  !C***
  !C*** hecmw_axpby_R
  !C***
  !C
  subroutine hecmw_axpby_r (n, alpha, beta, X, Y)
 
    use hecmw_util
 
    implicit none
    integer(kind=kint) :: n
    real(kind=kreal) :: x(:), y(:)
    real(kind=kreal)          :: alpha, beta
 
    integer(kind=kint) :: i
 
    
    if (beta == 0.d0) then
#ifdef _OPENACC
      !$acc kernels
      !$acc loop independent
#else
      !$OMP PARALLEL
      !$OMP DO
#endif
      do i = 1, n
        y(i) = alpha * x(i)
      end do
#ifdef _OPENACC
      !$acc end kernels
#else
      !$OMP END DO
      !$OMP END PARALLEL
#endif
    else
#ifdef _OPENACC
      !$acc kernels
      !$acc loop independent
#else
      !$OMP PARALLEL
      !$OMP DO
#endif
      do i = 1, n
        y(i) = alpha * x(i) + beta * y(i)
      end do
#ifdef _OPENACC
      !$acc end kernels
#else
      !$OMP END DO
      !$OMP END PARALLEL
#endif
    end if
 
  end subroutine hecmw_axpby_r
 
  !C
  !C***
  !C*** hecmw_axpyz_R
  !C***
  !C
  subroutine hecmw_axpyz_r (n, alpha, X, Y, Z)
 
    use hecmw_util
 
    implicit none
    integer(kind=kint) :: n
    real(kind=kreal) :: x(:), y(:), z(:)
    real(kind=kreal)          :: alpha
 
    integer(kind=kint) :: i
 
    
#ifdef _OPENACC
    !$acc kernels
    !$acc loop independent
#else
    !$OMP PARALLEL
    !$OMP DO
#endif
    do i = 1, n
      z(i) = alpha * x(i) + y(i) 
    end do
#ifdef _OPENACC
    !$acc end kernels
#else
    !$OMP END DO
    !$OMP END PARALLEL 
#endif
  end subroutine hecmw_axpyz_r
 
  !C
  !C***
  !C*** hecmw_scale_R
  !C***
  !C
  subroutine hecmw_scale_r (n, alpha, X)
 
    use hecmw_util
 
    implicit none
    integer(kind=kint) :: n
    real(kind=kreal) :: x(:)
    real(kind=kreal)          :: alpha
 
    integer(kind=kint) :: i
    
    if (alpha == 0.d0) then
#ifdef _OPENACC
      !$acc kernels
      !$acc loop independent
#else
      !$OMP PARALLEL
      !$OMP DO
#endif
      do i = 1, n
        x(i) = 0.d0
      end do
#ifdef _OPENACC
      !$acc end kernels
#else
      !$OMP END DO
      !$OMP END PARALLEL
#endif
    else
#ifdef _OPENACC
      !$acc kernels
      !$acc loop independent
#else
      !$OMP PARALLEL
      !$OMP DO
#endif  
      do i = 1, n
        x(i) = alpha * x(i) 
      end do
#ifdef _OPENACC
      !$acc end kernels
#else
      !$OMP END DO
      !$OMP END PARALLEL
#endif
    end if
 
  end subroutine hecmw_scale_r
 
  !C
  !C***
  !C*** hecmw_copy_R
  !C***
  !C
  subroutine hecmw_copy_r (n, X, Y)
 
    use hecmw_util
 
    implicit none
    integer(kind=kint) :: n
    real(kind=kreal) :: x(:), y(:)
 
    integer(kind=kint) :: i
 
    
#ifdef _OPENACC
    !$acc kernels
    !$acc loop independent
#else
    !$OMP PARALLEL
    !$OMP DO
#endif
    do i = 1, n
      y(i) = x(i) 
    end do
#ifdef _OPENACC
    !$acc end kernels
#else
    !$OMP END DO
    !$OMP END PARALLEL 
#endif
 
  end subroutine hecmw_copy_r
 
  !C
  !C***
  !C*** hecmw_time_statistics
  !C***
  !C
  subroutine hecmw_time_statistics (hecMESH, time, &
      t_max, t_min, t_avg, t_sd)
    use hecmw_util
    use m_hecmw_comm_f
 
    implicit none
    type (hecmwST_local_mesh), intent(in) :: hecMESH
    real(kind=kreal), intent(in) :: time
    real(kind=kreal), intent(out) :: t_max
    real(kind=kreal), intent(out), optional :: t_min, t_avg, t_sd
    real(kind=kreal) :: t2_avg
    integer(kind=kint) :: nprocs
 
    nprocs = hecmw_comm_get_size()
 
    t_max = time
    call hecmw_allreduce_r1(hecmesh, t_max, hecmw_max)
 
    if (.not. present(t_min)) return
    t_min = time
    call hecmw_allreduce_r1(hecmesh, t_min, hecmw_min)
 
    if (.not. present(t_avg)) return
    t_avg = time
    call hecmw_allreduce_r1(hecmesh, t_avg, hecmw_sum)
    t_avg = t_avg / nprocs
 
    if (.not. present(t_sd)) return
    t2_avg = time*time
    call hecmw_allreduce_r1(hecmesh, t2_avg, hecmw_sum)
    t2_avg = t2_avg / nprocs
 
    t_sd = dsqrt(t2_avg - t_avg*t_avg)
  end subroutine hecmw_time_statistics
 
end module hecmw_solver_misc