comm_faces Subroutine

public subroutine comm_faces()

Uses

  • proc~~comm_faces~~UsesGraph proc~comm_faces comm_faces module~mod_forest mod_forest proc~comm_faces->module~mod_forest module~mod_global_parameters mod_global_parameters proc~comm_faces->module~mod_global_parameters module~mod_basic_types mod_basic_types module~mod_global_parameters->module~mod_basic_types module~mod_connectivity mod_connectivity module~mod_global_parameters->module~mod_connectivity module~mod_constants mod_constants module~mod_global_parameters->module~mod_constants module~mod_physicaldata mod_physicaldata module~mod_global_parameters->module~mod_physicaldata module~mod_variables mod_variables module~mod_global_parameters->module~mod_variables mpi mpi module~mod_global_parameters->mpi module~mod_variables->module~mod_basic_types

When refining a coarse block with fine neighbours, it is necessary prolong consistently with the already fine faces. This routine takes care of the communication of such faces.

Arguments

None

Calls

proc~~comm_faces~~CallsGraph proc~comm_faces comm_faces mpi_waitall mpi_waitall proc~comm_faces->mpi_waitall proc~mpi_irecv_wrapper mpi_irecv_wrapper proc~comm_faces->proc~mpi_irecv_wrapper proc~mpi_isend_wrapper mpi_isend_wrapper proc~comm_faces->proc~mpi_isend_wrapper mpi_irecv mpi_irecv proc~mpi_irecv_wrapper->mpi_irecv mpi_isend mpi_isend proc~mpi_isend_wrapper->mpi_isend

Called by

proc~~comm_faces~~CalledByGraph proc~comm_faces comm_faces proc~amr_coarsen_refine amr_coarsen_refine proc~amr_coarsen_refine->proc~comm_faces proc~resettree resettree proc~resettree->proc~amr_coarsen_refine proc~resettree_convert resettree_convert proc~resettree_convert->proc~amr_coarsen_refine proc~settree settree proc~settree->proc~amr_coarsen_refine proc~main main proc~main->proc~resettree_convert proc~main->proc~settree proc~timeintegration timeintegration proc~main->proc~timeintegration proc~timeintegration->proc~resettree program~agile agile program~agile->proc~main

