proper_nesting Subroutine

private subroutine proper_nesting()

Uses

  • proc~~proper_nesting~~UsesGraph proc~proper_nesting proper_nesting module~mod_amr_neighbors mod_amr_neighbors proc~proper_nesting->module~mod_amr_neighbors module~mod_forest mod_forest proc~proper_nesting->module~mod_forest module~mod_global_parameters mod_global_parameters proc~proper_nesting->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

For all grids on all processors, do a check on refinement flags. Make sure that neighbors will not differ more than one level of refinement.

Arguments

None

Calls

proc~~proper_nesting~~CallsGraph proc~proper_nesting proper_nesting mpi_allgather mpi_allgather proc~proper_nesting->mpi_allgather mpi_allreduce mpi_allreduce proc~proper_nesting->mpi_allreduce proc~find_neighbor find_neighbor proc~proper_nesting->proc~find_neighbor proc~find_root_neighbor find_root_neighbor proc~find_neighbor->proc~find_root_neighbor

Called by

proc~~proper_nesting~~CalledByGraph proc~proper_nesting proper_nesting proc~amr_coarsen_refine amr_coarsen_refine proc~amr_coarsen_refine->proc~proper_nesting 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 proper_nesting
    use mod_forest
    use mod_global_parameters
    use mod_amr_neighbors, only: find_neighbor

    logical, dimension(:,:), allocatable :: refine2
    integer :: iigrid, igrid, level, ic1,ic2,ic3, inp1,inp2,inp3, i1,i2,i3,&
         my_neighbor_type,ipe
    logical :: coarsening, pole(ndim), sendbuf(max_blocks)
    type(tree_node_ptr) :: tree, p_neighbor, my_parent, sibling, my_neighbor,&
         neighborchild

    if (nbufferx1/=0.or.nbufferx2/=0.or.nbufferx3/=0) then
       allocate(refine2(max_blocks,npe))
       call MPI_ALLREDUCE(refine,refine2,max_blocks*npe,MPI_LOGICAL,MPI_LOR,&
            icomm,ierrmpi)
       refine=refine2
    else
       sendbuf(:)=refine(:,mype)
       call MPI_ALLGATHER(sendbuf,max_blocks,MPI_LOGICAL,refine,max_blocks,&
            MPI_LOGICAL,icomm,ierrmpi)
    end if

    do level=min(levmax,refine_max_level-1),levmin+1,-1
       tree%node => level_head(level)%node
       do
          if (.not.associated(tree%node)) exit

          if (refine(tree%node%igrid,tree%node%ipe)) then
             ic1=1+modulo(tree%node%ig1-1,2);ic2=1+modulo(tree%node%ig2-1,2)
             ic3=1+modulo(tree%node%ig3-1,2);
             do inp3=ic3-2,ic3-1
                do inp2=ic2-2,ic2-1
                   do inp1=ic1-2,ic1-1
                      if (inp1==0.and.inp2==0.and.inp3==0) cycle
                      p_neighbor%node => tree%node%parent%node
                      if (inp1/=0) then
                         p_neighbor%node => p_neighbor%node%neighbor(ic1,1)%node
                         if (.not.associated(p_neighbor%node)) cycle
                      end if
                      if (inp2/=0) then
                         p_neighbor%node => p_neighbor%node%neighbor(ic2,2)%node
                         if (.not.associated(p_neighbor%node)) cycle
                      end if
                      if (inp3/=0) then
                         p_neighbor%node => p_neighbor%node%neighbor(ic3,3)%node
                         if (.not.associated(p_neighbor%node)) cycle
                      end if
                      if (p_neighbor%node%leaf) then
                         refine(p_neighbor%node%igrid,p_neighbor%node%ipe)=.true.
                      end if
                   end do
                end do
             end do
          end if

          tree%node => tree%node%next%node
       end do
    end do

    ! On each processor locally, check if grids set for coarsening are already
    ! set for refinement.

    do iigrid=1,igridstail; igrid=igrids(iigrid);
       if (refine(igrid,mype).and.coarsen(igrid,mype)) coarsen(igrid,&
            mype)=.false.
    end do

    ! For all grids on all processors, do a check on coarse refinement flags
    sendbuf(:)=coarsen(:,mype)
    call MPI_ALLGATHER(sendbuf,max_blocks,MPI_LOGICAL,coarsen,max_blocks,&
         MPI_LOGICAL,icomm,ierrmpi)

    do level=levmax,max(2,levmin),-1
       tree%node => level_head(level)%node
       do
          if (.not.associated(tree%node)) exit

          if (coarsen(tree%node%igrid,tree%node%ipe)) then
             coarsening=.true.
             my_parent%node => tree%node%parent%node

             ! are all siblings flagged for coarsen ?
             check1:  do ic3=1,2
                do ic2=1,2
                   do ic1=1,2
                      sibling%node => my_parent%node%child(ic1,ic2,ic3)%node
                      if (sibling%node%leaf) then
                         if (coarsen(sibling%node%igrid,sibling%node%ipe)) cycle
                      end if
                      call unflag_coarsen_siblings
                      exit check1
                   end do
                end do
             end do check1

             ! Make sure that neighbors will not differ more than one level of
             ! refinement, otherwise unflag all siblings
             if (coarsening) then
                check2:     do ic3=1,2
                   do ic2=1,2
                      do ic1=1,2
                         sibling%node => my_parent%node%child(ic1,ic2,ic3)%node
                         do i3=ic3-2,ic3-1
                            do i2=ic2-2,ic2-1
                               do i1=ic1-2,ic1-1
                                  if (i1==0.and.i2==0.and.i3==0) cycle
                                  call find_neighbor(my_neighbor,my_neighbor_type, sibling,&
                                       i1,i2,i3,pole)
                                  select case (my_neighbor_type)
                                  case (neighbor_sibling)
                                     if (refine(my_neighbor%node%igrid,&
                                          my_neighbor%node%ipe)) then
                                        call unflag_coarsen_siblings
                                        exit check2
                                     else
                                        cycle
                                     end if
                                  case (neighbor_fine)
                                     neighborchild%node=>my_neighbor%node%child(1,1,&
                                          1)%node
                                     if (neighborchild%node%leaf) then
                                        if (coarsen(neighborchild%node%igrid,&
                                             neighborchild%node%ipe)) then
                                           cycle
                                        end if
                                     end if
                                     call unflag_coarsen_siblings
                                     exit check2
                                  end select
                               end do
                            end do
                         end do
                      end do
                   end do
                end do check2
             end if

          end if

          tree%node => tree%node%next%node
       end do
    end do

  contains

    subroutine unflag_coarsen_siblings

      integer :: ic1,ic2,ic3
      type(tree_node_ptr) :: sibling

      do ic3=1,2
         do ic2=1,2
            do ic1=1,2
               sibling%node => my_parent%node%child(ic1,ic2,ic3)%node
               if (sibling%node%leaf) then
                  coarsen(sibling%node%igrid,sibling%node%ipe)=.false.
               end if
            end do
         end do
      end do
      coarsening=.false.

    end subroutine unflag_coarsen_siblings

  end subroutine proper_nesting