scale_meshfieldcomm_cubedspheredom2d.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
#include "scaleFElib.h"
module scale_meshfieldcomm_cubedspheredom2d
 
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
 
  use scale_element_base, only: elementbase, elementbase2d
  use scale_mesh_cubedspheredom2d, only: meshcubedspheredom2d
  use scale_meshfield_base, only: meshfield2d
  use scale_meshfieldcomm_base, only: &
    meshfieldcommbase,                               &
    meshfieldcommbase_init, meshfieldcommbase_final, &
    meshfieldcommbase_extract_bounddata,             &
    meshfieldcommbase_set_bounddata,                 &
    meshfieldcontainer
  use scale_localmesh_2d, only: localmesh2d
   
  !-----------------------------------------------------------------------------
  implicit none
  private
 
  !-----------------------------------------------------------------------------
  !
  !++ Public type & procedure
  ! 
 
  type :: veccovariantcomp
    type(MeshField2D), pointer :: u1 => null()
    type(MeshField2D), pointer :: u2 => null()
  end type    
 
  type, public, extends(meshfieldcommbase) :: meshfieldcommcubedspheredom2d
    class(meshcubedspheredom2d), pointer :: mesh2d
    type(veccovariantcomp), allocatable :: vec_covariant_comp_ptrlist(:)
    integer, allocatable :: nnode_lcmeshallface(:)
  contains
    procedure, public :: init   => meshfieldcommcubedspheredom2d_init
    procedure, public :: put    => meshfieldcommcubedspheredom2d_put
    procedure, public :: get    => meshfieldcommcubedspheredom2d_get
    procedure, public :: exchange => meshfieldcommcubedspheredom2d_exchange  
    procedure, public :: setcovariantvec => meshfieldcommcubedspheredom2d_set_covariantvec
    procedure, public :: final => meshfieldcommcubedspheredom2d_final
  end type meshfieldcommcubedspheredom2d
 
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  
  !-----------------------------------------------------------------------------
  !
  !++ Private type & procedure
  !
  private :: post_exchange_core
  private :: push_localsendbuf
  
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  integer :: bufsize_per_field
  integer, parameter :: comm_face_num = 4
 
