hecmw_adapt_edge_comm_table.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
 
!C
!C***
!C*** hecmw_adapt_edge_comm_table
!C***
!C
!C    global edge information
!C    edge-based communication table
!C
subroutine hecmw_adapt_edge_comm_table (hecMESH)
 
  use  hecmw_util
  use  hecmw_adapt_stack_sr
  use  hecmw_adapt_item_sr
 
  implicit real*8 (a-h,o-z)
 
  integer(kind=kint ), pointer :: wSI(:), wSE(:)
  integer(kind=kint ), pointer :: wiIa(:), wiEa(:), wiIb(:), wiEb(:)
  integer(kind=kint ), dimension(:), allocatable :: IW1, IW2
 
  type (hecmwST_local_mesh) :: hecMESH
 
  !C
  !C +-------------------------+
  !C | EDGE related parameters |
  !C +-------------------------+
  !C===
  allocate (hecmesh%adapt_iemb    (hecmesh%n_adapt_edge),           &
    &          hecmesh%adapt_mid_edge(hecmesh%n_adapt_edge))
  hecmesh%adapt_iemb    = 0
  hecmesh%adapt_mid_edge= 0
 
  allocate (hecmesh%rev_neighbor_pe(0:hecmesh%n_neighbor_pe))
 
  hecmesh%rev_neighbor_pe(hecmesh%my_rank)= 0
  do neib= 1, hecmesh%n_neighbor_pe
    hecmesh%rev_neighbor_pe(hecmesh%neighbor_pe(neib))= neib
  enddo
 
  allocate (hecmesh%adapt_act_elem_341(hecmesh%n_adapt_elem_341))
  allocate (hecmesh%adapt_act_elem_351(hecmesh%n_adapt_elem_351))
 
  icouta= 0
  icoupa= 0
  do icel= 1, hecmesh%n_elem
    ityp= hecmesh%elem_type(icel)
    !C
    !C-- TETRAHEDRA : active
    if (ityp.eq.341) then
      if (hecmesh%adapt_type(icel).eq.0) then
        icouta = icouta + 1
        hecmesh%adapt_act_elem_341(icouta)= icel
      endif
    endif
    !C
    !C-- PRISMS : active
    if (ityp.eq.351) then
      if (hecmesh%adapt_type(icel).eq.0) then
        icoupa = icoupa + 1
        hecmesh%adapt_act_elem_351(icoupa)= icel
      endif
    endif
  enddo
 
  hecmesh%n_adapt_act_elem_341= icouta
  hecmesh%n_adapt_act_elem_351= icoupa
  !C===
  !C
  !C +---------------+
  !C | Global EDGE # |
  !C +---------------+
  !C===
  nnn= 0
  do ie= 1, hecmesh%n_adapt_edge
    if (hecmesh%adapt_edge_home(ie).eq.hecmesh%my_rank) nnn= nnn + 1
  enddo
  hecmesh%n_adapt_edge_global= hecmesh%n_adapt_act_edge
 
  call hecmw_allreduce_i (hecmesh, hecmesh%n_adapt_edge_global, 1, hecmw_sum)
  !C===
 
  !C
  !C +-----------------------------+
  !C | prepare EXTERNAL edge info. |
  !C +-----------------------------+
  !C===
 
  !C
  !C-- init.
  neibpetot= hecmesh%n_neighbor_pe
 
  allocate (iw1(hecmesh%n_neighbor_pe))
  allocate (wse(0:hecmesh%n_neighbor_pe), wsi(0:hecmesh%n_neighbor_pe))
  iw1 = 0
  wse = 0
  wsi = 0
 
  !C
  !C-- search IMPORT items
  do ie= 1, hecmesh%n_adapt_edge
    ih= hecmesh%adapt_edge_home(ie)
    if (ih.ne.hecmesh%my_rank) then
      ihr = hecmesh%rev_neighbor_pe(ih)
      wsi(ihr)= wsi(ihr) + 1
    endif
  enddo
  !C
  !C-- exchange INFO. on IMPORT item #
  stime0= mpi_wtime()
  call hecmw_adapt_stack_send_recv                                  &
    &   ( hecmesh%n_neighbor_pe, hecmesh%neighbor_pe, wsi, wse,        &
    &     hecmesh%MPI_COMM, hecmesh%my_rank)
  etime0= mpi_wtime()
  commtime= commtime + etime0 - stime0
 
  !C
  !C-- IMPORT/EXPORT item #
  do neib= 1, hecmesh%n_neighbor_pe
    wsi(neib)= wsi(neib-1) + wsi(neib)
    wse(neib)= wse(neib-1) + wse(neib)
  enddo
 
  !C
  !C-- send as IMPORT/recv. as EXPORT
  allocate (wiia(wsi(hecmesh%n_neighbor_pe)*4))
  allocate (wiea(wse(hecmesh%n_neighbor_pe)*4))
  allocate (wiib(wsi(hecmesh%n_neighbor_pe)  ))
  allocate (wieb(wse(hecmesh%n_neighbor_pe)  ))
  ! JF
  wiia=0
  wiea=0
  wiib=0
  wieb=0
 
  do ie= 1, hecmesh%n_adapt_edge
    ih= hecmesh%adapt_edge_home(ie)
 
    if (ih.ne.hecmesh%my_rank) then
      ihr     = hecmesh%rev_neighbor_pe(ih)
      iw1(ihr  )  = iw1(ihr) + 1
      is   = wsi(ihr-1)+iw1(ihr)
 
      in1= hecmesh%adapt_edge_node(2*ie-1)
      in2= hecmesh%adapt_edge_node(2*ie  )
 
      wiia(4*is-3)= hecmesh%node_ID(2*in1  )
      wiia(4*is-2)= hecmesh%node_ID(2*in1-1)
      wiia(4*is-1)= hecmesh%node_ID(2*in2  )
      wiia(4*is  )= hecmesh%node_ID(2*in2-1)
    endif
  enddo
 
  len= max(wsi(hecmesh%n_neighbor_pe),wse(hecmesh%n_neighbor_pe),   &
    &         hecmesh%n_adapt_edge)
 
  deallocate (iw1)
  allocate (iw1(len*4), iw2(len*4))
  iw1 = 0
  iw2 = 0
  stime0= mpi_wtime()
  call hecmw_adapt_item_send_recv                                   &
    &    (len, hecmesh%n_neighbor_pe, hecmesh%neighbor_pe,             &
    &     wsi, wiia, wse, wiea, iw1, iw2,                              &
    &     hecmesh%MPI_COMM, hecmesh%my_rank, 4)
  etime0= mpi_wtime()
  commtime= commtime + etime0 - stime0
 
  deallocate (iw1, iw2)
  !C===
 
  !C
  !C +---------------------+
  !C | EXTERNAL edge info. |
  !C +---------------------+
  !C===
 
 
  !C
  !C-- find LOCAL edge ID at DESTINY
  do neib= 1, hecmesh%n_neighbor_pe
    is= wse(neib-1)+1
    ie= wse(neib  )
    do k= is, ie
      ip1= wiea(4*k-3)
      in1= wiea(4*k-2)
      ip2= wiea(4*k-1)
      in2= wiea(4*k  )
      call hecmw_adapt_local_node_info (ip1,in1,inc1)
      call hecmw_adapt_local_node_info (ip2,in2,inc2)
      call hecmw_adapt_edge_info (hecmesh, inc1,inc2,ie0,1)
      wieb(k)= ie0
    enddo
  enddo
 
  len= max(wsi(hecmesh%n_neighbor_pe),wse(hecmesh%n_neighbor_pe),iedgtot)
  allocate (iw1(len), iw2(len))
  iw1 = 0
  iw2 = 0
 
  stime0= mpi_wtime()
  call hecmw_adapt_item_send_recv                                   &
    &    (len, hecmesh%n_neighbor_pe, hecmesh%neighbor_pe,             &
    &     wse, wieb, wsi, wiib, iw1, iw2,                              &
    &     hecmesh%MPI_COMM, hecmesh%my_rank, 1)
  etime0= mpi_wtime()
  commtime= commtime + etime0 - stime0
 
  !C
  !C-- reconstruct IMPORT table
 
  deallocate (iw1)
  allocate (iw1(hecmesh%n_neighbor_pe))
  iw1 = 0
 
  do ie= 1, hecmesh%n_adapt_edge
    ih= hecmesh%adapt_edge_home(ie)
 
    if (ih.ne.hecmesh%my_rank) then
      ihr   = hecmesh%rev_neighbor_pe(ih)
      iw1(ihr  )= iw1(ihr) + 1
 
      wiib(wsi(ihr-1)+iw1(ihr))= ie
    endif
  enddo
 
  !C
  !C-- new ARRAY
  allocate (hecmesh%adapt_import_edge_index(0:hecmesh%n_neighbor_pe))
  allocate (hecmesh%adapt_export_edge_index(0:hecmesh%n_neighbor_pe))
 
  do neib= 0, hecmesh%n_neighbor_pe
    hecmesh%adapt_import_edge_index(neib)= wsi(neib)
    hecmesh%adapt_export_edge_index(neib)= wse(neib)
  enddo
 
  maximport= wsi(hecmesh%n_neighbor_pe)
  maxexport= wse(hecmesh%n_neighbor_pe)
 
  allocate (hecmesh%adapt_import_edge_item(maximport))
  allocate (hecmesh%adapt_export_edge_item(maxexport))
  do k= 1, maximport
    hecmesh%adapt_import_edge_item(k)= wiib(k)
  enddo
  do k= 1, maxexport
    hecmesh%adapt_export_edge_item(k)= wieb(k)
  enddo
 
  deallocate (iw1,iw2)
  deallocate (wse,wsi,wiea,wieb,wiia,wiib)
 
  !C===
contains
  subroutine hecmw_adapt_local_node_info (ip,in,in0)
    do i= 1, hecmesh%n_node
      if (hecmesh%node_ID(2*i)  .eq.ip .and.                      &
          &          hecmesh%node_ID(2*i-1).eq.in) then
        in0= i
        return
      endif
    enddo
  end subroutine hecmw_adapt_local_node_info
end subroutine hecmw_adapt_edge_comm_table