ecearth3/sources/nemo-3.6/EXTERNAL/AGRIF/AGRIF_FILES/modgrids.F90

module Agrif_Grids

    use Agrif_Types
!
    implicit none
!
!===================================================================================================
type Agrif_Grid_List
!---------------------------------------------------------------------------------------------------
!<  List of grids.
!
    integer                     :: nitems = 0      !< Number of elements in the list
    type(Agrif_PGrid), pointer  :: first => NULL() !< Pointer to the first grid in the list
    type(Agrif_PGrid), pointer  :: last  => NULL() !< Pointer to the last  grid inserted in the list
!---------------------------------------------------------------------------------------------------
end type Agrif_Grid_List
!===================================================================================================
!
!===================================================================================================
type Agrif_PGrid
!---------------------------------------------------------------------------------------------------
!<  Data type to go over the grid hierarchy (used for the creation of this grid hierarchy
!<  and during the time integration).
!
    type(Agrif_Grid) , pointer :: gr   => NULL()  !< Pointer to the actual grid data structure
    type(Agrif_PGrid), pointer :: next => NULL()  !< Next grid in the list
!
!---------------------------------------------------------------------------------------------------
end type Agrif_PGrid
!===================================================================================================
!
!===================================================================================================
type Agrif_Grid
!---------------------------------------------------------------------------------------------------
!<  Data type to define a grid (position, space and time refinement factors).
!
    type(Agrif_Grid)                    , pointer :: parent      => NULL() !< pointer on the parent grid
    type(Agrif_Grid)                    , pointer :: save_grid   => NULL() !< pointer on the save grid
    type(Agrif_Grid_List)                         :: child_list            !< List of child grids
    type(Agrif_Variable),   dimension(:), allocatable :: tabvars    !< List of grid variables
    type(Agrif_Variable_c), dimension(:), allocatable :: tabvars_c  !< List of character grid variables
    type(Agrif_Variable_r), dimension(:), allocatable :: tabvars_r  !< List of real      grid variables
    type(Agrif_Variable_l), dimension(:), allocatable :: tabvars_l  !< List of logical   grid variables
    type(Agrif_Variable_i), dimension(:), allocatable :: tabvars_i  !< List of integer   grid variables
!
    real   , dimension(3)              :: Agrif_x   !< global x, y and z position
    real   , dimension(3)              :: Agrif_dx  !< global space step in the x, y and z direction
    real   , dimension(3)              :: Agrif_dt  !< global time  step in the x, y and z direction
    integer, dimension(3)              :: nb        !< number of cells in the x, y and z direction
    integer, dimension(3)              :: ix        !< minimal position in the x, y and z direction
    integer, dimension(3)              :: spaceref  !< space refinement factor in the x, y and z direction
    integer, dimension(3)              :: timeref   !< Time refinement factor in the x, y and z direction
    integer                            :: ngridstep !< number of time steps
    integer                            :: rank
    integer                            :: grid_id   !< moving grid id
    integer                            :: fixedrank !< number of the grid
    logical                            :: fixed     !< fixed or moving grid ?
    logical                            :: oldgrid
!> \name Logicals indicating if the current grid has a common border with the root coarse grid
!> @{
    logical, dimension(3)              :: NearRootBorder
    logical, dimension(3)              :: DistantRootBorder
!> @}
!> \name Arrays for adaptive grid refinement
!> @{
    integer, dimension(:)    ,   allocatable :: tabpoint1D
    integer, dimension(:,:)  ,   allocatable :: tabpoint2D
    integer, dimension(:,:,:),   allocatable :: tabpoint3D
!> @}
!> \name Members for parallel integration
!> @{
    type(Agrif_Rectangle),  pointer    :: rect_in_parent => NULL()
    type(Agrif_Grid_List)              :: neigh_list                !< List of neighboring grids (ie. connected through a common proc)
    type(Agrif_Proc_List)              :: proc_def_list             !< List of procs that will integrate this grid
    type(Agrif_Proc_List)              :: proc_def_in_parent_list   !< List of procs that will integrate this grid (defined as in the parent grid)
    type(Agrif_Proc_List)              :: required_proc_list        !< List of procs that are required for this grid
    type(Agrif_Sequence_List), pointer :: child_seq => NULL()       !< Sequence for childs
    integer                            :: seq_num = 0
    integer                            :: size = 0
    integer                            :: dsat = 0
#if defined AGRIF_MPI
    integer                            :: communicator = -1
#endif
!> @}
    type(Agrif_Variables_List), pointer :: variables => NULL()
    integer                             :: NbVariables = 0
    integer                             :: level    !< level of the grid in the hierarchy
    logical                             :: allocation_is_done = .false.
    logical                             :: grand_mother_grid = .false.
