scale_meshfieldcomm_base.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
#include "scaleFElib.h"
module scale_meshfieldcomm_base
 
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
 
  use scale_element_base, only: elementbase
  use scale_mesh_base, only: meshbase
  use scale_meshfield_base, only: &
    meshfieldbase, meshfield1d, meshfield2d, meshfield3d
  use scale_localmesh_base, only: &
    localmeshbase
 
  !-----------------------------------------------------------------------------
  implicit none
  private
 
  !-----------------------------------------------------------------------------
  !
  !++ Public type & procedure
  ! 
 
  type, public :: localmeshcommdata
    class(localmeshbase), pointer :: lcmesh
    real(rp), allocatable :: send_buf(:,:)
    real(rp), allocatable :: recv_buf(:,:)
    integer :: nnode_lcmeshface
    integer :: s_tileid
    integer :: s_faceid
    integer :: s_panelid
    integer :: s_rank
    integer :: s_tilelocalid
    integer :: faceid
  contains
    procedure, public :: init => localmeshcommdata_init
    procedure, public :: final => localmeshcommdata_final
    procedure, public :: sendrecv => localmeshcommdata_sendrecv
    procedure, public :: pc_init => localmeshcommdata_pc_init
  end type
 
  type, abstract, public :: meshfieldcommbase
    integer :: sfield_num
    integer :: hvfield_num
    integer :: htensorfield_num
    integer :: field_num_tot
    integer :: nfaces_comm
 
    class(meshbase), pointer :: mesh
    real(rp), allocatable :: send_buf(:,:,:)
    real(rp), allocatable :: recv_buf(:,:,:)
    integer, allocatable :: request_send(:)
    integer, allocatable :: request_recv(:)
 
    type(localmeshcommdata), allocatable :: commdata_list(:,:)
    integer, allocatable :: is_f(:,:)
 
    logical :: mpi_pc_flag
    integer, allocatable :: request_pc(:)
 
    integer :: req_counter
    logical :: call_wait_flag_sub_get
  contains
    procedure(meshfieldcommbase_put), public, deferred :: put   
    procedure(meshfieldcommbase_get), public, deferred :: get
    procedure(meshfieldcommbase_exchange), public, deferred :: exchange
    procedure, public :: prepare_pc => meshfieldcommbase_prepare_pc
  end type meshfieldcommbase
 
  public :: meshfieldcommbase_init, meshfieldcommbase_final
  public :: meshfieldcommbase_exchange_core
  public :: meshfieldcommbase_wait_core
  public :: meshfieldcommbase_extract_bounddata
  public :: meshfieldcommbase_set_bounddata
 
  type, public :: meshfieldcontainer
    class(meshfield1d), pointer :: field1d
    class(meshfield2d), pointer :: field2d
    class(meshfield3d), pointer :: field3d        
  end type  
  
  interface
    subroutine meshfieldcommbase_put(this, field_list, varid_s)
      import meshfieldcommbase
      import meshfieldcontainer
      class(meshfieldcommbase), intent(inout) :: this
      type(meshfieldcontainer), intent(in) :: field_list(:)
      integer, intent(in) :: varid_s
    end subroutine meshfieldcommbase_put
 
    subroutine meshfieldcommbase_get(this, field_list, varid_s)
      import meshfieldcommbase
      import meshfieldcontainer
      class(meshfieldcommbase), intent(inout) :: this
      type(meshfieldcontainer), intent(inout) :: field_list(:)
      integer, intent(in) :: varid_s
    end subroutine meshfieldcommbase_get
 
    subroutine meshfieldcommbase_exchange(this, do_wait)
        import meshfieldcommbase
        class(meshfieldcommbase), intent(inout), target :: this
        logical, intent(in), optional :: do_wait
    end subroutine meshfieldcommbase_exchange
 
    subroutine meshfieldcomm_final(this)
      import meshfieldcommbase  
      class(meshfieldcommbase), intent(inout) :: this
    end subroutine meshfieldcomm_final    
  end interface
 
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
 
contains
 
