Line data Source code
1 : module subcol_pack_mod
2 : !---------------------------------------------------------------------------
3 : ! Purpose:
4 : !
5 : ! Provides utilities to pack and unpack subcolumns
6 : !
7 : !---------------------------------------------------------------------------
8 :
9 : use shr_kind_mod, only: r8=>shr_kind_r8, r4=>shr_kind_r4, i4=>shr_kind_i4
10 : use infnan, only: nan, assignment(=)
11 : use cam_abortutils, only: endrun
12 : use ppgrid, only: pcols, psubcols
13 : use pio, only: var_desc_t
14 :
15 : implicit none
16 :
17 : private
18 : save
19 :
20 : public :: subcol_unpack ! Unpack a subcolumn field
21 : public :: subcol_pack ! Pack a subcolumn field
22 : public :: subcol_get_nsubcol ! Copy chunk from nsubcol2d
23 : public :: subcol_set_nsubcol ! Copy chunk to nsubcol2d
24 : public :: subcol_get_indcol ! Copy chunk from indcol2d
25 : public :: subcol_pack_allocate ! Allocate subcol packing arrays
26 : public :: subcol_pack_init_restart
27 : public :: subcol_pack_write_restart
28 : public :: subcol_pack_read_restart
29 :
30 : !! Private variable to provide default packing and unpacking of fields
31 : !! for use in restart functionality. Allocated as (pcols, begchunk:endchunk)
32 : integer, target, allocatable :: nsubcol2d(:,:)
33 : integer, target, allocatable :: indcol2d(:,:)
34 :
35 : interface subcol_pack
36 : ! TYPE int,double,real
37 : ! DIMS 1,2,3,4,5,6
38 : module procedure subcol_pack_{DIMS}d_{TYPE}
39 : end interface subcol_pack
40 :
41 : interface subcol_unpack
42 : ! TYPE int,double,real
43 : ! DIMS 1,2,3,4,5,6
44 : module procedure subcol_unpack_{DIMS}d_{TYPE}
45 : end interface subcol_unpack
46 :
47 : type(var_desc_t) :: nsubcol_desc
48 :
49 : contains
50 :
51 768 : subroutine subcol_pack_allocate()
52 : use ppgrid, only: begchunk, endchunk
53 : !-----------------------------------------------------------------------
54 : ! Allocate nsubcol2d and indcol2d
55 : !-----------------------------------------------------------------------
56 768 : if (allocated(nsubcol2d)) then
57 0 : deallocate(nsubcol2d)
58 : end if
59 2304 : allocate(nsubcol2d(pcols, begchunk:endchunk))
60 53400 : nsubcol2d = 0
61 :
62 768 : if (allocated(indcol2d)) then
63 0 : deallocate(indcol2d)
64 : end if
65 2304 : allocate(indcol2d(pcols*psubcols, begchunk:endchunk))
66 53400 : indcol2d = 0
67 768 : end subroutine subcol_pack_allocate
68 :
69 0 : subroutine subcol_pack_init_restart(File, hdimids)
70 :
71 : use pio, only: file_desc_t, pio_int
72 : use cam_pio_utils, only: cam_pio_def_var
73 :
74 : ! Dummy arguments
75 : type(file_desc_t), intent(inout) :: File
76 : integer, intent(in) :: hdimids(:)
77 :
78 0 : call cam_pio_def_var(File, 'NSUBCOL2D', pio_int, hdimids, nsubcol_desc)
79 0 : end subroutine subcol_pack_init_restart
80 :
81 0 : subroutine subcol_pack_write_restart(File, grid_id, fdimlens)
82 0 : use cam_grid_support, only: cam_grid_write_dist_array
83 : use ppgrid, only: begchunk, endchunk
84 : use pio, only: file_desc_t
85 :
86 : ! Dummy argument
87 : type(file_desc_t), intent(inout) :: File
88 : integer, intent(in) :: grid_id
89 : integer, intent(in) :: fdimlens(:)
90 :
91 : ! Local variables
92 : integer :: adimlens(2)
93 : character(len=*), parameter :: subname = 'SUBCOL_PACK_WRITE_RESTART'
94 :
95 : ! Write nsubcol2d
96 0 : adimlens(1) = size(nsubcol2d, 1)
97 0 : adimlens(2) = endchunk - begchunk + 1
98 : call cam_grid_write_dist_array(File, grid_id, adimlens(1:2), &
99 0 : fdimlens(:), nsubcol2d, nsubcol_desc)
100 0 : end subroutine subcol_pack_write_restart
101 :
102 0 : subroutine subcol_pack_read_restart(File, grid_id, fdimlens)
103 0 : use pio, only: file_desc_t, pio_inq_varid
104 : use cam_pio_utils, only: cam_pio_handle_error
105 : use cam_grid_support, only: cam_grid_read_dist_array
106 : use ppgrid, only: begchunk, endchunk
107 : use phys_grid, only: get_ncols_p
108 :
109 : ! Dummy argument
110 : type(file_desc_t), intent(inout) :: File
111 : integer, intent(in) :: grid_id
112 : integer, intent(in) :: fdimlens(:)
113 :
114 : integer :: ierr, c
115 : integer :: adimlens(3)
116 : integer :: ncols
117 : character(len=*), parameter :: subname = 'SUBCOL_PACK_READ_RESTART'
118 :
119 : ! Array dimensions
120 0 : adimlens(1) = size(nsubcol2d, 1)
121 0 : adimlens(2) = endchunk - begchunk + 1
122 : ! Find nsubcol2d and read it in
123 0 : ierr = pio_inq_varid(File, 'NSUBCOL2D', nsubcol_desc)
124 0 : call cam_pio_handle_error(ierr, trim(subname)//': NSUBCOL2D not found')
125 : call cam_grid_read_dist_array(File, grid_id, adimlens(1:2), &
126 0 : fdimlens(:), nsubcol2d, nsubcol_desc)
127 :
128 :
129 : ! We need to update indcol2d so set nsubcol2d to itself
130 0 : do c = begchunk, endchunk
131 0 : ncols = get_ncols_p(c)
132 0 : if(ncols < pcols) nsubcol2d(ncols+1:pcols,:) = 0
133 0 : call subcol_set_nsubcol(c, pcols, nsubcol2d(:, c))
134 : end do
135 :
136 0 : end subroutine subcol_pack_read_restart
137 :
138 0 : subroutine subcol_get_nsubcol(lchnk, nsubcol)
139 : !-----------------------------------------------------------------------
140 : ! Retrieve a chunk from the nsubcol module variable
141 : !-----------------------------------------------------------------------
142 :
143 : integer, intent(in) :: lchnk
144 : integer, intent(out) :: nsubcol(:)
145 :
146 0 : if (.not. allocated(nsubcol2d)) then
147 0 : call endrun('subcol_get_nsubcol: nsubcol2d not allocated')
148 : end if
149 0 : nsubcol(:) = nsubcol2d(:,lchnk)
150 0 : end subroutine subcol_get_nsubcol
151 :
152 0 : subroutine subcol_get_indcol(lchnk, indcol)
153 : !-----------------------------------------------------------------------
154 : ! Retrieve a chunk from the nsubcol module variable
155 : !-----------------------------------------------------------------------
156 :
157 : integer, intent(in) :: lchnk
158 : integer, intent(out) :: indcol(:)
159 :
160 0 : if (.not. allocated(indcol2d)) then
161 0 : call endrun('subcol_get_indcol: indcol2d not allocated')
162 : end if
163 0 : indcol(:) = indcol2d(:,lchnk)
164 0 : end subroutine subcol_get_indcol
165 :
166 0 : subroutine subcol_set_nsubcol(lchnk, ngrdcol, nsubcol)
167 : use cam_logfile, only : iulog
168 : !-----------------------------------------------------------------------
169 : ! Set a chunk of the nsubcol module variable
170 : ! Also, recompute indcol for lchnk
171 : !-----------------------------------------------------------------------
172 :
173 : integer, intent(in) :: lchnk
174 : integer, intent(in) :: ngrdcol
175 : integer, intent(in) :: nsubcol(:)
176 :
177 : integer :: i, j, indx
178 :
179 0 : if (any(nsubcol(:) > psubcols)) then
180 0 : write(iulog, *) __FILE__,__LINE__,psubcols, nsubcol
181 0 : call endrun('subcol_set_nsubcol: psubcols not set large enough to hold the number of subcolumns requested')
182 : end if
183 0 : if (any(nsubcol(:) < 0)) then
184 0 : call endrun('subcol_set_nsubcol: nsubcols must be non-negative')
185 : end if
186 0 : if (ngrdcol < pcols) then
187 0 : if (any(nsubcol(ngrdcol+1:) > 0)) then
188 0 : call endrun('subcol_set_nsubcol: Cannot set subcolumns for columns past ngrdcol')
189 : end if
190 : end if
191 0 : nsubcol2d(:, lchnk) = nsubcol(:)
192 : ! Recalculate indcol for the chunk
193 : indx = 1
194 0 : do i = 1, pcols
195 0 : do j = 1, nsubcol2d(i, lchnk)
196 0 : indcol2d(indx, lchnk) = i
197 0 : indx = indx + 1
198 : end do
199 : end do
200 : ! Fill with zeros
201 0 : if (indx <= pcols * psubcols) then
202 0 : indcol2d(indx:pcols*psubcols, lchnk) = 0
203 : end if
204 0 : end subroutine subcol_set_nsubcol
205 :
206 : ! TYPE int,double,real
207 : ! DIMS 1,2,3,4,5,6
208 0 : subroutine subcol_pack_{DIMS}d_{TYPE}(lchnk, field, field_sc)
209 : !-----------------------------------------------------------------------
210 : ! Pack the field defined on (pcols, psubcols, *) into (pcols*psubcols, *)
211 : ! Packing is done accoding to the values in the proper chunk from nsubcol2d
212 : !-----------------------------------------------------------------------
213 :
214 : integer, intent(in) :: lchnk ! Chunk index
215 : #if ({DIMS} == 1)
216 : {VTYPE}, intent(in) :: field(:,:) ! grid
217 : #elif ({DIMS} == 2)
218 : {VTYPE}, intent(in) :: field(:,:,:) ! grid
219 : #elif ({DIMS} == 3)
220 : {VTYPE}, intent(in) :: field(:,:,:,:) ! grid
221 : #elif ({DIMS} == 4)
222 : {VTYPE}, intent(in) :: field(:,:,:,:,:) ! grid
223 : #elif ({DIMS} == 5)
224 : {VTYPE}, intent(in) :: field(:,:,:,:,:,:) ! grid
225 : #elif ({DIMS} == 6)
226 : {VTYPE}, intent(in) :: field(:,:,:,:,:,:,:) ! grid
227 : #endif
228 : {VTYPE}, intent(out) :: field_sc{DIMSTR} ! subcols
229 :
230 : !
231 : ! Local variables
232 : !
233 : integer :: indx, i, j
234 : integer :: nsubcol(pcols)
235 :
236 0 : call subcol_get_nsubcol(lchnk, nsubcol)
237 0 : indx = 1
238 0 : do i=1, pcols
239 0 : do j = 1, nsubcol(i)
240 : #if ({DIMS} == 1)
241 0 : field_sc(indx) = field(i, j)
242 : #elif ({DIMS} == 2)
243 0 : field_sc(indx, :) = field(i, j, :)
244 : #elif ({DIMS} == 3)
245 0 : field_sc(indx, :, :) = field(i, j, :, :)
246 : #elif ({DIMS} == 4)
247 0 : field_sc(indx, :, :, :) = field(i, j, :, :, :)
248 : #elif ({DIMS} == 5)
249 0 : field_sc(indx, :, :, :, :) = field(i, j, :, :, :, :)
250 : #elif ({DIMS} == 6)
251 0 : field_sc(indx, :, :, :, :, :) = field(i, j, :, :, :, :, :)
252 : #endif
253 0 : indx = indx + 1
254 : end do
255 : end do
256 0 : end subroutine subcol_pack_{DIMS}d_{TYPE}
257 :
258 : ! TYPE int,double,real
259 : ! DIMS 1,2,3,4,5,6
260 0 : subroutine subcol_unpack_{DIMS}d_{TYPE}(lchnk, field_sc, field, fillvalue)
261 : !-----------------------------------------------------------------------
262 : ! UnPack the field defined on (pcols*psubcols, *) into (pcols, psubcols, *)
263 : ! Unpacking is done accoding to the values in the proper chunk from nsubcol2d
264 : ! If fillvalue is present, unused entries in field are set.
265 : ! NB: The output field is not initialized, if fillvalue is not passed, it
266 : ! will end up with undefined values for columns where nsubcol < psubcols
267 : !-----------------------------------------------------------------------
268 :
269 : integer, intent(in) :: lchnk ! Chunk index
270 : {VTYPE}, intent(in) :: field_sc{DIMSTR} ! subcols
271 : #if ({DIMS} == 1)
272 : {VTYPE}, intent(out) :: field(:,:) ! grid
273 : #elif ({DIMS} == 2)
274 : {VTYPE}, intent(out) :: field(:,:,:) ! grid
275 : #elif ({DIMS} == 3)
276 : {VTYPE}, intent(out) :: field(:,:,:,:) ! grid
277 : #elif ({DIMS} == 4)
278 : {VTYPE}, intent(out) :: field(:,:,:,:,:) ! grid
279 : #elif ({DIMS} == 5)
280 : {VTYPE}, intent(out) :: field(:,:,:,:,:,:) ! grid
281 : #elif ({DIMS} == 6)
282 : {VTYPE}, intent(out) :: field(:,:,:,:,:,:,:) ! grid
283 : #endif
284 : {VTYPE}, intent(in), optional :: fillvalue ! fil
285 :
286 : !
287 : ! Local variables
288 : !
289 : integer :: indx, i, j
290 : integer :: nsubcol(pcols)
291 :
292 0 : call subcol_get_nsubcol(lchnk, nsubcol)
293 0 : indx = 1
294 0 : do i=1, pcols
295 0 : do j = 1, nsubcol(i)
296 : #if ({DIMS} == 1)
297 0 : field(i, j) = field_sc(indx)
298 : #elif ({DIMS} == 2)
299 0 : field(i, j, :) = field_sc(indx, :)
300 : #elif ({DIMS} == 3)
301 0 : field(i, j, :, :) = field_sc(indx, :, :)
302 : #elif ({DIMS} == 4)
303 0 : field(i, j, :, :, :) = field_sc(indx, :, :, :)
304 : #elif ({DIMS} == 5)
305 0 : field(i, j, :, :, :, :) = field_sc(indx, :, :, :, :)
306 : #elif ({DIMS} == 6)
307 0 : field(i, j, :, :, :, :, :) = field_sc(indx, :, :, :, :, :)
308 : #endif
309 0 : indx = indx + 1
310 : end do
311 0 : if (present(fillvalue)) then
312 0 : do j = nsubcol(i) + 1, psubcols
313 : #if ({DIMS} == 1)
314 0 : field(i, j) = fillvalue
315 : #elif ({DIMS} == 2)
316 0 : field(i, j, :) = fillvalue
317 : #elif ({DIMS} == 3)
318 0 : field(i, j, :, :) = fillvalue
319 : #elif ({DIMS} == 4)
320 0 : field(i, j, :, :, :) = fillvalue
321 : #elif ({DIMS} == 5)
322 0 : field(i, j, :, :, :, :) = fillvalue
323 : #elif ({DIMS} == 6)
324 0 : field(i, j, :, :, :, :, :) = fillvalue
325 : #endif
326 : end do
327 : end if
328 : end do
329 0 : end subroutine subcol_unpack_{DIMS}d_{TYPE}
330 :
331 : end module subcol_pack_mod
|