!---------------------------------------------------------------------------------------------------
end type Agrif_Grid
!===================================================================================================
!
!> this pointer always points on the root grid of the grid hierarchy
type(Agrif_Grid) , pointer :: Agrif_Mygrid => NULL()

!> this pointer always points on the grand mother grid of the grid hierarchy (if any)
type(Agrif_Grid) , pointer :: Agrif_Coarsegrid => NULL()

!> Grid list used in the \link Agrif_Util::Agrif_Regrid() Agrif_regrid \endlink subroutine.
!> It contains  the safeguard of the grid hierarchy.
type(Agrif_Grid_List), pointer :: Agrif_oldmygrid => NULL()

!> Pointer to the current grid (the link is done by using the Agrif_Instance procedure (\see module Agrif_Init))
type(Agrif_Grid) , pointer :: Agrif_Curgrid => NULL()
!
!===================================================================================================
type Agrif_Sequence
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List) :: gridlist
    type(Agrif_Proc_List) :: proclist
!---------------------------------------------------------------------------------------------------
end type Agrif_Sequence
!===================================================================================================
!
!===================================================================================================
type Agrif_Sequence_List
!---------------------------------------------------------------------------------------------------
    integer :: nb_seqs
    type(Agrif_Sequence), dimension(:), allocatable :: sequences
!---------------------------------------------------------------------------------------------------
end type Agrif_Sequence_List
!===================================================================================================
!
interface
    function compare_grids ( grid1, grid2 ) result( res )
        import Agrif_Grid
        type(Agrif_Grid), intent(in)    :: grid1
        type(Agrif_Grid), intent(in)    :: grid2
        integer                         :: res  !< Result of the comparison :
                                                !!  - res  < 0   if grid1 <  grid2
                                                !!  - res == 0   if grid1 == grid2
                                                !!  - res  > 0   if grid1 >  grid2
    end function compare_grids
end interface
!
contains
!
!===================================================================================================
subroutine Agrif_gl_print ( gridlist )
!
!< DEBUG : a virer à terme.
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), intent(in)   :: gridlist
!
    type(Agrif_PGrid), pointer  :: gridp
    type(Agrif_Grid),  pointer  :: grid
!
    gridp => gridlist % first
    do while ( associated(gridp) )
        grid => gridp % gr
        write(*,'("G",i0,", ")', advance='no') grid % fixedrank
        gridp => gridp % next
    enddo
    write(*,*)
!---------------------------------------------------------------------------------------------------
end subroutine Agrif_gl_print
!===================================================================================================
!
!===================================================================================================
subroutine Agrif_gl_print_debug ( gridlist )
!
!< DEBUG : a virer à terme.
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), intent(in)   :: gridlist
!
    type(Agrif_PGrid), pointer  :: gridp
    type(Agrif_Grid),  pointer  :: grid
!
    write(*,'(" (nitems=",i2,"), (id,neighs,color,dsat,size) = ")', advance='no') gridlist % nitems
    gridp => gridlist % first
    do while ( associated(gridp) )
        grid => gridp % gr
        write(*,'("(G",i0,4(",",i0),"), ")', advance='no') grid % fixedrank, &
            grid % neigh_list % nitems, grid % seq_num, grid % dsat, grid % size
        gridp => gridp % next
    enddo
    write(*,*)
!---------------------------------------------------------------------------------------------------
end subroutine Agrif_gl_print_debug
!===================================================================================================
!
!===================================================================================================
subroutine Agrif_gl_append ( gridlist, grid )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List),     intent(inout)  :: gridlist
    type(Agrif_Grid), pointer, intent(in)     :: grid
!
    type(Agrif_PGrid), pointer   :: new_gp
!
    allocate( new_gp )
!
    new_gp % gr   => grid
    new_gp % next => NULL()
!
    if ( associated(gridlist % last) ) then
    ! the list is not empty, append the new pointer at the end
        gridlist % last % next => new_gp
    else
    ! the list is empty, the new pointer is the first one
        gridlist % first => new_gp
    endif
    ! anyway, for next time 'grid' will be the last one.
    gridlist % last => new_gp
    gridlist % nitems = gridlist % nitems + 1