!OCL SERIAL
  subroutine meshfieldcommbase_init( this, &
    sfield_num, hvfield_num, htensorfield_num, bufsize_per_field, comm_face_num, &
    Nnode_LCMeshFace, mesh )
 
    implicit none
    
    class(meshfieldcommbase), intent(inout) :: this
    class(meshbase), intent(in), target :: mesh
    integer, intent(in) :: sfield_num
    integer, intent(in) :: hvfield_num
    integer, intent(in) :: htensorfield_num
    integer, intent(in) :: bufsize_per_field
    integer, intent(in) :: comm_face_num
    integer, intent(in) :: nnode_lcmeshface(comm_face_num,mesh%local_mesh_num)
 
    integer :: n, f
    class(localmeshbase), pointer :: lcmesh
    !-----------------------------------------------------------------------------
 
    this%mesh => mesh
    this%sfield_num = sfield_num
    this%hvfield_num = hvfield_num
    this%htensorfield_num = htensorfield_num
    this%field_num_tot = sfield_num + hvfield_num*2 + htensorfield_num*4
    this%nfaces_comm = comm_face_num
 
    if (this%field_num_tot > 0) then
      allocate( this%send_buf(bufsize_per_field, this%field_num_tot, mesh%LOCAL_MESH_NUM) )
      allocate( this%recv_buf(bufsize_per_field, this%field_num_tot, mesh%LOCAL_MESH_NUM) )
      allocate( this%request_send(comm_face_num*mesh%LOCAL_MESH_NUM) )
      allocate( this%request_recv(comm_face_num*mesh%LOCAL_MESH_NUM) )
 
      allocate( this%commdata_list(comm_face_num,mesh%LOCAL_MESH_NUM) )
      allocate( this%is_f(comm_face_num,mesh%LOCAL_MESH_NUM) ) 
 
      do n=1, mesh%LOCAL_MESH_NUM
        this%is_f(1,n) = 1
        do f=2, this%nfaces_comm
          this%is_f(f,n) = this%is_f(f-1,n) + nnode_lcmeshface(f-1,n)
        end do
 
        call mesh%GetLocalMesh(n, lcmesh)
        do f=1, this%nfaces_comm
          call this%commdata_list(f,n)%Init( this, lcmesh, f, nnode_lcmeshface(f,n) )
        end do
      end do  
    end if 
 
    this%MPI_pc_flag = .false.
 
    return
  end subroutine meshfieldcommbase_init
 
!OCL SERIAL
  subroutine meshfieldcommbase_final( this )
    implicit none
    
    class(meshfieldcommbase), intent(inout) :: this
 
    integer :: n, f
    integer :: ireq
    integer :: ierr
    !-----------------------------------------------------------------------------
 
    if (this%field_num_tot > 0) then
      deallocate( this%send_buf, this%recv_buf )
      deallocate( this%request_send, this%request_recv )
 
      do n=1, this%mesh%LOCAL_MESH_NUM
      do f=1, this%nfaces_comm
        call this%commdata_list(f,n)%Final()
      end do
      end do     
      deallocate( this%commdata_list, this%is_f )
 
      if (this%MPI_pc_flag) then
        do ireq=1, this%req_counter
          call mpi_request_free( this%request_pc(ireq), ierr )
        end do           
        deallocate( this%request_pc ) 
      end if
    end if
 
    return
  end subroutine meshfieldcommbase_final
 
!OCL SERIAL
  subroutine meshfieldcommbase_prepare_pc( this )
    implicit none    
    class(meshfieldcommbase), intent(inout) :: this
 
    integer :: n, f
    !-----------------------------------------------------------------------------
 
    this%MPI_pc_flag = .true.
    if (this%field_num_tot > 0) then
      allocate( this%request_pc(2*this%nfaces_comm*this%mesh%LOCAL_MESH_NUM) )
    end if
 
    this%req_counter = 0
    do n=1, this%mesh%LOCAL_MESH_NUM
    do f=1, this%nfaces_comm
      call this%commdata_list(f,n)%PC_Init(     &
        this%req_counter, this%request_pc(:) ) ! (inout)
    end do
    end do     
 
    return
  end subroutine meshfieldcommbase_prepare_pc
 
!OCL SERIAL
  subroutine meshfieldcommbase_exchange_core( this, commdata_list, do_wait )
!    use scale_prof
    implicit none
  
    class(meshfieldcommbase), intent(inout) :: this
    type(localmeshcommdata), intent(inout), target :: commdata_list(this%nfaces_comm, this%mesh%local_mesh_num)
    logical, intent(in), optional :: do_wait
  
    integer :: n, f    
    integer :: ierr
    logical :: do_wait_
    !-----------------------------------------------------------------------------
 
    if ( present(do_wait) ) then
      do_wait_ = do_wait
    else
      do_wait_ = .true.
    end if    
    
!    call PROF_rapstart( 'meshfiled_comm_ex_core', 3)
    if ( this%MPI_pc_flag ) then
      call mpi_startall( this%req_counter, this%request_pc(1:this%req_counter), ierr )
    else
      this%req_counter = 0
    end if
    do n=1, this%mesh%LOCAL_MESH_NUM      
    do f=1, this%nfaces_comm
      call commdata_list(f,n)%SendRecv( &
        this%req_counter, this%request_send(:), this%request_recv(:), & ! (inout)
        commdata_list(:,:),                                           & ! (inout) 
        this%MPI_pc_flag )                                              ! (in)  
    end do
    end do
