!> @file shared_memory_io_mod.f90 !------------------------------------------------------------------------------! ! This file is part of PALM. ! ! PALM is free software: you can redistribute it and/or modify it under the ! terms of the GNU General Public License as published by the Free Software ! Foundation, either version 3 of the License, or (at your option) any later ! version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License along with ! PALM. If not, see . ! ! Copyright 1997-2020 Leibniz Universitaet Hannover !------------------------------------------------------------------------------! ! ! Current revisions: ! ----------------- ! ! ! Former revisions: ! $Id: shared_memory_io_mod.f90 4534 2020-05-14 18:35:22Z raasch $ ! ! Initial version (Klaus Ketelsen) ! ! ! ! Description: ! ------------ !> handle MPI-IO or NetCDF-IO shared memory arrays. !> This module performs the organization of new communicators, adapted PE-grids !> and allocation of shared memory arrays. The IO itself is not done here. !------------------------------------------------------------------------------! MODULE shared_memory_io_mod #if defined( __parallel ) #if defined( __mpifh ) INCLUDE "mpif.h" #else USE MPI #endif #endif USE, INTRINSIC :: ISO_C_BINDING USE control_parameters, & ONLY: maximum_grid_level, mg_switch_to_pe0_level, message_string USE indices, & ONLY: nbgp, nnx, nny, nnz, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, nzt USE kinds, & ONLY: wp, iwp USE transpose_indices, & ONLY: nys_x, nyn_x, nys_z, nyn_z, nxl_z, nxr_z USE pegrid, & ONLY: comm1dx, comm1dy, comm2d, ierr, myid, myidx, myidy, npex, npey, numprocs, pdims, & pleft, pnorth, pright, psouth, sendrecvcount_xy #if defined( __parallel ) USE pegrid, & ONLY: pcoord, reorder #endif IMPLICIT NONE PRIVATE SAVE ! !-- Type to store grid information TYPE, PUBLIC :: local_boundaries INTEGER(iwp) :: nxl INTEGER(iwp) :: nxr INTEGER(iwp) :: nys INTEGER(iwp) :: nyn INTEGER(iwp) :: nnx INTEGER(iwp) :: nny INTEGER(iwp) :: nx INTEGER(iwp) :: ny END TYPE local_boundaries ! !-- Class definition for shared memory instances. !-- For every use of shared memory IO, one instance of this class is created. TYPE, PUBLIC :: sm_class INTEGER(iwp) :: nr_io_pe_per_node = 2 !< typical configuration, 2 sockets per node LOGICAL :: no_shared_Memory_in_this_run ! !-- Variables for the shared memory communicator INTEGER(iwp), PUBLIC :: comm_shared !< Communicator for processes with shared array INTEGER(iwp), PUBLIC :: sh_npes INTEGER(iwp), PUBLIC :: sh_rank LOGICAL, PUBLIC :: iam_io_pe = .TRUE. !< This PE is an IO-PE ! !-- Variables for the I/O virtual grid INTEGER(iwp), PUBLIC :: comm_io !< Communicator for all IO processes INTEGER(iwp), PUBLIC :: io_npes INTEGER(iwp), PUBLIC :: io_rank TYPE( local_boundaries ), PUBLIC :: io_grid ! !-- Variables for the node local communicator INTEGER(iwp) :: comm_node !< Communicator for all processes of current node INTEGER(iwp) :: io_pe_global_rank INTEGER(iwp) :: n_npes INTEGER(iwp) :: n_rank CONTAINS PRIVATE PROCEDURE, PASS(this), PUBLIC :: is_sm_active PROCEDURE, PASS(this), PUBLIC :: sm_adjust_outer_boundary PROCEDURE, PASS(this), PUBLIC :: sm_free_shared PROCEDURE, PASS(this), PUBLIC :: sm_init_comm PROCEDURE, PASS(this), PUBLIC :: sm_node_barrier #if defined( __parallel ) PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_1d PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_2d PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_2di PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_3d GENERIC, PUBLIC :: sm_allocate_shared => sm_allocate_shared_1d, sm_allocate_shared_2d, & sm_allocate_shared_2di, sm_allocate_shared_3d #endif END TYPE sm_class CONTAINS !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Create the communicator for shared memory groups and IO-PEs. !> Setup the grid for shared memory IO. !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_init_comm( this, sm_active ) IMPLICIT NONE CLASS(sm_class), INTENT(INOUT) :: this !< pointer to access internal variables of this call #if defined( __parallel ) INTEGER :: color INTEGER :: max_n_npes !< Maximum number of PEs/node #endif LOGICAL, INTENT(IN) :: sm_active !< Flag to activate shared-memory IO this%no_shared_memory_in_this_run = .NOT. sm_active IF ( this%no_shared_memory_in_this_run ) THEN this%iam_io_pe = .TRUE. RETURN ENDIF #if defined( __parallel ) ! !-- Determine, how many MPI threads are running on a node this%iam_io_pe = .FALSE. CALL MPI_COMM_SPLIT_TYPE( comm2d, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, this%comm_node, ierr ) CALL MPI_COMM_SIZE( this%comm_node, this%n_npes, ierr ) CALL MPI_COMM_RANK( this%comm_node, this%n_rank, ierr ) CALL MPI_ALLREDUCE( this%n_npes, max_n_npes, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) ! !-- Decide, if the configuration can run with shared-memory IO IF ( max_n_npes > 64 ) THEN ! !-- Special configuration on the HLRN-IV system with 4 shared memory blocks/node this%nr_io_pe_per_node = 4 ELSEIF ( max_n_npes <= 32 ) THEN ! !-- No shared memory IO with less than 32 threads/node this%no_shared_memory_in_this_run = .TRUE. this%iam_io_pe = .TRUE. RETURN ENDIF ! !-- No shared memory IO with small setups IF ( nx < 24 .OR. ny < 24 ) THEN this%no_shared_memory_in_this_run = .TRUE. this%iam_io_pe = .TRUE. RETURN ENDIF ! !-- Divide a node into shared memory groups, depending on the virtual x-y grid CALL compute_color( color ) ! !-- If no shared memory IO possible, nothing is left to be done here. IF ( this%no_shared_memory_in_this_run ) RETURN ! !-- Setup the shared memory area CALL MPI_COMM_SPLIT( this%comm_node, color, 0, this%comm_shared, ierr ) CALL MPI_COMM_SIZE( this%comm_shared, this%sh_npes, ierr ) CALL MPI_COMM_RANK( this%comm_shared, this%sh_rank, ierr ) ! !-- Setup the communicator across the nodes depending on the shared memory rank. !-- All threads with shared memory rank 0 will be I/O threads. color = this%sh_rank CALL MPI_COMM_SPLIT( comm2d, color, 0, this%comm_io, ierr ) IF ( this%comm_io /= MPI_COMM_NULL ) THEN CALL MPI_COMM_SIZE( this%comm_io, this%io_npes, ierr ) CALL MPI_COMM_RANK( this%comm_io, this%io_rank, ierr ) ELSE this%io_npes = -1 this%io_rank = -1 ENDIF IF ( this%sh_rank == 0 ) THEN this%iam_io_pe = .TRUE. this%io_pe_global_rank = myid ENDIF CALL MPI_BCAST( this%io_pe_global_rank, 1, MPI_INTEGER, 0, this%comm_shared, ierr ) #else this%iam_io_pe = .TRUE. #endif #if defined( __parallel ) CONTAINS SUBROUTINE compute_color( color ) IMPLICIT NONE INTEGER(iwp), INTENT(OUT) :: color INTEGER(iwp) :: group_start INTEGER(iwp) :: n INTEGER(iwp) :: my_color INTEGER(iwp) :: pe INTEGER(iwp) :: sh_group_size INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) :: local_dim_s INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) :: local_dim_r TYPE(local_boundaries), DIMENSION(32) :: node_grid #if defined( __intel_compiler ) IF ( numprocs < this%n_npes ) THEN ! NO shared memory IO on one node jobs this%no_shared_Memory_in_this_run = .TRUE. RETURN ENDIF #endif local_dim_s = 0 local_dim_s(1,this%n_rank) = nxl local_dim_s(2,this%n_rank) = nxr local_dim_s(3,this%n_rank) = nys local_dim_s(4,this%n_rank) = nyn node_grid%nyn = -1 ! !-- Distribute the x-y layout of all cores of a node to all node processes CALL MPI_ALLREDUCE( local_dim_s, local_dim_r, SIZE( local_dim_s ), MPI_INTEGER, MPI_SUM, & this%comm_node, ierr ) sh_group_size = ( max_n_npes + this%nr_io_pe_per_node - 1 ) / this%nr_io_pe_per_node pe = 0 my_color = 1 ! color is used to split the shared memory communicator into a communicator for ! io groups group_start = pe node_grid(my_color)%nxl = local_dim_r(1,group_start) node_grid(my_color)%nxr = local_dim_r(2,group_start) node_grid(my_color)%nys = local_dim_r(3,group_start) DO n = 1, this%n_npes-1 pe = n IF ( n > 0 .AND. MOD( n,sh_group_size ) == 0 ) THEN ! !-- If group boundary, start new IO group node_grid(my_color)%nyn = local_dim_r(4,pe-1) my_color = my_color + 1 group_start = pe node_grid(my_color)%nxl = local_dim_r(1,group_start) node_grid(my_color)%nxr = local_dim_r(2,group_start) node_grid(my_color)%nys = local_dim_r(3,group_start) ELSEIF ( local_dim_r(1,pe) /= node_grid(my_color)%nxl ) THEN ! !-- If nxl changes, start new IO group node_grid(my_color)%nyn = local_dim_r(4,pe-1) my_color = my_color+1 group_start = pe node_grid(my_color)%nxl = local_dim_r(1,group_start) node_grid(my_color)%nxr = local_dim_r(2,group_start) node_grid(my_color)%nys = local_dim_r(3,group_start) ENDIF ! !-- Save values for local PE IF ( this%n_rank == pe ) THEN ! color = my_color ENDIF IF ( n == this%n_npes-1 ) node_grid(my_color)%nyn = local_dim_r(4,pe) ENDDO IF ( this%n_rank == 0 ) THEN color = 1 ENDIF END SUBROUTINE compute_color #endif END SUBROUTINE sm_init_comm !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Function to return if shared Memory IO is active. !--------------------------------------------------------------------------------------------------! FUNCTION is_sm_active( this) RESULT( ac ) IMPLICIT NONE CLASS(sm_class), INTENT(inout) :: this LOGICAL :: ac ac = .NOT. this%no_shared_memory_in_this_run END FUNCTION is_sm_active #if defined( __parallel ) !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Allocate shared 1d-REAL array on ALL threads !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_allocate_shared_1d( this, p1, d1, d2, win ) IMPLICIT NONE CLASS(sm_class), INTENT(inout) :: this INTEGER(iwp) :: disp_unit INTEGER(iwp), INTENT(IN) :: d1 INTEGER(iwp), INTENT(IN) :: d2 INTEGER(iwp), SAVE :: pe_from = 0 INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size INTEGER(iwp), INTENT(OUT) :: win INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize INTEGER, DIMENSION(1) :: buf_shape REAL(wp), DIMENSION(:), POINTER :: buf REAL(wp), DIMENSION(:), POINTER :: p1 TYPE(C_PTR), SAVE :: base_ptr TYPE(C_PTR), SAVE :: rem_ptr IF ( this%no_shared_memory_in_this_run ) RETURN ! !-- Allocate shared memory on node rank 0 threads. IF ( this%sh_rank == pe_from ) THEN wsize = d2 - d1 + 1 ELSE wsize = 1 ENDIF wsize = wsize * 8 ! Please note, size is always in bytes, independently of the displacement ! unit CALL MPI_WIN_ALLOCATE_SHARED( wsize, 8, MPI_INFO_NULL, this%comm_shared,base_ptr, win, ierr ) ! !-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from) CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr ) ! !-- Convert C- to Fortran-pointer buf_shape(1) = d2 - d1 + 1 CALL C_F_POINTER( rem_ptr, buf, buf_shape ) p1(d1:) => buf ! !-- Allocate shared memory in round robin on all PEs of a node. pe_from = MOD( pe_from, this%sh_npes ) END SUBROUTINE sm_allocate_shared_1d !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Allocate shared 2d-REAL array on ALL threads !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_allocate_shared_2d( this, p2, n_nxlg, n_nxrg, n_nysg, n_nyng, win ) IMPLICIT NONE CLASS(sm_class), INTENT(INOUT) :: this INTEGER(iwp) :: disp_unit INTEGER(iwp), INTENT(IN) :: n_nxlg INTEGER(iwp), INTENT(IN) :: n_nxrg INTEGER(iwp), INTENT(IN) :: n_nyng INTEGER(iwp), INTENT(IN) :: n_nysg INTEGER(iwp), SAVE :: pe_from = 0 INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size INTEGER(iwp), INTENT(OUT) :: win INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize INTEGER(iwp), DIMENSION(2) :: buf_shape REAL(wp), DIMENSION(:,:), POINTER :: buf REAL(wp), DIMENSION(:,:), POINTER :: p2 TYPE(C_PTR),SAVE :: base_ptr TYPE(C_PTR),SAVE :: rem_ptr IF ( this%no_shared_memory_in_this_run ) RETURN ! !-- Allocate shared memory on node rank 0 threads. IF ( this%sh_rank == pe_from ) THEN wsize = ( n_nyng - n_nysg + 1 ) * ( n_nxrg - n_nxlg + 1 ) ELSE wsize = 1 ENDIF wsize = wsize * 8 ! Please note, size is always in bytes, independently of the displacement ! unit CALL MPI_WIN_ALLOCATE_SHARED( wsize, 8, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr ) ! !-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from) CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr ) ! !-- Convert C- to Fortran-pointer buf_shape(2) = n_nyng - n_nysg + 1 buf_shape(1) = n_nxrg - n_nxlg + 1 CALL C_F_POINTER( rem_ptr, buf, buf_shape ) p2(n_nxlg:, n_nysg:) => buf ! !-- Allocate shared memory in round robin on all PEs of a node. pe_from = MOD( pe_from, this%sh_npes ) END SUBROUTINE sm_allocate_shared_2d !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Allocate shared 2d-INTEGER array on ALL threads !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_allocate_shared_2di( this, p2i, n_nxlg, n_nxrg, n_nysg, n_nyng, win ) IMPLICIT NONE CLASS(sm_class), INTENT(inout) :: this INTEGER(iwp) :: disp_unit INTEGER(iwp), INTENT(IN) :: n_nxlg INTEGER(iwp), INTENT(IN) :: n_nxrg INTEGER(iwp), INTENT(IN) :: n_nyng INTEGER(iwp), INTENT(IN) :: n_nysg INTEGER(iwp), SAVE :: pe_from = 0 INTEGER(kind=MPI_ADDRESS_KIND) :: rem_size INTEGER(iwp), INTENT(OUT) :: win INTEGER(kind=MPI_ADDRESS_KIND) :: wsize INTEGER(iwp), DIMENSION(2) :: buf_shape INTEGER(iwp), DIMENSION(:,:), POINTER :: buf INTEGER(iwp), DIMENSION(:,:), POINTER :: p2i TYPE(C_PTR),SAVE :: base_ptr TYPE(C_PTR),SAVE :: rem_ptr IF ( this%no_shared_memory_in_this_run ) RETURN ! !-- Allocate shared memory on node rank 0 threads. IF ( this%sh_rank == pe_from ) THEN wsize = ( n_nyng - n_nysg + 1 ) * ( n_nxrg - n_nxlg + 1 ) ELSE wsize = 1 ENDIF wsize = wsize * 4 ! Please note, size is always in bytes, independently of the displacement ! unit CALL MPI_WIN_ALLOCATE_SHARED( wsize, 4, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr ) ! !-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from) CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr ) ! !-- Convert C- to Fortran-pointer buf_shape(2) = n_nyng - n_nysg + 1 buf_shape(1) = n_nxrg - n_nxlg + 1 CALL C_F_POINTER( rem_ptr, buf, buf_shape ) p2i(n_nxlg:, n_nysg:) => buf ! !-- Allocate shared memory in round robin on all PEs of a node. pe_from = MOD( pe_from, this%sh_npes ) END SUBROUTINE sm_allocate_shared_2di !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Allocate shared 3d-REAL array on ALL threads !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_allocate_shared_3d( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, win ) IMPLICIT NONE CLASS(sm_class), INTENT(inout) :: this INTEGER :: disp_unit INTEGER, INTENT(IN) :: d1e INTEGER, INTENT(IN) :: d1s INTEGER, INTENT(IN) :: d2e INTEGER, INTENT(IN) :: d2s INTEGER, INTENT(IN) :: d3e INTEGER, INTENT(IN) :: d3s INTEGER, SAVE :: pe_from = 0 INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size INTEGER, INTENT(OUT) :: win INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize INTEGER, DIMENSION(3) :: buf_shape REAL(wp), DIMENSION(:,:,:), POINTER :: buf REAL(wp), DIMENSION(:,:,:), POINTER :: p3 TYPE(C_PTR), SAVE :: base_ptr TYPE(C_PTR), SAVE :: rem_ptr IF ( this%no_shared_memory_in_this_run ) RETURN ! !-- Allocate shared memory on node rank 0 threads. IF ( this%sh_rank == pe_from ) THEN wsize = ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 ) ELSE wsize = 1 ENDIF wsize = wsize * 8 ! Please note, size is always in bytes, independently of the displacement ! unit CALL MPI_WIN_ALLOCATE_SHARED( wsize, 8, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr ) ! !-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from) CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr ) ! !-- Convert C- to Fortran-pointer buf_shape(3) = d3e - d3s + 1 buf_shape(2) = d2e - d2s + 1 buf_shape(1) = d1e - d1s + 1 CALL C_F_POINTER( rem_ptr, buf, buf_shape ) p3(d1s:,d2s:,d3s:) => buf ! !-- Allocate shared memory in round robin on all PEs of a node. pe_from = MOD( pe_from, this%sh_npes ) END SUBROUTINE sm_allocate_shared_3d #endif !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> ??? !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_adjust_outer_boundary( this ) IMPLICIT NONE CLASS(sm_class), INTENT(inout) :: this IF ( this%no_shared_memory_in_this_run ) RETURN IF ( this%io_grid%nxl == 0 ) THEN this%io_grid%nxl = this%io_grid%nxl - nbgp this%io_grid%nnx = this%io_grid%nnx + nbgp ENDIF IF ( this%io_grid%nxr == nx .OR. npex == -1 ) THEN ! npex == -1 if -D__parallel not set this%io_grid%nxr = this%io_grid%nxr + nbgp this%io_grid%nnx = this%io_grid%nnx + nbgp ENDIF IF ( this%io_grid%nys == 0 ) THEN this%io_grid%nys = this%io_grid%nys - nbgp this%io_grid%nny = this%io_grid%nny + nbgp ENDIF IF ( this%io_grid%nyn == ny .OR. npey == -1 ) THEN ! npey == -1 if -D__parallel not set this%io_grid%nyn = this%io_grid%nyn + nbgp this%io_grid%nny = this%io_grid%nny + nbgp ENDIF this%io_grid%nxl = this%io_grid%nxl + nbgp this%io_grid%nxr = this%io_grid%nxr + nbgp this%io_grid%nys = this%io_grid%nys + nbgp this%io_grid%nyn = this%io_grid%nyn + nbgp this%io_grid%nnx = this%io_grid%nnx this%io_grid%nny = this%io_grid%nny END SUBROUTINE sm_adjust_outer_boundary !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Deallocate shared aray and free related window. !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_free_shared( this, win ) IMPLICIT NONE CLASS(sm_class), INTENT(inout) :: this INTEGER(iwp), INTENT(INOUT) :: win IF ( this%no_shared_memory_in_this_run .OR. win == -1234567890 ) RETURN ! win is used just to avoid compile errors because of unused arguments #if defined( __parallel ) CALL MPI_WIN_FREE( win, ierr ) #endif END SUBROUTINE sm_free_shared !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> ... !--------------------------------------------------------------------------------------------------! SUBROUTINE sm_node_barrier( this ) IMPLICIT NONE CLASS(sm_class), INTENT(inout) :: this IF ( this%no_shared_memory_in_this_run ) RETURN #if defined( __parallel ) CALL MPI_BARRIER( this%comm_shared, ierr ) #endif END SUBROUTINE sm_node_barrier END MODULE shared_memory_io_mod