Source Code

  subroutine comm_faces
    use mod_forest, only: refine
    use mod_global_parameters

    integer                   :: iigrid,igrid,ineighbor,ipe_neighbor
    integer                   :: idims,iside,i1,i2,i3,ic1,ic2,ic3,inc1,inc2,&
       inc3,nx1,nx2,nx3
    integer                   :: recvsize, sendsize

    ! Communicate the block faces to achieve consistency when refining
    ! Initialize communication structures

    nrecv=0
    nsend=0
    recvsize=0
    sendsize=0

    do idims=1,ndim
       select case (idims)
       case (1)
          nrecv=nrecv+nrecv_fc(1)
          nsend=nsend+nsend_fc(1)
          nx1=1;nx2=ixMhi2-ixMlo2+1;nx3=ixMhi3-ixMlo3+1;
          isize(1)=nx1*nx2*nx3
          recvsize=recvsize+nrecv_fc(1)*isize(1)
          sendsize=sendsize+nsend_fc(1)*isize(1)

       case (2)
          nrecv=nrecv+nrecv_fc(2)
          nsend=nsend+nsend_fc(2)
          nx1=ixMhi1-ixMlo1+1;nx2=1;nx3=ixMhi3-ixMlo3+1;
          isize(2)=nx1*nx2*nx3
          recvsize=recvsize+nrecv_fc(2)*isize(2)
          sendsize=sendsize+nsend_fc(2)*isize(2)

       case (3)
          nrecv=nrecv+nrecv_fc(3)
          nsend=nsend+nsend_fc(3)
          nx1=ixMhi1-ixMlo1+1;nx2=ixMhi2-ixMlo2+1;nx3=1;
          isize(3)=nx1*nx2*nx3
          recvsize=recvsize+nrecv_fc(3)*isize(3)
          sendsize=sendsize+nsend_fc(3)*isize(3)

       end select
    end do

    if (nrecv>0) then
    ! Allocate receive buffer
      allocate(recvbuffer(recvsize),recvstatus(MPI_STATUS_SIZE,nrecv),&
          recvrequest(nrecv))
      recvrequest=MPI_REQUEST_NULL
      ibuf_recv=1
      irecv=0

    ! Receive
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        if (refine(igrid,mype)) then
         do ic3=1,2
         do ic2=1,2
         do ic1=1,2
            ! Only one of the sides will be necessary,
            ! so we do the loop only over dimensions, instead of
            ! over dimensions and sizes as in the routines
            ! old_neighbors and already_fine.
            do idims=1,ndim
              ipe_neighbor=fine_neighbors(ic1,ic2,ic3,idims,igrid)%ipe
              ineighbor   =fine_neighbors(ic1,ic2,ic3,idims,igrid)%igrid
              if (ineighbor>0.and.ipe_neighbor/=mype) then
               if (idims==1) iside=ic1
               if (idims==2) iside=ic2
               if (idims==3) iside=ic3
                !!! Check indices
                i1=kr(1,idims)*(2*iside-3);i2=kr(2,idims)*(2*iside-3)
                i3=kr(3,idims)*(2*iside-3);
                if (neighbor_pole(i1,i2,i3,igrid)/=0) cycle
                inc1=ic1+i1;inc2=ic2+i2;inc3=ic3+i3;
                irecv=irecv+1
                itag=4**3*(igrid-1)+inc1*4**(1-1)+inc2*4**(2-1)+inc3*4**(3-1)

                call mpi_irecv_wrapper(recvbuffer(ibuf_recv),isize(idims),&
                    MPI_DOUBLE_PRECISION,ipe_neighbor,itag, icomm,&
                   recvrequest(irecv),ierrmpi)
                ibuf_recv=ibuf_recv+isize(idims)
              end if
            end do
         end do
         end do
         end do
        end if
      end do

    end if

    if (nsend>0) then
    ! Allocate send buffer
      allocate(sendbuffer(sendsize),sendstatus(MPI_STATUS_SIZE,nsend),&
         sendrequest(nsend))
      sendrequest=MPI_REQUEST_NULL
      isend=0
      ibuf_send=1
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ! Check whether it is necessary to store any block face, i.e.
        ! if any coarser neighbour is going to be refined
       do iside=1,2
          i1=kr(1,1)*(2*iside-3);i2=kr(2,1)*(2*iside-3)
          i3=kr(3,1)*(2*iside-3);
 !When there is a pole, faces are always zero and this is not necessary
          if (neighbor_pole(i1,i2,i3,igrid)/=0) cycle
          if (neighbor_type(i1,i2,i3,igrid)==neighbor_coarse) then
            ineighbor   =neighbor(1,i1,i2,i3,igrid)
            ipe_neighbor=neighbor(2,i1,i2,i3,igrid)
            if (refine(ineighbor,ipe_neighbor)) then
              if (ipe_neighbor/=mype) then
                ic1=1+modulo(node(pig1_,igrid)-1,2)
                ic2=1+modulo(node(pig2_,igrid)-1,2)
                ic3=1+modulo(node(pig3_,igrid)-1,2);
                inc1=-2*i1+ic1;inc2=ic2;inc3=ic3;
                itag=4**3*(ineighbor-1)+inc1*4**(1-1)+inc2*4**(2-1)+&
                   inc3*4**(3-1)
                isend=isend+1
                ibuf_send_next=ibuf_send+isize(1)
                sendbuffer(ibuf_send:ibuf_send_next-1)=reshape(pface(iside,1,&
                   igrid)%face,(/isize(1)/))
                call mpi_isend_wrapper(sendbuffer(ibuf_send),isize(1),&
                    MPI_DOUBLE_PRECISION,ipe_neighbor,itag, icomm,&
                   sendrequest(isend),ierrmpi)
                ibuf_send=ibuf_send_next
              end if
            end if
          end if
        end do
       do iside=1,2
          i1=kr(1,2)*(2*iside-3);i2=kr(2,2)*(2*iside-3)
          i3=kr(3,2)*(2*iside-3);
 !When there is a pole, faces are always zero and this is not necessary
          if (neighbor_pole(i1,i2,i3,igrid)/=0) cycle
          if (neighbor_type(i1,i2,i3,igrid)==neighbor_coarse) then
            ineighbor   =neighbor(1,i1,i2,i3,igrid)
            ipe_neighbor=neighbor(2,i1,i2,i3,igrid)
            if (refine(ineighbor,ipe_neighbor)) then
              if (ipe_neighbor/=mype) then
                ic1=1+modulo(node(pig1_,igrid)-1,2)
                ic2=1+modulo(node(pig2_,igrid)-1,2)
                ic3=1+modulo(node(pig3_,igrid)-1,2);
                inc1=ic1;inc2=-2*i2+ic2;inc3=ic3;
                itag=4**3*(ineighbor-1)+inc1*4**(1-1)+inc2*4**(2-1)+&
                   inc3*4**(3-1)
                isend=isend+1
                ibuf_send_next=ibuf_send+isize(2)
                sendbuffer(ibuf_send:ibuf_send_next-1)=reshape(pface(iside,2,&
                   igrid)%face,(/isize(2)/))
                call mpi_isend_wrapper(sendbuffer(ibuf_send),isize(2),&
                    MPI_DOUBLE_PRECISION,ipe_neighbor,itag, icomm,&
                   sendrequest(isend),ierrmpi)
                ibuf_send=ibuf_send_next
              end if
            end if
          end if
        end do
       do iside=1,2
          i1=kr(1,3)*(2*iside-3);i2=kr(2,3)*(2*iside-3)
          i3=kr(3,3)*(2*iside-3);
 !When there is a pole, faces are always zero and this is not necessary
          if (neighbor_pole(i1,i2,i3,igrid)/=0) cycle
          if (neighbor_type(i1,i2,i3,igrid)==neighbor_coarse) then
            ineighbor   =neighbor(1,i1,i2,i3,igrid)
            ipe_neighbor=neighbor(2,i1,i2,i3,igrid)
            if (refine(ineighbor,ipe_neighbor)) then
              if (ipe_neighbor/=mype) then
                ic1=1+modulo(node(pig1_,igrid)-1,2)
                ic2=1+modulo(node(pig2_,igrid)-1,2)
                ic3=1+modulo(node(pig3_,igrid)-1,2);
                inc1=ic1;inc2=ic2;inc3=-2*i3+ic3;
                itag=4**3*(ineighbor-1)+inc1*4**(1-1)+inc2*4**(2-1)+&
                   inc3*4**(3-1)
                isend=isend+1
                ibuf_send_next=ibuf_send+isize(3)
                sendbuffer(ibuf_send:ibuf_send_next-1)=reshape(pface(iside,3,&
                   igrid)%face,(/isize(3)/))
                call mpi_isend_wrapper(sendbuffer(ibuf_send),isize(3),&
                    MPI_DOUBLE_PRECISION,ipe_neighbor,itag, icomm,&
                   sendrequest(isend),ierrmpi)
                ibuf_send=ibuf_send_next
              end if
            end if
          end if
        end do
      end do
    end if

    ! Waitalls
    if (nrecv>0) then
       call MPI_WAITALL(nrecv,recvrequest,recvstatus,ierrmpi)
       deallocate(recvstatus,recvrequest)
       ibuf_recv=1
    end if

    if (nsend>0) then
       call MPI_WAITALL(nsend,sendrequest,sendstatus,ierrmpi)
       deallocate(sendbuffer,sendstatus,sendrequest)
    end if

  end subroutine comm_faces