1 !***********************************************************************
2 !* GNU Lesser General Public License
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
6 !* FMS is free software: you can redistribute it and/or modify it under
7 !* the terms of the GNU Lesser General Public License as published by
8 !* the Free Software Foundation, either version 3 of the License, or (at
9 !* your option) any later version.
11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 !* You should have received a copy of the GNU Lesser General Public
17 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18 !***********************************************************************
19 !> @defgroup block_control_mod block_control_mod
20 !> @ingroup block_control
21 !> @brief Routines for "blocks" used for OpenMP threading of column-based
24 module block_control_mod
26 use mpp_mod, only: mpp_error, NOTE, WARNING, FATAL
27 use mpp_domains_mod, only: mpp_compute_extent
30 public block_control_type
32 !> Type to dereference packed index from global index.
33 !> @ingroup block_control_mod
35 integer, dimension(:,:), allocatable :: ix
38 !> Type to dereference packed index from global indices.
39 !> @ingroup block_control_mod
41 integer, dimension(:), allocatable :: ii
42 integer, dimension(:), allocatable :: jj
45 !> @brief Block data and extents for OpenMP threading of column-based calculations
46 !> @ingroup block_control_mod
47 type :: block_control_type
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
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
65 end type block_control_type
67 !> @addtogroup block_control_mod
70 public :: define_blocks, define_blocks_packed
74 !###############################################################################
75 !> @brief Sets up "blocks" used for OpenMP threading of column-based
76 !! calculations using rad_n[x/y]xblock from coupler_nml
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
86 !-------------------------------------------------------------------------------
100 !-------------------------------------------------------------------------------
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
109 if ((mod(iec-isc+1,nx_block) .ne. 0) .or. (mod(jec-jsc+1,ny_block) .ne. 0)) then
110 write( text,'(a,a,2i4,a,2i4,a)' ) trim(component),'define_blocks: domain (',&
111 (iec-isc+1), (jec-jsc+1),') is not an even divisor with definition (',&
112 nx_block, ny_block,') - blocks will not be uniform'
113 call mpp_error (WARNING, trim(text))
119 if (iec-isc+1 .lt. nx_block) &
120 call mpp_error(FATAL, 'block_control: number of '//trim(component)//' nxblocks .gt. &
121 &number of elements in MPI-domain size')
122 if (jec-jsc+1 .lt. ny_block) &
123 call mpp_error(FATAL, 'block_control: number of '//trim(component)//' nyblocks .gt. &
124 &number of elements in MPI-domain size')
125 call mpp_compute_extent(isc,iec,nx_block,i1,i2)
126 call mpp_compute_extent(jsc,jec,ny_block,j1,j2)
128 nblks = nx_block*ny_block
134 Block%nx_block = nx_block
135 Block%ny_block = ny_block
138 if (.not.allocated(Block%ibs)) &
139 allocate (Block%ibs(nblks), &
149 Block%ibs(blocks) = i1(i)
150 Block%jbs(blocks) = j1(j)
151 Block%ibe(blocks) = i2(i)
152 Block%jbe(blocks) = j2(j)
153 allocate(Block%ix(blocks)%ix(i1(i):i2(i),j1(j):j2(j)) )
158 Block%ix(blocks)%ix(ii,jj) = ix
164 end subroutine define_blocks
168 !###############################################################################
169 !> @brief Creates and populates a data type which is used for defining the
170 !! sub-blocks of the MPI-domain to enhance OpenMP and memory performance.
171 !! Uses a packed concept.
173 subroutine define_blocks_packed (component, Block, isc, iec, jsc, jec, &
174 kpts, blksz, message)
175 character(len=*), intent(in) :: component !< Component name string
176 type(block_control_type), intent(inout) :: Block !< Returns instantiated @ref block_control_type
177 integer, intent(in) :: isc, iec, jsc, jec, kpts
178 integer, intent(inout) :: blksz !< block size
179 logical, intent(inout) :: message !< flag for outputting debug message
181 !-------------------------------------------------------------------------------
191 !-------------------------------------------------------------------------------
193 integer :: nblks, lblksz, tot_pts, nb, ix, ii, jj
194 character(len=256) :: text
196 tot_pts = (iec - isc + 1) * (jec - jsc + 1)
201 nblks = tot_pts/blksz
202 if (mod(tot_pts,blksz) .gt. 0) then
208 if (mod(tot_pts,blksz) .ne. 0) then
209 write( text,'(a,a,2i4,a,i4,a,i4)' ) trim(component),'define_blocks_packed: domain (',&
210 (iec-isc+1), (jec-jsc+1),') is not an even divisor with definition (',&
211 blksz,') - blocks will not be uniform with a remainder of ',mod(tot_pts,blksz)
212 call mpp_error (WARNING, trim(text))
223 if (.not. allocated(Block%blksz)) &
224 allocate (Block%blksz(nblks), &
225 Block%index(nblks), &
226 Block%blkno(isc:iec,jsc:jec), &
227 Block%ixp(isc:iec,jsc:jec))
232 if (nb .EQ. nblks) lblksz = tot_pts - (nb-1) * blksz
233 Block%blksz(nb) = lblksz
234 allocate (Block%index(nb)%ii(lblksz), &
235 Block%index(nb)%jj(lblksz))
238 !--- set up packed indices
244 if (ix .GT. blksz) then
248 Block%ixp(ii,jj) = ix
249 Block%blkno(ii,jj) = nb
250 Block%index(nb)%ii(ix) = ii
251 Block%index(nb)%jj(ix) = jj
255 end subroutine define_blocks_packed
257 end module block_control_mod
259 ! close documentation grouping