FMS  2025.04
Flexible Modeling System
block_control.F90
1 !***********************************************************************
2 !* Apache License 2.0
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* Licensed under the Apache License, Version 2.0 (the "License");
7 !* you may not use this file except in compliance with the License.
8 !* You may obtain a copy of the License at
9 !*
10 !* http://www.apache.org/licenses/LICENSE-2.0
11 !*
12 !* FMS is distributed in the hope that it will be useful, but WITHOUT
13 !* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
14 !* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
15 !* PARTICULAR PURPOSE. See the License for the specific language
16 !* governing permissions and limitations under the License.
17 !***********************************************************************
18 !> @defgroup block_control_mod block_control_mod
19 !> @ingroup block_control
20 !> @brief Routines for "blocks" used for OpenMP threading of column-based
21 !! calculations
22 
23 module block_control_mod
24 
25 use mpp_mod, only: mpp_error, note, warning, fatal, mpp_sum, mpp_npes
26 use mpp_domains_mod, only: mpp_compute_extent
27 use fms_string_utils_mod, only: string
28 implicit none
29 
30 public block_control_type
31 
32 !> Type to dereference packed index from global index.
33 !> @ingroup block_control_mod
34 type :: ix_type
35  integer, dimension(:,:), allocatable :: ix
36 end type ix_type
37 
38 !> Type to dereference packed index from global indices.
39 !> @ingroup block_control_mod
40 type :: pk_type
41  integer, dimension(:), allocatable :: ii
42  integer, dimension(:), allocatable :: jj
43 end type pk_type
44 
45 !> @brief Block data and extents for OpenMP threading of column-based calculations
46 !> @ingroup block_control_mod
48  integer :: nx_block, ny_block !< blocking factor using mpp-style decomposition
49  integer :: nblks !< number of blocks cover MPI domain
50  integer :: isc, iec, jsc, jec !< MPI domain global extents
51  integer :: npz !< vertical extent
52  integer, dimension(:), allocatable :: ibs , & !< block extents for mpp-style
53  ibe , & !! decompositions
54  jbs , &
55  jbe
56  type(ix_type), dimension(:), allocatable :: ix !< dereference packed index from global index
57  !--- packed blocking fields
58  integer, dimension(:), allocatable :: blksz !< number of points in each individual block
59  !! blocks are not required to be uniforom in size
60  integer, dimension(:,:), allocatable :: blkno !< dereference block number using global indices
61  integer, dimension(:,:), allocatable :: ixp !< dereference packed index from global indices
62  !! must be used in conjuction with blkno
63  type(pk_type), dimension(:), allocatable :: index !< dereference global indices from
64  !! block/ixp combo
65 end type block_control_type
66 
67 !> @addtogroup block_control_mod
68 !> @{
69 
71 
72 contains
73 
74 !###############################################################################
75 !> @brief Sets up "blocks" used for OpenMP threading of column-based
76 !! calculations using rad_n[x/y]xblock from coupler_nml
77 !!
78  subroutine define_blocks (component, Block, isc, iec, jsc, jec, kpts, &
79  nx_block, ny_block, message)
80  character(len=*), intent(in) :: component !< Component name string
81  type(block_control_type), intent(inout) :: block !< Returns instantiated @ref block_control_type
82  integer, intent(in) :: isc, iec, jsc, jec, kpts
83  integer, intent(in) :: nx_block, ny_block
84  logical, intent(inout) :: message !< flag for outputting debug message
85 
86 !-------------------------------------------------------------------------------
87 ! Local variables:
88 ! blocks
89 ! i1
90 ! i2
91 ! j1
92 ! j2
93 ! text
94 ! i
95 ! j
96 ! nblks
97 ! ix
98 ! ii
99 ! jj
100 !-------------------------------------------------------------------------------
101 
102  integer :: blocks
103  integer, dimension(nx_block) :: i1, i2
104  integer, dimension(ny_block) :: j1, j2
105  character(len=256) :: text
106  integer :: i, j, nblks, ix, ii, jj
107  integer :: non_uniform_blocks !< Number of non uniform blocks
108 
109  if (message) then
110  non_uniform_blocks = 0
111  if ((mod(iec-isc+1,nx_block) .ne. 0) .or. (mod(jec-jsc+1,ny_block) .ne. 0)) then
112  non_uniform_blocks = 1
113  endif
114  call mpp_sum(non_uniform_blocks)
115  if (non_uniform_blocks > 0 ) then
116  call mpp_error(note, string(non_uniform_blocks)//" out of "//string(mpp_npes())//" total domains "//&
117  "have non-uniform blocks for block size ("//string(nx_block)//","//string(ny_block)//")")
118  message = .false.
119  endif
120  endif
121 
122 !--- set up blocks
123  if (iec-isc+1 .lt. nx_block) &
124  call mpp_error(fatal, 'block_control: number of '//trim(component)//.gt.' nxblocks &
125  &number of elements in MPI-domain size')
126  if (jec-jsc+1 .lt. ny_block) &
127  call mpp_error(fatal, 'block_control: number of '//trim(component)//.gt.' nyblocks &
128  &number of elements in MPI-domain size')
129  call mpp_compute_extent(isc,iec,nx_block,i1,i2)
130  call mpp_compute_extent(jsc,jec,ny_block,j1,j2)
131 
132  nblks = nx_block*ny_block
133  block%isc = isc
134  block%iec = iec
135  block%jsc = jsc
136  block%jec = jec
137  block%npz = kpts
138  block%nx_block = nx_block
139  block%ny_block = ny_block
140  block%nblks = nblks
141 
142  if (.not.allocated(block%ibs)) &
143  allocate (block%ibs(nblks), &
144  block%ibe(nblks), &
145  block%jbs(nblks), &
146  block%jbe(nblks), &
147  block%ix(nblks) )
148 
149  blocks=0
150  do j = 1, ny_block
151  do i = 1, nx_block
152  blocks = blocks + 1
153  block%ibs(blocks) = i1(i)
154  block%jbs(blocks) = j1(j)
155  block%ibe(blocks) = i2(i)
156  block%jbe(blocks) = j2(j)
157  allocate(block%ix(blocks)%ix(i1(i):i2(i),j1(j):j2(j)) )
158  ix = 0
159  do jj = j1(j), j2(j)
160  do ii = i1(i), i2(i)
161  ix = ix+1
162  block%ix(blocks)%ix(ii,jj) = ix
163  enddo
164  enddo
165  enddo
166  enddo
167 
168  end subroutine define_blocks
169 
170 
171 
172 !###############################################################################
173 !> @brief Creates and populates a data type which is used for defining the
174 !! sub-blocks of the MPI-domain to enhance OpenMP and memory performance.
175 !! Uses a packed concept.
176 !!
177  subroutine define_blocks_packed (component, Block, isc, iec, jsc, jec, &
178  kpts, blksz, message)
179  character(len=*), intent(in) :: component !< Component name string
180  type(block_control_type), intent(inout) :: block !< Returns instantiated @ref block_control_type
181  integer, intent(in) :: isc, iec, jsc, jec, kpts
182  integer, intent(inout) :: blksz !< block size
183  logical, intent(inout) :: message !< flag for outputting debug message
184 
185 !-------------------------------------------------------------------------------
186 ! Local variables:
187 ! nblks
188 ! lblksz
189 ! tot_pts
190 ! nb
191 ! ix
192 ! ii
193 ! jj
194 ! text
195 !-------------------------------------------------------------------------------
196 
197  integer :: nblks, lblksz, tot_pts, nb, ix, ii, jj
198  character(len=256) :: text
199 
200  tot_pts = (iec - isc + 1) * (jec - jsc + 1)
201  if (blksz < 0) then
202  nblks = 1
203  blksz = tot_pts
204  else
205  nblks = tot_pts/blksz
206  if (mod(tot_pts,blksz) .gt. 0) then
207  nblks = nblks + 1
208  endif
209  endif
210 
211  if (message) then
212  if (mod(tot_pts,blksz) .ne. 0) then
213  write( text,'(a,a,2i4,a,i4,a,i4)' ) trim(component),'define_blocks_packed: domain (',&
214  (iec-isc+1), (jec-jsc+1),') is not an even divisor with definition (',&
215  blksz,') - blocks will not be uniform with a remainder of ',mod(tot_pts,blksz)
216  call mpp_error (warning, trim(text))
217  endif
218  message = .false.
219  endif
220 
221  block%isc = isc
222  block%iec = iec
223  block%jsc = jsc
224  block%jec = jec
225  block%npz = kpts
226  block%nblks = nblks
227  if (.not. allocated(block%blksz)) &
228  allocate (block%blksz(nblks), &
229  block%index(nblks), &
230  block%blkno(isc:iec,jsc:jec), &
231  block%ixp(isc:iec,jsc:jec))
232 
233 !--- set up blocks
234  do nb = 1, nblks
235  lblksz = blksz
236  if (nb .EQ. nblks) lblksz = tot_pts - (nb-1) * blksz
237  block%blksz(nb) = lblksz
238  allocate (block%index(nb)%ii(lblksz), &
239  block%index(nb)%jj(lblksz))
240  enddo
241 
242 !--- set up packed indices
243  nb = 1
244  ix = 0
245  do jj = jsc, jec
246  do ii = isc, iec
247  ix = ix + 1
248  if (ix .GT. blksz) then
249  ix = 1
250  nb = nb + 1
251  endif
252  block%ixp(ii,jj) = ix
253  block%blkno(ii,jj) = nb
254  block%index(nb)%ii(ix) = ii
255  block%index(nb)%jj(ix) = jj
256  enddo
257  enddo
258 
259  end subroutine define_blocks_packed
260 
261 end module block_control_mod
262 !> @}
263 ! close documentation grouping
subroutine, public define_blocks_packed(component, Block, isc, iec, jsc, jec, kpts, blksz, message)
Creates and populates a data type which is used for defining the sub-blocks of the MPI-domain to enha...
subroutine, public define_blocks(component, Block, isc, iec, jsc, jec, kpts, nx_block, ny_block, message)
Sets up "blocks" used for OpenMP threading of column-based calculations using rad_n[x/y]xblock from c...
Block data and extents for OpenMP threading of column-based calculations.
Type to dereference packed index from global index.
Type to dereference packed index from global indices.
character(:) function, allocatable, public string(v, fmt)
Converts a number or a Boolean value to a string.
subroutine mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
Computes extents for a grid decomposition with the given indices and divisions.
integer function mpp_npes()
Returns processor count for current pelist.
Definition: mpp_util.inc:420
Error handler.
Definition: mpp.F90:381
Reduction operation.
Definition: mpp.F90:596