!    call PROF_rapend( 'meshfiled_comm_ex_core', 3)
 
    if ( do_wait_ ) then
      call meshfieldcommbase_wait_core( this, commdata_list )
      this%call_wait_flag_sub_get = .false.
    else
      this%call_wait_flag_sub_get = .true.
    end if
 
    return
  end subroutine meshfieldcommbase_exchange_core
 
!OCL SERIAL
  subroutine meshfieldcommbase_wait_core( this, commdata_list )
    use mpi, only: &
      !MPI_waitall,    &
      mpi_status_size
    use scale_prof
    implicit none
  
    class(meshfieldcommbase), intent(inout) :: this
    type(localmeshcommdata), intent(inout), target :: commdata_list(this%nfaces_comm, this%mesh%local_mesh_num)
 
    integer :: ierr
    integer :: stat_send(mpi_status_size, this%nfaces_comm * this%mesh%local_mesh_num)
    integer :: stat_recv(mpi_status_size, this%nfaces_comm * this%mesh%local_mesh_num)
    integer :: stat_pc(mpi_status_size, 2*this%nfaces_comm * this%mesh%local_mesh_num)
 
    integer :: n, f
    integer :: var_id
    integer :: irs, ire
    !----------------------------
 
!    call PROF_rapstart( 'meshfiled_comm_wait_core', 3)
    if ( this%MPI_pc_flag ) then
      if (this%req_counter > 0) then
        call mpi_waitall( this%req_counter, this%request_pc(1:this%req_counter), stat_pc(:,1:this%req_counter), ierr )
      end if
    else
      if ( this%req_counter > 0 ) then
        call mpi_waitall( this%req_counter, this%request_recv(1:this%req_counter), stat_recv(:,1:this%req_counter), ierr )
        call mpi_waitall( this%req_counter, this%request_send(1:this%req_counter), stat_send(:,1:this%req_counter), ierr )
      end if
    end if
!    call PROF_rapend( 'meshfiled_comm_wait_core', 3)
  
    !---------------------
 
!    call PROF_rapstart( 'meshfiled_comm_wait_post', 3)
    do n=1, this%mesh%LOCAL_MESH_NUM
      !$omp parallel do private(var_id,f,irs,ire)
      do var_id=1, this%field_num_tot
        irs = 1
        do f=1, this%nfaces_comm
          ire = irs + commdata_list(f,n)%Nnode_LCMeshFace - 1
          this%recv_buf(irs:ire,var_id,n) = commdata_list(f,n)%recv_buf(:,var_id)
          irs = ire + 1
        end do ! end loop for face
      end do
    end do
!    call PROF_rapend( 'meshfiled_comm_wait_post', 3)
 
    return
  end subroutine meshfieldcommbase_wait_core
 
!OCL SERIAL
  subroutine meshfieldcommbase_extract_bounddata(var, refElem, mesh, buf)
    implicit none
  
    class(elementbase), intent(in) :: refelem
    class(localmeshbase), intent(in) :: mesh
    real(rp), intent(in) :: var(refelem%np * mesh%nea)
    real(rp), intent(out) :: buf(size(mesh%vmapb))
 
    integer :: i
    !-----------------------------------------------------------------------------
    !$omp parallel do
