Line data Source code
1 : module subcol_tstcp
2 : !---------------------------------------------------------------------------
3 : ! Purpose:
4 : !
5 : ! Implement the various TestCopy schemes
6 : ! sub-column schemes
7 : !
8 : !---------------------------------------------------------------------------
9 :
10 : use shr_kind_mod, only: r8=>shr_kind_r8
11 : use physics_types, only: physics_state, physics_tend, physics_ptend
12 : use ppgrid, only: pcols, psubcols, pver, pverp
13 : use constituents, only: pcnst
14 : use cam_abortutils, only: endrun
15 : use spmd_utils, only: masterproc
16 : use cam_logfile, only: iulog
17 :
18 : implicit none
19 :
20 : private
21 : save
22 :
23 : public :: subcol_gen_tstcp
24 : public :: subcol_register_tstcp
25 : public :: subcol_readnl_tstcp
26 : public :: subcol_field_avg_tstcp
27 : public :: subcol_ptend_avg_tstcp
28 :
29 : interface subcol_field_avg_tstcp
30 : module procedure subcol_field_avg_tstcp_1dr
31 : module procedure subcol_field_avg_tstcp_1di
32 : module procedure subcol_field_avg_tstcp_2dr
33 : end interface
34 :
35 : logical :: subcol_tstcp_noAvg ! if set, bypasses averaging and assigns back the first subcolumn to grid
36 :
37 : logical :: subcol_tstcp_filter ! if set, sets up a filter which yields BFB results
38 : ! (doesn't really excercise the filter arithmetic)
39 :
40 : logical :: subcol_tstcp_weight ! if set, sets up a weight which yields BFB results
41 : ! (doesn't really excercise the weight arithmetic)
42 :
43 : logical :: subcol_tstcp_perturb ! if set, turns on the perturbation test which changes the state temperatures
44 : ! to make sure subcolumns differ
45 :
46 : logical :: subcol_tstcp_restart ! if set, sets up weights so that they are more adequately tested in restart,
47 : ! but will not be BFB with non-subcolumnized run
48 :
49 : integer :: tstcpy_scol_idx ! pbuf index for subcolumn-only test field
50 :
51 : contains
52 :
53 0 : subroutine subcol_register_tstcp()
54 : use physics_buffer, only: pbuf_add_field, dtype_i4, col_type_subcol
55 : use phys_control, only: phys_getopts
56 :
57 : ! A subcolumn-only test field
58 : ! pbuf is global so it will show up in restart file
59 : call pbuf_add_field('TSTCPY_SCOL','global', dtype_i4, &
60 0 : (/pcols,pver/), tstcpy_scol_idx, col_type_subcol)
61 :
62 0 : end subroutine subcol_register_tstcp
63 :
64 0 : subroutine subcol_readnl_tstcp(nlfile)
65 0 : use namelist_utils, only: find_group_name
66 : use units, only: getunit, freeunit
67 : use spmd_utils, only: masterproc, mpi_logical, masterprocid, mpicom
68 :
69 : character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input
70 :
71 : ! Local variables
72 : integer :: unitn, ierr
73 :
74 : namelist /subcol_tstcp_nl/ subcol_tstcp_noAvg, subcol_tstcp_filter, subcol_tstcp_weight, subcol_tstcp_perturb, &
75 : subcol_tstcp_restart
76 :
77 : !-----------------------------------------------------------------------------
78 :
79 0 : if (masterproc) then
80 0 : unitn = getunit()
81 0 : open( unitn, file=trim(nlfile), status='old' )
82 0 : call find_group_name(unitn, 'subcol_tstcp_nl', status=ierr)
83 0 : if (ierr == 0) then
84 0 : read(unitn, subcol_tstcp_nl, iostat=ierr)
85 0 : if (ierr /= 0) then
86 0 : call endrun('subcol_readnl_tstcp: ERROR reading namelist')
87 : end if
88 : end if
89 0 : close(unitn)
90 0 : call freeunit(unitn)
91 : end if
92 :
93 : #ifdef SPMD
94 : ! Broadcast namelist variables
95 0 : call mpi_bcast(subcol_tstcp_noAvg, 1, mpi_logical, masterprocid, mpicom, ierr)
96 0 : call mpi_bcast(subcol_tstcp_filter, 1, mpi_logical, masterprocid, mpicom, ierr)
97 0 : call mpi_bcast(subcol_tstcp_weight, 1, mpi_logical, masterprocid, mpicom, ierr)
98 0 : call mpi_bcast(subcol_tstcp_perturb, 1, mpi_logical, masterprocid, mpicom, ierr)
99 0 : call mpi_bcast(subcol_tstcp_restart, 1, mpi_logical, masterprocid, mpicom, ierr)
100 : #endif
101 0 : end subroutine subcol_readnl_tstcp
102 :
103 0 : subroutine subcol_gen_tstcp(state, tend, state_sc, tend_sc, pbuf)
104 :
105 : use subcol_utils, only: subcol_set_subcols, subcol_set_weight, subcol_set_filter
106 : use subcol_pack_mod, only: subcol_get_nsubcol
107 : use physics_buffer, only: physics_buffer_desc, pbuf_get_field, col_type_subcol
108 : use phys_grid, only: get_gcol_p
109 : use time_manager, only: is_first_step, is_first_restart_step
110 :
111 :
112 : !-----------------------------------
113 : ! sub-column generator
114 : !-----------------------------------
115 : type(physics_state), intent(inout) :: state
116 : type(physics_tend), intent(inout) :: tend
117 : type(physics_state), intent(inout) :: state_sc ! sub-column state
118 : type(physics_tend), intent(inout) :: tend_sc ! sub-column tend
119 : type(physics_buffer_desc), pointer :: pbuf(:)
120 :
121 :
122 : !
123 : ! Local variables
124 : !
125 : integer :: i, j, k, ngrdcol, indx, indx1, indx2
126 : integer :: nsubcol(pcols)
127 0 : real(r8) :: weight(state_sc%psetcols)
128 0 : integer :: filter(state_sc%psetcols)
129 0 : integer, pointer :: test_field(:,:)
130 : character(len=128) :: errmsg
131 :
132 0 : ngrdcol = state%ngrdcol
133 :
134 : !----------------------
135 : ! Set the number of subcolumns on the 0th time step -- current implementation does not allow
136 : ! number of subcolumns to vary within a run. Cannot be done in init as ngrdcol is not known
137 : ! at init
138 : !----------------------
139 : ! Test differing number of subcolumns by setting columns > 45 degrees to
140 : ! have 1 subcolumn, columns < -45 to 2 subcolumns and others to 3 subcols
141 0 : if (is_first_step()) then
142 0 : nsubcol = 0
143 0 : do i = 1, ngrdcol
144 0 : if (state%lat(i) > 0.7854_r8) then
145 0 : nsubcol(i) = 1
146 0 : else if (state%lat(i) < -0.7854_r8) then
147 0 : nsubcol(i) = 2
148 : else
149 0 : nsubcol(i) = psubcols
150 : end if
151 : end do
152 :
153 : ! Set up the weights once and do not modify - this will test the restart ability to correctly retrieve them
154 0 : if(subcol_tstcp_restart) then
155 0 : weight=0._r8
156 0 : indx=1
157 0 : do i=1,ngrdcol
158 0 : weight(indx:indx+nsubcol(i)-1)=1._r8/nsubcol(i)
159 0 : if (state%lon(i) < -0.5236_r8) then
160 0 : if (nsubcol(i) >= 3) then
161 0 : weight(indx) = 2*1._r8/nsubcol(i)
162 0 : weight(indx+1) = 1._r8 - weight(indx)
163 0 : weight(indx+2:indx+nsubcol(i)-1)=0._r8
164 : end if
165 : end if
166 0 : indx = indx+nsubcol(i)
167 : end do
168 0 : call subcol_set_weight(state%lchnk, weight)
169 : end if
170 : else
171 0 : call subcol_get_nsubcol(state%lchnk, nsubcol)
172 : ! Since this is a test generator, check for nsubcol correctness.
173 0 : do i = 1, pcols
174 0 : if (i > ngrdcol) then
175 0 : if (nsubcol(i) /= 0) then
176 0 : write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
177 0 : i,') = ',nsubcol(i),', /= 0'
178 0 : call endrun(errmsg)
179 : end if
180 0 : else if (state%lat(i) > 0.7854_r8) then
181 0 : if (nsubcol(i) /= 1) then
182 0 : write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
183 0 : i,') = ',nsubcol(i),', /= 1'
184 0 : call endrun(errmsg)
185 : end if
186 0 : else if (state%lat(i) < -0.7854_r8) then
187 0 : if (nsubcol(i) /= 2) then
188 0 : write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
189 0 : i,') = ',nsubcol(i),', /= 2'
190 0 : call endrun(errmsg)
191 : end if
192 : else
193 0 : if (nsubcol(i) /= psubcols) then
194 0 : write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
195 0 : i,') = ',nsubcol(i),', /=',psubcols
196 0 : call endrun(errmsg)
197 : end if
198 : end if
199 : end do
200 : end if
201 :
202 0 : call subcol_set_subcols(state, tend, nsubcol, state_sc, tend_sc)
203 :
204 : ! For perturb case, adjust Temperature up and down one degree
205 0 : if (subcol_tstcp_perturb) then
206 0 : indx=1
207 0 : do i=1,ngrdcol
208 0 : if (nsubcol(i) >= 2) then
209 0 : state_sc%t(indx,:) = state_sc%t(indx,:)+1
210 0 : state_sc%t(indx+1,:) = state_sc%t(indx+1,:)-1
211 : end if
212 0 : indx=indx+nsubcol(i)
213 : end do
214 : end if
215 :
216 : ! Set weight to 1 for first column, 0 for all others -- will be BFB with noUniAv case
217 0 : if(subcol_tstcp_filter .and. subcol_tstcp_weight) then
218 0 : weight=1._r8
219 : ! Initialize to 1 - will match doAv_noUni, init to 0 - will match noUniAv
220 0 : filter=1
221 0 : indx=1
222 0 : do i=1,ngrdcol
223 0 : weight(indx) = 1.0_r8
224 0 : filter(indx) = 1
225 0 : indx = indx+nsubcol(i)
226 : end do
227 0 : call subcol_set_weight(state%lchnk, weight)
228 0 : call subcol_set_filter(state%lchnk, filter)
229 : ! Set weight to 1 for first column, 0 for all others -- will be BFB with noUniAv case
230 0 : else if(subcol_tstcp_weight) then
231 0 : weight=0._r8
232 0 : indx=1
233 0 : do i=1,ngrdcol
234 0 : weight(indx) = 1.0_r8
235 0 : indx = indx+nsubcol(i)
236 : end do
237 0 : call subcol_set_weight(state%lchnk, weight)
238 :
239 : ! Set filter to 1 for first column, 0 for all others -- will be BFB with noUniAv case
240 0 : else if(subcol_tstcp_filter) then
241 0 : filter=0
242 0 : indx=1
243 0 : do i=1,ngrdcol
244 0 : filter(indx) = 1
245 0 : indx = indx+nsubcol(i)
246 : end do
247 0 : call subcol_set_filter(state%lchnk, filter)
248 : end if
249 :
250 :
251 0 : if (is_first_restart_step()) then
252 : ! Test values for the test pbuf
253 : call pbuf_get_field(pbuf, tstcpy_scol_idx, test_field, &
254 0 : col_type=col_type_subcol, copy_if_needed=.false.)
255 0 : indx = 1
256 0 : do i=1,ngrdcol
257 0 : do indx1 = 1, nsubcol(i)
258 0 : do k = 1, pver
259 0 : indx2 = (get_gcol_p(state%lchnk, i) * 10000)
260 0 : indx2 = k + (100 * (indx1 + indx2))
261 0 : if(test_field(indx, k) /= indx2) then
262 0 : write(iulog, *) 'TSTCPY_SCOL check(',indx,',',k, &
263 0 : '): expected',indx2,', found',test_field(indx, k)
264 0 : call endrun("Restart check for TSTCPY_SCOL failed")
265 : end if
266 : end do
267 0 : indx = indx + 1
268 : end do
269 : end do
270 : ! Unused subcolumn space is not initialized so no check
271 0 : else if (is_first_step()) then
272 : ! Set values for the test pbuf
273 : call pbuf_get_field(pbuf, tstcpy_scol_idx, test_field, &
274 0 : col_type=col_type_subcol, copy_if_needed=.false.)
275 0 : test_field = -1
276 0 : indx = 1
277 0 : do i=1,ngrdcol
278 0 : do indx1 = 1, nsubcol(i)
279 0 : do k = 1, pver
280 0 : indx2 = (get_gcol_p(state%lchnk, i) * 10000)
281 0 : indx2 = k + (100 * (indx1 + indx2))
282 0 : test_field(indx, k) = indx2
283 : end do
284 0 : indx = indx + 1
285 : end do
286 : end do
287 : end if
288 :
289 0 : end subroutine subcol_gen_tstcp
290 :
291 0 : subroutine subcol_field_avg_tstcp_1dr (field_sc, ngrdcol, lchnk, field)
292 0 : use physics_buffer, only: physics_buffer_desc
293 : use subcol_utils, only: subcol_field_get_firstsubcol, subcol_field_avg_shr, is_filter_set, is_weight_set
294 :
295 : !-----------------------------------
296 : ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
297 : !-----------------------------------
298 :
299 : real(r8), intent(in) :: field_sc(:) ! intent in
300 : integer, intent(in) :: ngrdcol ! # grid cols
301 : integer, intent(in) :: lchnk ! chunk index
302 : real(r8), intent(out) :: field(:)
303 :
304 : !
305 : ! Local variables
306 : !
307 : real(r8),pointer :: weight(:)
308 : integer, pointer :: filter(:)
309 :
310 :
311 : ! Unless specialized averaging is needed, most subcolumn schemes will be handled here
312 0 : if (subcol_tstcp_noAvg) then
313 0 : call subcol_field_get_firstsubcol(field_sc, .true., ngrdcol, lchnk, field)
314 : else
315 0 : call subcol_field_avg_shr(field_sc, ngrdcol, lchnk, field, is_filter_set(), is_weight_set())
316 : end if
317 :
318 0 : end subroutine subcol_field_avg_tstcp_1dr
319 :
320 0 : subroutine subcol_field_avg_tstcp_1di (field_sc, ngrdcol, lchnk, field)
321 0 : use physics_buffer, only: physics_buffer_desc
322 : use subcol_utils, only: subcol_field_get_firstsubcol, subcol_field_avg_shr, is_filter_set, is_weight_set
323 :
324 : !-----------------------------------
325 : ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
326 : !-----------------------------------
327 :
328 : integer, intent(in) :: field_sc(:) ! intent in
329 : integer, intent(in) :: ngrdcol ! # grid cols
330 : integer, intent(in) :: lchnk ! chunk index
331 : integer, intent(out) :: field(:)
332 :
333 : !
334 : ! Local variables
335 : !
336 : real(r8),pointer :: weight(:)
337 : integer, pointer :: filter(:)
338 :
339 :
340 : ! Unless specialized averaging is needed, most subcolumn schemes will be handled here
341 0 : if (subcol_tstcp_noAvg) then
342 0 : call subcol_field_get_firstsubcol(field_sc, .true., ngrdcol, lchnk, field)
343 : else
344 0 : call subcol_field_avg_shr(field_sc, ngrdcol, lchnk, field, is_filter_set(), is_weight_set())
345 : end if
346 :
347 0 : end subroutine subcol_field_avg_tstcp_1di
348 :
349 0 : subroutine subcol_field_avg_tstcp_2dr (field_sc, ngrdcol, lchnk, field)
350 0 : use physics_buffer, only: physics_buffer_desc
351 : use subcol_utils, only: subcol_field_get_firstsubcol, subcol_field_avg_shr, is_filter_set, is_weight_set
352 :
353 : !-----------------------------------
354 : ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
355 : !-----------------------------------
356 :
357 : real(r8), intent(in) :: field_sc(:,:) ! intent in
358 : integer, intent(in) :: ngrdcol ! # grid cols
359 : integer, intent(in) :: lchnk ! chunk index
360 : real(r8), intent(out) :: field(:,:)
361 :
362 : ! Unless specialized averaging is needed, most subcolumn schemes will be handled here
363 0 : if (subcol_tstcp_noAvg) then
364 0 : call subcol_field_get_firstsubcol(field_sc, .true., ngrdcol, lchnk, field)
365 : else
366 0 : call subcol_field_avg_shr(field_sc, ngrdcol, lchnk, field, is_filter_set(), is_weight_set())
367 : end if
368 :
369 0 : end subroutine subcol_field_avg_tstcp_2dr
370 :
371 0 : subroutine subcol_ptend_avg_tstcp (ptend_sc, ngrdcol, lchnk, ptend)
372 0 : use physics_buffer, only: physics_buffer_desc
373 : use subcol_utils, only: subcol_ptend_get_firstsubcol, subcol_ptend_avg_shr, subcol_get_weight, subcol_get_filter, &
374 : is_filter_set, is_weight_set
375 :
376 : !-----------------------------------
377 : ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
378 : !-----------------------------------
379 :
380 : type(physics_ptend), intent(in) :: ptend_sc ! intent in
381 : integer, intent(in) :: ngrdcol ! # grid cols
382 : integer, intent(in) :: lchnk ! chunk index
383 : type(physics_ptend), intent(inout) :: ptend
384 :
385 0 : if (subcol_tstcp_noAvg) then
386 0 : call subcol_ptend_get_firstsubcol(ptend_sc, .true., ngrdcol, lchnk, ptend)
387 : else
388 0 : call subcol_ptend_avg_shr(ptend_sc, ngrdcol, lchnk, ptend, is_filter_set(), is_weight_set())
389 : end if
390 :
391 0 : end subroutine subcol_ptend_avg_tstcp
392 : end module subcol_tstcp
|