!---------------------------------------------------------------------------------------------------
end subroutine Agrif_gl_append
!===================================================================================================
!
!===================================================================================================
function Agrif_gl_popfirst ( gridlist ) result ( grid )
!
!<  Removes the first item of the list and returns it.
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), intent(inout)    :: gridlist
!
    type(Agrif_PGrid), pointer :: grid_p
    type(Agrif_Grid),  pointer :: grid
!
    grid_p => gridlist % first
!
    if ( .not. associated( grid_p ) ) then
        grid => NULL()
        return
    endif
!
    grid              => grid_p % gr
    gridlist % first  => grid_p % next
    gridlist % nitems =  gridlist % nitems - 1
    if ( .not. associated(gridlist % first) ) then
       nullify(gridlist % last)
    endif
    deallocate(grid_p)
!---------------------------------------------------------------------------------------------------
end function Agrif_gl_popfirst
!===================================================================================================
!
!===================================================================================================
subroutine Agrif_gl_copy ( new_gl, model )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), intent(out)  :: new_gl
    type(Agrif_Grid_List), intent(in)   :: model
!
    type(Agrif_PGrid), pointer :: gp
!
    call Agrif_gl_clear(new_gl)
    gp => model % first
!
    do while( associated(gp) )
        call Agrif_gl_append( new_gl, gp % gr )
        gp => gp % next
    enddo
!---------------------------------------------------------------------------------------------------
end subroutine Agrif_gl_copy
!===================================================================================================
!
!===================================================================================================
function Agrif_gl_build_from_gp ( gridp ) result ( gridlist )
!---------------------------------------------------------------------------------------------------
    type(Agrif_PGrid), pointer, intent(in)   :: gridp
!
    type(Agrif_Grid_List), pointer  :: gridlist
    type(Agrif_PGrid),     pointer  :: gp
!
    allocate(gridlist)
!
    gp => gridp
!
    do while ( associated( gp ) )
        call Agrif_gl_append( gridlist, gp % gr )
        gp => gp % next
    enddo
!---------------------------------------------------------------------------------------------------
end function Agrif_gl_build_from_gp
!===================================================================================================
!
!===================================================================================================
subroutine Agrif_gp_delete ( gridp )
!---------------------------------------------------------------------------------------------------
    type(Agrif_PGrid), pointer, intent(inout)  :: gridp
!
    type(Agrif_PGrid), pointer   :: gp, gpd
!
    if ( .not. associated( gridp ) ) return
!
    gp => gridp
!
    do while( associated(gp) )
        gpd => gp
        gp  => gp % next
        deallocate(gpd)
    enddo
!---------------------------------------------------------------------------------------------------
end subroutine Agrif_gp_delete
!===================================================================================================
!
!===================================================================================================
subroutine Agrif_gl_clear ( gridlist )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), intent(inout)  :: gridlist
!
    call Agrif_gp_delete(gridlist % first)
    gridlist % first => NULL()
    gridlist % last  => NULL()
    gridlist % nitems = 0
!---------------------------------------------------------------------------------------------------
end subroutine Agrif_gl_clear
!===================================================================================================
!
!===================================================================================================
subroutine Agrif_gl_delete ( gridlist )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), pointer, intent(inout)  :: gridlist
!
    if ( .not. associated( gridlist ) ) return
!
    call Agrif_gp_delete(gridlist % first)
    deallocate( gridlist )
!---------------------------------------------------------------------------------------------------
end subroutine Agrif_gl_delete
!===================================================================================================
!
!===================================================================================================
recursive function Agrif_gl_merge_sort ( gridlist, compare_func, compare_func_opt ) result( gl_sorted )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), intent(in)    :: gridlist
    procedure(compare_grids)             :: compare_func
    procedure(compare_grids), optional   :: compare_func_opt
!
    type(Agrif_Grid_List), pointer  :: gl_sorted
    type(Agrif_Grid_List), pointer  :: gl_left,  gl_sorted_left
    type(Agrif_Grid_List), pointer  :: gl_right, gl_sorted_right
    type(Agrif_PGrid),     pointer  :: grid_p
    integer                         :: n, middle
!
! if list size is 1, consider it sorted and return it
    if  ( (gridlist % nitems <= 1) ) then
        gl_sorted => Agrif_gl_build_from_gp(gridlist % first)
        return
    endif
!
! else split the list into two sublists
    n = 1
    middle    =  gridlist % nitems / 2
    grid_p    => gridlist % first
!
    allocate( gl_left, gl_right )