!OCL PREFETCH
    do i=1, size(buf)
      buf(i) = var(mesh%VmapB(i))
    end do
    return
  end subroutine meshfieldcommbase_extract_bounddata
 
  subroutine meshfieldcommbase_set_bounddata(buf, refElem, mesh, var)
    implicit none
    
    class(elementbase), intent(in) :: refelem
    class(localmeshbase), intent(in) :: mesh
    real(rp), intent(in) :: buf(size(mesh%vmapb))
    real(rp), intent(inout) :: var(refelem%np * mesh%nea)
    !-----------------------------------------------------------------------------
 
    var(refelem%Np*mesh%NeE+1:refelem%Np*mesh%NeE+size(buf)) = buf(:)
    return
  end subroutine meshfieldcommbase_set_bounddata  
 
  !-------------------------------------------
  
  subroutine localmeshcommdata_init( this, comm, lcmesh, faceID, Nnode_LCMeshFace )
    implicit none
 
    class(localmeshcommdata), intent(inout) :: this
    class(meshfieldcommbase), intent(in) :: comm
    class(localmeshbase), intent(in), target :: lcmesh
    integer, intent(in) :: faceid
    integer, intent(in) :: nnode_lcmeshface
    !-----------------------------------------------------------------------------
 
    this%lcmesh => lcmesh
    this%Nnode_LCMeshFace = nnode_lcmeshface
 
    allocate( this%send_buf(nnode_lcmeshface, comm%field_num_tot))
    allocate( this%recv_buf(nnode_lcmeshface, comm%field_num_tot))
 
    this%s_tileID  = comm%mesh%tileID_globalMap(faceid, lcmesh%tileID)
    this%s_faceID  = comm%mesh%tileFaceID_globalMap(faceid, lcmesh%tileID)
    this%s_panelID = comm%mesh%tilePanelID_globalMap(faceid, lcmesh%tileID)      
    this%s_rank    = comm%mesh%PRCrank_globalMap(this%s_tileID)
    this%s_tilelocalID = comm%mesh%tileID_global2localMap(this%s_tileID)
    this%faceID    = faceid
 
    return
  end subroutine localmeshcommdata_init
 
  subroutine localmeshcommdata_sendrecv( this, &
      req_counter, req_send, req_recv,          &
      lccommdat_list, MPI_pc_flag )
    
    use scale_prc, only: &
      prc_local_comm_world
    use mpi, only: &
      !MPI_isend, MPI_irecv, &
      mpi_double_precision
    implicit none
 
    class(localmeshcommdata), intent(inout) :: this
    integer, intent(inout) :: req_counter
    integer, intent(inout) :: req_send(:)
    integer, intent(inout) :: req_recv(:)
    type(localmeshcommdata), intent(inout) :: lccommdat_list(:,:)
    logical, intent(in) :: mpi_pc_flag
  
    integer :: tag
    integer :: bufsize
    integer :: ierr
    !-------------------------------------------
 
    if ( this%s_rank /= this%lcmesh%PRC_myrank &
      .and. (.not. mpi_pc_flag ) ) then
 
      req_counter = req_counter + 1
 
      tag = 10 * this%lcmesh%tileID + this%faceID
      bufsize = size(this%recv_buf)
      call mpi_irecv( this%recv_buf(1,1), bufsize, mpi_double_precision, &
        this%s_rank, tag, prc_local_comm_world,                          &
        req_recv(req_counter), ierr)
 
      bufsize = size(this%send_buf)
      tag = 10 * this%s_tileID + abs(this%s_faceID)
      call mpi_isend( this%send_buf(1,1), bufsize, mpi_double_precision, &
       this%s_rank, tag, prc_local_comm_world,                           &
       req_send(req_counter), ierr )
      
    else if ( this%s_rank == this%lcmesh%PRC_myrank ) then
      lccommdat_list(abs(this%s_faceID), this%s_tilelocalID)%recv_buf(:,:) &
        = this%send_buf(:,:)
    end if         
    
    return
  end subroutine localmeshcommdata_sendrecv
 
  subroutine localmeshcommdata_pc_init( this, &
      req_counter, req                        )
    
    use scale_prc, only: &
      prc_local_comm_world
    use mpi, only: &
      !MPI_isend, MPI_irecv, &
      mpi_double_precision
    implicit none
 
    class(localmeshcommdata), intent(inout) :: this
    integer, intent(inout) :: req_counter
    integer, intent(inout) :: req(:)
  
    integer :: tag
    integer :: bufsize
    integer :: ierr
    !-------------------------------------------
 
    if ( this%s_rank /= this%lcmesh%PRC_myrank ) then
 
      req_counter = req_counter + 1
 
      tag = 100 * this%lcmesh%tileID + this%faceID
      bufsize = size(this%recv_buf)
      call mpi_recv_init( this%recv_buf(1,1), bufsize, mpi_double_precision, &
        this%s_rank, tag, prc_local_comm_world,                              &
        req(req_counter), ierr)
 
      !--
      req_counter = req_counter + 1
 
      bufsize = size(this%send_buf)
      tag = 100 * this%s_tileID + abs(this%s_faceID)
      call mpi_send_init( this%send_buf(1,1), bufsize, mpi_double_precision, &
       this%s_rank, tag, prc_local_comm_world,                               &
       req(req_counter), ierr )
    end if         
    
    return
  end subroutine localmeshcommdata_pc_init
 
  subroutine localmeshcommdata_final( this )
    implicit none
    
    class(localmeshcommdata), intent(inout) :: this
    !-----------------------------------------------------------------------------
 
    deallocate( this%send_buf )
    deallocate( this%recv_buf )
 
    return
  end subroutine localmeshcommdata_final
 
end module scale_meshfieldcomm_base