contains
  subroutine meshfieldcommcubedspheredom2d_init( this, &
    sfield_num, hvfield_num, htensorfield_num, mesh2d )
 
    implicit none
    
    class(meshfieldcommcubedspheredom2d), intent(inout) :: this
    integer, intent(in) :: sfield_num
    integer, intent(in) :: hvfield_num
    integer, intent(in) :: htensorfield_num
    class(meshcubedspheredom2d), intent(in), target :: mesh2d
    
    type(localmesh2d), pointer :: lcmesh
    integer :: n
    integer :: nnode_lcmeshface(comm_face_num,mesh2d%local_mesh_num)
    !-----------------------------------------------------------------------------
    
    this%mesh2d => mesh2d
    lcmesh => mesh2d%lcmesh_list(1)
    bufsize_per_field = 2*(lcmesh%NeX + lcmesh%NeY)*lcmesh%refElem2D%Nfp
 
    allocate( this%Nnode_LCMeshAllFace(mesh2d%LOCAL_MESH_NUM) )
    do n=1, this%mesh2d%LOCAL_MESH_NUM
      lcmesh => this%mesh2d%lcmesh_list(n)
      nnode_lcmeshface(:,n) = (/ lcmesh%NeX, lcmesh%NeY, lcmesh%NeX, lcmesh%NeY /) * lcmesh%refElem2D%Nfp
      this%Nnode_LCMeshAllFace(n) = sum(nnode_lcmeshface(:,n))
    end do
 
    call meshfieldcommbase_init( this, sfield_num, hvfield_num, htensorfield_num, bufsize_per_field, comm_face_num, nnode_lcmeshface, mesh2d)  
 
    if (hvfield_num > 0) then
      allocate( this%vec_covariant_comp_ptrlist(hvfield_num) )
    end if
 
    return
  end subroutine meshfieldcommcubedspheredom2d_init
 
  subroutine meshfieldcommcubedspheredom2d_final( this )
    implicit none
    
    class(meshfieldcommcubedspheredom2d), intent(inout) :: this
    !-----------------------------------------------------------------------------
 
    deallocate( this%Nnode_LCMeshAllFace )
 
    if ( this%hvfield_num > 0 ) then
      deallocate( this%vec_covariant_comp_ptrlist )
    end if
 
    call meshfieldcommbase_final( this )
 
    return
  end subroutine meshfieldcommcubedspheredom2d_final
 
  subroutine meshfieldcommcubedspheredom2d_set_covariantvec( &
    this, hvfield_ID, u1, u2  )
    implicit none
    class(meshfieldcommcubedspheredom2d), intent(inout) :: this
    integer, intent(in) :: hvfield_id
    type(meshfield2d), intent(in), target :: u1
    type(meshfield2d), intent(in), target :: u2
    !--------------------------------------------------------------
 
    this%vec_covariant_comp_ptrlist(hvfield_id)%u1 => u1
    this%vec_covariant_comp_ptrlist(hvfield_id)%u2 => u2
 
    return
  end subroutine meshfieldcommcubedspheredom2d_set_covariantvec
 
  subroutine meshfieldcommcubedspheredom2d_put(this, field_list, varid_s)
    implicit none
    class(meshfieldcommcubedspheredom2d), intent(inout) :: this
    type(meshfieldcontainer), intent(in) :: field_list(:)
    integer, intent(in) :: varid_s
  
    integer :: i
    integer :: n
    type(localmesh2d), pointer :: lcmesh
    !-----------------------------------------------------------------------------
 
    do i=1, size(field_list)
    do n=1, this%mesh%LOCAL_MESH_NUM
      lcmesh => this%mesh2d%lcmesh_list(n)
      call meshfieldcommbase_extract_bounddata( field_list(i)%field2d%local(n)%val, lcmesh%refElem, lcmesh, & ! (in)
        this%send_buf(:,varid_s+i-1,n) )                                                                      ! (out)
    end do
    end do
 
    return
  end subroutine meshfieldcommcubedspheredom2d_put
 
  subroutine meshfieldcommcubedspheredom2d_get(this, field_list, varid_s)
    use scale_meshfieldcomm_base, only: &
      meshfieldcommbase_wait_core
    implicit none
    
    class(meshfieldcommcubedspheredom2d), intent(inout) :: this
    type(meshfieldcontainer), intent(inout) :: field_list(:)
    integer, intent(in) :: varid_s
 
    integer :: i
    integer :: n
    type(localmesh2d), pointer :: lcmesh
 
    integer :: varnum
    integer :: varid_e
    integer :: varid_vec_s
    type(meshfield2d), pointer :: u1, u2
    !-----------------------------------------------------------------------------
 
    varnum = size(field_list) 
 
    !--
    if ( this%call_wait_flag_sub_get ) then
      call post_exchange_core( this )
      call meshfieldcommbase_wait_core( this, this%commdata_list )
    end if
 
    !--
    do i=1, varnum
    do n=1, this%mesh2d%LOCAL_MESH_NUM
      lcmesh => this%mesh2d%lcmesh_list(n)
      call meshfieldcommbase_set_bounddata( this%recv_buf(:,varid_s+i-1,n), lcmesh%refElem, lcmesh, & !(in)
         field_list(i)%field2d%local(n)%val )  !(out)
    end do
    end do
 
    varid_e = varid_s + varnum - 1
    if ( varid_e > this%sfield_num ) then
      do i=1, this%hvfield_num
 
        varid_vec_s = this%sfield_num + 2*i - 1 
        if ( varid_vec_s > varid_e ) exit
 
        if (       associated(this%vec_covariant_comp_ptrlist(i)%u1 ) &
            .and.  associated(this%vec_covariant_comp_ptrlist(i)%u2 ) ) then
        
          do n=1, this%mesh2d%LOCAL_MESH_NUM
            call set_boundary_data2d_u1u2( &
              this%recv_buf(:,varid_vec_s,n), this%recv_buf(:,varid_vec_s+1,n), & ! (in)
              lcmesh%refElem2D, lcmesh, lcmesh%G_ij,                            & ! (in)
              this%vec_covariant_comp_ptrlist(i)%u1%local(n)%val,               & ! (out)
              this%vec_covariant_comp_ptrlist(i)%u2%local(n)%val                ) ! (out)
          end do
       end if
      end do
    end if
 
    return
  end subroutine meshfieldcommcubedspheredom2d_get
 
