!> @file shared_memory_io_mod.f90 !--------------------------------------------------------------------------------------------------! ! This file is part of the PALM model system. ! ! 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 4591 2020-07-06 15:56:08Z suehring $ ! ! File re-formatted to follow the PALM coding standard ! ! ! ! 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, & message_string, & mg_switch_to_pe0_level USE indices, & ONLY: nbgp, & nnx, & nny, & nnz, & nx, & nxl, & nxlg, & nxr, & nxrg, & ny, & nyn, & nyng, & nys, & nysg, & nzb, & nzt USE kinds, & ONLY: iwp, & wp USE transpose_indices, & ONLY: nxl_z, & nxr_z, & nyn_x, & nyn_z, & nys_x, & nys_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) :: nnx !< INTEGER(iwp) :: nny !< INTEGER(iwp) :: nx !< INTEGER(iwp) :: nxl !< INTEGER(iwp) :: nxr !< INTEGER(iwp) :: ny !< INTEGER(iwp) :: nyn !< INTEGER(iwp) :: nys !< 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) :: my_color !< INTEGER(iwp) :: n !< 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 !< ! !-- No shared memory I/O on one node jobs IF ( numprocs < this%n_npes ) THEN this%no_shared_memory_in_this_run = .TRUE. RETURN 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 this%io_grid = node_grid(color) this%io_grid%nnx = this%io_grid%nxr - this%io_grid%nxl + 1 this%io_grid%nny = this%io_grid%nyn - this%io_grid%nys + 1 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