!
    do while ( associated(grid_p) )
        if ( n <= middle ) then
            call Agrif_gl_append(gl_left,  grid_p % gr)
        else
            call Agrif_gl_append(gl_right, grid_p % gr)
        endif
        grid_p => grid_p % next
        n = n+1
    enddo
!
! recursively call Agrif_gl_merge_sort() to further split each sublist until sublist size is 1
    gl_sorted_left  => Agrif_gl_merge_sort(gl_left,  compare_func, compare_func_opt)
    gl_sorted_right => Agrif_gl_merge_sort(gl_right, compare_func, compare_func_opt)
!
! merge the sublists returned from prior calls to gl_merge_sort() and return the resulting merged sublist
    gl_sorted => Agrif_gl_merge(gl_sorted_left, gl_sorted_right, compare_func, compare_func_opt)
!
    call Agrif_gl_delete( gl_left )
    call Agrif_gl_delete( gl_right )
    call Agrif_gl_delete( gl_sorted_left )
    call Agrif_gl_delete( gl_sorted_right )
!---------------------------------------------------------------------------------------------------
end function Agrif_gl_merge_sort
!===================================================================================================
!
!===================================================================================================
function Agrif_gl_merge ( gl_left, gl_right, compare_func, compare_func_opt ) result( gl_merged )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid_List), intent(inout)    :: gl_left
    type(Agrif_Grid_List), intent(inout)    :: gl_right
    procedure(compare_grids)                :: compare_func
    procedure(compare_grids), optional      :: compare_func_opt
!
    type(Agrif_Grid_List), pointer  :: gl_merged
    type(Agrif_Grid),      pointer  :: poped_grid
    integer                         :: comp_value
!
    allocate( gl_merged )
!
    do while ( gl_left % nitems > 0 .or. gl_right % nitems > 0 )
!
        if ( gl_left % nitems > 0 .and. gl_right % nitems > 0 ) then
!
!         Let.s compare both items with the first compare function
            comp_value = compare_func( gl_left % first % gr, gl_right % first % gr )
!
            if     ( comp_value < 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_left)
            elseif ( comp_value > 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_right)
            else ! ( comp_value == 0 )
!
!             Both items are equal, let.s use the second criterion if the optional
!             compare function is present.
                if ( present(compare_func_opt) ) then
!
                    comp_value = compare_func_opt( gl_left % first % gr, gl_right % first % gr )
!
                    if ( comp_value <= 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_left)
                    else                        ; poped_grid => Agrif_gl_popfirst(gl_right)
                    endif
                else
!                 If the second criterion is not present, let.s just pick the left item
                    poped_grid => Agrif_gl_popfirst(gl_left)
                endif
            endif
!
!     If one of the lists is empty, we just have to pick in the other one.
        elseif ( gl_left  % nitems > 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_left)
        elseif ( gl_right % nitems > 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_right)
        endif
!
        call Agrif_gl_append( gl_merged, poped_grid )
!
    enddo
!---------------------------------------------------------------------------------------------------
end function Agrif_gl_merge
!===================================================================================================
!
!===================================================================================================
function compare_grid_degrees ( grid1, grid2 ) result( res )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid), intent(in)    :: grid1
    type(Agrif_Grid), intent(in)    :: grid2
!
    integer     :: res
!
    res = grid2 % neigh_list % nitems - grid1 % neigh_list % nitems
!---------------------------------------------------------------------------------------------------
end function compare_grid_degrees
!===================================================================================================
!
!===================================================================================================
function compare_colors ( grid1, grid2 ) result( res )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid), intent(in)    :: grid1
    type(Agrif_Grid), intent(in)    :: grid2
!
    integer     :: res
!
    res = grid1 % seq_num - grid2 % seq_num
!---------------------------------------------------------------------------------------------------
end function compare_colors
!===================================================================================================
!
!===================================================================================================
function compare_dsat_values ( grid1, grid2 ) result( res )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid), intent(in)    :: grid1
    type(Agrif_Grid), intent(in)    :: grid2
!
    integer     :: res
!
    res = grid2 % dsat - grid1 % dsat
!---------------------------------------------------------------------------------------------------
end function compare_dsat_values
!===================================================================================================
!
!===================================================================================================
function compare_size_values ( grid1, grid2 ) result( res )
!---------------------------------------------------------------------------------------------------
    type(Agrif_Grid), intent(in)    :: grid1
    type(Agrif_Grid), intent(in)    :: grid2
!
    integer     :: res
!
    res = grid2 % size - grid1 % size
!---------------------------------------------------------------------------------------------------
end function compare_size_values
!===================================================================================================
!
end module Agrif_Grids