!OCL SERIAL
  subroutine meshfieldcommcubedspheredom2d_exchange( this, do_wait )    
    use scale_meshfieldcomm_base, only: &
      meshfieldcommbase_exchange_core,  &
      localmeshcommdata
 
    use scale_cubedsphere_coord_cnv, only: &
      cubedspherecoordcnv_cs2lonlatvec, &
      cubedspherecoordcnv_lonlat2csvec
    
    implicit none
  
    class(meshfieldcommcubedspheredom2d), intent(inout), target :: this
    logical, intent(in), optional :: do_wait
 
    integer :: n, f
    integer :: varid
 
    real(rp), allocatable :: fpos2d(:,:)
    real(rp), allocatable :: lcfpos2d(:,:)
    real(rp), allocatable :: unity_fac(:)
    real(rp), allocatable :: tmp_svec2d(:,:)
    
    class(elementbase2d), pointer :: elem
    type(localmesh2d), pointer :: lcmesh
    type(localmeshcommdata), pointer :: commdata
 
    integer :: irs, ire    
    !-----------------------------------------------------------------------------
 
    do n=1, this%mesh%LOCAL_MESH_NUM
      lcmesh => this%mesh2d%lcmesh_list(n)
      elem => lcmesh%refElem2D
 
      allocate( fpos2d(this%Nnode_LCMeshAllFace(n),2) )
      call extract_boundary_data2d( lcmesh%pos_en(:,:,1), elem, lcmesh, fpos2d(:,1) )  
      call extract_boundary_data2d( lcmesh%pos_en(:,:,2), elem, lcmesh, fpos2d(:,2) ) 
 
      irs = 1
      do f=1, this%nfaces_comm
        commdata => this%commdata_list(f,n)
        call push_localsendbuf( commdata%send_buf(:,:),             &  ! (inout)
          this%send_buf(:,:,n), commdata%s_faceID, this%is_f(f,n),  &  ! (in)
          commdata%Nnode_LCMeshFace, this%field_num_tot)               ! (in)
        
        if ( commdata%s_panelID /= lcmesh%panelID ) then
          if ( this%hvfield_num > 0 ) then
            
            allocate( lcfpos2d(commdata%Nnode_LCMeshFace,2), unity_fac(commdata%Nnode_LCMeshFace) )
            allocate( tmp_svec2d(commdata%Nnode_LCMeshFace,2) )
 
            call push_localsendbuf( lcfpos2d,                                   &
              fpos2d, commdata%s_faceID, this%is_f(f,n), commdata%Nnode_LCMeshFace, 2 )
            unity_fac(:) = 1.0_rp
 
            ire = irs + commdata%Nnode_LCMeshFace - 1
 
            do varid=this%sfield_num+1, this%field_num_tot-1,2
              tmp_svec2d(:,1) = commdata%send_buf(:,varid  )
              tmp_svec2d(:,2) = commdata%send_buf(:,varid+1)
              call cubedspherecoordcnv_cs2lonlatvec( &
                lcmesh%panelID, lcfpos2d(:,1), lcfpos2d(:,2), unity_fac,           &
                commdata%Nnode_LCMeshFace,                                         &
                tmp_svec2d(:,1), tmp_svec2d(:,2),                                  &
                commdata%send_buf(:,varid), commdata%send_buf(:,varid+1)           )
            end do
 
            deallocate( lcfpos2d, unity_fac, tmp_svec2d )
          end if
        end if
        
        irs = ire + 1
      end do
      deallocate( fpos2d )
    end do
 
    !-----------------------
 
    call meshfieldcommbase_exchange_core(this, this%commdata_list(:,:), do_wait )
    if ( .not. this%call_wait_flag_sub_get ) &
      call post_exchange_core( this )
 
    return
  end subroutine meshfieldcommcubedspheredom2d_exchange
 
!- Private ---------------------------
 
  subroutine post_exchange_core( this )
    use scale_meshfieldcomm_base, only: localmeshcommdata
    use scale_cubedsphere_coord_cnv, only: &
      cubedspherecoordcnv_lonlat2csvec
    implicit none
 
    class(meshfieldcommcubedspheredom2d), intent(inout), target :: this
 
    integer :: n, f
    integer :: varid
 
    real(rp), allocatable :: fpos2d(:,:)
    real(rp), allocatable :: lcfpos2d(:,:)
    real(rp), allocatable :: unity_fac(:)
    
    class(elementbase2d), pointer :: elem
    type(localmesh2d), pointer :: lcmesh
    type(localmeshcommdata), pointer :: commdata
 
    integer :: irs, ire    
    !-----------------------------------------------------------------------------
 
    do n=1, this%mesh%LOCAL_MESH_NUM
      lcmesh => this%mesh2d%lcmesh_list(n)
      elem => lcmesh%refElem2D
 
      allocate( fpos2d(this%Nnode_LCMeshAllFace(n),2) )
      call extract_boundary_data2d( lcmesh%pos_en(:,:,1), elem, lcmesh, fpos2d(:,1) )  
      call extract_boundary_data2d( lcmesh%pos_en(:,:,2), elem, lcmesh, fpos2d(:,2) ) 
 
      irs = 1
      do f=1, this%nfaces_comm
        commdata => this%commdata_list(f,n)
        ire = irs + commdata%Nnode_LCMeshFace - 1
 
        if ( commdata%s_panelID /= lcmesh%panelID ) then
          if ( this%hvfield_num > 0 ) then
 
            allocate( lcfpos2d(commdata%Nnode_LCMeshFace,2), unity_fac(commdata%Nnode_LCMeshFace) )
 
            call push_localsendbuf( lcfpos2d,                          &
              fpos2d, f, this%is_f(f,n), commdata%Nnode_LCMeshFace, 2 )
            unity_fac(:) = 1.0_rp
 
            do varid=this%sfield_num+1, this%field_num_tot-1, 2
              call cubedspherecoordcnv_lonlat2csvec( &
                lcmesh%panelID, lcfpos2d(:,1), lcfpos2d(:,2), unity_fac(:),          &
                commdata%Nnode_LCMeshFace,                                           &
                commdata%recv_buf(:,varid), commdata%recv_buf(:,varid+1),            &
                this%recv_buf(irs:ire,varid,n), this%recv_buf(irs:ire,varid+1,n)     )
            end do
            deallocate( lcfpos2d, unity_fac )
          end if
        end if
 
        irs = ire + 1
      end do
 
      deallocate( fpos2d )
    end do
 
    return    
  end subroutine post_exchange_core
 
  subroutine push_localsendbuf( lc_send_buf, send_buf, s_faceID, is, Nnode_LCMeshFace, var_num )
    implicit none
 
    integer, intent(in) :: var_num
    integer, intent(in) ::  nnode_lcmeshface
    real(rp), intent(inout) :: lc_send_buf(nnode_lcmeshface,var_num)
    real(rp), intent(in) :: send_buf(bufsize_per_field,var_num)  
    integer, intent(in) :: s_faceid, is
  
    integer :: ie
    !-----------------------------------------------------------------------------
 
    ie = is + nnode_lcmeshface - 1
    if ( s_faceid > 0 ) then
      lc_send_buf(:,:) = send_buf(is:ie,:)   
    else
      lc_send_buf(:,:) = send_buf(ie:is:-1,:)   
    end if 
    
    return
  end subroutine push_localsendbuf
 
  subroutine extract_boundary_data2d( var, refElem, mesh, buf )
    implicit none
  
    type(elementbase2d), intent(in) :: refelem
    type(localmesh2d), intent(in) :: mesh
    real(dp), intent(in) :: var(refelem%np * mesh%ne)
    real(dp), intent(inout) :: buf(refelem%nfp * mesh%nex * 4)
    !------------------------------------------------------------
  
    buf(:) = var(mesh%VmapB(:))
 
    return
  end subroutine extract_boundary_data2d
 
  subroutine set_boundary_data2d_u1u2( buf_U, buf_V, &
    elem, mesh, G_ij,                             &
    u1, u2)
  
    implicit none
  
    type(elementbase2d), intent(in) :: elem
    type(localmesh2d), intent(in) :: mesh
    real(dp), intent(in) :: buf_u(elem%nfp * mesh%nex * 4)
    real(dp), intent(in) :: buf_v(elem%nfp * mesh%nex * 4)
    real(dp), intent(in) :: g_ij(elem%np * mesh%ne,2,2)
    real(dp), intent(inout) :: u1(elem%np * mesh%nea)
    real(dp), intent(inout) :: u2(elem%np * mesh%nea)
    !------------------------------------------------------------
 
    u1(elem%Np*mesh%NeE+1:elem%Np*mesh%NeE+size(buf_u)) &
      = g_ij(mesh%VmapB,1,1) * buf_u(:) + g_ij(mesh%VmapB,1,2) * buf_v(:)
    u2(elem%Np*mesh%NeE+1:elem%Np*mesh%NeE+size(buf_u)) &
      = g_ij(mesh%VmapB,2,1) * buf_u(:) + g_ij(mesh%VmapB,2,2) * buf_v(:)
  
    return
  end subroutine set_boundary_data2d_u1u2
 
end module scale_meshfieldcomm_cubedspheredom2d